theory special_exp_day1
  imports Main
begin
  lemma name : "\<And>P. P \<Longrightarrow> P"
  proof-
    fix P
    assume 1:"P"
    show "P" by (rule 1)
  qed(*comment*)

  lemma name2 : "\<And>P .P \<Longrightarrow> P"
  proof-
    show "\<And>P. P \<Longrightarrow> P" by auto
  qed(*auto version*)

  lemma cont1 : "\<And>P .(A \<equiv> \<not>A) \<Longrightarrow> P"
  proof-
    show "\<And>P .(A \<equiv> \<not>A) \<Longrightarrow> P" by auto
  qed(*What's the purpose of your visit?*)

  lemma mul : "\<And>A B. A \<Longrightarrow> B \<Longrightarrow> A\<and>B"
  proof-
    fix "A"
    fix "B"
    assume 1: "A"
    assume 2: "B"
    show "\<And>A B. A \<Longrightarrow> B \<Longrightarrow> A\<and>B" by (rule conjI)
  qed(*contents of auto*)

  lemma adjd : "\<And>A B.  A \<Longrightarrow> (A \<Longrightarrow> B) \<Longrightarrow> B"
    proof-
      fix "A"
      fix "B"
      assume 1: "A"
      assume 2: "A \<Longrightarrow> B"
      show "B" by (rule 2 ,rule 1)
    qed

  lemma nat_unit : "\<And>n::nat. n+0=n"
  proof-
    fix n :: "nat"
    show "n+0=n"
    proof (cases n)
      case 0
      then show ?thesis by auto
    next
      case (Suc nat)
      then show ?thesis by auto
    qed
  qed

  lemma "\<And>n :: nat. n\<ge>5 \<Longrightarrow> n^2 < 2^n"
  proof-
    fix n :: "nat"
    assume 1: "n\<ge>5"
    show  "n^2 < 2^n"
      proof (cases n)
        case 0
        then show ?thesis by auto
      next
        case (Suc nat)
        then show ?thesis by auto
      qed
  qed

  (*homework*)
  (*flow
    assume (())
    (()) \<Longrightarrow> A
    proof (())
    () \<Longrightarrow> A
  *)

  lemma parse : "\<And> A B. ((A\<Longrightarrow>B) \<Longrightarrow> A) \<Longrightarrow> A"
  proof-
    (*show "\<And> A B. ((A\<Longrightarrow>B) \<Longrightarrow> A) \<Longrightarrow> A" by auto*)
    fix "A"
    fix "B"
    assume 1: "(A\<Longrightarrow>B)"
    show "A\<open>\<close>
  qed

end


(*<*)
theory ExistenciaModeloIngles
imports T11EnumFormulasIngles
begin
(*>*)

section \<open> Formalización de la existencia de models proposicionales \<close>
 text \<open>
   \label{existenciamodelP}

   En esta sección formalizamos la demostración del teorema de
   existencia de models en la lógica proposicional.  Es decir,
   demostramos en Isar que cualquier conjunto {\em consistente} $S$
   de fórmulas proposicionales es {\em satisfiable}.

   Teniendo en cuenta el corolario \ref{Hintikkasatisfiable}, que
   garantiza que cualquier conjunto de Hintikka es satisfiable, la
   formalización de la prueba se basa en que todo conjunto
   consistente puede extenderse a un conjunto de Hintikka.  Para la
   demostración de esto último se utilizará el teorema
   \ref{MaximalHintikkaP} que afirma que en una propiedad de
   consistencia proposicional $\mathcal{C}$ que sea cerrada por
   subconjuntos, si $M$ es un conjunto maximal de $\mathcal{C}$ y
   pertenece a $\mathcal{C}$ entonces $M$ es un conjunto de Hintikka. En
   particular, si el límite de la sucesión $S^{n}_{S,\mathcal{C},f}$
   pertenece a $\mathcal{C}$ y es un conjunto maximal de $\mathcal{C}$,
   entonces dicho límite es un conjunto de Hintikka. Además, el
   corolario \ref{ExtensionConsistenteP} afirma que estas dos últimas
   condiciones se tienen si la propiedad de consistencia $\mathcal{C}$
   es de carácter finito y $S \in \mathcal{C}$.

   De acuerdo con lo anterior, en el teorema \ref{ExtensionCaracterFinitoP}
   extendemos una propiedad de
   consistencia proposicional a una de carácter finito (y por lo tanto
   cerrada por subconjuntos).
   Los teoremas \ref{AlternativaCfinitoP} y
   \ref{CerraduraSubconjuntosP} permiten hacer esta extensión:
\<close>

text \<open>
  \begin{teorema}\label{AlternativaCfinitoP}
  Sea @{text "\<C>"} una colección de conjuntos. Se verifican las
  siguientes propiedades:
  \begin{itemize}
  \item[(a)] Si @{text "\<C>"} es cerrada por subconjuntos, entonces
    @{text "\<C> \<subseteq> \<C>⁻"}.
  \item[(b)] @{text "\<C>⁻"} es de carácter finito.
  \item[(c)] Si @{text "\<C>"} es una propiedad de consistencia
    proposicional que es cerrada por subconjuntos entonces,
    @{text "\<C>⁻"} es una propiedad de consistencia proposicional.
  \end{itemize}
  \end{teorema}
\<close>
  text \<open>
  \begin{teorema}\label{CerraduraSubconjuntosP}\mbox{}
  \par\noindent
  Sea $\mathcal{C}$ una colección de conjuntos. entonces,
  \begin{itemize}
  \item[(a)] $\mathcal{C} \subseteq \mathcal{C^{+}}$.
  \item[(b)] $\mathcal{C^{+}}$ es cerrada por subconjuntos.
  \item[(c)] Si $\mathcal{C}$ es una propiedad de consistencia
    proposicional entonces $\mathcal{C^{+}}$ también es una propiedad de
    consistencia proposicional.
  \end{itemize}
  \end{teorema}
\<close>

text\<open>
   \begin{teorema}\label{ExtensionCaracterFinitoP}
   Si $\mathcal{C}$ es una colección de conjuntos entonces se tiene lo
   si\-guiente.
   \begin{itemize}
   \item[(a)] $\mathcal{C} \subseteq \mathcal{C}^{+-}$.
   \item[(b)] $\mathcal{C}^{+-}$ es de carácter finito.
   \item[(c)] Si $\mathcal{C}$ es una propiedad de consistencia
     proposicional entonces, $\mathcal{C}^{+-}$  es una propiedad de
     consistencia proposicional.
   \end{itemize}
   \end{teorema}

   \begin{demostracion}

   \begin{itemize}

   \item[(a)] Por el teorema \ref{CerraduraSubconjuntosP} tenemos que,
   $\mathcal{C} \subseteq \mathcal{C}^{+}$ y $\mathcal{C}^{+}$ es
   cerrada por subconjuntos. Además, por el teorema
   \ref{AlternativaCfinitoP}, $\mathcal{C}^{+} \subseteq
   \mathcal{C}^{+-}$.  Por lo tanto, $\mathcal{C} \subseteq
   \mathcal{C}^{+-}$.

   \item[(b)] Por el teorema \ref{AlternativaCfinitoP} tenemos que
   $\mathcal{C}^{+-}$ es de carácter finito.

   \item[(c)] Supongamos que $\mathcal{C}$ es una propiedad de
   consistencia proposicional. Entonces, por el teorema
   \ref{CerraduraSubconjuntosP}, $\mathcal{C}^{+}$ es una propiedad de
   consistencia proposicional cerrada por subconjuntos. Finalmente, por
   el teorema \ref{AlternativaCfinitoP}, $\mathcal{C}^{+-}$ es una
   propiedad de consistencia proposicional.
   \end{itemize} \mbox{}
   \end{demostracion}

   \noindent Su formalización es:
\<close>

theorem ExtensionCaracterFinitoP:
  shows "\<C> \<subseteq> \<C>⁺⁻"
  and "caracter_finito (\<C>⁺⁻)"
  and "consistenceP \<C> \<longrightarrow> consistenceP (\<C>⁺⁻)"
proof -
show "\<C> \<subseteq> \<C>⁺⁻"
  proof -
    have "\<C> \<subseteq> \<C>⁺" using cerrado_subset by auto
    also
    have "... \<subseteq> \<C>⁺⁻"
    proof -
      have "subconj_cerrada (\<C>⁺)" using cerrado_cerrado by auto
      thus ?thesis using caracter_finito_subset  by auto
    qed
    finally show ?thesis by simp
  qed
next
  show "caracter_finito (\<C>⁺⁻)" using caracter_finito by auto
next
  show "consistenceP \<C> \<longrightarrow> consistenceP (\<C>⁺⁻)"
  proof(rule impI)
    assume "consistenceP \<C>"
    hence  "consistenceP (\<C>⁺)" using cerrado_consistenceP by auto
    moreover
    have "subconj_cerrada (\<C>⁺)" using  cerrado_cerrado by auto
    ultimately
    show "consistenceP (\<C>⁺⁻)" using cfinito_consistenceP
      by auto
  qed
qed

text \<open>
  Usando el teorema anterior se demuestra que
  $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}$ pertenece a
  $\mathcal{C}^{+-}$ y es un elemento maximal de $\mathcal{C}^{+-}$ que
  contiene a $S$.

  \begin{lema}\label{ExtensionConsistenteP1}
  Sean $\mathbf{L}$ un lenguaje proposicional, $g$ una enumeración del
  conjunto de símbolos proposicionales de $\mathbf{L}$ y $\Delta_{g}$ la
  correspondiente enumeración de las fórmulas de $\mathbf{L}$
  (definición \ref{enumformulasP}).  Si $\mathcal{C}$ es una propiedad
  de consistencia proposicional tal que $S\in \mathcal{C}$, entonces
  \begin{itemize}
  \item[(a)] $S\subseteq S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}$.
  \item[(b)] $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}$ es un elemento
    maximal de $\mathcal{C}^{+-}$.
  \item[(c)] $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}\in \mathcal{C}^{+-}$.
  \end{itemize}
  \end{lema}

  \begin{demostracion}
  Por el teorema \ref{ExtensionCaracterFinitoP} tenemos que,
  $\mathcal{C}^{+-}$ es una propiedad de consistencia de carácter
  finito, y también que $S\in \mathcal{C}^{+-}$.  Además, por el
  corolario \ref{enumformulasP} se tiene que la sucesión $\Delta_{g}$ es
  una enumeración del conjunto de fórmulas de $\mathbf{L}$, De lo
  anterior y por el corolario \ref{ExtensionConsistenteP}, se tienen
  $(a), (b)$ y $(c)$.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

