(*
 * Social Choice Functions (SCFs).
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced July 2006.
 * License: BSD
 *)

(*<*)
theory SCFs

imports RPRs

begin
(*>*)

(* **************************************** *)

subsection\<open>Choice Sets, Choice Functions\<close>

text\<open>A \emph{choice set} is the subset of @{term "A"} where every element
of that subset is (weakly) preferred to every other element of @{term "A"}
with respect to a given RPR. A \emph{choice function} yields a non-empty
choice set whenever @{term "A"} is non-empty.\<close>

definition choiceSet :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> 'a set" where
  "choiceSet A r \<equiv> { x \<in> A . \<forall>y \<in> A. x \<^bsub>r\<^esub>\<preceq> y }"

definition choiceFn :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "choiceFn A r \<equiv> \<forall>A' \<subseteq> A. A' \<noteq> {} \<longrightarrow> choiceSet A' r \<noteq> {}"

lemma choiceSetI[intro]:
  "\<lbrakk> x \<in> A; \<And>y. y \<in> A \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<rbrakk> \<Longrightarrow> x \<in> choiceSet A r"
  unfolding choiceSet_def by simp

lemma choiceFnI[intro]:
  "(\<And>A'. \<lbrakk> A' \<subseteq> A; A' \<noteq> {} \<rbrakk> \<Longrightarrow> choiceSet A' r \<noteq> {}) \<Longrightarrow> choiceFn A r"
  unfolding choiceFn_def by simp

text\<open>If a complete and reflexive relation is also \emph{quasi-transitive}
it will yield a choice function.\<close>

definition quasi_trans :: "'a RPR \<Rightarrow> bool" where
  "quasi_trans r \<equiv> \<forall>x y z. x \<^bsub>r\<^esub>\<prec> y \<and> y \<^bsub>r\<^esub>\<prec> z \<longrightarrow> x \<^bsub>r\<^esub>\<prec> z"

lemma quasi_transI[intro]:
  "(\<And>x y z. \<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<prec> z \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z) \<Longrightarrow> quasi_trans r"
  unfolding quasi_trans_def by blast

lemma quasi_transD: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<prec> z; quasi_trans r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding quasi_trans_def by blast

lemma trans_imp_quasi_trans: "trans r \<Longrightarrow> quasi_trans r"
  by (rule quasi_transI, unfold strict_pref_def trans_def, blast)

lemma r_c_qt_imp_cf:
  assumes finiteA: "finite A"
      and c: "complete A r"
      and qt: "quasi_trans r"
      and r: "refl_on A r"
  shows "choiceFn A r"