lemma ExtensionConsistenteP1:
  assumes h: "enumeration g"
  and h1: "consistenceP \<C>"
  and h2: "S \<in> \<C>"
  shows "S \<subseteq> MsucP S (\<C>⁺⁻) g"
  and "maximal (MsucP S (\<C>⁺⁻)  g) (\<C>⁺⁻)"
  and "MsucP S  (\<C>⁺⁻)  g \<in> \<C>⁺⁻"

proof -
  have "consistenceP (\<C>⁺⁻)"
    using h1 and ExtensionCaracterFinitoP by auto
  moreover
  have "caracter_finito (\<C>⁺⁻)" using ExtensionCaracterFinitoP by auto
  moreover
  have "S \<in> \<C>⁺⁻"
    using h2 and ExtensionCaracterFinitoP by auto
  ultimately
  show "S \<subseteq> MsucP S (\<C>⁺⁻) g"
    and "maximal (MsucP S (\<C>⁺⁻) g) (\<C>⁺⁻)"
    and "MsucP S (\<C>⁺⁻) g \<in> \<C>⁺⁻"
    using h ExtensionConsistenteP[of "\<C>⁺⁻"] by auto
qed

text \<open>
  El siguiente resultado demuestra que si $S$ es un conjunto consistente
  entonces \linebreak
  $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}$ es un conjunto de Hintikka.

  \begin{teorema}\label{HintikkaP}
  Sean $\mathbf{L}$ un lenguaje proposicional, $g$ una numeración del
  conjunto de símbolos proposicionales de $\mathbf{L}$ y $\Delta_{g}$ la
  correspondiente numeración de las fórmulas de $\mathbf{L}$
  (definición \ref{enumformulasP}).  Si $\mathcal{C}$ es una propiedad
  de consistencia proposicional tal que $S\in \mathcal{C}$, entonces
  $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}$ es un conjunto de Hintikka.
  \end{teorema}

  \begin{demostracion}
  Por el teorema \ref{ExtensionCaracterFinitoP}, se tiene que
  $\mathcal{C}^{+-}$ es una propiedad de consistencia y es de carácter
  finito; también es subconjunto cerrada (por el teorema
  \ref{CaracterFinitoCerradaP}).  Luego por el teorema
  \ref{ExtensionConsistenteP1} se tiene que $S_{S,\,\mathcal{C}^{+-},\,
  \Delta_{g}}$ es un elemento maximal de $\mathcal{C}^{+-}$ y
  $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}\in \mathcal{C}^{+-}$.  De lo
  anterior y por el teorema \ref{MaximalHintikkaP} se tiene que
  $S_{S,\,\mathcal{C}^{+-},\, \Delta_{g}}$ es un conjunto de Hintikka.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

theorem HintikkaP:
  assumes h0:"enumeration g" and h1: "consistenceP \<C>" and h2: "S \<in> \<C>"
  shows "hintikkaP (MsucP S (\<C>⁺⁻) g)"
proof -
  have 1: "consistenceP (\<C>⁺⁻)"
  using h1 ExtensionCaracterFinitoP by auto
  have 2: "subconj_cerrada (\<C>⁺⁻)"
  proof -
    have "caracter_finito (\<C>⁺⁻)"
      using ExtensionCaracterFinitoP by auto
    thus "subconj_cerrada (\<C>⁺⁻)" by (rule caracter_finito_cerrado)
  qed
  have 3: "maximal (MsucP S (\<C>⁺⁻) g) (\<C>⁺⁻)"
    and 4: "MsucP S (\<C>⁺⁻) g \<in> \<C>⁺⁻"
    using ExtensionConsistenteP1[OF h0 h1 h2] by auto
  show ?thesis
    using 1 and 2 and 3 and 4 and MaximalHintikkaP[of "\<C>⁺⁻"] by simp
qed

text \<open>
  Por último, el siguiente teorema garantiza la existencia de models.

  \begin{teorema}\label{ExistenciaModeloP}
  Sean $\mathbf{L}$ un lenguaje proposicional, $g$ una numeración del
  conjunto de fórmulas de  $\mathbf{L}$. Si $\mathcal{C}$ es una propiedad de
  consistencia proposicional tal que $S\in \mathcal{C}$ y $F\in S$, sean
  $H = S_{S,\,\mathcal{C}^{+-},\, g}$ e $I_H$ la interpretación
  de Hintikka definida en \ref{interpretacionhintikka}. Entonces, $I'_H(F)=\V.$
  \end{teorema}

  \begin{demostracion}
  Por el teorema \ref{HintikkaP}, $S_{S,\,\mathcal{C}^{+-},\,
  \Delta_{g}}$ es de Hintikka. Además por el teorema
  \ref{MaxSubconjuntoP} se tiene que $F \in S_{S,\,\mathcal{C}^{+-},\,
  \Delta_{g}}$.  De lo anterior y por el corolario \ref{ModeloHintikkaP}
  se tiene el teorema.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

theorem ExistenciaModeloP:
  assumes h0: "enumeration g"
  and h1: "consistenceP \<C>"
  and h2: "S \<in> \<C>"
  and h3: "F \<in> S"
  shows "t_v_evaluation (IH (MsucP S (\<C>⁺⁻) g)) F = Ttrue"
proof (rule ModeloHintikkaPa)
  show "hintikkaP (MsucP S (\<C>⁺⁻) g)"
    using h0 and h1 and h2 by(rule HintikkaP)
next
  show "F \<in> MsucP S (\<C>⁺⁻) g"
    using h3  Max_subconjuntoP by auto
qed

text \<open>
  Por último, como una consecuencia del teorema \ref{ExistenciaModeloP}
  tenemos que todo conjunto consistente es satisfiable.

  \begin{teorema}\label{ConjuntosatisfiableP}
  Sea $\mathbf{L}$ un lenguaje proposicional numerable. Si $\mathcal{C}$
  es una propiedad de consistencia proposicional y $S\in \mathcal{C}$,
  entonces $S$ es satisfiable.
  \end{teorema}

  \begin{demostracion}
  Es consecuencia del teorema \ref{ExistenciaModeloP} y de la definición
  de satis\-facibilidad.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

theorem TeoremaExistenciaModelos:
  assumes h1: "\<exists>g. enumeration (g:: nat \<Rightarrow> 'b formula)"
  and h2: "consistenceP \<C>"
  and h3: "(S:: 'b formula set) \<in> \<C>"
  shows "satisfiable S"
proof -
  obtain g where g: "enumeration (g:: nat \<Rightarrow> 'b formula)"
    using h1 by auto
  { fix F
    assume hip: "F \<in> S"
    have  "t_v_evaluation (IH (MsucP S (\<C>⁺⁻) g)) F = Ttrue"
      using g h2 h3 ExistenciaModeloP hip by blast }
  hence "\<forall>F\<in>S. t_v_evaluation (IH (MsucP S (\<C>⁺⁻) g)) F = Ttrue"
    by (rule ballI)
  hence "\<exists> I. \<forall> F \<in> S. t_v_evaluation I F = Ttrue" by auto
  thus "satisfiable S" by(unfold satisfiable_def, unfold model_def)
qed

text\<open>
  En el caso de que se tenga únicamente una  numeración $g$ del conjunto de símbolos proposicionales,
  se puede construir a partir de $g$ una numeración $\Delta_{g}$ de las correspondientes
  fórmulas de  $\mathbf{L}$ (definición \ref{enumformulasP}).

 \begin{corolario}\label{ConjuntosatisfiableP1}
  Sean $\mathbf{L}$ un lenguaje proposicional, $g$ una numeración del
  conjunto de símbolos proposicionales de $\mathbf{L}$.
  Si $\mathcal{C}$
  es una propiedad de consistencia proposicional y $S\in \mathcal{C}$,
  entonces $S$ es satisfiable.
  \end{corolario}
 \begin{demostracion}
 Por el corolario \ref{EnumeracionFormulas}, $\Delta_{g}$ es una numeración
 del conjunto de fórmulas de $\mathbf{L}$. Por lo tanto, por el teorema anterior,
 $S$ es satisfiable.
 \end{demostracion}
\<close>

corollary ConjuntosatisfiableP1:
  assumes h0:  "\<exists>g. enumeration (g:: nat \<Rightarrow> 'b)"
  and h1: "consistenceP \<C>"
  and h2: "(S:: 'b formula set) \<in> \<C>"
  shows "satisfiable S"
proof -
  obtain g where g: "enumeration (g:: nat \<Rightarrow> 'b )"
    using h0 by auto
  have "enumeration ((\<Delta>P g):: nat \<Rightarrow> 'b formula)" using g  EnumerationFormulasP1 by auto
  hence  h'0: "\<exists>g. enumeration (g:: nat \<Rightarrow> 'b formula)" by auto
  show ?thesis using TeoremaExistenciaModelos[OF h'0 h1 h2] by auto
qed

text \<open>
  En el caso del lenguaje proposicional $\mathbf{L}$ en el que
  identificamos los símbolos proposicionales con los números naturales,
  tenemos que la función identidad $i(n) = n$, es una numeración del
  conjunto de símbolos proposicionales.  En este caso la función
  $\Delta_{i}$ es una numeración de las fórmulas de este lenguaje y se
  tiene el siguiente corolario.

  \begin{corolario}\label{CasoExistenciaModeloP1}
  Sea $\mathbf{L}$ el lenguaje proposicional en el que los símbolos
  proposicionales son los números naturales.
  Si $\mathcal{C}$
  es una propiedad de consistencia proposicional y $S\in \mathcal{C}$
  entonces $S$ es satisfiable.
  \end{corolario}
  \begin{demostracion}
  Por hipótesis, la función identidad $i$ es una numeración de los
  símbolos proposicionales de $\mathbf{L}$.  De esta forma, por el
  corolario \ref{ConjuntosatisfiableP1}, se tiene que $S$ es satisfiable.
  \end{demostracion}

  \noindent Su formalización es:
\<close>
corollary ConjuntosatisfiableP2:
  assumes "consistenceP \<C>" and "(S:: nat formula set) \<in> \<C>"
  shows "satisfiable S"
  using  enum_nat assms ConjuntosatisfiableP1 by auto
(*<*)
end
(*>*)


theory Pf_Add
imports Automatic_Refinement.Misc "HOL-Library.Monad_Syntax"
begin

lemma fun_ordI:
  assumes "\<And>x. ord (f x) (g x)"
  shows "fun_ord ord f g"
  using assms unfolding fun_ord_def by auto

lemma fun_ordD:
  assumes "fun_ord ord f g"
  shows "ord (f x) (g x)"
  using assms unfolding fun_ord_def by auto

lemma mono_fun_fun_cnv:
  assumes "\<And>d. monotone (fun_ord ordA) ordB (\<lambda>x. F x d)"
  shows "monotone (fun_ord ordA) (fun_ord ordB) F"
  apply rule
  apply (rule fun_ordI)
  using assms
  by (blast dest: monotoneD)

lemma fun_lub_Sup[simp]: "fun_lub Sup = Sup"
  unfolding fun_lub_def[abs_def]
  by (clarsimp intro!: ext; metis image_def)

lemma fun_ord_le[simp]: "fun_ord (\<le>) = (\<le>)"
  unfolding fun_ord_def[abs_def]
  by (auto intro!: ext simp: le_fun_def)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_nat
imports Infra_common
begin

(*****************************************************
                      nat
 *****************************************************)

lemma nat_zero_or_Suc: "ALL n::nat. n=0 | (EX m::nat. n=Suc m)"
apply (intro allI)
apply (induct_tac n)
apply (simp)
apply (rule disjI2)
apply (erule disjE)
apply (rule_tac x=0 in exI)
apply (simp)
apply (erule exE)
apply (rule_tac x="Suc m" in exI)
apply (simp)
done

(*** min ***)

lemma min_is1: "(m::'a::order) <= n ==> min m n = m"
by (simp add: min_def)

lemma min_is2: "(n::'a::order) <= m ==> min m n = n"
apply (simp add: min_def)
done

lemmas min_is = min_is1 min_is2

(*** max ***)

lemma max_is1: "(m::'a::order) <= n ==> max m n = n"
by (simp add: max_def)

lemma max_is2: "(n::'a::order) <= m ==> max m n = m"
apply (simp add: max_def)
done

lemmas max_is = max_is1 max_is2

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL
*)

header {* Yonedas Lemma *}

theory Yoneda
imports HomFunctors NatTrans
begin

subsection {* The Sandwich Natural Transformation *}

locale Yoneda = "functor" + into_set +
  assumes "TERM (AA :: ('o,'a,'m)category_scheme)"
  fixes sandwich :: "['o,'a,'o] \<Rightarrow> 'a set_arrow"  ("\<sigma>'(_,_')")
  defines "sandwich A a \<equiv> (\<lambda>B\<in>Ob. \<lparr>
  set_dom=Hom A B,
  set_func=(\<lambda>f\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> f) a),
  set_cod=F\<^bsub>\<o>\<^esub> B
  \<rparr>)"
  fixes unsandwich :: "['o,'o \<Rightarrow> 'a set_arrow] \<Rightarrow> 'a" ("\<sigma>\<^sup>\<leftarrow>'(_,_')")
  defines "unsandwich A u \<equiv> set_func (u A) (Id A)"

lemma (in Yoneda) F_into_set:
  "Functor F : AA \<longrightarrow> Set"
proof-
  from F_axioms have "Functor F : AA \<longrightarrow> BB" by intro_locales
  thus ?thesis
    by (simp only: BB_Set)
qed

lemma (in Yoneda) F_comp_func:
  assumes 1: "A \<in> Ob" and 2: "B \<in> Ob" and 3: "C \<in> Ob"
  and 4: "g \<in> Hom A B" and 5: "f \<in> Hom B C"
  shows "set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) = compose (F\<^bsub>\<o>\<^esub> A) (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (F\<^bsub>\<a>\<^esub> g))"
proof-
  from 4 and 5
  have 7: "Cod g = Dom f"
    and 8: "g \<in> Ar"
    and 9: "f \<in> Ar"
    and 10: "Dom g = A"
    by (simp_all add: hom_def)
  from F_preserves_dom and 8 and 10
  have 11: "set_dom (F\<^bsub>\<a>\<^esub> g) = F\<^bsub>\<o>\<^esub> A"
    by (simp add: preserves_dom_def BB_Set Set_def) auto
  from F_preserves_comp and 7 and 8 and 9
  have "F\<^bsub>\<a>\<^esub> (f \<bullet> g) = (F\<^bsub>\<a>\<^esub> f) \<bullet>\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> g)"
    by (simp add: preserves_comp_def)
  hence "set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g))  = set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (F\<^bsub>\<a>\<^esub> g))"
    by (simp add: BB_Set Set_def)
  also have "\<dots> = compose (F\<^bsub>\<o>\<^esub> A) (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (F\<^bsub>\<a>\<^esub> g))"
    by (simp add: set_comp_def 11)
  finally show ?thesis .
qed

lemma (in Yoneda) sandwich_type:
  assumes A: "A \<in> Ob" and B: "B \<in> Ob"
  and "a \<in> F\<^bsub>\<o>\<^esub> A"
  shows "\<sigma>(A,a) B \<in> hom Set (Hom A B) (F\<^bsub>\<o>\<^esub> B)"
proof-
  have "\<sigma>(A,a) \<in> Ob \<rightarrow> Ar\<^bsub>Set\<^esub>"
    using A and `a \<in> F\<^bsub>\<o>\<^esub> A` by (rule sandwich_funcset)
  hence "\<sigma>(A,a) B \<in> ar Set"
    using B by (rule funcset_mem)
  thus ?thesis
    using B by (simp add: sandwich_def hom_def Set_def)
qed

lemma (in Yoneda) sandwich_commutes:
  assumes AOb: "A \<in> Ob" and BOb: "B \<in> Ob" and COb: "C \<in> Ob"
  and aFa: "a \<in> F\<^bsub>\<o>\<^esub> A"
  and fBC: "f \<in> Hom B C"
  shows "(F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B) = (\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f)"
proof-
  from fBC have 1: "f \<in> Ar" and 2: "Dom f = B" and 3: "Cod f = C"
    by (simp_all add: hom_def)
  from BOb have "set_dom ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B)) = Hom A B"
    by (simp add: set_comp_def sandwich_def)
  also have "\<dots> = set_dom ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by (simp add: set_comp_def homf_def 1 2)
  finally have set_dom_eq:
    "set_dom ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B))
    = set_dom ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))" .
  from BOb COb fBC have "(F\<^bsub>\<a>\<^esub> f) \<in> Hom\<^bsub>BB\<^esub> (F\<^bsub>\<o>\<^esub> B) (F\<^bsub>\<o>\<^esub> C)"
    by (rule functors_preserve_homsets)
  hence "set_cod ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B)) = F\<^bsub>\<o>\<^esub> C"
    by (simp add: set_comp_def BB_Set Set_def set_cat_def hom_def)
  also from COb
  have "\<dots> = set_cod ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by (simp add: set_comp_def sandwich_def)
  finally have set_cod_eq:
    "set_cod ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B))
    = set_cod ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))" .
  from AOb and BOb and COb and fBC and aFa
  have set_func_lhs:
    "set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B)) =
    (\<lambda>g\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) a)"
    apply (simp add:  set_comp_def sandwich_def compose_def)
    apply (rule extensionalityI, rule restrict_extensional, rule restrict_extensional)
    by (simp add: F_comp_func compose_def)
  have "(op \<bullet>) : Hom B C \<rightarrow> Hom A B \<rightarrow> Hom A C" ..
  from this and fBC
  have opfType: "(op \<bullet>) f : Hom A B \<rightarrow> Hom A C"
    by (rule funcset_mem)
  from 1 and 2
  have "set_func ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f)) =
    (\<lambda>g\<in>Hom A B. set_func (\<sigma>(A,a) C) (f \<bullet> g))"
    apply (simp add: set_comp_def homf_def)
    apply (simp add: compose_def)
    apply (rule extensionalityI, rule restrict_extensional, rule restrict_extensional)
    by auto
  also from COb and opfType
  have " \<dots> = (\<lambda>g\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) a)"
    apply (simp add: sandwich_def)
    apply (rule extensionalityI, rule restrict_extensional, rule restrict_extensional)
    by (simp add:Pi_def)
  finally have set_func_rhs:
    "set_func ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f)) =
    (\<lambda>g\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) a)" .
  from set_func_lhs and set_func_rhs have
    "set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B))
    = set_func ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by simp
  with set_dom_eq and set_cod_eq show ?thesis
    by simp
qed

lemma (in Yoneda) sandwich_natural:
  assumes "A \<in> Ob"
  and "a \<in> F\<^bsub>\<o>\<^esub> A"
  shows "\<sigma>(A,a) : Hom(A,_) \<Rightarrow> F in Func(AA,Set)"
proof (intro natural_transformation.intro natural_transformation_axioms.intro two_cats.intro)
  show "category AA" ..
  show "category Set"
    by (simp only: Set_def)(rule set_cat_cat)
  show "Functor Hom(A,_) : AA \<longrightarrow> Set"
    by (rule homf_into_set)
  show "Functor F : AA \<longrightarrow> Set"
    by (rule F_into_set)
  show "\<forall>B\<in>Ob. \<sigma>(A,a) B \<in> hom Set (Hom(A,_)\<^bsub>\<o>\<^esub> B) (F\<^bsub>\<o>\<^esub> B)"
    using assms by (auto simp add: homf_def intro: sandwich_type)
  show "\<sigma>(A,a) : Ob \<rightarrow> ar Set"
    using assms by (rule sandwich_funcset)
  show "\<sigma>(A,a) \<in> extensional (Ob)"
    unfolding sandwich_def by (rule restrict_extensional)
  show "\<forall>B\<in>Ob. \<forall>C\<in>Ob. \<forall>f\<in>Hom B C.
    comp Set (F \<^bsub>\<a>\<^esub> f) (\<sigma>(A,a) B) = comp Set (\<sigma>(A,a) C) (Hom(A,_)\<^bsub>\<a>\<^esub> f)"
    using assms by (auto simp add: Set_def intro: sandwich_commutes)
qed

subsection {* Sandwich Components are Bijective *}

lemma (in Yoneda) unsandwich_left_inverse:
  assumes 1: "A \<in> Ob"
  and 2: "a \<in> F\<^bsub>\<o>\<^esub> A"
  shows "\<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,a)) = a"
proof-
  from 1 have "Id A \<in> Hom A A" ..
  with 1
  have 3: "\<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,a)) = set_func (F\<^bsub>\<a>\<^esub> (Id A)) a"
    by (simp add: sandwich_def homf_def unsandwich_def)
  from F_preserves_id and 1
  have 4: "F\<^bsub>\<a>\<^esub> (Id A) = id Set (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: preserves_id_def BB_Set)
  from F_preserves_objects and 1
  have "F\<^bsub>\<o>\<^esub> A \<in> Ob\<^bsub>BB\<^esub>"
    by (rule funcset_mem)
  hence "F\<^bsub>\<o>\<^esub> A \<subseteq> U"
    by (simp add: BB_Set Set_def set_cat_def)
  with 2
  have 5: "set_func (id Set (F\<^bsub>\<o>\<^esub> A)) a = a"
    by (simp add: Set_def  set_id_def)
  show ?thesis
    by (simp add: 3 4 5)
qed