proof
  fix B assume B: "B \<subseteq> A" "B \<noteq> {}"
  with finite_subset finiteA have finiteB: "finite B" by auto
  from finiteB B show "choiceSet B r \<noteq> {}"
  proof(induct rule: finite_subset_induct')
    case empty with B show ?case by auto
  next
    case (insert a B)
    hence finiteB: "finite B"
        and aA: "a \<in> A"
        and AB: "B \<subseteq> A"
        and aB: "a \<notin> B"
        and cF: "B \<noteq> {} \<Longrightarrow> choiceSet B r \<noteq> {}" by - blast
    show ?case
    proof(cases "B = {}")
      case True with aA r show ?thesis
        unfolding choiceSet_def by blast
    next
      case False
      with cF obtain b where bCF: "b \<in> choiceSet B r" by blast
      from AB aA bCF complete_refl_on[OF c r]
      have "a \<^bsub>r\<^esub>\<prec> b \<or> b \<^bsub>r\<^esub>\<preceq> a" unfolding choiceSet_def strict_pref_def by blast
      thus ?thesis
      proof
        assume ab: "b \<^bsub>r\<^esub>\<preceq> a"
        with bCF show ?thesis unfolding choiceSet_def by auto
      next
        assume ab: "a \<^bsub>r\<^esub>\<prec> b"
        have "a \<in> choiceSet (insert a B) r"
        proof(rule ccontr)
          assume aCF: "a \<notin> choiceSet (insert a B) r"
          from aB have "\<And>b. b \<in> B \<Longrightarrow> a \<noteq> b" by auto
          with aCF aA AB c r obtain b' where B: "b' \<in> B" "b' \<^bsub>r\<^esub>\<prec> a"
            unfolding choiceSet_def complete_def strict_pref_def by blast
          with ab qt have "b' \<^bsub>r\<^esub>\<prec> b" by (blast dest: quasi_transD)
          with bCF B show False unfolding choiceSet_def strict_pref_def by blast
        qed
        thus ?thesis by auto
      qed
    qed
  qed
qed

lemma rpr_choiceFn: "\<lbrakk> finite A; rpr A r \<rbrakk> \<Longrightarrow> choiceFn A r"
  unfolding rpr_def by (blast dest: trans_imp_quasi_trans r_c_qt_imp_cf)

(* **************************************** *)

subsection\<open>Social Choice Functions (SCFs)\<close>

text \<open>A \emph{social choice function} (SCF), also called a
\emph{collective choice rule} by Sen \cite[p28]{Sen:70a}, is a function that
somehow aggregates society's opinions, expressed as a profile, into a
preference relation.\<close>

type_synonym ('a, 'i) SCF = "('a, 'i) Profile \<Rightarrow> 'a RPR"

text \<open>The least we require of an SCF is that it be \emph{complete} and
some function of the profile. The latter condition is usually implied by
other conditions, such as @{term "iia"}.\<close>

definition
  SCF :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> ('a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool) \<Rightarrow> bool"
where
  "SCF scf A Is Pcond \<equiv> (\<forall>P. Pcond A Is P \<longrightarrow> (complete A (scf P)))"

lemma SCFI[intro]:
  assumes c: "\<And>P. Pcond A Is P \<Longrightarrow> complete A (scf P)"
  shows "SCF scf A Is Pcond"
  unfolding SCF_def using assms by blast

lemma SCF_completeD[dest]: "\<lbrakk> SCF scf A Is Pcond; Pcond A Is P \<rbrakk> \<Longrightarrow> complete A (scf P)"
  unfolding SCF_def by blast

(* **************************************** *)

subsection\<open>Social Welfare Functions (SWFs)\<close>

text \<open>A \emph{Social Welfare Function} (SWF) is an SCF that expresses the
society's opinion as a single RPR.

In some situations it might make sense to restrict the allowable
profiles.\<close>

definition
  SWF :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> ('a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool) \<Rightarrow> bool"
where
  "SWF swf A Is Pcond \<equiv> (\<forall>P. Pcond A Is P \<longrightarrow> rpr A (swf P))"

lemma SWF_rpr[dest]: "\<lbrakk> SWF swf A Is Pcond; Pcond A Is P \<rbrakk> \<Longrightarrow> rpr A (swf P)"
  unfolding SWF_def by simp

(* **************************************** *)

subsection\<open>General Properties of an SCF\<close>

text\<open>An SCF has a \emph{universal domain} if it works for all profiles.\<close>

definition universal_domain :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool" where
  "universal_domain A Is P \<equiv> profile A Is P"

declare universal_domain_def[simp]

text\<open>An SCF is \emph{weakly Pareto-optimal} if, whenever everyone strictly
prefers @{term "x"} to @{term "y"}, the SCF does too.\<close>

definition
  weak_pareto :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> ('a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool) \<Rightarrow> bool"
where
  "weak_pareto scf A Is Pcond \<equiv>
     (\<forall>P x y. Pcond A Is P \<and> x \<in> A \<and> y \<in> A \<and> (\<forall>i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y) \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)"

lemma weak_paretoI[intro]:
  "(\<And>P x y. \<lbrakk>Pcond A Is P; x \<in> A; y \<in> A; \<And>i. i\<in>Is \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y\<rbrakk> \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)
  \<Longrightarrow> weak_pareto scf A Is Pcond"
  unfolding weak_pareto_def by simp

lemma weak_paretoD:
  "\<lbrakk> weak_pareto scf A Is Pcond; Pcond A Is P; x \<in> A; y \<in> A;
     (\<And>i. i \<in> Is \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y) \<rbrakk> \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y"
  unfolding weak_pareto_def by simp

text\<open>

An SCF satisfies \emph{independence of irrelevant alternatives} if, for two
preference profiles @{term "P"} and @{term "P'"} where for all individuals
@{term "i"}, alternatives @{term "x"} and @{term "y"} drawn from set @{term
"S"} have the same order in @{term "P i"} and @{term "P' i"}, then
alternatives @{term "x"} and @{term "y"} have the same order in @{term "scf
P"} and @{term "scf P'"}.

\<close>

definition iia :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> bool" where
  "iia scf S Is \<equiv>
    (\<forall>P P' x y. profile S Is P \<and> profile S Is P'
      \<and> x \<in> S \<and> y \<in> S
      \<and> (\<forall>i \<in> Is. ((x \<^bsub>(P i)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(P' i)\<^esub>\<preceq> y)) \<and> ((y \<^bsub>(P i)\<^esub>\<preceq> x) \<longleftrightarrow> (y \<^bsub>(P' i)\<^esub>\<preceq> x)))
         \<longrightarrow> ((x \<^bsub>(scf P)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(scf P')\<^esub>\<preceq> y)))"

lemma iiaI[intro]:
  "(\<And>P P' x y.
    \<lbrakk> profile S Is P; profile S Is P';
      x \<in> S; y \<in> S;
      \<And>i. i \<in> Is \<Longrightarrow> ((x \<^bsub>(P i)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(P' i)\<^esub>\<preceq> y)) \<and> ((y \<^bsub>(P i)\<^esub>\<preceq> x) \<longleftrightarrow> (y \<^bsub>(P' i)\<^esub>\<preceq> x))
    \<rbrakk> \<Longrightarrow> ((x \<^bsub>(swf P)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(swf P')\<^esub>\<preceq> y)))
  \<Longrightarrow> iia swf S Is"
  unfolding iia_def by simp

lemma iiaE:
  "\<lbrakk> iia swf S Is;
     {x,y} \<subseteq> S;
     a \<in> {x, y}; b \<in> {x, y};
     \<And>i a b. \<lbrakk> a \<in> {x, y}; b \<in> {x, y}; i \<in> Is \<rbrakk> \<Longrightarrow> (a \<^bsub>(P' i)\<^esub>\<preceq> b) \<longleftrightarrow> (a \<^bsub>(P i)\<^esub>\<preceq> b);
     profile S Is P; profile S Is P' \<rbrakk>
  \<Longrightarrow> (a \<^bsub>(swf P)\<^esub>\<preceq> b) \<longleftrightarrow> (a \<^bsub>(swf P')\<^esub>\<preceq> b)"
  unfolding iia_def by (simp, blast)

(* **************************************** *)

subsection\<open>Decisiveness and Semi-decisiveness\<close>

text\<open>This notion is the key to Arrow's Theorem, and hinges on the use of
strict preference \cite[p42]{Sen:70a}.\<close>

text\<open>A coalition @{term "C"} of agents is \emph{semi-decisive} for @{term
"x"} over @{term "y"} if, whenever the coalition prefers @{term "x"} to
@{term "y"} and all other agents prefer the converse, the coalition
prevails.\<close>

definition semidecisive :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> 'i set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "semidecisive scf A Is C x y \<equiv>
    C \<subseteq> Is \<and> (\<forall>P. profile A Is P \<and> (\<forall>i \<in> C. x \<^bsub>(P i)\<^esub>\<prec> y) \<and> (\<forall>i \<in> Is - C. y \<^bsub>(P i)\<^esub>\<prec> x)
      \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)"

lemma semidecisiveI[intro]:
  "\<lbrakk> C \<subseteq> Is;
    \<And>P. \<lbrakk> profile A Is P; \<And>i. i \<in> C \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y; \<And>i. i \<in> Is - C \<Longrightarrow> y \<^bsub>(P i)\<^esub>\<prec> x \<rbrakk>
     \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> semidecisive scf A Is C x y"
  unfolding semidecisive_def by simp

lemma semidecisive_coalitionD[dest]: "semidecisive scf A Is C x y \<Longrightarrow> C \<subseteq> Is"
  unfolding semidecisive_def by simp

lemma sd_refl: "\<lbrakk> C \<subseteq> Is; C \<noteq> {} \<rbrakk> \<Longrightarrow> semidecisive scf A Is C x x"
  unfolding semidecisive_def strict_pref_def by blast

text\<open>A coalition @{term "C"} is \emph{decisive} for @{term "x"} over
@{term "y"} if, whenever the coalition prefers @{term "x"} to @{term "y"},
the coalition prevails.\<close>

definition decisive :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> 'i set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "decisive scf A Is C x y \<equiv>
    C \<subseteq> Is \<and> (\<forall>P. profile A Is P \<and> (\<forall>i \<in> C. x \<^bsub>(P i)\<^esub>\<prec> y) \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)"

lemma decisiveI[intro]:
  "\<lbrakk> C \<subseteq> Is; \<And>P. \<lbrakk> profile A Is P; \<And>i. i \<in> C \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y \<rbrakk>
    \<Longrightarrow> decisive scf A Is C x y"
  unfolding decisive_def by simp

lemma d_imp_sd: "decisive scf A Is C x y \<Longrightarrow> semidecisive scf A Is C x y"
  unfolding decisive_def by (rule semidecisiveI, blast+)

lemma decisive_coalitionD[dest]: "decisive scf A Is C x y \<Longrightarrow> C \<subseteq> Is"
  unfolding decisive_def by simp

text \<open>Anyone is trivially decisive for @{term "x"} against @{term "x"}.\<close>

lemma d_refl: "\<lbrakk> C \<subseteq> Is; C \<noteq> {} \<rbrakk> \<Longrightarrow> decisive scf A Is C x x"
  unfolding decisive_def strict_pref_def by simp

text\<open>Agent @{term "j"} is a \emph{dictator} if her preferences always
prevail. This is the same as saying that she is decisive for all @{term "x"}
and @{term "y"}.\<close>

definition dictator :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> 'i \<Rightarrow> bool" where
  "dictator scf A Is j \<equiv> j \<in> Is \<and> (\<forall>x \<in> A. \<forall>y \<in> A. decisive scf A Is {j} x y)"

lemma dictatorI[intro]:
  "\<lbrakk> j \<in> Is; \<And>x y. \<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> decisive scf A Is {j} x y \<rbrakk> \<Longrightarrow> dictator scf A Is j"
  unfolding dictator_def by simp

lemma dictator_individual[dest]: "dictator scf A Is j \<Longrightarrow> j \<in> Is"
  unfolding dictator_def by simp

(*<*)
end
(*>*)


(*<*)
theory Regex
  imports Trace "HOL-Library.Lattice_Syntax" "HOL-Library.Extended_Nat"
begin
(*>*)

section \<open>Regular expressions\<close>

context begin

qualified datatype (atms: 'a) regex = Skip nat | Test 'a
  | Plus "'a regex" "'a regex" | Times "'a regex" "'a regex"  | Star "'a regex"

lemma finite_atms[simp]: "finite (atms r)"
  by (induct r) auto

definition "Wild = Skip 1"

lemma size_regex_estimation[termination_simp]: "x \<in> atms r \<Longrightarrow> y < f x \<Longrightarrow> y < size_regex f r"
  by (induct r) auto

lemma size_regex_estimation'[termination_simp]: "x \<in> atms r \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_regex f r"
  by (induct r) auto

qualified definition "TimesL r S = Times r ` S"
qualified definition "TimesR R s = (\<lambda>r. Times r s) ` R"

qualified primrec fv_regex where
  "fv_regex fv (Skip n) = {}"
| "fv_regex fv (Test \<phi>) = fv \<phi>"
| "fv_regex fv (Plus r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Times r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Star r) = fv_regex fv r"

lemma fv_regex_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>z. z \<in> atms r \<Longrightarrow> fv z = fv' z) \<Longrightarrow> fv_regex fv r = fv_regex fv' r'"
  by (induct r arbitrary: r') auto

lemma finite_fv_regex[simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z)) \<Longrightarrow> finite (fv_regex fv r)"
  by (induct r) auto

lemma fv_regex_commute:
  "(\<And>z. z \<in> atms r \<Longrightarrow> x \<in> fv z \<longleftrightarrow> g x \<in> fv' z) \<Longrightarrow> x \<in> fv_regex fv r \<longleftrightarrow> g x \<in> fv_regex fv' r"
  by (induct r) auto

lemma fv_regex_alt: "fv_regex fv r = (\<Union>z \<in> atms r. fv z)"
  by (induct r) auto

qualified definition nfv_regex where
  "nfv_regex fv r = Max (insert 0 (Suc ` fv_regex fv r))"

lemma insert_Un: "insert x (A \<union> B) = insert x A \<union> insert x B"
  by auto

lemma nfv_regex_simps[simp]:
  assumes [simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z))" "(\<And>z. z \<in> atms s \<Longrightarrow> finite (fv z))"
  shows
  "nfv_regex fv (Skip n) = 0"
  "nfv_regex fv (Test \<phi>) = Max (insert 0 (Suc ` fv \<phi>))"
  "nfv_regex fv (Plus r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Times r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Star r) = nfv_regex fv r"
  unfolding nfv_regex_def
  by (auto simp add: image_Un Max_Un insert_Un simp del: Un_insert_right Un_insert_left)

abbreviation "min_regex_default f r j \<equiv> (if atms r = {} then j else Min ((\<lambda>z. f z j) ` atms r))"

qualified primrec match :: "(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a regex \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "match test (Skip n) = (\<lambda>i j. j = i + n)"
| "match test (Test \<phi>) = (\<lambda>i j. i = j \<and> test i \<phi>)"
| "match test (Plus r s) = match test r \<squnion> match test s"
| "match test (Times r s) = match test r OO match test s"
| "match test (Star r) = (match test r)\<^sup>*\<^sup>*"

lemma match_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>i z. z \<in> atms r \<Longrightarrow> t i z = t' i z) \<Longrightarrow> match t r = match t' r'"
  by (induct r arbitrary: r') auto

qualified primrec eps where
  "eps test i (Skip n) = (n = 0)"
| "eps test i (Test \<phi>) = test i \<phi>"
| "eps test i (Plus r s) = (eps test i r \<or> eps test i s)"
| "eps test i (Times r s) = (eps test i r \<and> eps test i s)"
| "eps test i (Star r) = True"

qualified primrec lpd where
  "lpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "lpd test i (Test \<phi>) = {}"
| "lpd test i (Plus r s) = (lpd test i r \<union> lpd test i s)"
| "lpd test i (Times r s) = TimesR (lpd test i r) s \<union> (if eps test i r then lpd test i s else {})"
| "lpd test i (Star r) = TimesR (lpd test i r) (Star r)"

qualified primrec lpd\<kappa> where
  "lpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "lpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "lpd\<kappa> \<kappa> test i (Plus r s) = lpd\<kappa> \<kappa> test i r \<union> lpd\<kappa> \<kappa> test i s"
| "lpd\<kappa> \<kappa> test i (Times r s) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t s)) test i r \<union> (if eps test i r then lpd\<kappa> \<kappa> test i s else {})"
| "lpd\<kappa> \<kappa> test i (Star r) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t (Star r))) test i r"

qualified primrec rpd where
  "rpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "rpd test i (Test \<phi>) = {}"
| "rpd test i (Plus r s) = (rpd test i r \<union> rpd test i s)"
| "rpd test i (Times r s) = TimesL r (rpd test i s) \<union> (if eps test i s then rpd test i r else {})"
| "rpd test i (Star r) = TimesL (Star r) (rpd test i r)"

qualified primrec rpd\<kappa> where
  "rpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "rpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "rpd\<kappa> \<kappa> test i (Plus r s) = rpd\<kappa> \<kappa> test i r \<union> rpd\<kappa> \<kappa> test i s"
| "rpd\<kappa> \<kappa> test i (Times r s) = rpd\<kappa> (\<lambda>t. \<kappa> (Times r t)) test i s \<union> (if eps test i s then rpd\<kappa> \<kappa> test i r else {})"
| "rpd\<kappa> \<kappa> test i (Star r) = rpd\<kappa> (\<lambda>t. \<kappa> (Times (Star r) t)) test i r"

lemma lpd\<kappa>_lpd: "lpd\<kappa> \<kappa> test i r = \<kappa> ` lpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesR_def split: nat.splits)

lemma rpd\<kappa>_rpd: "rpd\<kappa> \<kappa> test i r = \<kappa> ` rpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesL_def split: nat.splits)

lemma match_le: "match test r i j \<Longrightarrow> i \<le> j"
proof (induction r arbitrary: i j)
  case (Times r s)
  then show ?case using order.trans by fastforce
next
  case (Star r)
  from Star.prems show ?case
    unfolding match.simps by (induct i j rule: rtranclp.induct) (force dest: Star.IH)+
qed auto

lemma match_rtranclp_le: "(match test r)\<^sup>*\<^sup>* i j \<Longrightarrow> i \<le> j"
  by (metis match.simps(5) match_le)

lemma eps_match: "eps test i r \<longleftrightarrow> match test r i i"
  by (induction r) (auto dest: antisym[OF match_le match_le])

lemma lpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> lpd test i r. match test s) (i + 1) j"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> match test s i j \<or>
    (\<exists>k>i. match test r i k \<and> match test s k j)"
    using match_le[of test r i] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k>i. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.IH(1) Times.IH(2)[OF Times.prems] by metis
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` lpd test i (Times r s))) (i + 1) j"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>lpd test i r. (match test s OO (match test r)\<^sup>*\<^sup>*) (i + 1) j" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ "i + 1"]
  proof (induct rule: converse_rtranclp_induct)
    case (step i k)
    then show ?case
      by (cases "i < k") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case using match_le[of test _  "i + 1"]
    by (auto simp: TimesL_def TimesR_def Suc_le_eq Star.IH[of i]
      elim!: converse_rtranclp_into_rtranclp[rotated])
qed (auto split: nat.splits)

lemma rpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> rpd test j r. match test s) i (j - 1)"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i j \<and> match test s j j \<or>
    (\<exists>k<j. match test r i k \<and> match test s k j)"
    using match_le[of test s _ j] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k<j. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.IH(1)[OF Times.prems] Times.IH(2) by metis
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` rpd test j (Times r s))) i (j - 1)"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>rpd test j r. ((match test r)\<^sup>*\<^sup>* OO match test s) i (j - 1)" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ _ "j - 1"]
  proof (induct rule: rtranclp_induct)
    case (step k j)
    then show ?case
      by (cases "k < j") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case
    by (auto 0 3 simp: TimesL_def TimesR_def intro: Star.IH[of _ j, THEN iffD2]
      elim!: rtranclp.rtrancl_into_rtrancl dest: match_le[of test _ _ "j - 1", unfolded One_nat_def])
qed (auto split: nat.splits)

lemma lpd_fv_regex: "s \<in> lpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma rpd_fv_regex: "s \<in> rpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma match_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> match test r = match test' r"
  by (induct r) auto

lemma eps_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> eps test i r = eps test' i r"
  by (induct r) auto

datatype modality = Past | Futu
datatype safety = Strict | Lax

context
  fixes fv :: "'a \<Rightarrow> 'b set"
  and safe :: "safety \<Rightarrow> 'a \<Rightarrow> bool"
begin

qualified fun safe_regex :: "modality \<Rightarrow> safety \<Rightarrow> 'a regex \<Rightarrow> bool" where
  "safe_regex m _ (Skip n) = True"
| "safe_regex m g (Test \<phi>) = safe g \<phi>"
| "safe_regex m g (Plus r s) = ((g = Lax \<or> fv_regex fv r = fv_regex fv s) \<and> safe_regex m g r \<and> safe_regex m g s)"
| "safe_regex Futu g (Times r s) =
    ((g = Lax \<or> fv_regex fv r \<subseteq> fv_regex fv s) \<and> safe_regex Futu g s \<and> safe_regex Futu Lax r)"
| "safe_regex Past g (Times r s) =
    ((g = Lax \<or> fv_regex fv s \<subseteq> fv_regex fv r) \<and> safe_regex Past g r \<and> safe_regex Past Lax s)"
| "safe_regex m g (Star r) = ((g = Lax \<or> fv_regex fv r = {}) \<and> safe_regex m g r)"

lemmas safe_regex_induct = safe_regex.induct[case_names Skip Test Plus TimesF TimesP Star]

lemma safe_cosafe:
  "(\<And>x. x \<in> atms r \<Longrightarrow> safe Strict x \<Longrightarrow> safe Lax x) \<Longrightarrow> safe_regex m Strict r \<Longrightarrow> safe_regex m Lax r"
  by (induct r; cases m) auto

lemma safe_lpd_fv_regex_le: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesR_def split: if_splits)

lemma safe_lpd_fv_regex: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff lpd_fv_regex safe_lpd_fv_regex_le)

lemma cosafe_lpd: "safe_regex Futu Lax r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesR_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesR_def split: nat.splits)

lemma safe_lpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesR_def ball_Un elim: Times(1,2) cosafe_lpd dest: lpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesR_def elim: Star(1) cosafe_lpd
      dest: safe_cosafe[rotated] lpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_rpd_fv_regex_le: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesL_def split: if_splits)

lemma safe_rpd_fv_regex: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff rpd_fv_regex safe_rpd_fv_regex_le)

lemma cosafe_rpd: "safe_regex Past Lax r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesL_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesL_def split: nat.splits)

lemma safe_rpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesL_def ball_Un elim: Times(1,2) cosafe_rpd dest: rpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesL_def elim: Star(1) cosafe_rpd
      dest: safe_cosafe[rotated] rpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_regex_safe: "(\<And>g r. safe g r \<Longrightarrow> safe Lax r) \<Longrightarrow>
  safe_regex m g r \<Longrightarrow> x \<in> atms r \<Longrightarrow> safe Lax x"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_map_regex:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow>  safe g (f x)) \<Longrightarrow> (\<And>x. x \<in> atms r \<Longrightarrow> fv (f x) = fv x) \<Longrightarrow>
   safe_regex m g r \<Longrightarrow> safe_regex m g (map_regex f r)"
  by (induct m g r rule: safe_regex.induct) (auto simp: fv_regex_alt regex.set_map)

end

lemma safe_regex_cong[fundef_cong]:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x = safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r = Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_mono:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow> safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r \<Longrightarrow> Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma match_map_regex: "match t (map_regex f r) = match (\<lambda>k z. t k (f z)) r"
  by (induct r) auto

lemma match_cong_strong:
  "(\<And>k z. k \<in> {i ..< j + 1} \<Longrightarrow> z \<in> atms r \<Longrightarrow> t k z = t' k z) \<Longrightarrow> match t r i j = match t' r i j"
proof (induction r arbitrary: i j)
  case (Times r s)
  from Times.prems show ?case
    by (auto 0 4 simp: relcompp_apply intro: le_less_trans match_le less_Suc_eq_le
      dest: Times.IH[THEN iffD1, rotated -1] Times.IH[THEN iffD2, rotated -1] match_le)
next
  case (Star r)
  show ?case unfolding match.simps
  proof (rule iffI)
    assume *: "(match t r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t' r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD1, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  next
    assume *: "(match t' r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD2, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  qed
qed auto

end

(*<*)
end
(*>*)


(*
Title: Value-Dependent SIFUM-Type-Systems
Authors: Toby Murray, Robert Sison, Edward Pierzchalski, Christine Rizkallah
(Based on the SIFUM-Type-Systems AFP entry, whose authors
 are: Sylvia Grewe, Heiko Mantel, Daniel Schoepe)
*)
section \<open>Preliminaries\<close>
theory Preliminaries
imports Main
begin

text \<open>Possible modes for variables:\<close>
datatype Mode = AsmNoReadOrWrite | AsmNoWrite | GuarNoReadOrWrite | GuarNoWrite

text \<open>We consider a two-element security lattice:\<close>
datatype Sec = High | Low

text \<open>@{term Sec} forms a (complete) lattice:\<close>
instantiation Sec :: complete_lattice
begin

definition top_Sec_def: "top = High"
definition sup_Sec_def: "sup d1 d2 = (if (d1 = High \<or> d2 = High) then High else Low)"
definition inf_Sec_def: "inf d1 d2 = (if (d1 = Low \<or> d2 = Low) then Low else High)"
definition bot_Sec_def: "bot = Low"
definition less_eq_Sec_def: "d1 \<le> d2 = (d1 = d2 \<or> d1 = Low)"
definition less_Sec_def: "d1 < d2 = (d1 = Low \<and> d2 = High)"
definition Sup_Sec_def: "Sup S = (if (High \<in> S) then High else Low)"
definition Inf_Sec_def: "Inf S = (if (Low \<in> S) then Low else High)"

instance
  apply (intro_classes)
                 using Sec.exhaust less_Sec_def less_eq_Sec_def inf_Sec_def sup_Sec_def apply auto[10]
       apply (metis Inf_Sec_def Sec.exhaust less_eq_Sec_def)
      apply (metis Inf_Sec_def Sec.exhaust less_eq_Sec_def)
     using Sec.exhaust less_Sec_def less_eq_Sec_def inf_Sec_def sup_Sec_def Inf_Sec_def Sup_Sec_def top_Sec_def bot_Sec_def
     by auto
end

text \<open>Memories are mappings from variables to values\<close>
type_synonym ('var, 'val) Mem = "'var \<Rightarrow> 'val"

text \<open>A mode state maps modes to the set of variables for which the
  given mode is set.\<close>
type_synonym 'var Mds = "Mode \<Rightarrow> 'var set"

text \<open>Local configurations:\<close>
type_synonym ('com, 'var, 'val) LocalConf = "('com \<times> 'var Mds) \<times> ('var, 'val) Mem"

text \<open>Global configurations:\<close>
type_synonym ('com, 'var, 'val) GlobalConf = "('com \<times> 'var Mds) list \<times> ('var, 'val) Mem"

text \<open>A locale to fix various parametric components in Mantel et. al, and assumptions
  about them:\<close>
locale sifum_security_init =
  fixes dma :: "('Var,'Val) Mem \<Rightarrow> 'Var \<Rightarrow> Sec"
  fixes \<C>_vars :: "'Var \<Rightarrow> 'Var set"
  fixes \<C> :: "'Var set" (* classification control variables *)
  fixes eval :: "('Com, 'Var, 'Val) LocalConf rel"
  fixes some_val :: "'Val"
  fixes INIT :: "('Var,'Val) Mem \<Rightarrow> bool"
  assumes deterministic: "\<lbrakk> (lc, lc') \<in> eval; (lc, lc'') \<in> eval \<rbrakk> \<Longrightarrow> lc' = lc''"
  assumes finite_memory: "finite {(x::'Var). True}"
  defines "\<C> \<equiv> \<Union>x. \<C>_vars x"
  assumes \<C>_vars_\<C>: "x \<in> \<C> \<Longrightarrow> \<C>_vars x = {}"
  assumes dma_\<C>_vars: "\<forall>x\<in>\<C>_vars y. mem\<^sub>1 x = mem\<^sub>2 x \<Longrightarrow> dma mem\<^sub>1 y = dma mem\<^sub>2 y"
  assumes \<C>_Low: "\<forall>x\<in>\<C>. dma mem x = Low"

locale sifum_security = sifum_security_init dma \<C>_vars \<C> eval some_val "\<lambda>_.True"
  for dma :: "('Var,'Val) Mem \<Rightarrow> 'Var \<Rightarrow> Sec"
  and \<C>_vars :: "'Var \<Rightarrow> 'Var set"
  and \<C> :: "'Var set" (* classification control variables *)
  and eval :: "('Com, 'Var, 'Val) LocalConf rel"
  and some_val :: "'Val"

context sifum_security_init begin

lemma \<C>_vars_subset_\<C>:
  "\<C>_vars x \<subseteq> \<C>"
  by(force simp: \<C>_def)

lemma dma_\<C>:
  "\<forall>x\<in>\<C>. mem\<^sub>1 x = mem\<^sub>2 x \<Longrightarrow> dma mem\<^sub>1 = dma mem\<^sub>2"
  proof
    fix y
    assume "\<forall>x\<in>\<C>. mem\<^sub>1 x = mem\<^sub>2 x"
    hence "\<forall>x\<in>\<C>_vars y. mem\<^sub>1 x = mem\<^sub>2 x"
      using \<C>_vars_subset_\<C> by blast
    thus "dma mem\<^sub>1 y = dma mem\<^sub>2 y"
      by(rule dma_\<C>_vars)
  qed

end

(* induction tools, moved up as far as possible *)

lemma my_trancl_induct [consumes 1, case_names base step]:
  "\<lbrakk>(a, b) \<in> r\<^sup>+;
    P a ;
   \<And>x y. \<lbrakk>(x, y) \<in> r; P x\<rbrakk> \<Longrightarrow> P y\<rbrakk> \<Longrightarrow> P b"
  by (induct rule: trancl.induct, blast+)

lemma my_trancl_step_induct [consumes 1, case_names base step]:
  "\<lbrakk>(a, b) \<in> r\<^sup>+;
   \<And>x y. (x, y) \<in> r \<Longrightarrow> P x y;
   \<And>x y z. P x y \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> P x z\<rbrakk> \<Longrightarrow> P a b"
  by (induct rule: trancl_induct, blast+)

lemma my_trancl_big_step_induct [consumes 1, case_names base step]:
  "\<lbrakk>(a, b) \<in> r\<^sup>+;
   \<And>x y. (x, y) \<in> r \<Longrightarrow> P x y;
   \<And>x y z. (x, y) \<in> r\<^sup>+ \<Longrightarrow> P x y \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> P y z \<Longrightarrow> P x z\<rbrakk> \<Longrightarrow> P a b"
  by (induct rule: trancl.induct, blast+)

lemmas my_trancl_step_induct3 =
  my_trancl_step_induct[of "((ax,ay), az)" "((bx,by), bz)", split_format (complete),
                 consumes 1, case_names step]

lemmas my_trancl_big_step_induct3 =
  my_trancl_big_step_induct[of "((ax,ay), az)" "((bx,by), bz)", split_format (complete),
                 consumes 1, case_names base step]

end


theory T37
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory LambekCalculus
  imports Main
begin

datatype 'a category =
  Atomic 'a ("^")
  | LeftFunctional "'a category" "'a category" (infix "←" 65)
  | RightFunctional "'a category" "'a category" (infix "→" 65)

inductive Lambek :: "'a category list ⇒ 'a category ⇒ bool" (infix "⊢" 60)
  where
  identity : "[x]⊢x"
  | cut : "⟦A@[x]@B⊢y; C⊢x⟧ ⟹ A@C@B⊢y"
  | left_intro_1 : "⟦A@[x]@B⊢y; C⊢z⟧ ⟹ A@C@[z→x]@B⊢y"
  | left_intro_2 : "⟦A@[x]@B⊢y; C⊢z⟧ ⟹ A@[x←z]@C@B⊢y"
  | right_intro_1 : "A@[x]⊢y ⟹ A⊢x→y"
  | right_intro_2 : "[x]@A⊢y ⟹ A⊢y←x"

lemma rev_right_intro_1:
  assumes "A⊢y←x"
    shows "A@[x]⊢y"
proof -
  have "[y←x]@[x]⊢y"
    by (metis append_Cons append_Nil identity left_intro_2)
  thus ?thesis
    by (metis append_Nil assms cut)
qed

lemma rev_right_intro_2:
  assumes "A⊢x→y"
    shows "[x]@A⊢y"
proof -
  have "[x]@[x→y]⊢y"
    by (metis append_Cons append_Nil identity left_intro_1)
  thus ?thesis
    by (metis append_Nil2 assms cut)
qed

theorem type_raising_1: "[x]⊢(y←x)→y"
  using
    rev_right_intro_1
    rev_right_intro_2
    right_intro_1
    identity by blast

theorem type_raising_2: "[x]⊢y←(x→y)"
  using
    rev_right_intro_1
    rev_right_intro_2
    right_intro_2
    identity
  by blast

inductive CPS :: "'a category ⇒ 'a category ⇒ 'a category ⇒ bool"
      and CPS' :: "'a category ⇒ 'a category ⇒ 'a category ⇒ bool"
  where
  "CPS' a x y ⟹ CPS a x ((a←y)→a)"
  | "CPS' a x y ⟹ CPS a x (a←(y→a))"
  | "⟦CPS' a x1 y1; CPS a x2 y2⟧ ⟹ CPS' a (x1→x2) (y1→y2)"
  | "⟦CPS' a x1 y1; CPS a x2 y2⟧ ⟹ CPS' a (x2←x1) (y2←y1)"
  | "CPS' a (^x) (^x)"

lemma CPS_and_CPS': "{y. CPS a x y} = ((λy. (a←y)→a) ` {y. CPS' a x y}) ∪ ((λy. a←(y→a)) ` {y. CPS' a x y})"
  apply auto
  apply (smt (verit, ccfv_SIG) CollectI CPS.simps image_iff)
  apply (simp add: CPS_CPS'.intros(1))
  by (simp add: CPS_CPS'.intros(2))

theorem CPS_is_finite:
  fixes a x :: "'a category"
  shows "finite {y. CPS' a x y}"
    and "finite {y. CPS a x y}"
proof (induct x)
  case (Atomic x)
  case 1
  have "{y. CPS' a (^x) y} = {(^x)}"
    proof
      have "⋀y. CPS' a (^x) y ⟹ y=(^x)"
        by (metis category.distinct(1) category.distinct(3) CPS'.simps)
      thus "{y. CPS' a (^x) y} ⊆ {(^x)}" by auto
      have "CPS' a (^x) (^x)"
        by (simp add: CPS_CPS'.intros(5))
      thus "{(^x)} ⊆ {y. CPS' a (^x) y}" by auto
    qed
  thus ?case by auto
  case 2
    thus ?case by (simp add: ‹finite {b. CPS' a (^ x) b}› CPS_and_CPS')
next
  case (LeftFunctional x1 x2)
  case 1
  have "finite ((λ(u, v). (u←v)) ` ({y. CPS a x1 y}×{y. CPS' a x2 y}))"
    using LeftFunctional.hyps(2) LeftFunctional.hyps(3) by blast
  moreover have "{y. CPS' a (x1←x2) y} = (λ(u, v). (u←v)) ` ({y. CPS a x1 y}×{y. CPS' a x2 y})"
    apply auto
    apply (smt (verit, best) CollectI SigmaI category.distinct(1) category.distinct(5) category.inject(2) CPS'.cases pair_imageI)
    by (simp add: CPS_CPS'.intros(4))
  ultimately show ?case
    by presburger
  case 2
  have "finite (((λy. (a←y)→a) ` {y. CPS' a (x1←x2) y}) ∪ ((λy. a←(y→a)) ` {y. CPS' a (x1←x2) y}))"
    using ‹finite {b. CPS' a (x1 ← x2) b}› by blast
  thus ?case by (simp add: CPS_and_CPS')
next
  case (RightFunctional x1 x2)
  case 1
  have "finite ((λ(u, v). (u→v)) ` ({y. CPS' a x1 y}×{y. CPS a x2 y}))"
    using RightFunctional.hyps(1) RightFunctional.hyps(4) by blast
  moreover have "{y. CPS' a (x1→x2) y} = (λ(u, v). (u→v)) ` ({y. CPS' a x1 y}×{y. CPS a x2 y})"
    apply auto
    apply (smt (verit, ccfv_SIG) CollectI SigmaI category.distinct(3) category.distinct(5) category.inject(3) CPS'.cases pair_imageI)
    by (simp add: CPS_CPS'.intros(3))
  ultimately show ?case by presburger
  case 2 show ?case by (simp add: ‹finite {b. CPS' a (x1 → x2) b}› CPS_and_CPS')
qed

inductive rCPS :: "'a category ⇒ 'a category ⇒ 'a category ⇒ bool"
      and rCPS' :: "'a category ⇒ 'a category ⇒ 'a category ⇒ bool"
  where
  "rCPS' a x y ⟹ rCPS a x ((a←y)→a)"
  | "rCPS' a x y ⟹ rCPS a x (a←(y→a))"
  | "rCPS a x2 y2 ⟹ rCPS' a ((^x1)→x2) ((^x1)→y2)"
  | "rCPS a x2 y2 ⟹ rCPS' a (x2←(^x1)) (y2←(^x1))"
  | "rCPS' a (^x) (^x)"

lemma CPS_contains_rCPS:
  fixes a x :: "'a category"
  shows "{y. rCPS' a x y} ⊆ {y. CPS' a x y}"
    and "{y. rCPS a x y} ⊆ {y. CPS a x y}"
proof (induct x)
  case (Atomic x)
  case 1 show ?case apply auto using CPS'.simps rCPS'.cases by fastforce
  case 2 show ?case apply auto by (smt (verit, ccfv_threshold) ‹{b. rCPS' a (^ x) b} ⊆ {b. CPS' a (^ x) b}› rCPS.cases CPS_CPS'.intros(1) CPS_CPS'.intros(2) mem_Collect_eq subsetD)
next
  case (LeftFunctional x1 x2)
  case 1 show ?case apply auto by (smt (verit, ccfv_SIG) Collect_mono_iff LeftFunctional.hyps(2) category.distinct(5) category.inject(2) CPS'.simps rCPS'.cases)
  case 2 show ?case apply auto by (smt (verit, ccfv_SIG) Collect_mono_iff ‹{b. rCPS' a (x1 ← x2) b} ⊆ {b. CPS' a (x1 ← x2) b}› CPS.simps rCPS.cases)
next
  case (RightFunctional x1 x2)
  case 1 show ?case apply auto by (smt (verit, ccfv_SIG) Collect_mono_iff RightFunctional.hyps(4) category.inject(3) category.simps(9) CPS'.simps rCPS'.cases)
  case 2 show ?case apply auto by (smt (verit, ccfv_SIG) Collect_mono_iff ‹{b. rCPS' a (x1 → x2) b} ⊆ {b. CPS' a (x1 → x2) b}› CPS.simps rCPS.cases)
qed

theorem rCPS_is_finite:
  shows "finite {y. rCPS' a x y}"
    and "finite {y. rCPS a x y}"
apply (meson CPS_contains_rCPS(1) CPS_is_finite(1) infinite_super)
by (meson CPS_contains_rCPS(2) CPS_is_finite(2) infinite_super)

theorem rCPS_transformation:
  fixes a x :: "'a category"
  shows "⋀y. rCPS' a x y ⟹ [x]⊢y"
    and "⋀y. rCPS a x y ⟹ [x]⊢y"
proof (induct x)
  case (Atomic x)
  {case 1
    show ?case using "1.prems" rCPS'.cases identity by blast}
  {case 2
    have "⋀y. rCPS' a (^x) y ⟹ [^x]⊢y"
      using "2.prems" rCPS'.cases identity by blast
    moreover hence "⋀y. rCPS' a (^x) y ⟹ [^x]⊢(a←y)→a"
      by (metis append_Cons append_Nil cut type_raising_1)
    moreover hence "⋀y. rCPS' a (^x) y ⟹ [^x]⊢a←(y→a)"
      by (metis category.distinct(1) category.distinct(3)
                rCPS'.cases type_raising_2)
    ultimately show "⋀y. rCPS a (^x) y ⟹ [^x]⊢y"
      by (metis rCPS.cases)}
next
  case (LeftFunctional x1 x2)
  hence "⋀y1. rCPS a x1 y1 ⟹ [x1←x2]@[x2]⊢y1"
    by (metis append.left_neutral append_Cons
              cut identity rev_right_intro_1)
  hence "⋀y1. rCPS a x1 y1 ⟹ [x1←x2]⊢y1←x2"
    using rev_right_intro_1 right_intro_2 by blast
  hence "⋀y1. rCPS' a (x1←x2) (y1←x2) ⟹ [x1←x2]⊢y1←x2"
    using rCPS'.cases by force
  thus "⋀y. rCPS' a (x1←x2) y ⟹ [x1←x2]⊢y"
    using rCPS'.cases by force
  hence "⋀y. rCPS' a (x1←x2) y ⟹ [x1←x2]⊢(a←y)→a ∧ [x1←x2]⊢a←(y→a)"
    by (metis append.left_neutral append_Cons
              cut type_raising_1 type_raising_2)
  thus "⋀y. rCPS a (x1←x2) y ⟹ [x1←x2]⊢y"
    by (metis rCPS.cases)
next
  case (RightFunctional x1 x2)
  hence "⋀y2. rCPS a x2 y2 ⟹ [x1]@[x1→x2]⊢y2"
    by (metis (no_types, hide_lams) append.left_neutral
              append_Nil2 cut rev_right_intro_1 type_raising_2)
  hence "⋀y2. rCPS a x2 y2 ⟹ [x1→x2]⊢x1→y2"
    using rev_right_intro_2 right_intro_1 by blast
  hence "⋀y2. rCPS' a (x1→x2) (x1→y2) ⟹ [x1→x2]⊢x1→y2"
    using rCPS'.cases by force
  thus "⋀y. rCPS' a (x1→x2) y ⟹ [x1→x2]⊢y"
    using rCPS'.cases by force
  hence "⋀y. rCPS' a (x1→x2) y ⟹ [x1→x2]⊢(a←y)→a ∧ [x1→x2]⊢a←(y→a)"
    by (metis append.left_neutral append_Cons
              cut type_raising_1 type_raising_2)
  thus "⋀y. rCPS a (x1→x2) y ⟹ [x1→x2]⊢y"
    by (metis rCPS.cases)
qed

lemma Type_raising_1_is_CPS : "rCPS a (^x) (a←((^x)→a))"
  and Type_raising_2_is_CPS : "rCPS a (^x) ((a←(^x))→a)"
apply (simp add: rCPS_rCPS'.intros(2) rCPS_rCPS'.intros(5))
  by (simp add: rCPS_rCPS'.intros(1) rCPS_rCPS'.intros(5))

end


theory Lambda
  imports "HOL-Nominal.Nominal"
begin

atom_decl var

section {* lambda term *}

subsection {* syntax *}

nominal_datatype lambda =
  Var "var"
| App "lambda" "lambda" (infixl "$" 120)
| Lam "\<guillemotleft>var\<guillemotright>lambda" ("lam [_]._" [100, 100] 100)

(* ascii code *)

abbreviation nf where
  "nf == var 102"

abbreviation np where
  "np == var 112"

abbreviation nq where
  "nq == var 113"

abbreviation nx where
  "nx == var 120"

abbreviation ny where
  "ny == var 121"

abbreviation nz where
  "nz == var 122"

subsection {* substitution *}

nominal_primrec subst :: "lambda \<Rightarrow> var \<Rightarrow> lambda \<Rightarrow> lambda" ("_[_::=_]" [100,100,100] 120) where
  "(Var x)[y ::= s] = (if x = y then s else (Var x))"
  | "(App M1 M2)[y ::= s] = App (M1[y ::= s]) (M2[y ::= s])"
  | "x \<sharp> (y,s) \<Longrightarrow> (lam [x].M)[y ::= s] = lam [x].(M[y ::= s])"
  apply (finite_guess)+
  apply (rule TrueI)+
  apply (simp add: abs_fresh)
  apply (fresh_guess)+
  done

subsubsection {* lemmas *}

lemma subst_gfresh':
  assumes "x \<sharp> t" "x \<sharp> s" "x \<noteq> y"
  shows "x \<sharp> t [y ::= s]"
using assms
apply (nominal_induct t avoiding: x y s rule: lambda.strong_induct)
  apply (simp add: assms(2))
  apply simp
  apply (metis abs_fresh(1) fresh_prod lambda.fresh(3) simps(3))
done

lemma subst_fresh: "x \<sharp> s \<Longrightarrow> x \<sharp> t[x ::= s]"
apply (nominal_induct t avoiding: x s rule: lambda.strong_induct)
apply (auto simp add: fresh_atm abs_fresh)
done

lemma subst_gfresh:
  fixes x y :: var
  assumes "x \<sharp> t" "x \<sharp> s"
  shows "x \<sharp> t [y ::= s]"
apply (cases "x = y")
  using assms(2) subst_fresh apply blast
  using assms(1) assms(2) subst_gfresh' apply auto
done

lemma no_subst: "x \<sharp> t \<Longrightarrow> t[x ::= s] = t"
apply (nominal_induct t avoiding: x s rule: lambda.strong_induct)
  apply (simp add: fresh_atm)
  apply simp
  apply (simp add: abs_fresh(1) fresh_atm)
done

lemma substitution:
  assumes "x \<noteq> y" "x \<sharp> L"
  shows "M [x ::= N] [y ::= L] = M [y ::= L] [x ::= N [y ::= L]]"
using assms
apply (nominal_induct M avoiding: x y N L rule: lambda.strong_induct)
  apply (simp add: no_subst)
  apply simp
  apply (simp add: fresh_atm subst_gfresh')
done

lemma subst_eqvt[eqvt]:
  fixes \<pi> :: "var prm"
  shows "\<pi>\<bullet>(t[x ::= s]) = (\<pi>\<bullet>t)[(\<pi>\<bullet>x) ::= (\<pi>\<bullet>s)]"
apply (nominal_induct t avoiding: x s rule: strong_induct)
apply (simp add: perm_bij)
apply (simp)
apply (simp add: fresh_bij)
done

lemma subst_rename:
  assumes "x \<sharp> t"
  shows "([(x,y)]\<bullet>t) [x ::= s] = t [y ::= s]"
using assms
apply (nominal_induct t avoiding: x y s rule: lambda.strong_induct)
apply (auto simp add: swap_simps fresh_atm abs_fresh)
done

subsection {* beta reduction *}

inductive beta :: "lambda \<Rightarrow> lambda \<Rightarrow> bool" (infixl "\<rightarrow>\<beta>" 50) where
  b_app1 [intro]: "t1 \<rightarrow>\<beta> t2 \<Longrightarrow> App t1 s \<rightarrow>\<beta> App t2 s"
| b_app2 [intro]: "t1 \<rightarrow>\<beta> t2 \<Longrightarrow> App s t1 \<rightarrow>\<beta> App s t2"
| b_abs [intro]: "t1 \<rightarrow>\<beta> t2 \<Longrightarrow> lam[x].t1 \<rightarrow>\<beta> lam[x].t2"
| b_beta' [intro]: "x \<sharp> s \<Longrightarrow> App (lam [x].t) s \<rightarrow>\<beta> (t[x::=s])"

equivariance beta

nominal_inductive beta
by (simp_all add: abs_fresh subst_fresh)

lemma b_beta: "App (lam [x].t) s \<rightarrow>\<beta> t[x::=s]"
proof (generate_fresh var)
  fix c :: var
  assume c_fresh: "c \<sharp> (s,t,x)"
  have "App (lam [x].t) s = App (lam [c]. ([(c,x)]\<bullet>t)) s"
    apply (simp add: lambda.inject alpha', rule disjI2, simp add: c_fresh)
    apply (rule not_sym, subst fresh_atm [symmetric]) using c_fresh apply simp
    done
  also have "... \<rightarrow>\<beta> ([(c,x)]\<bullet>t)[c::=s]"
    by (rule, simp add: c_fresh)
  also have "... = t[x::=s]"
    by (subst subst_rename, simp add: c_fresh, simp)
  finally show ?thesis by simp
qed

inductive long_beta :: "lambda \<Rightarrow> lambda \<Rightarrow> bool" (infixl "\<longrightarrow>\<beta>*" 50) where
  bs_refl [intro]: "t \<longrightarrow>\<beta>* t"
| bs_step [intro]: "t \<rightarrow>\<beta> s \<Longrightarrow> t \<longrightarrow>\<beta>* s"
| bs_trans [trans]: "\<lbrakk> t1 \<longrightarrow>\<beta>* t2; t2 \<longrightarrow>\<beta>* t3 \<rbrakk> \<Longrightarrow> t1 \<longrightarrow>\<beta>* t3"

inductive beta_eq :: "lambda \<Rightarrow> lambda \<Rightarrow> bool" (infixl "=\<beta>" 50) where
  beq_bs [intro]: "t \<longrightarrow>\<beta>* s \<Longrightarrow> t =\<beta> s"
| beq_sym [sym]: "t =\<beta> s \<Longrightarrow> s =\<beta> t"
| beq_trans [trans]: "\<lbrakk> s =\<beta> t; t =\<beta> u \<rbrakk> \<Longrightarrow> s =\<beta> u"

lemma bs_abs:
  assumes "t1 \<longrightarrow>\<beta>* t2"
  shows "\<And>x. lam [x]. t1 \<longrightarrow>\<beta>* lam [x]. t2"
apply (rule long_beta.induct [OF assms], auto)
apply (rule bs_trans, auto)
done

lemma bs_app1:
  assumes "t1 \<longrightarrow>\<beta>* t2"
  shows "\<And>s. App t1 s \<longrightarrow>\<beta>* App t2 s"
apply (rule long_beta.induct [OF assms], auto)
apply (rule bs_trans, auto)
done

lemma bs_app2:
  assumes "t1 \<longrightarrow>\<beta>* t2"
  shows "\<And>s. App s t1 \<longrightarrow>\<beta>* App s t2"
apply (rule long_beta.induct [OF assms], auto)
apply (rule bs_trans, auto)
done

lemma beq_refl [intro]: "t =\<beta> t"
by (rule, rule bs_refl)

lemma beq_app1:
  assumes "t1 =\<beta> t2"
  shows "\<And>s. App t1 s =\<beta> App t2 s"
apply (rule beta_eq.induct [OF assms])
apply (rule, rule bs_app1, simp)
apply (rule beq_sym, simp)
apply (rule beq_trans, simp, simp)
done

lemma beq_app2:
  assumes "t1 =\<beta> t2"
  shows "\<And>s. App s t1 =\<beta> App s t2"
apply (rule beta_eq.induct [OF assms])
apply (rule, rule bs_app2, simp)
apply (rule beq_sym, simp)
apply (rule beq_trans, simp, simp)
done

subsection {* free variables *}

subsection {* fixedpoint *}

definition Y where
  "Y \<equiv> lam [nf]. (lam [nx]. Var nf $ (Var nx $ Var nx)) $ (lam [nx]. Var nf $ (Var nx $ Var nx))"

theorem fixedpoint_Y:
  assumes Mvar: "nx \<sharp> M"
  shows "Y $ M =\<beta> M $ (Y $ M)"
proof-
  define X where "X = (lam [nx]. (Var nf $ (Var nx $ Var nx)))"
  define W where "W = (lam [nx]. (M $ (Var nx $ Var nx)))"
  have Y_is_lXX: "Y = (lam [nf]. (X $ X))"
    apply (simp add: Y_def X_def)
    done
  have Mvar': "nx \<sharp> (nf,M)"
    using Mvar
    by (simp add: fresh_atm)

  have L0: "(lam [nx].Var nf $ (Var nx $ Var nx))[nf::=M] = W"
    apply (simp add: W_def)
    using Mvar' apply simp
    done

  have H0: "Y $ M \<longrightarrow>\<beta>* (lam [nf]. (X $ X)) $ M"
    by (subst Y_is_lXX, simp add: X_def, rule bs_refl)
  also have H1: "(lam [nf]. (X $ X)) $ M \<longrightarrow>\<beta>* (lam [nx]. (M $ (Var nx $ Var nx))) $ W"
    apply (simp add: X_def W_def)
    apply (rule bs_trans, rule, rule b_beta)
    apply (simp add: L0 W_def)
    apply (rule bs_refl)
    done
  also have H2: "(lam [nx]. (M $ (Var nx $ Var nx))) $ W \<longrightarrow>\<beta>* M $ (W $ W)"
    unfolding W_def
    apply (rule bs_trans, rule, rule b_beta)
    using no_subst [OF Mvar] apply simp
    apply (rule bs_refl)
    done
  also have H3: "M $ (Y $ M) \<longrightarrow>\<beta>* M $ (W $ W)"
    proof-
      have H4: "Y $ M \<longrightarrow>\<beta>* W $ W"
        apply (subst Y_is_lXX)
        apply (rule bs_trans, rule H1, simp add: W_def, rule bs_refl)
        done
      show ?thesis
        using bs_app2 [OF H4] by simp
    qed
  show ?thesis
    apply (rule beq_trans, rule beq_bs)
    apply (rule bs_trans [OF H0], rule bs_trans [OF H1], rule H2)
    apply (rule beq_sym, rule, rule H3)
    done
qed

subsection {* definability *}

primrec iter :: "(lambda \<Rightarrow> lambda) \<Rightarrow> nat \<Rightarrow> lambda \<Rightarrow> lambda" where
  "iter F 0 M = M"
  | "iter F (Suc i) M = F (iter F i M)"

lemma iter_join: "iter F n (iter F m M) = iter F (n + m) M"
by (induction n, auto)

subsubsection {* Church number *}

fun ChurchN where
  "ChurchN n = lam [nf]. lam [nx]. iter (\<lambda>k. Var nf $ k) n (Var nx)"

definition ChAdd where
  "ChAdd = lam [nx]. lam [ny]. lam [np]. lam [nq]. Var nx $ Var np $ (Var ny $ Var np $ Var nq)"
definition ChMult where
  "ChMult = lam [nx]. lam [ny]. lam [nz]. Var nx $ (Var ny $ Var nz)"
definition ChExp where
  "ChExp = lam [nx]. lam [ny]. Var ny $ Var nx"

text {*
  ChAdd n m
  = (lam x. lam y. lam p. lam q. x p (y p q)) (lam f. lam x. iter (f -) n x) (lam f. lam x. iter (f -) m x)
  = lam p. lam q. (lam f. lam x. iter (f -) n x) p ((lam f. lam x. iter (f -) m x) p q)
  = lam p. lam q. (lam f. lam x. iter (f -) n x) p (iter (p -) m q))
  = lam p. lam q. (iter (p -) n (iter (p -) m q))
  = lam p. lam q. (iter (p -) (n + m) q)
  = n + m
*}

lemma ChAdd_add: "ChAdd $ ChurchN n $ ChurchN m =\<beta> ChurchN (n + m)"
proof-
  have f1y: "ny \<sharp> (nx, ChurchN n)"
    apply (induction n)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f1p: "np \<sharp> (nx, ChurchN n)"
    apply (induction n)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f1q: "nq \<sharp> (nx, ChurchN n)"
    apply (induction n)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f2p: "np \<sharp> (ny, ChurchN m)"
    apply (induction m)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f2q: "nq \<sharp> (ny, ChurchN m)"
    apply (induction m)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f3f: "nf \<sharp> (ny, ChurchN m)"
    apply (induction m)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f3x: "nx \<sharp> (ny, ChurchN m)"
    apply (induction m)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f4x: "nx \<sharp> (nf, Var np)"
    by (simp add: fresh_atm)

  have "ChAdd $ (ChurchN n) $ (ChurchN m) \<longrightarrow>\<beta>* (lam [nx]. lam [ny]. lam [np]. lam [nq]. Var nx $ Var np $ (Var ny $ Var np $ Var nq)) $ (ChurchN n) $ (ChurchN m)"
    by (simp add: ChAdd_def, rule bs_refl)
  also have "... \<longrightarrow>\<beta>* (lam [ny]. lam [np]. lam [nq]. ChurchN n $ Var np $ (Var ny $ Var np $ Var nq)) $ (ChurchN m)"
    apply (rule bs_app1, rule, rule, rule b_beta)
    proof-
      have h: "(lam [ny].lam [np].lam [nq].Var nx $ Var np $ (Var ny $ Var np $ Var nq))[nx::=ChurchN n] = lam [ny].lam [np].lam [nq].(ChurchN n $ Var np $ (Var ny $ Var np $ Var nq))"
        apply (subst subst.simps(3) [OF f1y])
        apply (subst subst.simps(3) [OF f1p])
        apply (subst subst.simps(3) [OF f1q])
        apply simp
        done
      show "(lam [ny].lam [np].lam [nq].Var nx $ Var np $ (Var ny $ Var np $ Var nq))[nx::=ChurchN n] \<longrightarrow>\<beta>* lam [ny].lam [np].lam [nq].ChurchN n $ Var np $ (Var ny $ Var np $ Var nq)"
        by (subst h, rule bs_refl)
    qed
  also have "... \<longrightarrow>\<beta>* lam [np]. lam [nq]. ChurchN n $ Var np $ (ChurchN m $ Var np $ Var nq)"
    apply (rule, rule, rule b_beta)
    proof-
      have h: "(lam [np].lam [nq].ChurchN n $ Var np $ (Var ny $ Var np $ Var nq))[ny::=ChurchN m] = lam [np].lam [nq].ChurchN n $ Var np $ (ChurchN m $ Var np $ Var nq)"
        apply (subst subst.simps(3) [OF f2p])
        apply (subst subst.simps(3) [OF f2q])
        apply (subst lambda.inject(3), subst abs_fun_eq1)
        apply (subst lambda.inject(3), subst abs_fun_eq1)
        apply simp
        using subst.simps(3) [OF f3f] subst.simps(3) [OF f3x]
        by (smt ChurchN.simps f1y no_subst fresh_prodD(2))
      show "(lam [np].lam [nq].ChurchN n $ Var np $ (Var ny $ Var np $ Var nq))[ny::=ChurchN m] \<longrightarrow>\<beta>* lam [np].lam [nq].ChurchN n $ Var np $ (ChurchN m $ Var np $ Var nq)"
        by (subst h, rule bs_refl)
    qed
  also have "... = lam [np]. lam [nq]. ChurchN n $ Var np $ ((lam [nf]. lam [nx]. iter (\<lambda>k. Var nf $ k) m (Var nx)) $ Var np $ Var nq)" by simp
  also have "... \<longrightarrow>\<beta>* lam [np]. lam [nq]. ChurchN n $ Var np $ (iter (\<lambda>k. Var np $ k) m (Var nq))"
    apply (rule bs_abs, rule bs_abs, rule bs_app2)
    apply (rule, rule, rule, rule b_beta)
    apply (simp add: subst.simps(3) [OF f4x])
    apply (rule bs_trans, rule, rule b_beta)
    proof-
      have h: "(iter (($) (Var nf)) m (Var nx)[nf::=Var np]) [nx::=Var nq] = iter (($) (Var np)) m (Var nq)"
        by (induction m, auto)
      show "(iter (($) (Var nf)) m (Var nx)[nf::=Var np]) [nx::=Var nq] \<longrightarrow>\<beta>* iter (($) (Var np)) m (Var nq)"
        by (subst h, rule bs_refl)
    qed
  also have "... = lam [np]. lam [nq]. (lam [nf]. lam [nx]. iter (\<lambda>k. Var nf $ k) n (Var nx)) $ Var np $ (iter (\<lambda>k. Var np $ k) m (Var nq))" by simp
  also have "... \<longrightarrow>\<beta>* lam [np]. lam [nq]. (iter (\<lambda>k. Var np $ k) n (iter (\<lambda>k. Var np $ k) m (Var nq)))"
    apply (rule bs_trans, rule bs_abs, rule bs_abs, rule bs_app1, rule, rule b_beta)
    apply (simp add: subst.simps(3) [OF f4x])
    apply (rule bs_abs, rule bs_abs)
    apply (rule bs_trans, rule, rule b_beta)
    proof-
      have h: "(iter (($) (Var nf)) n (Var nx)[nf::=Var np]) [nx::=iter (($) (Var np)) m (Var nq)] \<longrightarrow>\<beta>* iter (($) (Var np)) n (iter (($) (Var np)) m (Var nq))"
        apply (induction n, auto)
        apply (rule bs_app2, simp)
        done
      show "(iter (($) (Var nf)) n (Var nx)[nf::=Var np]) [nx::=iter (($) (Var np)) m (Var nq)] \<longrightarrow>\<beta>* iter (($) (Var np)) n (iter (($) (Var np)) m (Var nq))"
        by (simp add: h)
    qed
  also have "... = lam [np]. lam [nq]. (iter (\<lambda>k. Var np $ k) (n + m) (Var nq))" by (simp add: iter_join)
  also have "... = lam [nf]. lam [nx]. (iter (\<lambda>k. Var nf $ k) (n + m) (Var nx))"
    apply (subst lambda.inject(3), subst alpha)
    apply (rule disjI2, rule, simp, rule)
      apply (simp, subst swap_simps, simp, simp)
    apply (subst lambda.inject(3), subst alpha)
      apply (rule disjI2, rule, simp, rule)
      apply (induction n, simp)
        apply (induction m, simp add: swap_simps, simp add: swap_simps)
        apply (induction m, simp add: swap_simps, simp add: swap_simps)
    apply (induction n, simp)
      apply (induction m, simp add: swap_simps fresh_atm, simp add: swap_simps fresh_atm)
      apply (induction m, simp add: swap_simps fresh_atm, simp add: swap_simps fresh_atm)
    apply (induction n, simp)
      apply (induction m, simp add: swap_simps fresh_atm abs_fresh, simp add: swap_simps fresh_atm abs_fresh)
      apply (induction m, simp add: swap_simps fresh_atm abs_fresh, simp add: swap_simps fresh_atm abs_fresh)
    done
  also have "... = ChurchN (n + m)" by simp
  finally have lem: "(ChAdd $ ChurchN n $ ChurchN m) \<longrightarrow>\<beta>* ChurchN (n + m)" by simp

  show ?thesis
    by (rule, rule lem)
qed

subsubsection {* Boolean, conditional *}

definition Btrue where
  "Btrue = lam [nx]. lam [ny]. Var nx"
definition Bfalse where
  "Bfalse = lam [nx]. lam [ny]. Var ny"

definition Bif where
  "Bif b p q = b $ p $ q"

lemma Bif_true:
  assumes fp: "ny \<sharp> (nx, P)" "ny \<sharp> P"
  shows "Bif Btrue P Q =\<beta> P"
proof rule
  have "Bif Btrue P Q = (lam [nx]. lam [ny]. Var nx) $ P $ Q"
    by (simp add: Bif_def Btrue_def)
  also have "... \<longrightarrow>\<beta>* (lam [ny]. P) $ Q"
    apply (rule bs_app1, rule, rule, rule b_beta)
    apply (subst subst.simps(3) [OF fp(1)], rule bs_abs, simp, rule bs_refl)
    done
  also have "... \<longrightarrow>\<beta>* P"
    apply (rule, rule, rule b_beta)
    apply (subst no_subst, rule fp, rule bs_refl)
    done
  finally show "Bif Btrue P Q \<longrightarrow>\<beta>* P" by simp
qed

lemma Bif_false:
  assumes fp: "ny \<sharp> (nx, P)" "ny \<sharp> Q"
  shows "Bif Bfalse P Q =\<beta> Q"
proof rule
  have "Bif Bfalse P Q = (lam [nx]. lam [ny]. Var ny) $ P $ Q"
    by (simp add: Bif_def Bfalse_def)
  also have "... \<longrightarrow>\<beta>* (lam [ny]. Var ny) $ Q"
    apply (rule bs_app1, rule, rule, rule b_beta)
    apply (subst subst.simps(3) [OF fp(1)], rule bs_abs, simp, rule bs_refl)
    done
  also have "... \<longrightarrow>\<beta>* Q"
    apply (rule, rule, rule b_beta)
    apply (simp, rule bs_refl)
    done
  finally show "Bif Bfalse P Q \<longrightarrow>\<beta>* Q" by simp
qed

subsubsection {* Pairing *}

definition Ppair where
  "Ppair M N = lam [nz]. Var nz $ M $ N"
definition Pproj1 where
  "Pproj1 M = M $ Btrue"
definition Pproj2 where
  "Pproj2 M = M $ Bfalse"

lemma Ppair_proj1:
  assumes "nz \<sharp> M" "nz \<sharp> N" "ny \<sharp> M"
  shows "Pproj1 (Ppair M N) =\<beta> M"
proof rule
  have f1y: "ny \<sharp> (nx, M)"
    apply (simp add: fresh_prod, rule)
    apply (simp add: fresh_atm)
    apply (rule assms)
    done

  have "Pproj1 (Ppair M N) = (lam [nz]. Var nz $ M $ N) $ Btrue"
    by (simp add: Pproj1_def Ppair_def)
  also have "... \<longrightarrow>\<beta>* (Btrue $ M $ N)"
    apply (rule, rule, rule b_beta)
    apply (simp, subst no_subst, rule assms, subst no_subst, rule assms)
    apply (rule bs_refl)
    done
  also have "... = ((lam [nx]. lam [ny]. Var nx) $ M $ N)"
    by (simp add: Btrue_def)
  also have "... \<longrightarrow>\<beta>* (lam [ny]. M) $ N"
    apply (rule bs_app1, rule, rule, rule b_beta)
    apply (subst subst.simps, rule f1y, rule bs_abs, simp)
    apply (rule bs_refl)
    done
  also have "... \<longrightarrow>\<beta>* M"
    by (rule, rule, rule b_beta, subst no_subst, rule assms, rule bs_refl)
  finally show "Pproj1 (Ppair M N) \<longrightarrow>\<beta>* M" by simp
qed

lemma Ppair_proj2:
  assumes "nz \<sharp> M" "nz \<sharp> N" "ny \<sharp> M"
  shows "Pproj2 (Ppair M N) =\<beta> N"
proof rule
  have f1y: "ny \<sharp> (nx, M)"
    apply (simp add: fresh_prod, rule)
    apply (simp add: fresh_atm)
    apply (rule assms)
    done

  have "Pproj2 (Ppair M N) = (lam [nz]. Var nz $ M $ N) $ Bfalse"
    by (simp add: Pproj2_def Ppair_def)
  also have "... \<longrightarrow>\<beta>* (Bfalse $ M $ N)"
    apply (rule, rule, rule b_beta)
    apply (simp, subst no_subst, rule assms, subst no_subst, rule assms)
    apply (rule bs_refl)
    done
  also have "... = ((lam [nx]. lam [ny]. Var ny) $ M $ N)"
    by (simp add: Bfalse_def)
  also have "... \<longrightarrow>\<beta>* (lam [ny]. Var ny) $ N"
    apply (rule bs_app1, rule, rule, rule b_beta)
    apply (subst subst.simps, rule f1y, rule bs_abs, simp)
    apply (rule bs_refl)
    done
  also have "... \<longrightarrow>\<beta>* N"
    by (rule, rule, rule b_beta, simp, rule bs_refl)
  finally show "Pproj2 (Ppair M N) \<longrightarrow>\<beta>* N" by simp
qed

subsubsection {* definability *}

definition L1defined :: "(nat \<Rightarrow> nat) \<Rightarrow> lambda \<Rightarrow> bool" where
  "L1defined f F = (\<forall>(n :: nat). F $ ChurchN n =\<beta> ChurchN (f n))"

definition L1definable :: "(nat \<Rightarrow> nat) \<Rightarrow> bool" where
  "L1definable f = (\<exists>F. L1defined f F)"

subsubsection {* initial functions *}

definition iS where
  "iS = Suc"
definition iZ where
  "iZ = (\<lambda>x. 0)"

lemma iZ_defined: "L1defined iZ (lam [nx]. lam [nf]. lam [ny]. Var ny)"
proof (simp add: L1defined_def iZ_def, auto, rule)
  fix n
  have f1f: "nf \<sharp> (nx, lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx))"
    by (simp add: abs_fresh(1) fresh_atm)
  have f1y: "ny \<sharp> (nx, lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx))"
    apply (induction n)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done

  have "(lam [nx].lam [nf].lam [ny].Var ny) $ (lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx)) \<longrightarrow>\<beta>* (lam [nf].lam [ny].Var ny)"
    apply (rule, rule, rule b_beta, subst subst.simps, rule f1f, subst subst.simps, rule f1y)
    apply (subst no_subst, simp add: fresh_atm, rule bs_refl)
    done
  also have "... \<longrightarrow>\<beta>* lam [nf].lam [nx].Var nx"
    proof (rule bs_abs)
      have h: "lam [ny].Var ny = lam [nx].Var nx"
        apply (subst lambda.inject, subst alpha, rule disjI2, rule)
        apply (simp add: fresh_atm, rule, simp add: swap_simps, simp add: fresh_atm)
        done
      show "lam [ny].Var ny \<longrightarrow>\<beta>* lam [nx].Var nx"
        by (subst h, rule bs_refl)
    qed
  finally show "(lam [nx].lam [nf].lam [ny].Var ny) $ (lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx)) \<longrightarrow>\<beta>* lam [nf].lam [nx].Var nx"
    by simp
qed

lemma iS_defined: "L1defined iS (lam [nx]. lam [ny]. lam [nz]. Var ny $ (Var nx $ Var ny $ Var nz))"
proof (simp add: L1defined_def iS_def, auto, rule)
  fix n
  have f1x: "ny \<sharp> (nx, lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx))"
    apply (induction n)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f1z: "nz \<sharp> (nx, lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx))"
    apply (induction n)
      apply (simp add: abs_fresh fresh_atm)
      apply (simp add: abs_fresh fresh_atm fresh_prod)
    done
  have f2: "nx \<sharp> (nf, Var ny)"
    by (simp add: fresh_atm)

  have "(lam [nx].lam [ny].lam [nz].Var ny $ (Var nx $ Var ny $ Var nz)) $ (lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx)) \<longrightarrow>\<beta>* lam [ny].lam [nz].Var ny $ ((lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx)) $ Var ny $ Var nz)"
    apply (rule, rule, rule b_beta, subst subst.simps, rule f1x, rule bs_abs, subst subst.simps, rule f1z, rule bs_abs)
    apply (simp, rule bs_refl)
    done
  also have "... \<longrightarrow>\<beta>* lam [ny].lam [nz].Var ny $ (iter (($) (Var ny)) n (Var nz))"
    apply (rule bs_abs, rule bs_abs, rule bs_app2)
    apply (rule, rule, rule b_app1, rule b_beta)
    apply (subst subst.simps, rule f2, rule, rule, rule b_beta)
    apply (induction n, auto, rule bs_app2, simp)
    done
  also have "... = lam [nf].lam [nx].Var nf $ (iter (($) (Var nf)) n (Var nx))"
    apply (subst lambda.inject, subst alpha, rule disjI2, rule)
    apply (simp, rule, simp add: swap_simps)
    apply (subst lambda.inject, subst alpha, rule disjI2, rule)
    apply (simp, rule, simp add: swap_simps)
    apply (induction n, auto simp add: swap_simps)
    apply (simp add: fresh_atm)
    apply (induction n, auto simp add: swap_simps fresh_atm)
    apply (induction n)
      apply (simp add: fresh_atm abs_fresh)
      apply (simp add: fresh_atm abs_fresh)
    done
  finally show "(lam [nx].lam [ny].lam [nz].Var ny $ (Var nx $ Var ny $ Var nz)) $ (lam [nf].lam [nx].iter (($) (Var nf)) n (Var nx)) \<longrightarrow>\<beta>* lam [nf].lam [nx].Var nf $ iter (($) (Var nf)) n (Var nx)"
    by simp
qed

subsubsection {* lemmas *}

text {*
  L1defined fx Fx <-> \<forall>n. Fx $ (lam f. lam x. iter (f -) n x) = lam f. lam x. iter (f -) (fx n) x
  L1defined gx Gx <-> \<forall>n. Gx $ (lam f. lam x. iter (f -) n x) = lam f. lam x. iter (f -) (gx n) x

  gx (fx n)
  = lam f. lam x. iter (f -) (gx (fx n)) x
  = Gx $ (lam f. lam x. iter (f -) (fx n) x)
  = Gx $ Fx $ n
*}

lemma L1definable_closed_under_compose:
  assumes "L1definable f" "L1definable g"
  shows "L1definable (\<lambda>x. f (g x))"
proof (simp add: L1definable_def)
  from assms(1) obtain F where
    F: "L1defined f F"
    using L1definable_def by blast
  from assms(2) obtain G where
    G: "L1defined g G"
    using L1definable_def by blast

  have "\<exists>c :: var. c \<sharp> (F,G)"
    apply (generate_fresh "var")
    by blast
  then obtain x :: var where
    x_fresh: "x \<sharp> (F,G)" by blast

  define H where "H = lam [x]. F $ (G $ Var x)"

  have Q: "\<forall>n. H $ ChurchN n =\<beta> ChurchN (f (g n))"
    proof (rule, rule beq_sym)
      fix n
      have "ChurchN (f (g n)) =\<beta> F $ (ChurchN (g n))"
        apply (rule beq_sym)
        using F unfolding L1defined_def apply simp
        done
      also have "... =\<beta> F $ (G $ (ChurchN n))"
        apply (rule beq_sym)
        apply (rule beq_app2)
        using G unfolding L1defined_def apply simp
        done
      also have "... =\<beta> H $ (ChurchN n)"
        apply (rule beq_sym)
        unfolding H_def
        apply (rule, rule, rule, rule b_beta)
        apply (subst subst.simps, subst no_subst, simp add: x_fresh)
        apply (rule bs_app2)
        apply (subst subst.simps, subst no_subst, simp add: x_fresh)
        apply (rule bs_app2)
        apply (simp, rule bs_refl)
        done
      finally show "ChurchN (f (g n)) =\<beta> H $ ChurchN n" by simp
    qed

  show "\<exists>F. L1defined (\<lambda>x. f (g x)) F"
    unfolding L1defined_def
    by (rule, rule Q)
qed

subsection {* reduction *}

nominal_primrec beta_nf where
  "beta_nf (Var v) = True"
  | "beta_nf (App M N) = (if (\<exists>x. \<exists>y. M = lam [x]. y) then False else (beta_nf M \<and> beta_nf N))"
  | "beta_nf (lam [x]. M) = beta_nf M"
  apply (finite_guess)+
  apply (rule TrueI)+
  defer
  apply (fresh_guess)+
  by (simp add: fresh_bool)

inductive long_beta' :: "lambda \<Rightarrow> lambda \<Rightarrow> bool" where
  bs_refl' [intro]: "long_beta' t t"
| bs_cons' [intro]: "\<lbrakk> t1 \<rightarrow>\<beta> t2; long_beta' t2 t3 \<rbrakk> \<Longrightarrow> long_beta' t1 t3"

equivariance long_beta'

nominal_inductive long_beta'
proof-
qed

inductive long_beta_len :: "lambda \<Rightarrow> lambda \<Rightarrow> nat \<Rightarrow> bool" where
  bsl_refl: "long_beta_len t t 0"
| bsl_cons: "\<lbrakk> t1 \<rightarrow>\<beta> t2; long_beta_len t2 t3 m \<rbrakk> \<Longrightarrow> long_beta_len t1 t3 (Suc m)"

equivariance long_beta_len

nominal_inductive long_beta_len
proof-
qed

lemma long_beta_len_0: "long_beta_len M N 0 = (M = N)"
proof rule
  assume h: "long_beta_len M N 0"
  show "M = N"
    by (rule long_beta_len.cases [OF h], auto)
next
  show "M = N \<Longrightarrow> long_beta_len M N 0" by (simp, rule)
qed

lemma long_beta_len_Suc: "long_beta_len M N (Suc n) = (\<exists>L. M \<rightarrow>\<beta> L \<and> long_beta_len L N n)"
proof rule
  assume h: "long_beta_len M N (Suc n)"
  show "\<exists>L. M \<rightarrow>\<beta> L \<and> long_beta_len L N n"
    by (rule long_beta_len.cases [OF h], auto)
next
  assume "\<exists>L. M \<rightarrow>\<beta> L \<and> long_beta_len L N n"
  then obtain L where L: "M \<rightarrow>\<beta> L" "long_beta_len L N n" by fastforce
  show "long_beta_len M N (Suc n)"
    by (rule, rule L, rule L)
qed

lemma bsl_trans [trans]: "\<And>t1 t2 t3. \<lbrakk> long_beta_len t1 t2 n; long_beta_len t2 t3 m \<rbrakk> \<Longrightarrow> long_beta_len t1 t3 (n + m)"
proof (induction n)
  case 0
  assume hyp: "long_beta_len t1 t2 0" "long_beta_len t2 t3 m"
  have t12: "t1 = t2"
    by (rule long_beta_len.cases [OF hyp(1)], auto)
  show ?case
    by (subst t12, simp, rule hyp)
next
  case (Suc n)
  assume hyp: "\<And>s1 s2 s3. long_beta_len s1 s2 n \<Longrightarrow> long_beta_len s2 s3 m \<Longrightarrow> long_beta_len s1 s3 (n + m)"
  and hyp': "long_beta_len t1 t2 (Suc n)" "long_beta_len t2 t3 m"

  obtain t12 where
    t12_prop: "t1 \<rightarrow>\<beta> t12" "long_beta_len t12 t2 n"
    by (rule long_beta_len.cases [OF hyp'(1)], auto)

  show ?case
    by (simp, rule, rule t12_prop, rule hyp, rule t12_prop, rule hyp')
qed

subsubsection {* conversion *}

lemma long_beta_discard_len: "long_beta_len M N k \<Longrightarrow> M \<longrightarrow>\<beta>* N"
apply (rule long_beta_len.induct, auto)
apply (rule bs_trans, auto)
done

lemma long_beta'_len: "long_beta' M N = (\<exists>k. long_beta_len M N k)"
apply (rule)
  apply (rule long_beta'.induct, simp)
  apply (rule, rule bsl_refl)
proof-
  fix t1 t2 t3
  assume "long_beta' M N"
  and hyp: "t1 \<rightarrow>\<beta> t2" "long_beta' t2 t3" "\<exists>k. long_beta_len t2 t3 k"

  from hyp(3) obtain k where k: "long_beta_len t2 t3 k" by fastforce
  show "\<exists>k. long_beta_len t1 t3 k"
    by (rule, rule, rule hyp, rule k)
next
  assume "\<exists>k. long_beta_len M N k"
  then obtain k where k_prop: "long_beta_len M N k" by fastforce

  have Q: "\<And>M N. long_beta_len M N k \<Longrightarrow> long_beta' M N"
    apply (induction k)
      apply (simp add: long_beta_len_0, rule bs_refl')
    apply (simp add: long_beta_len_Suc)
    apply blast
    done
  show "long_beta' M N"
    by (rule Q [OF k_prop])
qed

lemma long_beta_exist_len: "M \<longrightarrow>\<beta>* N = (\<exists>k. long_beta_len M N k)"
apply rule
  apply (rule long_beta.induct, auto)
  apply (rule, rule bsl_refl, rule, rule, simp, rule bsl_refl)
  apply (rule, rule bsl_trans, simp, simp)
proof-
  fix k
  have Q: "\<And>M N. long_beta_len M N k \<Longrightarrow> M \<longrightarrow>\<beta>* N"
    apply (induction k)
      apply (simp add: long_beta_len_0, rule bs_refl)
    apply (auto simp add: long_beta_len_Suc, rule bs_trans, rule bs_step)
    apply simp
    apply simp
    done
  show "long_beta_len M N k \<Longrightarrow> M \<longrightarrow>\<beta>* N"
    by (rule Q)
qed

lemma long_beta_alt: "long_beta M N = long_beta' M N"
by (simp add: long_beta'_len long_beta_exist_len)

end


(*  Title:      HOL/Proofs/ex/Hilbert_Classical.thy
    Author:     Stefan Berghofer
    Author:     Makarius Wenzel
*)

section \<open>Hilbert's choice and classical logic\<close>

theory Hilbert_Classical
  imports Main
begin

text \<open>
  Derivation of the classical law of tertium-non-datur by means of
  Hilbert's choice operator (due to M. J. Beeson and J. Harrison).
\<close>

subsection \<open>Proof text\<close>

theorem tertium_non_datur: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>x. (A \<and> x) \<or> \<not> x"
  let ?Q = "\<lambda>x. (A \<and> \<not> x) \<or> x"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    have "\<not> False" ..
    then show "?P False" ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    have True ..
    then show "?Q True" ..
  qed

  from a show ?thesis
  proof
    assume "A \<and> Eps ?P"
    then have A ..
    then show ?thesis ..
  next
    assume "\<not> Eps ?P"
    from b show ?thesis
    proof
      assume "A \<and> \<not> Eps ?Q"
      then have A ..
      then show ?thesis ..
    next
      assume "Eps ?Q"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        then have "Eps ?P \<longleftrightarrow> Eps ?Q" by (rule arg_cong)
        also note \<open>Eps ?Q\<close>
        finally have "Eps ?P" .
        with \<open>\<not> Eps ?P\<close> show False by contradiction
      qed
      have "\<not> A"
      proof
        assume A
        have "?P = ?Q"
        proof (rule ext)
          show "?P x \<longleftrightarrow> ?Q x" for x
          proof
            assume "?P x"
            then show "?Q x"
            proof
              assume "\<not> x"
              with \<open>A\<close> have "A \<and> \<not> x" ..
              then show ?thesis ..
            next
              assume "A \<and> x"
              then have x ..
              then show ?thesis ..
            qed
          next
            assume "?Q x"
            then show "?P x"
            proof
              assume "A \<and> \<not> x"
              then have "\<not> x" ..
              then show ?thesis ..
            next
              assume x
              with \<open>A\<close> have "A \<and> x" ..
              then show ?thesis ..
            qed
          qed
        qed
        with neq show False by contradiction
      qed
      then show ?thesis ..
    qed
  qed
qed

subsection \<open>Old proof text\<close>

theorem tertium_non_datur1: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>x. (x \<longleftrightarrow> False) \<or> (x \<longleftrightarrow> True) \<and> A"
  let ?Q = "\<lambda>x. (x \<longleftrightarrow> False) \<and> A \<or> (x \<longleftrightarrow> True)"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    show "?P False" using refl ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    show "?Q True" using refl ..
  qed

  from a show ?thesis
  proof
    assume "(Eps ?P \<longleftrightarrow> True) \<and> A"
    then have A ..
    then show ?thesis ..
  next
    assume P: "Eps ?P \<longleftrightarrow> False"
    from b show ?thesis
    proof
      assume "(Eps ?Q \<longleftrightarrow> False) \<and> A"
      then have A ..
      then show ?thesis ..
    next
      assume Q: "Eps ?Q \<longleftrightarrow> True"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        then have "Eps ?P \<longleftrightarrow> Eps ?Q" by (rule arg_cong)
        also note P
        also note Q
        finally show False by (rule False_neq_True)
      qed
      have "\<not> A"
      proof
        assume A
        have "?P = ?Q"
        proof (rule ext)
          show "?P x \<longleftrightarrow> ?Q x" for x
          proof
            assume "?P x"
            then show "?Q x"
            proof
              assume "x \<longleftrightarrow> False"
              from this and \<open>A\<close> have "(x \<longleftrightarrow> False) \<and> A" ..
              then show ?thesis ..
            next
              assume "(x \<longleftrightarrow> True) \<and> A"
              then have "x \<longleftrightarrow> True" ..
              then show ?thesis ..
            qed
          next
            assume "?Q x"
            then show "?P x"
            proof
              assume "(x \<longleftrightarrow> False) \<and> A"
              then have "x \<longleftrightarrow> False" ..
              then show ?thesis ..
            next
              assume "x \<longleftrightarrow> True"
              from this and \<open>A\<close> have "(x \<longleftrightarrow> True) \<and> A" ..
              then show ?thesis ..
            qed
          qed
        qed
        with neq show False by contradiction
      qed
      then show ?thesis ..
    qed
  qed
qed

subsection \<open>Old proof script\<close>

theorem tertium_non_datur2: "A \<or> \<not> A"
  apply (subgoal_tac
      "(((SOME x. x = False \<or> x = True \<and> A) = False) \<or>
      ((SOME x. x = False \<or> x = True \<and> A) = True) \<and> A) \<and>
      (((SOME x. x = False \<and> A \<or> x = True) = False) \<and> A \<or>
      ((SOME x. x = False \<and> A \<or> x = True) = True))")
   prefer 2
   apply (rule conjI)
    apply (rule someI)
    apply (rule disjI1)
    apply (rule refl)
   apply (rule someI)
   apply (rule disjI2)
   apply (rule refl)
  apply (erule conjE)
  apply (erule disjE)
   apply (erule disjE)
    apply (erule conjE)
    apply (erule disjI1)
   prefer 2
   apply (erule conjE)
   apply (erule disjI1)
  apply (subgoal_tac
      "(\<lambda>x. (x = False) \<or> (x = True) \<and> A) \<noteq>
      (\<lambda>x. (x = False) \<and> A \<or> (x = True))")
   prefer 2
   apply (rule notI)
   apply (drule_tac f = "\<lambda>y. SOME x. y x" in arg_cong)
   apply (drule trans, assumption)
   apply (drule sym)
   apply (drule trans, assumption)
   apply (erule False_neq_True)
  apply (rule disjI2)
  apply (rule notI)
  apply (erule notE)
  apply (rule ext)
  apply (rule iffI)
   apply (erule disjE)
    apply (rule disjI1)
    apply (erule conjI)
    apply assumption
   apply (erule conjE)
   apply (erule disjI2)
  apply (erule disjE)
   apply (erule conjE)
   apply (erule disjI1)
  apply (rule disjI2)
  apply (erule conjI)
  apply assumption
  done

subsection \<open>Proof terms\<close>

prf tertium_non_datur
prf tertium_non_datur1
prf tertium_non_datur2

end


(*  Title:      HOL/Datatype_Examples/TreeFI.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Finitely branching possibly infinite trees.
*)

section {* Finitely Branching Possibly Infinite Trees *}

theory TreeFI
imports Main
begin

codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI list")

(* Tree reverse:*)
primcorec trev where
  "lab (trev t) = lab t"
| "sub (trev t) = map trev (rev (sub t))"

lemma treeFI_coinduct:
  assumes *: "phi x y"
  and step: "\<And>a b. phi a b \<Longrightarrow>
     lab a = lab b \<and>
     length (sub a) = length (sub b) \<and>
     (\<forall>i < length (sub a). phi (nth (sub a) i) (nth (sub b) i))"
  shows "x = y"
using * proof (coinduction arbitrary: x y)
  case (Eq_treeFI t1 t2)
  from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
  have "list_all2 phi (sub t1) (sub t2)"
  proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: list_induct2)
    case (Cons x xs y ys)
    note sub = Cons(3,4)[symmetric] and phi = mp[OF spec[OF Cons(5)], unfolded sub]
      and IH = Cons(2)[of "Tree (lab t1) (tl (sub t1))" "Tree (lab t2) (tl (sub t2))",
        unfolded sub, simplified]
    from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
  qed simp
  with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
qed

lemma trev_trev: "trev (trev tr) = tr"
  by (coinduction arbitrary: tr rule: treeFI_coinduct) (auto simp add: rev_map)

end