lemma (in Yoneda) unsandwich_right_inverse:
  assumes 1: "A \<in> Ob"
  and 2: "u : Hom(A,_) \<Rightarrow> F in Func(AA,Set)"
  shows "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) = u"
proof (rule extensionalityI)
  show "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) \<in> extensional (Ob)"
    by (unfold sandwich_def, rule restrict_extensional)
  from 2 show "u \<in>  extensional (Ob)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def)
  fix B
  assume 3: "B \<in> Ob"
  with 1
  have one: "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) B = \<lparr>
    set_dom = Hom A B,
    set_func = (\<lambda>f\<in>Hom A B. (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (u A) (Id A))),
    set_cod = F\<^bsub>\<o>\<^esub> B \<rparr>"
    by (simp add: sandwich_def unsandwich_def)
  from 1 have "Hom(A,_)\<^bsub>\<o>\<^esub> A = Hom A A"
    by (simp add: homf_def)
  with 1 and 2 have "(u A) \<in> hom Set (Hom A A) (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def,
      auto)
  hence "set_dom (u A) = Hom A A"
    by (simp add: hom_def Set_def)
  with 1 have applicable: "Id A \<in> set_dom (u A)"
    by (simp)(rule)
  have two: "(\<lambda>f\<in>Hom A B. (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (u A) (Id A)))
    = (\<lambda>f\<in>Hom A B. (set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (u A)) (Id A)))"
    by (rule extensionalityI,
      rule restrict_extensional, rule restrict_extensional,
      simp add: set_comp_def compose_def applicable)
  from 2
  have "(\<forall>X\<in>Ob. \<forall>Y\<in>Ob. \<forall>f\<in>Hom X Y. (F\<^bsub>\<a>\<^esub> f) \<bullet>\<^bsub>BB\<^esub> (u X) = (u Y) \<bullet>\<^bsub>BB\<^esub> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by (simp add: natural_transformation_def natural_transformation_axioms_def BB_Set)
  with 1 and 3
  have three: "(\<lambda>f\<in>Hom A B. (set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (u A)) (Id A)))
    = (\<lambda>f\<in>Hom A B. (set_func ((u B) \<odot> (Hom(A,_))\<^bsub>\<a>\<^esub> f)) (Id A))"
    apply (simp add: BB_Set Set_def)
    apply (rule extensionalityI)
    apply (rule restrict_extensional, rule restrict_extensional)
    by simp
  have "\<forall>f \<in> Hom A B. set_dom (Hom(A,_)\<^bsub>\<a>\<^esub> f) = Hom A A"
    by (intro ballI, simp add: homf_def hom_def)
  have roolz: "\<And>f. f \<in> Hom A B \<Longrightarrow> set_dom (Hom(A,_)\<^bsub>\<a>\<^esub> f) = Hom A A"
    by (simp add: homf_def hom_def)
  from 1 have rooly: "Id A \<in> Hom A A" ..
  have roolx: "\<And>f. f \<in> Hom A B \<Longrightarrow> f \<in> Ar"
    by (simp add: hom_def)
  have roolw: "\<And>f. f \<in> Hom A B \<Longrightarrow> Id A \<in> Hom A (Dom f)"
  proof-
    fix f
    assume "f \<in> Hom A B"
    hence "Dom f = A" by (simp add: hom_def)
    thus "Id A \<in> Hom A (Dom f)"
      by (simp add: rooly)
  qed
  have annoying: "\<And>f. f \<in> Hom A B \<Longrightarrow> Id A = Id (Dom f)"
    by (simp add: hom_def)
  have "(\<lambda>f\<in>Hom A B. (set_func ((u B) \<odot> (Hom(A,_))\<^bsub>\<a>\<^esub> f)) (Id A))
    = (\<lambda>f\<in>Hom A B. (compose (Hom A A) (set_func (u B)) (set_func (Hom(A,_)\<^bsub>\<a>\<^esub> f))) (Id A))"
    apply (rule extensionalityI)
    apply (rule restrict_extensional, rule restrict_extensional)
    by (simp add: compose_def set_comp_def roolz rooly)
  also have "\<dots> = (\<lambda>f\<in>Hom A B. (set_func (u B) f))"
    apply (rule extensionalityI)
    apply (rule restrict_extensional, rule restrict_extensional)
    apply (simp add: compose_def homf_def rooly roolx roolw)
    apply (simp only: annoying)
    apply (simp add: roolx id_right)
    done
  finally have four:
    "(\<lambda>f\<in>Hom A B. (set_func ((u B) \<odot> (Hom(A,_))\<^bsub>\<a>\<^esub> f)) (Id A))
    = (\<lambda>f\<in>Hom A B. (set_func (u B) f))" .
  from 2 and  3
  have uBhom: "u B \<in> hom Set (Hom(A,_)\<^bsub>\<o>\<^esub> B) (F\<^bsub>\<o>\<^esub> B)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def)
  with 3
  have five: "set_dom (u B) = Hom A B"
    by (simp add: hom_def homf_def Set_def set_cat_def)
  from uBhom
  have six: "set_cod (u B) = F\<^bsub>\<o>\<^esub> B"
    by (simp add: hom_def homf_def Set_def set_cat_def)
  have seven: "restrict (set_func (u B)) (Hom A B) = set_func (u B)"
    apply (rule extensionalityI)
    apply (rule restrict_extensional)
  proof-
    from uBhom have "u B \<in> ar Set"
      by (simp add: hom_def)
    hence almost: "set_func (u B) \<in> extensional (set_dom (u B))"
      by (simp add: Set_def set_cat_def set_arrow_def)
    from almost and five
    show "set_func (u B) \<in> extensional (Hom A B)"
      by simp
    fix f
    assume "f \<in> Hom A B"
    thus "restrict (set_func (u B)) (Hom A B) f = set_func (u B) f"
      by simp
  qed
  from one and two and three and four and five and six and seven
  show "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) B = u B"
    by simp
qed

text {* In order to state the lemma, we must rectify a curious
omission from the Isabelle/HOL library. They define the idea of
injectivity on a given set, but surjectivity is only defined relative
to the entire universe of the target type. *}

definition
  surj_on :: "['a \<Rightarrow> 'b, 'a set, 'b set] \<Rightarrow> bool" where
  "surj_on f A B \<longleftrightarrow> (\<forall>y\<in>B. \<exists>x\<in>A. f(x)=y)"

definition
  bij_on :: "['a \<Rightarrow> 'b, 'a set, 'b set] \<Rightarrow> bool" where
  "bij_on f A B \<longleftrightarrow> inj_on f A & surj_on f A B"

definition
  equinumerous :: "['a set, 'b set] \<Rightarrow> bool"  (infix "\<cong>" 40) where
  "equinumerous A B \<longleftrightarrow> (\<exists>f. bij_betw f A B)"

lemma bij_betw_eq:
  "bij_betw f A B \<longleftrightarrow>
    inj_on f A \<and> (\<forall>y\<in>B. \<exists>x\<in>A. f(x)=y) \<and> (\<forall>x\<in>A. f x \<in> B)"
unfolding bij_betw_def by auto

theorem (in Yoneda) Yoneda:
  assumes 1: "A \<in> Ob"
  shows "F\<^bsub>\<o>\<^esub> A \<cong> {u. u : Hom(A,_) \<Rightarrow> F in Func(AA,Set)}"
unfolding equinumerous_def bij_betw_eq inj_on_def
proof (intro exI conjI bexI ballI impI)
  -- "Sandwich is injective"
  fix x and y
  assume 2: "x \<in> F\<^bsub>\<o>\<^esub> A" and 3: "y \<in> F\<^bsub>\<o>\<^esub> A"
  and 4: "\<sigma>(A,x) = \<sigma>(A,y)"
  hence "\<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,x)) = \<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,y))"
    by simp
  with unsandwich_left_inverse
  show "x = y"
    by (simp add: 1 2 3)
next
  -- "Sandwich covers F A"
  fix u
  assume "u \<in> {y. y : Hom(A,_) \<Rightarrow> F in Func (AA,Set)}"
  hence 2: "u : Hom(A,_) \<Rightarrow> F in Func (AA,Set)"
    by simp
  with 1 show "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) = u"
    by (rule unsandwich_right_inverse)
  -- "Sandwich is into F A" (* there is really similar reasoning elsewhere*)
  from 1 and 2
  have "u A \<in> hom Set (Hom A A) (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def homf_def)
  hence "u A \<in> ar Set" and "dom Set (u A) = Hom A A" and "cod Set (u A) = F\<^bsub>\<o>\<^esub> A"
    by (simp_all add: hom_def)
  hence uAfuncset: "set_func (u A) : (Hom A A) \<rightarrow> (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: Set_def set_cat_def set_arrow_def)
  from 1 have "Id A \<in> Hom A A" ..
  with uAfuncset
  show "\<sigma>\<^sup>\<leftarrow>(A,u) \<in> F\<^bsub>\<o>\<^esub> A"
    by (simp add: unsandwich_def, rule funcset_mem)
next
  fix x
  assume "x \<in> F\<^bsub>\<o>\<^esub> A"
  with 1 have "\<sigma>(A,x) : Hom(A,_) \<Rightarrow> F in Func (AA,Set)"
    by (rule sandwich_natural)
  thus "\<sigma>(A,x) \<in> {y. y : Hom(A,_) \<Rightarrow> F in Func (AA,Set)}"
    by simp
qed

end


theory Deduction
  imports Main Unification Term
begin

section \<open>Assignment 6\<close>

subsection \<open>(a)\<close>

abbreviation "\<iota> \<equiv> Constant ''i''"

inductive deduce :: "msg set \<Rightarrow> msg \<Rightarrow> bool" (infix "\<turnstile>" 72) for T where
  Ax: "u \<in> T \<Longrightarrow> T \<turnstile> u"
| CompHash: "T \<turnstile> t \<Longrightarrow> T \<turnstile> Hash t"
| CompPair: "\<lbrakk> T \<turnstile> t1; T \<turnstile> t2 \<rbrakk> \<Longrightarrow> T \<turnstile> Pair t1 t2"
| CompSymEncrypt: "\<lbrakk> T \<turnstile> k; T \<turnstile> t \<rbrakk> \<Longrightarrow> T \<turnstile> SymEncrypt k t"
| CompPubKeyEncrypt: "\<lbrakk> T \<turnstile> k; T \<turnstile> t \<rbrakk> \<Longrightarrow> T \<turnstile> PubKeyEncrypt k t"
| CompSig: "\<lbrakk> T \<turnstile> \<iota>; T \<turnstile> t \<rbrakk> \<Longrightarrow> T \<turnstile> Sig \<iota> t"
| ProjL: "T \<turnstile> Pair t1 t2 \<Longrightarrow> T \<turnstile> t1"
| ProjR: "T \<turnstile> Pair t1 t2 \<Longrightarrow> T \<turnstile> t2"
| Sdec: "\<lbrakk> T \<turnstile> SymEncrypt k t; T \<turnstile> k \<rbrakk> \<Longrightarrow> T \<turnstile> t"
| Adec: "T \<turnstile> PubKeyEncrypt \<iota> t \<Longrightarrow> T \<turnstile> t"

lemma "{ Pair m n } \<turnstile> Hash (Pair n m)"
  apply(rule CompHash)
  apply(rule CompPair)
   apply(rule ProjR[of _ "m" "n"])
   apply(rule Ax)
   apply simp
  apply(rule ProjL[of _ "m" "n"])
  apply(rule Ax)
  apply simp
  done

lemma " { \<iota> } \<turnstile> Hash \<iota> "
  apply(rule CompHash)
  apply(rule Ax)
  apply simp
  done

subsection \<open>(b)\<close>

lemma deduce_weaken:
  assumes "G \<turnstile> t" and "G \<subseteq> H"
  shows "H \<turnstile> t"
  using assms
  apply(induction t rule: deduce.induct)
           apply(auto intro: deduce.intros)
  done

lemma deduce_cut:
  assumes "insert t H \<turnstile> u" and "H \<turnstile> t"
  shows "H \<turnstile> u"
  using assms
  apply(induction u rule: deduce.induct)
           apply(auto intro: deduce.intros)
  done

section \<open>Assignment 7\<close>

datatype constraint =
  Constraint "msg list" "msg list" "msg" ( "((2_/|_)/ \<rhd> _)" [67,67,67] 66)

type_synonym constraint_system = "constraint list"

subsection \<open>(a)\<close>

fun c_M :: "constraint \<Rightarrow> msg list" where
  "c_M (Constraint M _ _) = M"

fun c_A :: "constraint \<Rightarrow> msg list" where
  "c_A (Constraint _ A _) = A"

fun c_t :: "constraint \<Rightarrow> msg" where
  "c_t (Constraint _ _ t) = t"

definition c_fv :: "constraint \<Rightarrow> string set" where
  "c_fv c = union (\<Union> (set (map msg_fv ((c_M c) @ (c_A c))))) (msg_fv (c_t c))"

definition cs_fv :: "constraint_system \<Rightarrow> string set" where
  "cs_fv cs = \<Union> (set (map c_fv cs))"

definition c_sapply :: "msg_subst \<Rightarrow> constraint \<Rightarrow> constraint" where
  "c_sapply \<sigma> c = (map (msg_sapply \<sigma>) (c_M c)) | (map (msg_sapply \<sigma>) (c_A c)) \<rhd> (msg_sapply \<sigma>) (c_t c)"

definition cs_sapply :: "msg_subst \<Rightarrow> constraint_system \<Rightarrow> constraint_system" where
  "cs_sapply \<sigma> cs = map (c_sapply \<sigma>) cs"

lemma c_fv_finite: "finite (c_fv c)"
  using fv_finite unfolding c_fv_def msg_fv_def by auto

lemma cs_fv_finite: "finite (cs_fv cs)"
  using c_fv_finite unfolding cs_fv_def by simp

lemma c_fv_sapply_sdom_svran: "c_fv (c_sapply \<sigma> c) \<subseteq> (c_fv c - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
  using msg_fv_sapply_sdom_svran[of \<sigma> _]
  unfolding c_fv_def cs_sapply_def c_sapply_def
  by (clarsimp; blast+)

lemma cs_fv_sapply_sdom_svran: "cs_fv (cs_sapply \<sigma> cs) \<subseteq> (cs_fv cs - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
  using c_fv_sapply_sdom_svran[of \<sigma> _]
  unfolding cs_fv_def cs_sapply_def c_sapply_def
  by (clarsimp; blast+)

lemma cs_cs'_fv: "cs_fv (cs @ cs') = cs_fv cs \<union> cs_fv cs'"
  unfolding cs_fv_def by simp

lemma c_cs'_fv: "cs_fv (c # cs') = c_fv c \<union> cs_fv cs'"
  unfolding cs_fv_def by simp

lemma c_cs_fv: "cs_fv [c] = c_fv c"
  unfolding cs_fv_def by simp

definition sol :: "constraint_system \<Rightarrow> msg_subst set" where
  "sol cs = { \<sigma>. \<forall>c \<in> (set cs). ((set (map (msg_sapply \<sigma>) (c_M c))) \<union> (set (map (msg_sapply \<sigma>) (c_A c)))) \<turnstile> (msg_sapply \<sigma>) (c_t c) }"

subsection \<open>(b)\<close>

lemma sol_inter: "sol (cs1 @ cs2) = sol(cs1) \<inter> sol(cs2)"
  unfolding sol_def by auto

lemma sol_scomp: "\<tau> \<in> sol(cs_sapply \<sigma> cs) \<Longrightarrow> (\<tau> \<circ>m \<sigma>) \<in> sol(cs)"
  unfolding c_sapply_def cs_sapply_def
  by (simp add: msg_scomp_distrib sol_def image_image)

subsection \<open>(c)\<close>

inductive rer1 :: "constraint \<Rightarrow> msg_subst \<Rightarrow> constraint_system \<Rightarrow> bool" ("(_)/ \<leadsto>\<^sub>1[_]/ (_) " [64,64,64] 63) where
  Unif: "\<not>(is_Variable t) \<Longrightarrow> u \<in> (set M) \<union> (set A) \<Longrightarrow> Some(\<sigma>) = msg_unify [(t, u)] \<Longrightarrow>
  M | A \<rhd> t \<leadsto>\<^sub>1[\<sigma>] []"
| CompHash: "M | A \<rhd> (Hash t) \<leadsto>\<^sub>1[Variable]
  [(M | A \<rhd> t)]"
| CompPair: "M | A \<rhd> (Pair t1 t2) \<leadsto>\<^sub>1[Variable]
  [(M | A \<rhd> t1), (M | A \<rhd> t2)]"
| CompSymEncrypt: "M | A \<rhd> (SymEncrypt k t) \<leadsto>\<^sub>1[Variable]
  [(M | A \<rhd> k), (M | A \<rhd> t)]"
| CompPubKeyEncrypt: "M | A \<rhd> (PubKeyEncrypt k t) \<leadsto>\<^sub>1[Variable]
  [(M | A \<rhd> k), (M | A \<rhd> t)]"
| CompSig: "M | A \<rhd> (Sig \<iota> t) \<leadsto>\<^sub>1[Variable]
  [M | A \<rhd> \<iota>, M | A \<rhd> t]"
| Proj: "(M1 @ (Pair u v) # M2) | A \<rhd> t \<leadsto>\<^sub>1[Variable]
  [(M1 @ (u # v # M2)) | ((Pair u v) # A) \<rhd> t]"
| Sdec: "(M1 @ (SymEncrypt k u) # M2) | A \<rhd> t \<leadsto>\<^sub>1[Variable]
  [(M1 @ (u # M2)) | ((SymEncrypt k u) # A) \<rhd> t, (M1 @ M2) | ((SymEncrypt k u) # A) \<rhd> k]"
| Adec: "(M1 @ (PubKeyEncrypt \<iota> u) # M2) | A \<rhd> t \<leadsto>\<^sub>1[Variable]
  [(M1 @ (u # M2)) | ((PubKeyEncrypt \<iota> u) # A) \<rhd> t]"
| Ksub: "(M1 @ (PubKeyEncrypt (Variable x) u) # M2) | A \<rhd> t \<leadsto>\<^sub>1[Variable(x := \<iota>)]
  [c_sapply (Variable(x := \<iota>)) ((M1 @ (PubKeyEncrypt (Variable x) u) # M2) | A \<rhd> t)]"

inductive rer :: "constraint_system \<Rightarrow> msg_subst \<Rightarrow> constraint_system \<Rightarrow> bool" ( "_/ \<leadsto>[_]/ _ " [73,73,73] 72) where
  Context: "c \<leadsto>\<^sub>1[\<sigma>] cs \<Longrightarrow> (cs'1 @ (c # cs'2)) \<leadsto>[\<sigma>] (cs @ (cs_sapply \<sigma> (cs'1 @ cs'2)))"

inductive rer_star :: "constraint_system \<Rightarrow> msg_subst \<Rightarrow> constraint_system \<Rightarrow> bool" ( "_/ \<leadsto>*[_]/ _ " [73,73,73] 72) where
  Refl: "cs \<leadsto>*[Variable] cs"
| Trans: "cs \<leadsto>[\<sigma>] cs'' \<Longrightarrow> cs'' \<leadsto>*[\<tau>] cs' \<Longrightarrow> cs \<leadsto>*[(\<tau> \<circ>m \<sigma>)] cs'"

section \<open>Assignment 8\<close>

subsection \<open>(a)\<close>

definition is_simple_c :: "constraint \<Rightarrow> bool" where
  "is_simple_c c = is_Variable (c_t c)"

definition is_simple_cs :: "constraint_system \<Rightarrow> bool" where
  "is_simple_cs cs = (\<forall>c \<in> (set cs). is_simple_c c)"

definition red :: "constraint_system \<Rightarrow> msg_subst set" where
  "red cs = {\<tau> \<circ>m \<sigma> | \<tau> \<sigma>. (\<exists>cs'. cs \<leadsto>*[\<sigma>] cs' \<and> is_simple_cs cs' \<and> \<tau> \<in> sol(cs'))}"

lemma one_step_red_soundness:
  assumes "c \<leadsto>\<^sub>1[\<sigma>] cs" and "\<tau> \<in> sol(cs)"
  shows "(\<tau> \<circ>m \<sigma>) \<in> sol([c])"
  using assms
proof(cases rule: rer1.cases)
  case (Unif t u M A)
  then have "\<sigma> \<cdot>m t = \<sigma> \<cdot>m u"
    using msg_unify_unifies[of "[(t,u)]" \<sigma>] unifies_forall
    unfolding msg_unifies_def by (simp add: msg_sapply_def unifies_eq_def)
  then have "set (map ((\<cdot>m) \<tau>) (map ((\<cdot>m) \<sigma>) (M @ A))) \<turnstile> (\<tau> \<cdot>m (\<sigma> \<cdot>m t))"
    using Unif Ax by auto
  then show ?thesis
    using Unif msg_scomp_distrib
    unfolding sol_def by simp
next
  case (CompHash M A t)
  have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms CompHash
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  then have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m (Hash t))"
    using deduce.CompHash[of "set (map ((\<cdot>m) \<tau>) (M @ A))" "\<tau> \<cdot>m t"]
    by (simp add: msg_sapply_def)
  then show ?thesis
    using CompHash unfolding sol_def by simp
next
  case (CompPair M A t1 t2)
  have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m t1)"
    using assms CompPair
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  moreover have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m t2)"
    using assms CompPair
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  ultimately have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m (Pair t1 t2))"
    using deduce.CompPair[of "set (map ((\<cdot>m) \<tau>) (M @ A))" "\<tau> \<cdot>m t1" "\<tau> \<cdot>m t2"]
    by (simp add: msg_sapply_def)
  then show ?thesis
    using CompPair unfolding sol_def by simp
next
  case (CompSymEncrypt M A k t)
  have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms CompSymEncrypt
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  moreover have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m k)"
    using assms CompSymEncrypt
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  ultimately have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m (SymEncrypt k t))"
    using deduce.CompSymEncrypt[of "set (map ((\<cdot>m) \<tau>) (M @ A))" "\<tau> \<cdot>m k" "\<tau> \<cdot>m t"]
    by (simp add: msg_sapply_def)
  then show ?thesis
    using CompSymEncrypt unfolding sol_def by simp
next
  case (CompPubKeyEncrypt M A k t)
  have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms CompPubKeyEncrypt
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  moreover have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m k)"
    using assms CompPubKeyEncrypt
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  ultimately have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m (PubKeyEncrypt k t))"
    using deduce.CompPubKeyEncrypt[of "set (map ((\<cdot>m) \<tau>) (M @ A))" "\<tau> \<cdot>m k" "\<tau> \<cdot>m t"]
    by (simp add: msg_sapply_def)
  then show ?thesis
    using CompPubKeyEncrypt unfolding sol_def by simp
next
  case (CompSig M A t)
  have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms CompSig
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  moreover have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m \<iota>)"
    using assms CompSig
    unfolding sol_def
    by simp
  ultimately have "set (map ((\<cdot>m) \<tau>) (M @ A)) \<turnstile> (\<tau> \<cdot>m (Sig \<iota> t))"
    using deduce.CompSig[of "set (map ((\<cdot>m) \<tau>) (M @ A))" "\<tau> \<cdot>m t"]
    by (simp add: msg_sapply_def)
  then show ?thesis
    using CompSig
    unfolding sol_def
    by simp
next
  (* Reminder: here we need to apply cut twice *)
  case (Proj M1 u v M2 A t)
  have ax_app: "set (map ((\<cdot>m) \<tau>) (M1 @ Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m (Pair u v))"
    by (rule Ax; simp)
  have tau_u_deriv: "set (map ((\<cdot>m) \<tau>) (M1 @ Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m u)"
    using ax_app deduce.ProjL[of _ "(\<tau> \<cdot>m u)" "(\<tau> \<cdot>m v)"]
    by (simp add: msg_sapply_def)
  have tau_v_deriv: "set (map ((\<cdot>m) \<tau>) (M1 @ Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m v)"
    using ax_app deduce.ProjR[of _ "(\<tau> \<cdot>m u)" "(\<tau> \<cdot>m v)"]
    by (simp add: msg_sapply_def)
  have u_deriv: "set (M1 @ v # Pair u v # M2 @ A) \<turnstile> u"
    using deduce.ProjL[of _ u v] ax_app
    by (simp; meson Ax insertCI)
  then have u_deriv': "set (map ((\<cdot>m) \<tau>) (M1 @ v # Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m u)"
    using deduce.ProjL[of _ "(\<tau> \<cdot>m u)" "(\<tau> \<cdot>m v)"] ax_app msg_sapply_def
    by (simp add: Ax)
  have tau_t_1: "set (map ((\<cdot>m) \<tau>) (M1 @ u # v # Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms Proj
    unfolding sol_def
    by (simp add: Un_assoc image_Un insert_commute)
  then have "set (map ((\<cdot>m) \<tau>) (M1 @ v # Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms Proj tau_u_deriv deduce_cut u_deriv'
    by auto
  then have "set (map ((\<cdot>m) \<tau>) (M1 @ Pair u v # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms Proj deduce_cut
    by (smt (verit, best) Un_insert_right image_insert list.set_map list.simps(15) set_append tau_v_deriv)
  then show ?thesis
    using assms Proj
    unfolding sol_def
    by (simp add: Un_assoc)
next
  case (Sdec M1 k u M2 A t)
  have "set (map ((\<cdot>m) \<tau>) (M1 @ SymEncrypt k u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m k)"
    using assms Sdec
    unfolding sol_def
    by (simp add: Un_assoc image_Un)
  moreover have "set (map ((\<cdot>m) \<tau>) (M1 @ SymEncrypt k u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m (SymEncrypt k u))"
    by (rule Ax; simp)
  ultimately have "set (map ((\<cdot>m) \<tau>) (M1 @ SymEncrypt k u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m u)"
    using deduce.Sdec[of "set (map ((\<cdot>m) \<tau>) (M1 @ SymEncrypt k u # M2 @ A))" "(\<tau> \<cdot>m k)" "(\<tau> \<cdot>m u)"]
    by (simp add: msg_sapply_def)
  moreover have "set (map ((\<cdot>m) \<tau>) (M1 @ u # SymEncrypt k u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms Sdec
    unfolding sol_def
    by (simp add: Un_assoc image_Un insert_commute)
  ultimately have "set (map ((\<cdot>m) \<tau>) (M1 @ SymEncrypt k u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    by (simp add: deduce_cut)
  then show ?thesis
    using assms Sdec
    unfolding sol_def
    by (simp add: Un_assoc)
next
  case (Adec M1 u M2 A t)
  have "set (map ((\<cdot>m) \<tau>) (M1 @ PubKeyEncrypt \<iota> u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m (PubKeyEncrypt \<iota> u))"
    by (rule Ax; simp)
  then have "set (map ((\<cdot>m) \<tau>) (M1 @ PubKeyEncrypt \<iota> u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m u)"
    using deduce.Adec[of "set (map ((\<cdot>m) \<tau>) (M1 @ PubKeyEncrypt \<iota> u # M2 @ A))" "(\<tau> \<cdot>m u)"]
    by (simp add: msg_sapply_def)
  moreover have "set (map ((\<cdot>m) \<tau>) (M1 @ u # PubKeyEncrypt \<iota> u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    using assms Adec
    unfolding sol_def
    by (simp add: Un_assoc image_Un insert_commute)
  ultimately have "set (map ((\<cdot>m) \<tau>) (M1 @ PubKeyEncrypt \<iota> u # M2 @ A)) \<turnstile> (\<tau> \<cdot>m t)"
    by (simp add: deduce_cut)
  then show ?thesis
    using assms Adec
    unfolding sol_def
    by (simp add: Un_assoc)
next
  case (Ksub M1 x u M2 A t)
  then show ?thesis
    using assms
    by (simp add: cs_sapply_def sol_scomp)
qed

lemma msg_scomp_sol:
  assumes "cs \<leadsto>[\<sigma>] cs'" and "\<tau> \<in> sol(cs')"
  shows "(\<tau> \<circ>m \<sigma>) \<in> sol(cs)"
  using assms
proof(cases rule: rer.cases)
  case (Context c cs cs'1 cs'2)
  have tau_cs: "\<tau> \<in> sol(cs)"
    using assms Context unfolding sol_def by simp
  have tau_cs2: "\<tau> \<in> sol(cs_sapply \<sigma> (cs'1 @ cs'2))"
    using assms Context unfolding sol_def by simp
  have "(\<tau> \<circ>m \<sigma>) \<in> sol([c])"
    using assms Context one_step_red_soundness[of c \<sigma> cs \<tau>]
    unfolding sol_def by simp
  moreover have "(\<tau> \<circ>m \<sigma>) \<in> sol(cs'1 @ cs'2)"
    using sol_scomp[of \<tau> \<sigma> "(cs'1 @ cs'2)"] tau_cs2
    unfolding sol_def by auto
  ultimately show ?thesis
    using Context unfolding sol_def by simp
qed

lemma msg_scomp_simple_sol:
  assumes "cs \<leadsto>*[\<sigma>] cs'"
    and "is_simple_cs cs'"
    and "\<tau> \<in> sol(cs')"
  shows "(\<tau> \<circ>m \<sigma>) \<in> sol(cs)"
  using assms
proof(induction rule: rer_star.induct)
  case (Refl cs)
  then show ?case by auto
next
  case (Trans cs \<sigma> cs'' \<tau> cs')
  then show ?case
    using msg_scomp_sol[of cs \<sigma> cs''] one_step_red_soundness msg_scomp_assoc
    by (simp; fastforce)
qed

theorem red_soundness: "red cs \<subseteq> sol(cs)"
  using sol_def red_def msg_scomp_simple_sol by auto

subsection \<open>(b)\<close>

fun \<theta> :: "msg \<Rightarrow> nat" where
  "\<theta> (Variable x) = 1"
| "\<theta> (Constant c) = 1"
| "\<theta> (Hash t) = \<theta> t + 1"
| "\<theta> (Pair t1 t2) = \<theta> t1 + \<theta> t2 + 1"
| "\<theta> (SymEncrypt k t) = \<theta> k + \<theta> t + 1"
| "\<theta> (PubKeyEncrypt k t) = \<theta> k + \<theta> t + 1"
| "\<theta> (Sig k t) = \<theta> k + \<theta> t + 1"

fun \<chi> :: "msg \<Rightarrow> nat" where
  "\<chi> (Variable x) = 1"
| "\<chi> (Constant c) = 1"
| "\<chi> (Hash t) = \<chi> t + 1"
| "\<chi> (Pair t1 t2) = \<chi> t1 * \<chi> t2 + 1"
| "\<chi> (SymEncrypt k t) = \<chi> t + \<theta> k + 1"
| "\<chi> (PubKeyEncrypt k t) = \<chi> t + 1"
| "\<chi> (Sig k t) = \<chi> t + 1"

definition \<chi>_list :: "msg list \<Rightarrow> nat" where
  "\<chi>_list msg_list = prod_list (map \<chi> msg_list)"

definition weight :: "constraint \<Rightarrow> nat" where
  "weight c = \<chi>_list (c_M c) * \<theta> (c_t c)"

lemma \<theta>_geq_1: "\<theta> m \<ge> 1"
  by(induction m; simp)

lemma \<chi>_geq_1: "\<chi> m \<ge> 1"
  by(induction m; simp)

lemma \<chi>_list_geq_1: "\<chi>_list l \<ge> 1"
proof(induction l)
  case Nil
  then show ?case
    using \<chi>_geq_1 unfolding \<chi>_list_def by simp
next
  case (Cons a l)
  then show ?case
    using \<chi>_geq_1 unfolding \<chi>_list_def by simp
qed

lemma \<chi>_list_pair_ineq: "\<chi>_list (M1 @ u # v # M2) < \<chi>_list (M1 @ Pair u v # M2)"
  using \<chi>_list_geq_1
  unfolding \<chi>_list_def
  by (auto simp add: Suc_le_lessD)

lemma weight_positive: "weight c \<ge> 1"
proof(cases c)
  case (Constraint M A t)
  then show ?thesis
    using \<chi>_list_geq_1 \<theta>_geq_1
    unfolding weight_def by simp
qed

definition \<eta>_1 :: "constraint_system \<Rightarrow> nat" where
  "\<eta>_1 cs = card (cs_fv cs)"

definition \<eta>_2 :: "constraint_system \<Rightarrow> nat" where
  "\<eta>_2 cs = sum_list (map weight cs)"

lemma cs_sapply_id: "cs_sapply Variable cs = cs"
proof(induction cs)
  case Nil
  then show ?case
    unfolding cs_sapply_def by simp
next
  case (Cons a cs)
  then show ?case
    using msg_var_sapply
    unfolding cs_sapply_def c_sapply_def msg_sapply_def
    by (cases a; simp)
qed

lemma fv_x_\<iota>:
  assumes "\<sigma> = Variable(x := \<iota>)"
    and "x \<in> c_fv c"
  shows "c_fv(c_sapply \<sigma> c) \<union> {x} \<subseteq> c_fv(c)"
proof -
  have \<sigma>_sdom: "msg_sdom \<sigma> = {x}"
    using assms msg_sdom_single_non_trivial[of \<iota> x] by simp
  moreover have \<sigma>_svran: "msg_svran \<sigma> = msg_fv \<iota>"
    using assms msg_svran_single_non_trivial[of \<iota> x] by simp
  moreover have \<sigma>_cs:  "c_fv (c_sapply \<sigma> c) \<subseteq> (c_fv(c) - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
    using c_fv_sapply_sdom_svran[of \<sigma> c] by simp
  ultimately show ?thesis
    using assms unfolding msg_fv_def by auto
qed

lemma c_cs_fv_subseteq:
  assumes "c  \<leadsto>\<^sub>1[\<sigma>] cs"
  shows "cs_fv(cs @ (cs_sapply \<sigma> cs')) \<subseteq> cs_fv(c # cs')"
  using assms
proof(cases rule: rer1.cases)
  case (Unif t u M A)
  have "cs_fv (cs_sapply \<sigma> cs') \<subseteq> (cs_fv(cs') - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
    using cs_fv_sapply_sdom_svran[of \<sigma> cs'] by simp
  moreover have "msg_svran \<sigma> \<subseteq> c_fv c"
    using Unif msg_unify_svran_fv[of "[(t, u)]" \<sigma>]
    by (auto simp add: c_fv_def msg_fv_eqs_def msg_fv_eq_def)
  ultimately show ?thesis
    using Unif
    unfolding cs_fv_def c_fv_def cs_sapply_def c_sapply_def
    by (simp; smt (verit, best) Diff_subset Un_commute Un_mono subset_trans)
next
  case (Ksub M1 x u M2 A t)
  have \<sigma>_sdom: "msg_sdom \<sigma> = {x}"
    using Ksub msg_sdom_single_non_trivial[of \<iota> x] by simp
  moreover have \<sigma>_svran: "msg_svran \<sigma> = msg_fv \<iota>"
    using Ksub msg_svran_single_non_trivial[of \<iota> x] by simp
  moreover have fv_subseteq: "cs_fv(cs) \<subseteq> c_fv(c)"
    using Ksub cs_fv_sapply_sdom_svran[of \<sigma> cs'] c_fv_sapply_sdom_svran \<sigma>_sdom \<sigma>_svran
    unfolding msg_fv_def
    by (simp add: cs_fv_def; fastforce)
  ultimately have "cs_fv (cs @ cs_sapply \<sigma> cs') \<subseteq> (cs_fv(cs @ cs') - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
    using Ksub(2) Ksub(3) cs_fv_sapply_sdom_svran[of \<sigma> cs'] c_fv_sapply_sdom_svran
    unfolding msg_fv_def
    by (simp add: cs_cs'_fv cs_fv_def; fastforce)
  also have "... \<subseteq> cs_fv(c # cs')"
    using Ksub(2) \<sigma>_sdom \<sigma>_svran fv_subseteq
    unfolding cs_fv_def msg_fv_def
    by auto
  finally show ?thesis by simp
qed (auto simp add: cs_fv_def c_fv_def cs_sapply_id msg_fv_def)

lemma c_cs_fv_noteq:
  assumes "c  \<leadsto>\<^sub>1[\<sigma>] cs"
    and "\<sigma> \<noteq> Variable"
  shows "cs_fv(cs @ (cs_sapply \<sigma> cs')) \<noteq> cs_fv(c # cs')"
  using assms
proof(cases rule: rer1.cases)
  case (Unif t u M A)
  obtain x where x_sdom: "x \<in> msg_sdom(\<sigma>)"
    using assms msg_not_var
    unfolding msg_sdom_def sdom_def
    by (simp; blast)
  moreover have "msg_sdom(\<sigma>) \<subseteq> c_fv(c)"
    using Unif msg_unify_sdom_fv[of "[(t, u)]" \<sigma>]
    unfolding c_fv_def msg_fv_eqs_def msg_fv_eq_def
    by auto
  ultimately have "x \<in> cs_fv(c # cs')"
    unfolding cs_fv_def by auto
  moreover have "cs_fv (cs_sapply \<sigma> cs') \<subseteq> (cs_fv(cs') - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
    using cs_fv_sapply_sdom_svran[of \<sigma> cs'] by simp
  moreover have "msg_sdom(\<sigma>) \<inter> msg_svran(\<sigma>) = {}"
    using Unif msg_unify_sdom_svran[of "[(t, u)]" \<sigma>]
    by simp
  ultimately show ?thesis
    using Unif by (metis (no_types, lifting) DiffD2 Diff_empty IntI Un_iff x_sdom self_append_conv2 subsetD)
next
  case (Ksub M1 x u M2 A t)
  have c_cs: "cs_fv cs = c_fv (c_sapply \<sigma> c)"
    using Ksub unfolding cs_fv_def by simp
  have \<sigma>_sdom: "msg_sdom \<sigma> = {x}"
    using Ksub msg_sdom_single_non_trivial[of \<iota> x] by simp
  have \<sigma>_svran: "msg_svran \<sigma> = msg_fv \<iota>"
    using Ksub msg_svran_single_non_trivial[of \<iota> x] by simp
  have sdom_svran: "msg_sdom(\<sigma>) \<inter> msg_svran(\<sigma>) = {}"
    using \<sigma>_sdom \<sigma>_svran unfolding msg_fv_def by simp
  have x_in_c: "x \<in> c_fv c"
    using Ksub unfolding c_fv_def msg_fv_def by simp
  have \<sigma>_cs':  "cs_fv (cs_sapply \<sigma> cs') \<subseteq> (cs_fv(cs') - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
    using cs_fv_sapply_sdom_svran[of \<sigma> cs'] by simp
  moreover have fv_subseteq: "cs_fv(cs) \<union> {x} \<subseteq> c_fv(c)"
    using c_cs fv_x_\<iota>[OF Ksub(2), of c] x_in_c by simp
  ultimately show ?thesis
    using Ksub cs_cs'_fv[of cs "cs_sapply \<sigma> cs'"] c_cs'_fv[of c cs'] \<sigma>_sdom \<sigma>_svran sdom_svran \<sigma>_cs'
    by (simp; smt (verit, best) DiffE Un_iff \<sigma>_sdom \<sigma>_svran c_cs_fv c_fv_sapply_sdom_svran insertI1 subset_Un_eq)
qed (auto simp add: assms)

lemma c_cs_\<eta>2_w:
  assumes "c  \<leadsto>\<^sub>1[Variable] cs"
  shows "\<eta>_2(cs) < weight(c)"
  using assms
proof(cases rule: rer1.cases)
  case (Unif t u M A)
  then show ?thesis
    using weight_positive[of c]
    unfolding \<eta>_2_def
    by simp
next
  case (CompHash M A t)
  have "weight (M|A \<rhd>t) = (\<chi>_list M * (\<theta> t))"
    unfolding weight_def
    by simp
  also have "... < (\<chi>_list M * (\<theta> t + 1))"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1
    by (simp add: Suc_le_lessD)
  also have "... = (\<chi>_list M * (\<theta> (Hash t)))"
    by simp
  also have "... = weight (M|A \<rhd> Hash t)"
    using weight_def
    by simp
  also have "... = weight (c)"
    using CompHash
    by simp
  finally show ?thesis
    using CompHash unfolding \<eta>_2_def by auto
next
  case (CompPair M A t1 t2)
  have "weight (M|A \<rhd>t1) + weight (M|A \<rhd>t2) = (\<chi>_list M * (\<theta> t1)) + (\<chi>_list M * (\<theta> t2))"
    unfolding weight_def
    by simp
  also have "... < \<chi>_list M * (\<theta> t1 + \<theta> t2 + 1)"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1
    by (simp add: discrete distrib_left)
  also have "... = \<chi>_list M * (\<theta> (Pair t1 t2))"
    by simp
  also have "... = weight (M|A \<rhd> Pair t1 t2)"
    using weight_def
    by simp
  also have "... = weight (c)"
    using CompPair
    by simp
  finally show ?thesis
    using CompPair unfolding \<eta>_2_def by auto
next
  case (CompSymEncrypt M A k t)
  have "weight (M|A \<rhd>k) + weight (M|A \<rhd>t) = (\<chi>_list M * (\<theta> k)) + (\<chi>_list M * (\<theta> t))"
    unfolding weight_def
    by simp
  also have "... < \<chi>_list M * (\<theta> k + \<theta> t + 1)"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1
    by (simp add: discrete distrib_left)
  also have "... = \<chi>_list M * (\<theta> (SymEncrypt k t))"
    by simp
  also have "... = weight (M|A \<rhd> (SymEncrypt k t))"
    using weight_def
    by simp
  also have "... = weight (c)"
    using CompSymEncrypt
    by simp
  finally show ?thesis
    using CompSymEncrypt
    unfolding \<eta>_2_def unfolding \<eta>_2_def by auto
next
  case (CompPubKeyEncrypt M A k t)
  have "weight (M|A \<rhd>k) + weight (M|A \<rhd>t) = (\<chi>_list M * (\<theta> k)) + (\<chi>_list M * (\<theta> t))"
    unfolding weight_def
    by simp
  also have "... < \<chi>_list M * (\<theta> k + \<theta> t + 1)"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1
    by (simp add: discrete distrib_left)
  also have "... = \<chi>_list M * (\<theta> (PubKeyEncrypt k t))"
    by simp
  also have "... = weight (M|A \<rhd> (PubKeyEncrypt k t))"
    using weight_def
    by simp
  also have "... = weight (c)"
    using CompPubKeyEncrypt
    by simp
  finally show ?thesis
    using CompPubKeyEncrypt unfolding \<eta>_2_def by auto
next
  case (CompSig M A t)
  have "weight (M|A \<rhd>\<iota>) + weight (M|A \<rhd>t) = (\<chi>_list M * (\<theta> \<iota>)) + (\<chi>_list M * (\<theta> t))"
    unfolding weight_def
    by simp
  also have "... < \<chi>_list M * (\<theta> \<iota> + \<theta> t + 1)"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1
    by (simp add: discrete distrib_left)
  also have "... = \<chi>_list M * (\<theta> (Sig \<iota> t))"
    by simp
  also have "... = weight (M|A \<rhd> (Sig \<iota> t))"
    using weight_def
    by simp
  also have "... = weight (c)"
    using CompSig
    by simp
  finally show ?thesis
    using CompSig unfolding \<eta>_2_def by auto
next
  case (Proj M1 u v M2 A t)
  have pair_ineq: "(\<chi> u) * (\<chi> v) < (\<chi> (Pair u v))"
    by auto
  then show ?thesis
    using Proj Suc_le_eq \<theta>_geq_1 \<chi>_list_pair_ineq
    unfolding \<eta>_2_def weight_def
    by auto
next
  case (Sdec M1 k u M2 A t)
  have "weight ((M1 @ u # M2)|(SymEncrypt k u # A) \<rhd>t) + weight ((M1 @ M2)|(SymEncrypt k u # A)\<rhd>k)
        = ((\<chi>_list (M1 @ M2) * (\<chi> u) * (\<theta> t)) + (\<chi>_list (M1 @ M2) * (\<theta> k)))"
    unfolding weight_def \<chi>_list_def
    by auto
  also have "... < ((\<chi>_list (M1 @ M2) * (\<chi> u) * (\<theta> t)) + (\<chi>_list (M1 @ M2) * ((\<theta> k) + 1) * (\<theta> t)))"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1
    by (clarsimp; metis One_nat_def Suc_le_lessD add.commute add_lessD1 less_add_same_cancel2 n_less_n_mult_m nat_mult_1_right order_less_le)
  also have "... = (\<chi>_list (M1 @ M2) * (\<chi> u + \<theta> k + 1) * (\<theta> t))"
    by (simp add: add_mult_distrib add_mult_distrib2)
  also have "... = (\<chi>_list (M1 @ M2) * (\<chi> (SymEncrypt k u)) * (\<theta> t))"
    by simp
  also have "... = weight ((M1 @ (SymEncrypt k u) # M2)|A \<rhd>t)"
    unfolding weight_def \<chi>_list_def
    by (simp add: mult.commute mult.left_commute)
  also have "... = weight(c)"
    using Sdec unfolding weight_def by simp
  finally show ?thesis
    using Sdec unfolding \<eta>_2_def by auto
next
  case (Adec M1 u M2 A t)
  have "weight ((M1 @ u # M2)|(PubKeyEncrypt \<iota> u # A) \<rhd>t) = (\<chi>_list (M1 @ M2) * (\<chi> u) * (\<theta> t))"
    unfolding weight_def \<chi>_list_def
    by auto
  also have "... < (\<chi>_list (M1 @ M2) * (\<chi> u + 1) * (\<theta> t))"
    using \<theta>_geq_1 \<chi>_geq_1 \<chi>_list_geq_1 Suc_le_eq
    by auto
  also have "... = (\<chi>_list (M1 @ M2) * (\<chi> (PubKeyEncrypt \<iota> u)) * (\<theta> t))"
    by simp
  also have "... = weight ((M1 @ (PubKeyEncrypt \<iota> u) # M2)|A \<rhd>t)"
    unfolding weight_def \<chi>_list_def
    by (simp add: distrib_left)
  also have "... = weight(c)"
    using Adec unfolding weight_def by simp
  finally show ?thesis
    using Adec unfolding \<eta>_2_def by auto
next
  case (Ksub M1 x u M2 A t)
  have "Variable \<noteq> Variable(x := \<iota>)"
    by (metis fun_upd_def msg.distinct(1))
  then show ?thesis using Ksub by simp
qed

lemma do_Unif:
  assumes "\<not>(is_Variable t)"
    and "u \<in> (set M) \<union> (set A)"
    and "Some(\<sigma>) = msg_unify [(t, u)]"
    and "c = M | A \<rhd> t"
    and "cs = []"
  shows "M | A \<rhd> t \<leadsto>\<^sub>1[\<sigma>] []"
  using rer1.Unif assms by simp

lemma cs_fv_perm: "cs_fv (c # cs'1 @ cs'2) = cs_fv (cs'1 @ c # cs'2)"
  unfolding cs_fv_def by auto

lemma wf_cs_\<eta>1:
  assumes "c \<leadsto>\<^sub>1[\<sigma>] cs"
    and "cs' = cs'1 @ c # cs'2"
    and "cs'' = cs @ cs_sapply \<sigma> (cs'1 @ cs'2)"
  shows "\<eta>_1 cs'' \<le> \<eta>_1 cs'"
proof -
  have "cs_fv (cs @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<subseteq> cs_fv (c # cs'1 @ cs'2)"
    using assms c_cs_fv_subseteq[of c \<sigma> cs "(cs'1 @ cs'2)"] by simp
  moreover have "... = cs_fv (cs'1 @ c # cs'2)"
      using cs_fv_perm by simp
  ultimately have "cs_fv (cs @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<subseteq> cs_fv (cs'1 @ c # cs'2)"
    by simp
  then show ?thesis
    using assms cs_fv_finite[of "(cs'1 @ c # cs'2)"] card_mono
    unfolding \<eta>_1_def by simp
qed

lemma wf_cs_\<eta>2:
  assumes "c \<leadsto>\<^sub>1[Variable] cs"
    and "cs' = cs'1 @ c # cs'2"
    and "cs'' = cs @ cs_sapply Variable (cs'1 @ cs'2)"
  shows "\<eta>_2 cs'' < \<eta>_2 cs'"
proof -
  have "cs'' = cs @ (cs'1 @ cs'2)"
    using assms cs_sapply_id[of "cs'1 @ cs'2"] by simp
  moreover have "\<eta>_2 cs < weight c"
    using assms c_cs_\<eta>2_w[of c cs] by simp
  ultimately show ?thesis
    using assms(2) cs_fv_finite[of "(cs'1 @ c # cs'2)"] card_mono
    unfolding \<eta>_2_def by simp
qed

lemma wf_cs:
  assumes "cs \<leadsto>[\<sigma>] cs'"
  shows "(cs', cs) \<in> measures [\<eta>_1, \<eta>_2]"
  using assms
proof(cases rule: rer.cases)
  case (Context c cs'' cs'1 cs'2)
  from this(3,1,2) show ?thesis
  proof(cases rule: rer1.cases)
    case (Unif t u M A)
    then have rer1_Unif: "c \<leadsto>\<^sub>1[\<sigma>] []"
      using do_Unif[of t u M A \<sigma> c cs''] by simp
    have "cs_fv (cs'' @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<subseteq> cs_fv (c # cs'1 @ cs'2)"
      using rer1_Unif Unif(2) c_cs_fv_subseteq[of c \<sigma> "[]" "(cs'1 @ cs'2)"] by simp
    moreover have perm_eq: "... = cs_fv (cs'1 @ c # cs'2)"
      using cs_fv_perm by simp
    ultimately have cs_fv_subseteq: "cs_fv (cs'' @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<subseteq> cs_fv (cs'1 @ c # cs'2)"
      by simp
    then show ?thesis
      using Context(1,2) cs_fv_finite[of "(cs'1 @ c # cs'2)"]
      unfolding \<eta>_1_def \<eta>_2_def
      by (simp; metis \<eta>_2_def add.left_commute add_less_cancel_right c_cs_\<eta>2_w c_cs_fv_noteq cs_sapply_id Context(3) map_append perm_eq psubsetI psubset_card_mono sum_list_append)
  next
    case (CompHash M A t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context CompHash wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (CompPair M A t1 t2)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context CompPair wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (CompSymEncrypt M A k t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context CompSymEncrypt wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (CompPubKeyEncrypt M A k t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context CompPubKeyEncrypt wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (CompSig M A t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context CompSig wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (Proj M1 u v M2 A t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context Proj wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (Sdec M1 k u M2 A t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context Sdec wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (Adec M1 u M2 A t)
    have "\<eta>_1 cs' \<le> \<eta>_1 cs"
      using Context wf_cs_\<eta>1[of c \<sigma> cs'' _ cs'1 cs'2] by simp
    moreover have "\<eta>_2 cs' < \<eta>_2 cs"
      using Context Adec wf_cs_\<eta>2[of c cs'' cs cs'1 cs'2 cs'] by simp
    ultimately show ?thesis by auto
  next
    case (Ksub M1 x u M2 A t)
    have "cs_fv (cs'' @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<subseteq> cs_fv (c # cs'1 @ cs'2)"
      using Context(3) c_cs_fv_subseteq[of c \<sigma> "cs''" "(cs'1 @ cs'2)"] by simp
    moreover have perm_eq: "... = cs_fv (cs'1 @ c # cs'2)"
      using cs_fv_perm by simp
    ultimately have cs_fv_subseteq: "cs_fv (cs'' @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<subseteq> cs_fv (cs'1 @ c # cs'2)"
      by simp
    have "\<sigma> \<noteq> Variable" using Ksub(2)
      by (simp add: fun_upd_idem_iff)
    then have "cs_fv (cs'' @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<noteq> cs_fv (c # cs'1 @ cs'2)"
      using Context(3) c_cs_fv_noteq[of c \<sigma> "cs''" "(cs'1 @ cs'2)"] by simp
    then have "cs_fv (cs'' @ cs_sapply \<sigma> (cs'1 @ cs'2)) \<noteq> cs_fv (cs'1 @ c # cs'2)"
      using perm_eq by simp
    then show ?thesis
      using Context(1,2) cs_fv_subseteq
      unfolding \<eta>_1_def \<eta>_2_def
      by (simp add: cs_fv_finite[of "(cs'1 @ c # cs'2)"] psubset_card_mono)
  qed
qed

theorem wf_red: "wf ({(cs', cs). \<exists>\<sigma>. cs \<leadsto>[\<sigma>] cs'})"
  using wf_subset[of "measures [\<eta>_1, \<eta>_2]" "{(cs', cs). \<exists>\<sigma>. cs \<leadsto>[\<sigma>] cs'}"] wf_cs by force

end