(*  Title:      LList2.thy
    Author:     Stefan Friedrich
    Maintainer: Stefan Friedrich
    License:    LGPL

Llists over an alphabet.
Common operations on LLists (ltake, ldrop, lnth).
The prefix order of llists.
Safety and liveness.
*)

section\<open>More on llists\<close>

theory LList2
imports Coinductive.Coinductive_List
begin

subsection\<open>Preliminaries\<close>

notation
  LCons  (infixr "##" 65) and
  lappend  (infixr "@@" 65)

translations
  "case p of XCONST LNil \<Rightarrow> a | x ## l \<Rightarrow> b" \<rightleftharpoons> "CONST case_llist a (\<lambda>x l. b) p"
  "case p of XCONST LNil :: 'a \<Rightarrow> a | x ## l \<Rightarrow> b" \<rightharpoonup> "CONST case_llist a (\<lambda>x l. b) p"

lemmas llistE = llist.exhaust

subsection\<open>Finite and infinite llists over an alphabet\<close>

inductive_set
  finlsts :: "'a set \<Rightarrow> 'a llist set" ("(_\<^sup>\<star>)" [1000] 999)
  for A :: "'a set"
where
  LNil_fin [iff]: "LNil \<in>  A\<^sup>\<star>"
| LCons_fin [intro!]: "\<lbrakk> l \<in> A\<^sup>\<star>; a \<in> A \<rbrakk> \<Longrightarrow>  a ## l \<in> A\<^sup>\<star>"

coinductive_set
  alllsts :: "'a set \<Rightarrow> 'a llist set" ("(_\<^sup>\<infinity>)" [1000] 999)
  for A :: "'a set"
where
  LNil_all [iff]: "LNil \<in> A\<^sup>\<infinity>"
| LCons_all [intro!]: "\<lbrakk> l \<in> A\<^sup>\<infinity>; a \<in> A \<rbrakk> \<Longrightarrow>  a ## l \<in> A\<^sup>\<infinity>"

declare alllsts.cases [case_names LNil LCons, cases set: alllsts]

definition inflsts :: "'a set \<Rightarrow> 'a llist set"  ("(_\<^sup>\<omega>)" [1000] 999)
where "A\<^sup>\<omega> \<equiv>  A\<^sup>\<infinity> - UNIV\<^sup>\<star>"

definition fpslsts :: "'a set \<Rightarrow> 'a llist set"  ("(_\<^sup>\<clubsuit>)" [1000] 999)
where "A\<^sup>\<clubsuit> \<equiv> A\<^sup>\<star> - {LNil}"

definition poslsts :: "'a set \<Rightarrow> 'a llist set"  ("(_\<^sup>\<spadesuit>)" [1000] 999)
where "A\<^sup>\<spadesuit> \<equiv> A\<^sup>\<infinity> - {LNil}"

subsubsection\<open>Facts about all llists\<close>

lemma alllsts_UNIV [iff]:
  "s \<in> UNIV\<^sup>\<infinity>"
proof -
  have "s \<in> UNIV" by blast
  thus ?thesis
  proof coinduct
    case (alllsts z)
    thus ?case by(cases z) auto
  qed
qed

lemma alllsts_empty [simp]: "{}\<^sup>\<infinity> = {LNil}"
  by (auto elim: alllsts.cases)

lemma alllsts_mono:
  assumes asubb: "A \<subseteq> B"
  shows "A\<^sup>\<infinity> \<subseteq> B\<^sup>\<infinity>"
proof
  fix x assume "x \<in> A\<^sup>\<infinity>"
  thus "x \<in> B\<^sup>\<infinity>"
  proof coinduct
    case (alllsts z)
    thus ?case using asubb by(cases z) auto
  qed
qed

lemmas alllstsp_mono [mono] = alllsts_mono [to_pred pred_subset_eq]

lemma LConsE [iff]: "x##xs \<in> A\<^sup>\<infinity> = (x\<in>A \<and> xs \<in> A\<^sup>\<infinity>)"
  by (auto elim: alllsts.cases)

subsubsection\<open>Facts about non-empty (positive) llists\<close>

lemma poslsts_iff [iff]:
  "(s \<in> A\<^sup>\<spadesuit>) = (s \<in> A\<^sup>\<infinity> \<and> s \<noteq> LNil)"
  by (simp add: poslsts_def)

lemma poslsts_UNIV [iff]:
  "s \<in> UNIV\<^sup>\<spadesuit> = (s \<noteq> LNil)"
  by auto

lemma poslsts_empty [simp]: "{}\<^sup>\<spadesuit> = {}"
  by auto

lemma poslsts_mono:
  "A \<subseteq> B \<Longrightarrow> A\<^sup>\<spadesuit> \<subseteq> B\<^sup>\<spadesuit>"
  by (auto dest: alllsts_mono)

subsubsection\<open>Facts about finite llists\<close>

lemma finlsts_empty [simp]: "{}\<^sup>\<star> = {LNil}"
  by (auto elim: finlsts.cases)

lemma finsubsetall: "x \<in> A\<^sup>\<star> \<Longrightarrow> x \<in> A\<^sup>\<infinity>"
  by (induct rule: finlsts.induct) auto

lemma finlsts_mono:
"A\<subseteq>B \<Longrightarrow> A\<^sup>\<star> \<subseteq> B\<^sup>\<star>"
  by (auto, erule finlsts.induct) auto

lemmas finlstsp_mono [mono] = finlsts_mono [to_pred pred_subset_eq]

lemma finlsts_induct
  [case_names LNil_fin LCons_fin, induct set: finlsts, consumes 1]:
  assumes xA: "x \<in> A\<^sup>\<star>"
  and lnil: "\<And>l. l = LNil \<Longrightarrow> P l"
  and lcons: "\<And>a l. \<lbrakk>l \<in> A\<^sup>\<star>; P l; a \<in> A\<rbrakk> \<Longrightarrow> P (a ## l)"
  shows "P x"
  using xA by (induct "x") (auto intro: lnil lcons)

lemma finite_lemma:
  assumes "x \<in> A\<^sup>\<star>"
  shows "x \<in> B\<^sup>\<infinity> \<Longrightarrow> x \<in> B\<^sup>\<star>"
using assms
proof (induct)
  case LNil_fin thus ?case by auto
next
  case (LCons_fin a l)
  thus ?case using LCons_fin by (cases "a##l") auto
qed

lemma fin_finite [dest]:
assumes "r \<in> A\<^sup>\<star>" "r \<notin> UNIV\<^sup>\<star>"
  shows "False"
proof-
  have "A \<subseteq> UNIV" by auto
  hence "A\<^sup>\<star> \<subseteq> UNIV\<^sup>\<star>" by (rule finlsts_mono)
  thus ?thesis using assms by auto
qed

lemma finT_simp [simp]:
  "r \<in> A\<^sup>\<star> \<Longrightarrow> r\<in>UNIV\<^sup>\<star>"
  by auto

subsubsection\<open>A recursion operator for finite llists\<close>

definition finlsts_pred :: "('a llist \<times> 'a llist) set"
where "finlsts_pred \<equiv> {(r,s). r \<in> UNIV\<^sup>\<star> \<and> (\<exists>a. a##r = s)}"

definition finlsts_rec :: "['b, ['a, 'a llist, 'b] \<Rightarrow> 'b] \<Rightarrow> 'a llist \<Rightarrow> 'b"
where
  "finlsts_rec c d r \<equiv> if r \<in> UNIV\<^sup>\<star>
  then (wfrec finlsts_pred (%f. case_llist c (%a r. d a r (f r))) r)
  else undefined"

lemma finlsts_predI: "r \<in> A\<^sup>\<star> \<Longrightarrow> (r, a##r) \<in> finlsts_pred"
  by (auto simp: finlsts_pred_def)

lemma wf_finlsts_pred: "wf finlsts_pred"
proof (rule wfI [of _ "UNIV\<^sup>\<star>"])
  show "finlsts_pred \<subseteq> UNIV\<^sup>\<star> \<times> UNIV\<^sup>\<star>"
    by (auto simp: finlsts_pred_def elim: finlsts.cases)
next
  fix x::"'a llist" and P::"'a llist \<Rightarrow> bool"
  assume xfin: "x \<in> UNIV\<^sup>\<star>" and H [unfolded finlsts_pred_def]:
    "(\<forall>x. (\<forall>y. (y, x) \<in> finlsts_pred \<longrightarrow> P y) \<longrightarrow> P x)"
  from  xfin show "P x"
  proof(induct x)
    case LNil_fin with H show ?case by blast
  next
    case (LCons_fin a l) with H show ?case by blast
  qed
qed

lemma finlsts_rec_LNil: "finlsts_rec c d LNil = c"
  by (auto simp: wf_finlsts_pred finlsts_rec_def wfrec)

lemma finlsts_rec_LCons:
 "r \<in> A\<^sup>\<star> \<Longrightarrow> finlsts_rec c d (a ## r) = d a r (finlsts_rec c d r)"
  by (auto simp: wf_finlsts_pred finlsts_rec_def wfrec cut_def intro: finlsts_predI)

lemma finlsts_rec_LNil_def:
  "f \<equiv> finlsts_rec c d \<Longrightarrow> f LNil = c"
  by (auto simp: finlsts_rec_LNil)

lemma finlsts_rec_LCons_def:
  "\<lbrakk> f \<equiv> finlsts_rec c d; r \<in> A\<^sup>\<star> \<rbrakk> \<Longrightarrow> f (a ## r) = d a r (f r)"
  by (auto simp: finlsts_rec_LCons)

subsubsection\<open>Facts about non-empty (positive) finite llists\<close>

lemma fpslsts_iff [iff]:
  "(s \<in> A\<^sup>\<clubsuit>) = (s \<in> A\<^sup>\<star> \<and> s \<noteq> LNil)"
  by (auto simp: fpslsts_def)

lemma fpslsts_empty [simp]: "{}\<^sup>\<clubsuit> = {}"
  by auto

lemma fpslsts_mono:
  "A \<subseteq> B \<Longrightarrow> A\<^sup>\<clubsuit> \<subseteq> B\<^sup>\<clubsuit>"
  by (auto dest: finlsts_mono)

lemma fpslsts_cases [case_names LCons, cases set: fpslsts]:
assumes rfps: "r \<in> A\<^sup>\<clubsuit>"
  and H: "\<And> a rs. \<lbrakk> r = a ## rs; a\<in>A; rs \<in> A\<^sup>\<star> \<rbrakk> \<Longrightarrow> R"
  shows "R"
proof-
  from rfps have "r \<in> A\<^sup>\<star>" and "r \<noteq> LNil" by auto
  thus ?thesis
    by (cases r, simp) (blast intro!: H)
qed

subsubsection\<open>Facts about infinite llists\<close>

lemma inflstsI [intro]:
  "\<lbrakk> x \<in> A\<^sup>\<infinity>; x \<in> UNIV\<^sup>\<star> \<Longrightarrow> False \<rbrakk> \<Longrightarrow> x \<in> A\<^sup>\<omega>"
unfolding inflsts_def by clarsimp

lemma inflstsE [elim]:
  "\<lbrakk> x \<in> A\<^sup>\<omega>; \<lbrakk> x \<in> A\<^sup>\<infinity>; x \<notin> UNIV\<^sup>\<star> \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (unfold inflsts_def) auto

lemma inflsts_empty [simp]: "{}\<^sup>\<omega> = {}"
  by auto

lemma inflsts_mono:
  "A \<subseteq> B \<Longrightarrow> A\<^sup>\<omega> \<subseteq> B\<^sup>\<omega>"
  by (blast dest: alllsts_mono infsubsetall)

lemma inflsts_cases [case_names LCons, cases set: inflsts, consumes 1]:
  assumes sinf: "s \<in> A\<^sup>\<omega>"
  and R: "\<And>a l. \<lbrakk> l \<in> A\<^sup>\<omega>; a \<in> A; s = a ## l \<rbrakk> \<Longrightarrow> R"
  shows "R"
proof -
  from sinf have "s \<in> A\<^sup>\<infinity>" "s \<notin> UNIV\<^sup>\<star>"
    by auto
  then obtain a l where "l \<in> A\<^sup>\<omega>" and "a\<in>A" and "s = a ## l"
    by (cases "s") auto
  thus ?thesis by (rule R)
qed

lemma inflstsI2: "\<lbrakk>a \<in> A; t \<in> A\<^sup>\<omega>\<rbrakk> \<Longrightarrow> a ## t \<in> A\<^sup>\<omega>"
  by  (auto elim: finlsts.cases)

lemma infT_simp [simp]:
  "r \<in> A\<^sup>\<omega> \<Longrightarrow> r\<in>UNIV\<^sup>\<omega>"
  by auto

lemma  alllstsE [consumes 1, case_names finite infinite]:
  "\<lbrakk> x\<in>A\<^sup>\<infinity>; x \<in> A\<^sup>\<star> \<Longrightarrow> P; x \<in> A\<^sup>\<omega> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto intro: finite_lemma simp: inflsts_def)

lemma fin_inf_cases [case_names finite infinite]:
  "\<lbrakk> r\<in>UNIV\<^sup>\<star> \<Longrightarrow> P; r \<in> UNIV\<^sup>\<omega> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma  fin_Int_inf: "A\<^sup>\<star> \<inter> A\<^sup>\<omega> = {}"
  and   fin_Un_inf: "A\<^sup>\<star> \<union> A\<^sup>\<omega> = A\<^sup>\<infinity>"
  by (auto intro: finite_lemma finsubsetall)

lemma notfin_inf [iff]: "(x \<notin> UNIV\<^sup>\<star>) = (x \<in> UNIV\<^sup>\<omega>)"
  by auto

lemma notinf_fin [iff]: "(x \<notin> UNIV\<^sup>\<omega>) = (x \<in> UNIV\<^sup>\<star>)"
  by auto

subsection\<open>Lappend\<close>

subsubsection\<open>Simplification\<close>

lemma lapp_inf [simp]:
  assumes "s \<in> A\<^sup>\<omega>"
  shows "s @@ t = s"
using assms
by(coinduction arbitrary: s)(auto elim: inflsts_cases)

lemma LNil_is_lappend_conv [iff]:
"(LNil = s @@ t) = (s = LNil \<and> t = LNil)"
  by (cases "s") auto

lemma lappend_is_LNil_conv [iff]:
  "(s @@ t = LNil) = (s = LNil \<and> t = LNil)"
  by (cases "s") auto

lemma same_lappend_eq [iff]:
 "r \<in> A\<^sup>\<star> \<Longrightarrow> (r @@ s = r @@ t) = (s = t)"
  by (erule finlsts.induct) simp+

subsubsection\<open>Typing rules\<close>

lemma lappT:
  assumes sllist: "s \<in> A\<^sup>\<infinity>"
  and tllist: "t \<in> A\<^sup>\<infinity>"
  shows "s@@t \<in> A\<^sup>\<infinity>"
proof -
  from assms have "lappend s t \<in> (\<Union>u\<in>A\<^sup>\<infinity>. \<Union>v\<in>A\<^sup>\<infinity>. {lappend u v})" by fast
  thus ?thesis
  proof coinduct
    case (alllsts z)
    then obtain u v where ullist: "u\<in>A\<^sup>\<infinity>" and vllist: "v\<in>A\<^sup>\<infinity>"
      and zapp: "z=u @@ v" by auto
    thus ?case by (cases "u") (auto elim: alllsts.cases)
  qed
qed

lemma lappfin_finT: "\<lbrakk> s \<in> A\<^sup>\<star>; t \<in> A\<^sup>\<star> \<rbrakk> \<Longrightarrow> s@@t \<in> A\<^sup>\<star>"
  by (induct rule: finlsts.induct) auto

lemma lapp_fin_fin_lemma:
  assumes rsA: "r @@ s \<in> A\<^sup>\<star>"
  shows "r \<in> A\<^sup>\<star>"
using rsA
proof(induct l\<equiv>"r@@s" arbitrary: r)
  case LNil_fin thus ?case by auto
next
  case (LCons_fin a l')
  show ?case
  proof (cases "r")
    case LNil thus ?thesis by auto
  next
    case (LCons x xs) with \<open>a##l' = r @@ s\<close>
    have "a = x" and "l' = xs @@ s" by auto
    with LCons_fin LCons show ?thesis by auto
  qed
qed

lemma lapp_fin_fin_iff [iff]: "(r @@ s \<in> A\<^sup>\<star>) = (r \<in> A\<^sup>\<star> \<and> s \<in> A\<^sup>\<star>)"
proof (auto intro: lappfin_finT lapp_fin_fin_lemma)
  assume rsA: "r @@ s \<in> A\<^sup>\<star>"
  hence "r \<in> A\<^sup>\<star>" by (rule lapp_fin_fin_lemma)
  hence "r @@ s \<in> A\<^sup>\<star> \<longrightarrow> s \<in> A\<^sup>\<star>"
    by (induct "r", simp) (auto elim: finlsts.cases)
  with rsA show "s \<in> A\<^sup>\<star>" by auto
qed

lemma lapp_all_invT:
assumes rs: "r@@s \<in> A\<^sup>\<infinity>"
  shows "r \<in> A\<^sup>\<infinity>"
proof (cases "r \<in> UNIV\<^sup>\<star>")
  case False
  with rs show ?thesis by simp
next
  case True
  thus ?thesis using rs
    by (induct "r") auto
qed

lemma lapp_fin_infT: "\<lbrakk>s \<in> A\<^sup>\<star>; t \<in> A\<^sup>\<omega>\<rbrakk> \<Longrightarrow> s @@ t \<in> A\<^sup>\<omega>"
  by (induct rule: finlsts.induct)
     (auto intro: inflstsI2)

lemma app_invT:
  assumes "r \<in> A\<^sup>\<star>" shows "r @@ s \<in> A\<^sup>\<omega> \<Longrightarrow> s \<in> A\<^sup>\<omega>"
using assms
proof (induct arbitrary: s)
  case LNil_fin thus ?case by simp
next
  case (LCons_fin a l)
  from \<open>(a ## l) @@ s \<in> A\<^sup>\<omega>\<close>
  have "a ## (l @@ s) \<in> A\<^sup>\<omega>" by simp
  hence "l @@ s \<in> A\<^sup>\<omega>" by (auto elim: inflsts_cases)
  with LCons_fin show "s \<in> A\<^sup>\<omega>" by blast
qed

lemma lapp_inv2T:
  assumes rsinf: "r @@ s \<in> A\<^sup>\<omega>"
  shows "r \<in> A\<^sup>\<star> \<and> s \<in> A\<^sup>\<omega> \<or> r \<in> A\<^sup>\<omega>"
proof (rule disjCI)
  assume rnotinf: "r \<notin> A\<^sup>\<omega>"
  moreover from rsinf have rsall: "r@@s \<in> A\<^sup>\<infinity>"
    by auto
  hence "r \<in> A\<^sup>\<infinity>" by (rule lapp_all_invT)
  hence "r \<in> A\<^sup>\<star>" using rnotinf by (auto elim: alllstsE)
  ultimately show "r \<in> A\<^sup>\<star> \<and> s \<in> A\<^sup>\<omega>" using rsinf
    by (auto  intro: app_invT)
qed

lemma lapp_infT:
  "(r @@ s \<in> A\<^sup>\<omega>) = (r \<in> A\<^sup>\<star> \<and> s \<in> A\<^sup>\<omega> \<or> r \<in> A\<^sup>\<omega>)"
  by (auto dest: lapp_inv2T intro: lapp_fin_infT)

lemma lapp_allT_iff:
  "(r @@ s \<in> A\<^sup>\<infinity>) = (r \<in> A\<^sup>\<star> \<and> s \<in> A\<^sup>\<infinity> \<or> r \<in> A\<^sup>\<omega>)"
  (is "?L = ?R")
proof
  assume ?L thus ?R by (cases rule: alllstsE) (auto simp: lapp_infT intro: finsubsetall)
next
  assume ?R thus ?L by (auto dest: finsubsetall intro: lappT)
qed

subsection\<open>Length, indexing, prefixes, and suffixes of llists\<close>

primrec ll2f :: "'a llist \<Rightarrow> nat \<Rightarrow> 'a option" (infix "!!" 100)
where
  "l!!0 = (case l of LNil \<Rightarrow> None | x ## xs \<Rightarrow> Some x)"
| "l!!(Suc i) = (case l of LNil \<Rightarrow> None | x ## xs \<Rightarrow> xs!!i)"

primrec ltake :: "'a llist \<Rightarrow> nat \<Rightarrow> 'a llist"  (infixl "\<down>" 110)
where
  "l \<down> 0     = LNil"
| "l \<down> Suc i = (case l of LNil \<Rightarrow> LNil | x ## xs \<Rightarrow> x ## ltake xs i)"

primrec ldrop :: "'a llist \<Rightarrow> nat \<Rightarrow> 'a llist"  (infixl "\<up>" 110)
where
  "l \<up> 0     = l"
| "l \<up> Suc i = (case l of LNil \<Rightarrow> LNil | x ## xs \<Rightarrow> ldrop xs i)"

definition lset :: "'a llist \<Rightarrow> 'a set"
where "lset l \<equiv> ran (ll2f l)"

definition llength :: "'a llist \<Rightarrow> nat"
where "llength \<equiv> finlsts_rec 0 (\<lambda> a r n. Suc n)"

definition llast :: "'a llist \<Rightarrow> 'a"
where "llast \<equiv> finlsts_rec undefined (\<lambda> x xs l. if xs = LNil then x else l)"

definition lbutlast :: "'a llist \<Rightarrow> 'a llist"
where "lbutlast \<equiv> finlsts_rec LNil (\<lambda> x xs l. if xs = LNil then LNil else x##l)"

definition lrev :: "'a llist \<Rightarrow> 'a llist"
where "lrev \<equiv> finlsts_rec LNil (\<lambda> x xs l. l @@ x ## LNil)"

lemmas llength_LNil  = llength_def [THEN finlsts_rec_LNil_def]
  and  llength_LCons = llength_def [THEN finlsts_rec_LCons_def]
lemmas llength_simps [simp] = llength_LNil llength_LCons

lemmas llast_LNil  = llast_def [THEN finlsts_rec_LNil_def]
  and  llast_LCons = llast_def [THEN finlsts_rec_LCons_def]
lemmas llast_simps [simp] = llast_LNil llast_LCons

lemmas lbutlast_LNil = lbutlast_def [THEN finlsts_rec_LNil_def]
  and lbutlast_LCons = lbutlast_def [THEN finlsts_rec_LCons_def]
lemmas lbutlast_simps [simp] = lbutlast_LNil lbutlast_LCons

lemmas lrev_LNil = lrev_def [THEN finlsts_rec_LNil_def]
  and lrev_LCons = lrev_def [THEN finlsts_rec_LCons_def]
lemmas lrev_simps [simp] = lrev_LNil lrev_LCons

lemma lrevT [simp, intro!]:
  "xs \<in> A\<^sup>\<star> \<Longrightarrow> lrev xs \<in> A\<^sup>\<star>"
  by (induct rule: finlsts.induct) auto

lemma lrev_lappend [simp]:
  assumes fin: "xs \<in> UNIV\<^sup>\<star>" "ys \<in> UNIV\<^sup>\<star>"
  shows "lrev (xs @@ ys) = (lrev ys) @@ (lrev xs)"
  using fin
  by induct (auto simp: lrev_LCons [of _ UNIV] lappend_assoc)

lemma lrev_lrev_ident [simp]:
  assumes fin: "xs \<in> UNIV\<^sup>\<star>"
  shows "lrev (lrev xs) = xs"
  using fin
proof (induct)
  case (LCons_fin a l)
  have "a ## LNil \<in> UNIV\<^sup>\<star>" by auto
  thus ?case using LCons_fin
    by auto
qed simp

lemma lrev_is_LNil_conv [iff]:
  "xs \<in> UNIV\<^sup>\<star> \<Longrightarrow> (lrev xs = LNil) = (xs = LNil)"
  by (induct rule: finlsts.induct) auto

lemma LNil_is_lrev_conv [iff]:
"xs \<in> UNIV\<^sup>\<star> \<Longrightarrow> (LNil = lrev xs) = (xs = LNil)"
by (induct rule: finlsts.induct) auto

lemma lrev_is_lrev_conv [iff]:
assumes fin: "xs \<in> UNIV\<^sup>\<star>" "ys \<in> UNIV\<^sup>\<star>"
  shows "(lrev xs = lrev ys) = (xs = ys)"
  (is "?L = ?R")
proof
  assume L: ?L
  hence "lrev (lrev xs) = lrev (lrev ys)" by simp
  thus ?R using fin by simp
qed simp

lemma lrev_induct [case_names LNil snocl, consumes 1]:
  assumes fin: "xs \<in> A\<^sup>\<star>"
  and init: "P LNil"
  and step: "\<And>x xs. \<lbrakk> xs \<in> A\<^sup>\<star>; P xs; x \<in> A \<rbrakk> \<Longrightarrow> P (xs @@ x##LNil)"
  shows "P xs"
proof-
  define l where "l = lrev xs"
  with fin have "l \<in> A\<^sup>\<star>" by simp
  hence "P (lrev l)"
  proof (induct l)
    case LNil_fin with init show ?case by simp
  next
    case (LCons_fin a l) thus ?case by (auto intro: step)
  qed
  thus ?thesis using fin l_def by simp
qed

lemma finlsts_rev_cases:
  assumes tfin: "t \<in> A\<^sup>\<star>"
  obtains (LNil) "t = LNil"
    |    (snocl) a l where "l \<in> A\<^sup>\<star>" "a \<in> A" "t = l @@ a ## LNil"
  using assms
  by (induct rule: lrev_induct) auto

lemma ll2f_LNil [simp]: "LNil!!x = None"
  by (cases "x") auto

lemma None_lfinite: "t!!i = None \<Longrightarrow> t \<in> UNIV\<^sup>\<star>"
proof (induct "i" arbitrary: t)
  case 0 thus ?case
    by(cases t) auto
next
  case (Suc n)
  show ?case
  proof(cases t)
    case LNil thus ?thesis by auto
  next
    case (LCons x l')
    with \<open>l' !! n = None \<Longrightarrow> l' \<in> UNIV\<^sup>\<star>\<close> \<open>t !! Suc n = None\<close>
    show ?thesis by auto
  qed
qed

lemma infinite_Some: "t \<in> A\<^sup>\<omega> \<Longrightarrow> \<exists>a. t!!i = Some a"
  by (rule ccontr) (auto dest: None_lfinite)

lemmas infinite_idx_SomeE = exE [OF infinite_Some]

lemma Least_True [simp]:
  "(LEAST (n::nat). True) = 0"
  by (auto simp: Least_def)

lemma  ll2f_llength [simp]: "r \<in> A\<^sup>\<star> \<Longrightarrow> r!!(llength r) = None"
  by (erule finlsts.induct) auto

lemma llength_least_None:
  assumes rA: "r \<in> A\<^sup>\<star>"
  shows "llength r = (LEAST i. r!!i = None)"
using rA
proof induct
  case LNil_fin thus ?case by simp
next
  case (LCons_fin a l)
  hence "(LEAST i. (a ## l) !! i = None) = llength (a ## l)"
    by (auto intro!: ll2f_llength Least_Suc2)
  thus ?case by rule
qed

lemma ll2f_lem1:
 "t !! (Suc i) = Some x \<Longrightarrow> \<exists> y. t !! i = Some y"
proof (induct i arbitrary: x t)
  case 0 thus ?case by (auto split: llist.splits)
next
  case (Suc k) thus ?case
    by (cases t) auto
qed

lemmas ll2f_Suc_Some = ll2f_lem1 [THEN exE]

lemma ll2f_None_Suc: "t !! i = None \<Longrightarrow> t !! Suc i = None"
proof (induct i arbitrary: t)
  case 0 thus ?case by (auto split: llist.split)
next
  case (Suc k) thus ?case by (cases t) auto
qed

lemma ll2f_None_le:
  "\<lbrakk> t!!j = None; j \<le> i \<rbrakk> \<Longrightarrow> t!!i = None"
proof (induct i arbitrary: t j)
  case 0 thus ?case by simp
next
  case (Suc k) thus ?case by (cases j) (auto split: llist.split)
qed

lemma ll2f_Some_le:
  assumes jlei: "j \<le> i"
  and tisome: "t !! i = Some x"
  and H: "\<And> y. t !! j = Some y \<Longrightarrow> Q"
  shows "Q"
proof -
  have  "\<exists> y. t !! j = Some y" (is "?R")
  proof (rule ccontr)
    assume "\<not> ?R"
    hence "t !! j = None" by auto
    with tisome jlei show False
      by (auto dest:  ll2f_None_le)
  qed
  thus ?thesis using H by auto
qed

lemma ltake_LNil [simp]: "LNil \<down> i = LNil"
  by (cases "i") auto

lemma ltake_LCons_Suc: "(a ## l) \<down> (Suc i) = a ## l \<down> i"
  by simp

lemma take_fin [iff]: "t \<in> A\<^sup>\<infinity> \<Longrightarrow> t\<down>i \<in> A\<^sup>\<star>"
proof (induct i arbitrary: t)
  case 0 show ?case by auto
next
  case (Suc j) thus ?case
    by (cases "t") auto
qed

lemma ltake_fin [iff]:
  "r \<down> i \<in> UNIV\<^sup>\<star>"
  by simp

lemma llength_take [simp]: "t \<in> A\<^sup>\<omega> \<Longrightarrow> llength (t\<down>i) = i"
proof (induct "i" arbitrary: t)
  case 0 thus ?case by simp
next
  case (Suc j)
  from \<open>t \<in> A\<^sup>\<omega>\<close> \<open>\<And>t. t \<in> A\<^sup>\<omega> \<Longrightarrow> llength (t \<down> j) = j\<close> show ?case
    by(cases) (auto simp: llength_LCons [of _ UNIV])
qed

lemma ltake_ldrop_id: "(x \<down> i) @@ (x \<up> i) = x"
proof (induct "i" arbitrary: x)
  case 0 thus ?case by simp
next
  case (Suc j) thus ?case
    by (cases x) auto
qed

lemma ldrop_LNil [simp]: "LNil \<up> i = LNil"
  by (cases "i") auto

lemma ldrop_add: "t \<up> (i + k) = t \<up> i \<up> k"
proof (induct "i" arbitrary: t)
  case (Suc j) thus ?case
    by (cases "t") auto
qed simp

lemma ldrop_fun: "t \<up> i !! j = t!!(i + j)"
proof (induct i arbitrary: t)
  case 0 thus ?case by simp
next
  case (Suc k) then show ?case
    by (cases "t") auto
qed

lemma ldropT[simp]: "t \<in> A\<^sup>\<infinity> \<Longrightarrow> t \<up> i \<in> A\<^sup>\<infinity>"
proof (induct i arbitrary: t)
  case 0 thus ?case by simp
next case (Suc j)
  thus ?case by (cases "t") auto
qed

lemma ldrop_finT[simp]: "t \<in> A\<^sup>\<star> \<Longrightarrow> t \<up> i \<in> A\<^sup>\<star>"
proof (induct i arbitrary: t)
  case 0 thus ?case by simp
next
  fix n t assume "t \<in> A\<^sup>\<star>" and
    "\<And>t::'a llist. t \<in> A\<^sup>\<star> \<Longrightarrow> t \<up> n \<in> A\<^sup>\<star>"
  thus "t \<up> Suc n \<in> A\<^sup>\<star>"
    by (cases "t") auto
qed

lemma ldrop_infT[simp]: "t \<in> A\<^sup>\<omega> \<Longrightarrow> t \<up> i \<in> A\<^sup>\<omega>"
proof (induct i arbitrary: t)
  case 0 thus ?case by simp
next
  case (Suc n)
  from \<open>t \<in> A\<^sup>\<omega>\<close> \<open>\<And>t. t \<in> A\<^sup>\<omega> \<Longrightarrow> t \<up> n \<in> A\<^sup>\<omega>\<close> show ?case
    by (cases "t") auto
qed

lemma lapp_suff_llength: "r \<in> A\<^sup>\<star> \<Longrightarrow> (r@@s) \<up> llength r = s"
  by (induct rule: finlsts.induct) auto

lemma ltake_lappend_llength [simp]:
  "r \<in> A\<^sup>\<star> \<Longrightarrow> (r @@ s) \<down> llength r = r"
  by (induct rule: finlsts.induct) auto

lemma ldrop_LNil_less:
  "\<lbrakk>j \<le> i; t \<up> j = LNil\<rbrakk> \<Longrightarrow> t \<up> i = LNil"
proof (induct i arbitrary: j t)
  case 0 thus ?case by auto
next case (Suc n) thus ?case
    by (cases j, simp) (cases t, simp_all)
qed

lemma ldrop_inf_iffT [iff]: "(t \<up> i \<in> UNIV\<^sup>\<omega>)  =  (t \<in> UNIV\<^sup>\<omega>)"
proof
  show "t\<up>i \<in> UNIV\<^sup>\<omega> \<Longrightarrow> t \<in> UNIV\<^sup>\<omega>"
    by (rule ccontr) (auto dest: ldrop_finT)
qed auto

lemma ldrop_fin_iffT [iff]: "(t \<up> i \<in> UNIV\<^sup>\<star>) = (t \<in> UNIV\<^sup>\<star>)"
  by auto

lemma drop_nonLNil: "t\<up>i \<noteq> LNil \<Longrightarrow> t \<noteq> LNil"
  by (auto)

lemma llength_drop_take:
  "t\<up>i \<noteq> LNil \<Longrightarrow> llength (t\<down>i) = i"
proof (induct i arbitrary: t)
  case 0 show ?case by simp
next
  case (Suc j) thus ?case by (cases t) (auto simp: llength_LCons [of _ UNIV])
qed

lemma fps_induct [case_names LNil LCons, induct set: fpslsts, consumes 1]:
  assumes fps: "l \<in> A\<^sup>\<clubsuit>"
  and    init: "\<And>a. a \<in> A \<Longrightarrow> P (a##LNil)"
  and    step: "\<And>a l. \<lbrakk> l \<in> A\<^sup>\<clubsuit>; P l; a \<in> A \<rbrakk> \<Longrightarrow> P (a ## l)"
  shows "P l"
proof-
  from fps have "l \<in> A\<^sup>\<star>" and "l \<noteq> LNil" by auto
  thus ?thesis
    by (induct, simp) (cases, auto intro: init step)
qed

lemma lbutlast_lapp_llast:
assumes "l \<in> A\<^sup>\<clubsuit>"
  shows "l = lbutlast l @@ (llast l ## LNil)"
  using assms by induct auto

lemma llast_snoc [simp]:
  assumes fin: "xs \<in> A\<^sup>\<star>"
  shows "llast (xs @@ x ## LNil) = x"
  using fin
proof induct
  case LNil_fin thus ?case by simp
next
  case (LCons_fin a l)
  have "x ## LNil \<in> UNIV\<^sup>\<star>" by auto
  with LCons_fin show ?case
    by (auto simp: llast_LCons [of _ UNIV])
qed

lemma lbutlast_snoc [simp]:
  assumes fin: "xs \<in> A\<^sup>\<star>"
  shows "lbutlast (xs @@ x ## LNil) = xs"
  using fin
proof induct
  case LNil_fin thus ?case by simp
next
  case (LCons_fin a l)
  have "x ## LNil \<in> UNIV\<^sup>\<star>" by auto
  with LCons_fin show ?case
    by (auto simp: lbutlast_LCons [of _ UNIV])
qed

lemma llast_lappend [simp]:
"\<lbrakk> x \<in> UNIV\<^sup>\<star>; y \<in> UNIV\<^sup>\<star> \<rbrakk> \<Longrightarrow> llast (x @@ a ## y) = llast (a ## y)"
proof (induct rule: finlsts.induct)
  case LNil_fin thus ?case by simp
next case (LCons_fin l b)
  hence "l @@ a ## y \<in> UNIV\<^sup>\<star>" by auto
  thus ?case using LCons_fin
    by (auto simp: llast_LCons [of _ UNIV])
qed

lemma llast_llength:
  assumes tfin: "t \<in> UNIV\<^sup>\<star>"
  shows "t \<noteq> LNil \<Longrightarrow> t !! (llength t - (Suc 0)) = Some (llast t)"
  using tfin
proof induct
  case (LNil_fin l) thus ?case by auto
next
  case (LCons_fin a l) note consal = this thus ?case
  proof (cases l)
    case LNil_fin thus ?thesis using consal by simp
  next
    case (LCons_fin aa la)
    thus ?thesis using consal by simp
  qed
qed

subsection\<open>The constant llist\<close>

definition lconst :: "'a \<Rightarrow> 'a llist" where
  "lconst a \<equiv> iterates (\<lambda>x. x) a"

lemma lconst_unfold: "lconst a = a ## lconst a"
  by (auto simp: lconst_def intro: iterates)

lemma lconst_LNil [iff]: "lconst a \<noteq> LNil"
  by (clarify,frule subst [OF lconst_unfold]) simp

lemma lconstT:
  assumes aA: "a \<in> A"
  shows "lconst a \<in> A\<^sup>\<omega>"
proof (rule inflstsI)
  show "lconst a \<in> A\<^sup>\<infinity>"
  proof (rule alllsts.coinduct [of "\<lambda>x. x = lconst a"], simp_all)
    have "lconst a = a ## lconst a"
      by (rule lconst_unfold)
    with aA
    show "\<exists>l aa. lconst a = aa ## l \<and> (l = lconst a \<or> l \<in> A\<^sup>\<infinity>) \<and> aa \<in> A"
      by blast
  qed
next assume lconst: "lconst a \<in> UNIV\<^sup>\<star>"
  moreover have "\<And>l. l \<in> UNIV\<^sup>\<star> \<Longrightarrow> lconst a \<noteq> l"
  proof-
    fix l::"'a llist" assume "l\<in>UNIV\<^sup>\<star>"
    thus "lconst a \<noteq> l"
    proof (rule finlsts_induct, simp_all)
      fix a' l' assume
        al': "lconst a \<noteq> l'" and
        l'A: "l' \<in> UNIV\<^sup>\<star>"
      from al' show  "lconst a \<noteq> a' ## l'"
      proof (rule contrapos_np)
        assume notal: "\<not> lconst a \<noteq> a' ## l'"
        hence "lconst a = a' ## l'" by simp
        hence "a ## lconst a = a' ## l'"
          by (rule subst [OF lconst_unfold])
        thus "lconst a = l'" by auto
      qed
    qed
  qed
  ultimately show "False" using aA by auto
qed

subsection\<open>The prefix order of llists\<close>

instantiation llist :: (type) order
begin

definition
  llist_le_def: "(s :: 'a llist) \<le> t \<longleftrightarrow> (\<exists>d. t = s @@ d)"

definition
  llist_less_def: "(s :: 'a llist) < t \<longleftrightarrow> (s \<le> t \<and> s \<noteq> t)"

lemma not_LCons_le_LNil [iff]:
  "\<not> (a##l) \<le> LNil"
  by (unfold llist_le_def) auto

lemma LNil_le [iff]:"LNil \<le> s"
  by (auto simp: llist_le_def)

lemma le_LNil [iff]: "(s \<le> LNil) = (s = LNil)"
  by (auto simp: llist_le_def)

lemma llist_inf_le:
  "s \<in> A\<^sup>\<omega>  \<Longrightarrow> (s\<le>t) = (s=t)"
  by (unfold llist_le_def) auto

lemma le_LCons [iff]: "(x ## xs \<le> y ## ys) = (x = y \<and> xs \<le> ys)"
  by (unfold llist_le_def) auto

lemma llist_le_refl [iff]:
  "(s:: 'a llist) \<le> s"
  by (unfold llist_le_def) (rule exI [of _ "LNil"], simp)

lemma llist_le_trans [trans]:
  fixes r:: "'a llist"
  shows "r \<le> s \<Longrightarrow> s \<le> t \<Longrightarrow> r \<le> t"
  by (auto simp: llist_le_def lappend_assoc)

lemma llist_le_anti_sym:
  fixes s:: "'a llist"
  assumes st: "s \<le> t"
  and ts: "t \<le> s"
  shows "s = t"
proof-
  have "s \<in> UNIV\<^sup>\<infinity>" by auto
  thus ?thesis
  proof (cases rule: alllstsE)
    case finite
    hence "\<forall> t.  s \<le> t \<and> t \<le> s \<longrightarrow> s = t"
    proof (induct rule: finlsts.induct)
      case LNil_fin thus ?case by auto
    next
      case (LCons_fin l a) show ?case
      proof
        fix t from LCons_fin show  "a ## l \<le> t \<and> t \<le> a ## l \<longrightarrow> a ## l = t"
          by (cases "t") blast+
      qed
    qed
    thus ?thesis using st ts by blast
  next case infinite thus ?thesis using st by (simp add: llist_inf_le)
  qed
qed

lemma llist_less_le_not_le:
  fixes s :: "'a llist"
  shows "(s < t) = (s \<le> t \<and> \<not> t \<le> s)"
  by (auto simp add: llist_less_def dest: llist_le_anti_sym)

instance
  by standard
    (assumption | rule llist_le_refl
      llist_le_trans llist_le_anti_sym llist_less_le_not_le)+

end

subsubsection\<open>Typing rules\<close>

lemma llist_le_finT [simp]:
 "r\<le>s \<Longrightarrow> s \<in> A\<^sup>\<star> \<Longrightarrow> r \<in> A\<^sup>\<star>"
proof-
  assume rs: "r\<le>s" and sfin: "s \<in> A\<^sup>\<star>"
  from sfin have "\<forall>r. r\<le>s \<longrightarrow> r\<in>A\<^sup>\<star>"
  proof (induct "s")
    case LNil_fin thus ?case by auto
  next
    case (LCons_fin a l) show  ?case
    proof (clarify)
      fix r assume ral: "r \<le> a ## l"
      thus "r \<in> A\<^sup>\<star>" using LCons_fin
        by (cases r) auto
    qed
  qed
  with rs show ?thesis by auto
qed

lemma llist_less_finT [iff]:
 "r<s \<Longrightarrow> s \<in> A\<^sup>\<star> \<Longrightarrow> r \<in> A\<^sup>\<star>"
  by (auto simp: less_le)

subsubsection\<open>More simplification rules\<close>

lemma LNil_less_LCons [iff]: "LNil < a ## t"
  by (simp add: less_le)

lemma not_less_LNil [iff]:
  "\<not> r < LNil"
  by (auto simp: less_le)

lemma less_LCons [iff]:
  " (a ## r < b ## t) = (a = b \<and> r < t)"
  by (auto simp: less_le)

lemma llength_mono [iff]:
  assumes"r \<in> A\<^sup>\<star>"
  shows "s<r \<Longrightarrow> llength s < llength r"
  using assms
proof(induct "r" arbitrary: s)
  case LNil_fin thus ?case by simp
next
  case (LCons_fin a l)
  thus ?case
    by (cases s) (auto simp: llength_LCons [of _ UNIV])
qed

lemma le_lappend [iff]: "r \<le> r @@ s"
  by (auto simp: llist_le_def)

lemma take_inf_less:
  "t \<in> UNIV\<^sup>\<omega> \<Longrightarrow> t \<down> i < t"
proof (induct i arbitrary: t)
  case 0 thus ?case by (auto elim: inflsts_cases)
next
  case (Suc i)
  from \<open>t \<in> UNIV\<^sup>\<omega>\<close> show ?case
  proof (cases "t")
    case (LCons a l) with Suc show ?thesis
      by auto
  qed
qed

lemma lapp_take_less:
  assumes iless: "i < llength r"
  shows "(r @@ s) \<down> i < r"
proof (cases "r \<in> UNIV\<^sup>\<star>")
  case True
  thus ?thesis using iless
  proof(induct i arbitrary: r)
    case 0 thus ?case by (cases "r") auto
  next
    case (Suc j)
    from \<open>r \<in> UNIV\<^sup>\<star>\<close> \<open>Suc j < llength r\<close> \<open>\<And>r. \<lbrakk>r \<in> UNIV\<^sup>\<star>; j < llength r\<rbrakk> \<Longrightarrow> lappend r s \<down> j < r\<close>
    show ?case by (cases) auto
  qed
next
  case False thus ?thesis by (simp add: take_inf_less)
qed

subsubsection\<open>Finite prefixes and infinite suffixes\<close>

definition finpref :: "'a set \<Rightarrow> 'a llist \<Rightarrow> 'a llist set"
where "finpref A s \<equiv> {r. r \<in> A\<^sup>\<star> \<and> r \<le> s}"

definition suff :: "'a set \<Rightarrow> 'a llist \<Rightarrow> 'a llist set"
where "suff A s \<equiv> {r. r \<in> A\<^sup>\<infinity> \<and> s \<le> r}"

definition infsuff :: "'a set \<Rightarrow> 'a llist \<Rightarrow> 'a llist set"
where "infsuff A s \<equiv> {r. r \<in> A\<^sup>\<omega> \<and> s \<le> r}"

definition prefix_closed :: "'a llist set \<Rightarrow> bool"
where "prefix_closed A \<equiv> \<forall> t \<in> A. \<forall> s \<le> t. s \<in> A"

definition pprefix_closed :: "'a llist set \<Rightarrow> bool"
where "pprefix_closed A \<equiv> \<forall> t \<in> A. \<forall> s. s \<le> t \<and> s \<noteq> LNil \<longrightarrow> s \<in> A"

definition suffix_closed :: "'a llist set \<Rightarrow> bool"
where "suffix_closed A \<equiv> \<forall> t \<in> A. \<forall> s. t \<le> s \<longrightarrow> s \<in> A"

lemma finpref_LNil [simp]:
  "finpref A LNil = {LNil}"
  by (auto simp: finpref_def)

lemma finpref_fin: "x \<in> finpref A s \<Longrightarrow> x \<in> A\<^sup>\<star>"
  by (auto simp: finpref_def)

lemma finpref_mono2: "s \<le> t \<Longrightarrow> finpref A s \<subseteq> finpref A t"
  by (unfold finpref_def) (auto dest: llist_le_trans)

lemma suff_LNil [simp]:
  "suff A LNil = A\<^sup>\<infinity>"
  by (simp add: suff_def)

lemma suff_all: "x \<in> suff A s \<Longrightarrow> x \<in> A\<^sup>\<infinity>"
  by (auto simp: suff_def)

lemma suff_mono2: "s \<le> t \<Longrightarrow> suff A t \<subseteq> suff A s"
  by (unfold suff_def) (auto dest: llist_le_trans)

lemma suff_appE:
  assumes rA: "r \<in> A\<^sup>\<star>"
  and  tsuff: "t \<in> suff A r"
  obtains s where "s \<in> A\<^sup>\<infinity>" "t = r@@s"
proof-
  from tsuff obtain s where
    tA: "t \<in> A\<^sup>\<infinity>" and trs: "t = r @@ s"
    by (auto simp: suff_def llist_le_def)
  from rA trs tA have "s \<in> A\<^sup>\<infinity>"
    by (auto simp: lapp_allT_iff)
  thus ?thesis using trs
    by (rule that)
qed

lemma LNil_suff [iff]: "(LNil \<in> suff A s) = (s = LNil)"
  by (auto simp: suff_def)

lemma finpref_suff [dest]:
  "\<lbrakk> r \<in> finpref A t; t\<in>A\<^sup>\<infinity> \<rbrakk> \<Longrightarrow> t \<in> suff A r"
  by (auto simp: finpref_def suff_def)

lemma suff_finpref:
  "\<lbrakk> t \<in> suff A r; r\<in>A\<^sup>\<star> \<rbrakk> \<Longrightarrow> r \<in> finpref A t"
  by (auto simp: finpref_def suff_def)

lemma suff_finpref_iff:
  "\<lbrakk> r\<in>A\<^sup>\<star>; t\<in>A\<^sup>\<infinity> \<rbrakk> \<Longrightarrow> (r \<in> finpref A t) = (t \<in> suff A r)"
  by (auto simp: finpref_def suff_def)

lemma infsuff_LNil [simp]:
  "infsuff A LNil = A\<^sup>\<omega>"
  by (simp add: infsuff_def)

lemma infsuff_inf: "x \<in> infsuff A s \<Longrightarrow> x \<in> A\<^sup>\<omega>"
  by (auto simp: infsuff_def)

lemma infsuff_mono2: "s \<le> t \<Longrightarrow> infsuff A t \<subseteq> infsuff A s"
  by (unfold infsuff_def) (auto dest: llist_le_trans)

lemma infsuff_appE:
  assumes   rA: "r \<in> A\<^sup>\<star>"
  and tinfsuff: "t \<in> infsuff A r"
  obtains s where "s \<in> A\<^sup>\<omega>" "t = r@@s"
proof-
  from tinfsuff obtain s where
    tA: "t \<in> A\<^sup>\<omega>" and trs: "t = r @@ s"
    by (auto simp: infsuff_def llist_le_def)
  from rA trs tA have "s \<in> A\<^sup>\<omega>"
    by (auto dest: app_invT)
  thus ?thesis using trs
    by (rule that)
qed

lemma finpref_infsuff [dest]:
  "\<lbrakk> r \<in> finpref A t; t\<in>A\<^sup>\<omega> \<rbrakk> \<Longrightarrow> t \<in> infsuff A r"
  by (auto simp: finpref_def infsuff_def)

lemma infsuff_finpref:
  "\<lbrakk> t \<in> infsuff A r; r\<in>A\<^sup>\<star> \<rbrakk> \<Longrightarrow> r \<in> finpref A t"
  by (auto simp: finpref_def infsuff_def)

lemma infsuff_finpref_iff [iff]:
  "\<lbrakk> r\<in>A\<^sup>\<star>; t\<in>A\<^sup>\<omega> \<rbrakk> \<Longrightarrow> (t \<in> finpref A r) = (r \<in> infsuff A t)"
  by (auto simp: finpref_def infsuff_def)

lemma prefix_lemma:
  assumes xinf: "x \<in> A\<^sup>\<omega>"
  and yinf: "y \<in> A\<^sup>\<omega>"
  and R: "\<And> s. \<lbrakk> s \<in> A\<^sup>\<star>; s \<le> x\<rbrakk> \<Longrightarrow> s \<le> y"
  shows "x = y"
proof-
  let ?r = "\<lambda>x y. x\<in>A\<^sup>\<omega> \<and> y\<in>A\<^sup>\<omega> \<and> finpref A x \<subseteq> finpref A y"
  have "?r x y" using xinf yinf
    by (auto simp: finpref_def intro: R)
  thus ?thesis
  proof (coinduct rule: llist.coinduct_strong)
    case (Eq_llist a b)
    hence ainf: "a \<in> A\<^sup>\<omega>"
      and binf: "b \<in> A\<^sup>\<omega>" and pref: "finpref A a \<subseteq> finpref A b" by auto
    from ainf show ?case
    proof cases
      case (LCons a' l')
      note acons = this with binf show ?thesis
      proof (cases b)
        case (LCons b' l'')
        with acons pref have "a' = b'" "finpref A l' \<subseteq> finpref A l''"
          by (auto simp: finpref_def)
        thus ?thesis using acons LCons by auto
      qed
    qed
  qed
qed

lemma inf_neqE:
"\<lbrakk> x \<in>  A\<^sup>\<omega>; y \<in> A\<^sup>\<omega>; x \<noteq> y;
  \<And>s. \<lbrakk> s\<in>A\<^sup>\<star>; s \<le> x; \<not> s \<le> y\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (auto intro!: prefix_lemma)

lemma pref_locally_linear:
  fixes s::"'a llist"
  assumes sx: "s \<le> x"
  and   tx: "t \<le> x"
  shows "s \<le> t \<or> t \<le> s"
proof-
  have "s \<in> UNIV\<^sup>\<infinity>" by auto
  thus ?thesis
  proof (cases rule: alllstsE)
    case infinite with sx tx show ?thesis
      by (auto simp: llist_inf_le)
  next
    case finite
    thus ?thesis using sx tx
    proof (induct "s" arbitrary: x t)
      case LNil_fin thus ?case by simp
    next
      case (LCons_fin a l)
      note alx = \<open>a ## l \<le> x\<close>
      note tx = \<open>t \<le> x\<close>
      show ?case
      proof(rule disjCI)
        assume tal: "\<not> t \<le> a ## l"
        show "LCons a l \<le> t"
        proof (cases t)
          case LNil thus ?thesis using tal by auto
        next case (LCons b ts) note tcons = this show ?thesis
          proof (cases x)
            case LNil thus ?thesis using alx by auto
          next
            case (LCons c xs)
            from alx  LCons have ac: "a = c" and lxs: "l \<le> xs"
              by auto
            from tx tcons LCons have bc: "b = c" and tsxs: "ts \<le> xs"
              by auto
            from tcons tal ac bc have tsl: "\<not> ts \<le> l"
              by auto
            from LCons_fin lxs tsxs tsl have "l \<le> ts"
              by auto
            with tcons ac bc show ?thesis
              by auto
          qed
        qed
      qed
    qed
  qed
qed

definition pfinpref :: "'a set \<Rightarrow> 'a llist \<Rightarrow> 'a llist set"
where "pfinpref A s \<equiv> finpref A s - {LNil}"

lemma pfinpref_iff [iff]:
  "(x \<in> pfinpref A s) = (x \<in> finpref A s \<and> x \<noteq> LNil)"
  by (auto simp: pfinpref_def)

subsection\<open>Safety and Liveness\<close>

definition infsafety :: "'a set \<Rightarrow> 'a llist set \<Rightarrow> bool"
where "infsafety A P \<equiv> \<forall> t \<in> A\<^sup>\<omega>. (\<forall> r \<in> finpref A t. \<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P) \<longrightarrow> t \<in> P"

definition infliveness :: "'a set \<Rightarrow> 'a llist set \<Rightarrow> bool"
where "infliveness A P \<equiv> \<forall> t \<in> A\<^sup>\<star>. \<exists> s \<in> A\<^sup>\<omega>. t @@ s \<in> P"

definition possafety :: "'a set \<Rightarrow> 'a llist set \<Rightarrow> bool"
where "possafety A P \<equiv> \<forall> t \<in> A\<^sup>\<spadesuit>. (\<forall> r \<in> pfinpref A t. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P) \<longrightarrow> t \<in> P"

definition posliveness :: "'a set \<Rightarrow> 'a llist set \<Rightarrow> bool"
where "posliveness A P \<equiv> \<forall> t \<in> A\<^sup>\<clubsuit>. \<exists> s \<in> A\<^sup>\<infinity>. t @@ s \<in> P"

definition safety :: "'a set \<Rightarrow> 'a llist set \<Rightarrow> bool"
where "safety A P \<equiv> \<forall> t \<in> A\<^sup>\<infinity>. (\<forall> r \<in> finpref A t. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P) \<longrightarrow> t \<in> P"

definition liveness :: "'a set \<Rightarrow> 'a llist set \<Rightarrow> bool"
where "liveness A P \<equiv> \<forall> t \<in> A\<^sup>\<star>. \<exists> s \<in> A\<^sup>\<infinity>. t @@ s \<in> P"

lemma safetyI:
  "(\<And>t. \<lbrakk>t \<in>  A\<^sup>\<infinity>; \<forall> r \<in> finpref A t. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P\<rbrakk> \<Longrightarrow> t \<in> P)
  \<Longrightarrow> safety A P"
  by (unfold safety_def) blast

lemma safetyD:
  "\<lbrakk> safety A P;  t \<in> A\<^sup>\<infinity>;
    \<And>r. r \<in> finpref A t \<Longrightarrow> \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P
  \<rbrakk> \<Longrightarrow> t \<in> P"
  by (unfold safety_def) blast

lemma safetyE:
  "\<lbrakk> safety A P;
    \<forall> t \<in> A\<^sup>\<infinity>. (\<forall> r \<in> finpref A t. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P) \<longrightarrow> t \<in> P \<Longrightarrow> R
   \<rbrakk> \<Longrightarrow> R"
  by (unfold safety_def) blast

lemma safety_prefix_closed:
  "safety UNIV P \<Longrightarrow> prefix_closed P"
  by (auto dest!: safetyD
       simp: prefix_closed_def finpref_def llist_le_def lappend_assoc)
    blast

lemma livenessI:
  "(\<And>s. s\<in> A\<^sup>\<star> \<Longrightarrow> \<exists> t \<in> A\<^sup>\<infinity>. s @@ t \<in> P) \<Longrightarrow> liveness A P"
  by (auto simp: liveness_def)

lemma livenessE:
  "\<lbrakk> liveness A P; \<And>t. \<lbrakk>  t \<in> A\<^sup>\<infinity>; s @@ t \<in> P\<rbrakk> \<Longrightarrow> R; s \<notin> A\<^sup>\<star> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp: liveness_def)

lemma possafetyI:
  "(\<And>t. \<lbrakk>t \<in>  A\<^sup>\<spadesuit>; \<forall> r \<in> pfinpref A t. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P\<rbrakk> \<Longrightarrow> t \<in> P)
  \<Longrightarrow> possafety A P"
  by (unfold possafety_def) blast

lemma possafetyD:
  "\<lbrakk> possafety A P;  t \<in> A\<^sup>\<spadesuit>;
    \<And>r. r \<in> pfinpref A t \<Longrightarrow> \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P
  \<rbrakk> \<Longrightarrow> t \<in> P"
  by (unfold possafety_def) blast

lemma possafetyE:
  "\<lbrakk> possafety A P;
    \<forall> t \<in> A\<^sup>\<spadesuit>. (\<forall> r \<in> pfinpref A t. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P) \<longrightarrow> t \<in> P \<Longrightarrow> R
   \<rbrakk> \<Longrightarrow> R"
  by (unfold possafety_def) blast

lemma possafety_pprefix_closed:
  assumes psafety: "possafety UNIV P"
  shows "pprefix_closed P"
unfolding pprefix_closed_def
proof(intro ballI allI impI, erule conjE)
  fix t s assume tP: "t \<in> P" and st: "s \<le> t" and spos: "s \<noteq> LNil"
  from psafety show "s \<in> P"
  proof (rule possafetyD)
    from spos show  "s \<in> UNIV\<^sup>\<spadesuit>" by auto
  next fix r assume "r \<in> pfinpref UNIV s"
    then obtain u where scons: "s = r @@ u"
      by (auto simp: pfinpref_def finpref_def llist_le_def)
    with st obtain v where "t = r @@ u @@ v"
      by (auto simp: lappend_assoc llist_le_def)
    with tP show "\<exists>s\<in>UNIV\<^sup>\<infinity>. r @@ s \<in> P" by auto
  qed
qed

lemma poslivenessI:
  "(\<And>s. s\<in> A\<^sup>\<clubsuit> \<Longrightarrow> \<exists> t \<in> A\<^sup>\<infinity>. s @@ t \<in> P) \<Longrightarrow> posliveness A P"
  by (auto simp: posliveness_def)

lemma poslivenessE:
  "\<lbrakk> posliveness A P; \<And>t. \<lbrakk>  t \<in> A\<^sup>\<infinity>; s @@ t \<in> P\<rbrakk> \<Longrightarrow> R; s \<notin> A\<^sup>\<clubsuit> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp: posliveness_def)

end


section \<open>Top-Level Proof\<close>

theory RealTimeDeque_Proof
  imports Deque RealTimeDeque States_Proof RealTimeDeque_Dequeue RealTimeDeque_Enqueue
begin

lemma swap_lists_left: "invar (States Left big small) \<Longrightarrow>
    States.listL (States Left big small) = rev (States.listL (States Right big small))"
  by(auto split: prod.splits Big.state.splits Small.state.splits)

lemma swap_lists_right: "invar (States Right big small) \<Longrightarrow>
    States.listL (States Right big small) = rev (States.listL (States Left big small))"
  by(auto split: prod.splits Big.state.splits Small.state.splits)

lemma swap_list [simp]: "invar q \<Longrightarrow> listR (swap q) = listL q"
proof(induction q)
  case (Transforming states)
  then show ?case
    apply(cases states)
    using swap_lists_left swap_lists_right
    by (metis (full_types) RealTimeDeque.listL.simps(6) direction.exhaust invar_deque.simps(6) swap.simps(6) swap.simps(7))
qed auto

lemma swap_list': "invar q \<Longrightarrow> listL (swap q) = listR q"
  using swap_list rev_swap
  by blast

lemma lists_same: "lists (States Left big small) = lists (States Right big small)"
  by(induction "States Left big small" rule: lists.induct) auto

lemma invar_swap: "invar q \<Longrightarrow> invar (swap q)"
  by(induction q rule: swap.induct) (auto simp: lists_same split: prod.splits)

lemma listL_is_empty: "invar deque \<Longrightarrow> is_empty deque = (listL deque = [])"
  using Idle_Proof.list_empty listL_remaining_steps
  by(cases deque) auto

interpretation RealTimeDeque: Deque where
  empty    = empty    and
  enqL     = enqL     and
  enqR     = enqR     and
  firstL   = firstL   and
  firstR   = firstR   and
  deqL     = deqL     and
  deqR     = deqR     and
  is_empty = is_empty and
  listL    = listL    and
  invar    = invar
proof (standard, goal_cases)
  case 1
  then show ?case
    by (simp add: empty_def)
next
  case 2
  then show ?case
    by(simp add: list_enqL)
next
  case (3 q x)

  then have "listL (enqL x (swap q)) = x # listR q"
    by (simp add: list_enqL invar_swap swap_list')

  with 3 show ?case
    by (simp add: invar_enqL invar_swap)
next
  case 4
  then show ?case
    using list_deqL by simp
next
  case (5 q)
  then have "listL (deqL (swap q)) = tl (listR q)"
    using 5 list_deqL swap_list' invar_swap by fastforce

  then have "listR (swap (deqL (swap q))) = tl (listR q)"
    using 5 swap_list' invar_deqL invar_swap listL_is_empty swap_list
    by metis

  then show ?case
    by(auto split: prod.splits)
next
  case 6
  then show ?case
    using list_firstL by simp
next
  case (7 q)

  from 7 have [simp]: "listR q = listL (swap q)"
    by (simp add: invar_swap swap_list')

  from 7 have [simp]: "firstR q = firstL (swap q)"
    by(auto split: prod.splits)

  from 7 have "listL (swap q) \<noteq> []"
    by auto

  with 7 have "firstL (swap q) = hd (listL (swap q))"
    using invar_swap list_firstL by blast

  then show ?case
    using \<open>firstR q = firstL (swap q)\<close> by auto
next
  case 8
  then show ?case
    using listL_is_empty by auto
next
  case 9
  then show ?case
    by (simp add: empty_def)
next
  case 10
  then show ?case
    by(simp add: invar_enqL)
next
  case 11
  then show ?case
    by (simp add: invar_enqL invar_swap)
next
  case 12
  then show ?case
    using invar_deqL by simp
next
  case (13 q)
  then have "invar (swap (deqL (swap q)))"
    by (metis invar_deqL invar_swap listL_is_empty rev.simps(1) swap_list)

  then show ?case
    by (auto split: prod.splits)
qed

end


(*  Title:      ZF/Constructible/Satisfies_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness for the Satisfies Relation on Formulas\<close>

theory Satisfies_absolute imports Datatype_absolute Rec_Separation begin

subsection \<open>More Internalization\<close>

subsubsection\<open>The Formula @{term is_depth}, Internalized\<close>

(*    "is_depth(M,p,n) ==
       \<exists>sn[M]. \<exists>formula_n[M]. \<exists>formula_sn[M].
         2          1                0
        is_formula_N(M,n,formula_n) & p \<notin> formula_n &
        successor(M,n,sn) & is_formula_N(M,sn,formula_sn) & p \<in> formula_sn" *)
definition
  depth_fm :: "[i,i]=>i" where
  "depth_fm(p,n) ==
     Exists(Exists(Exists(
       And(formula_N_fm(n#+3,1),
         And(Neg(Member(p#+3,1)),
          And(succ_fm(n#+3,2),
           And(formula_N_fm(2,0), Member(p#+3,0))))))))"

lemma depth_fm_type [TC]:
 "[| x \<in> nat; y \<in> nat |] ==> depth_fm(x,y) \<in> formula"
by (simp add: depth_fm_def)

lemma sats_depth_fm [simp]:
   "[| x \<in> nat; y < length(env); env \<in> list(A)|]
    ==> sats(A, depth_fm(x,y), env) \<longleftrightarrow>
        is_depth(##A, nth(x,env), nth(y,env))"
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: depth_fm_def is_depth_def)
done

lemma depth_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j < length(env); env \<in> list(A)|]
       ==> is_depth(##A, x, y) \<longleftrightarrow> sats(A, depth_fm(i,j), env)"
by (simp add: sats_depth_fm)

theorem depth_reflection:
     "REFLECTS[\<lambda>x. is_depth(L, f(x), g(x)),
               \<lambda>i x. is_depth(##Lset(i), f(x), g(x))]"
apply (simp only: is_depth_def)
apply (intro FOL_reflections function_reflections formula_N_reflection)
done

subsubsection\<open>The Operator @{term is_formula_case}\<close>

text\<open>The arguments of @{term is_a} are always 2, 1, 0, and the formula
      will be enclosed by three quantifiers.\<close>

(* is_formula_case ::
    "[i=>o, [i,i,i]=>o, [i,i,i]=>o, [i,i,i]=>o, [i,i]=>o, i, i] => o"
  "is_formula_case(M, is_a, is_b, is_c, is_d, v, z) ==
      (\<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> is_Member(M,x,y,v) \<longrightarrow> is_a(x,y,z)) &
      (\<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> is_Equal(M,x,y,v) \<longrightarrow> is_b(x,y,z)) &
      (\<forall>x[M]. \<forall>y[M]. x\<in>formula \<longrightarrow> y\<in>formula \<longrightarrow>
                     is_Nand(M,x,y,v) \<longrightarrow> is_c(x,y,z)) &
      (\<forall>x[M]. x\<in>formula \<longrightarrow> is_Forall(M,x,v) \<longrightarrow> is_d(x,z))" *)

definition
  formula_case_fm :: "[i, i, i, i, i, i]=>i" where
  "formula_case_fm(is_a, is_b, is_c, is_d, v, z) ==
        And(Forall(Forall(Implies(finite_ordinal_fm(1),
                           Implies(finite_ordinal_fm(0),
                            Implies(Member_fm(1,0,v#+2),
                             Forall(Implies(Equal(0,z#+3), is_a))))))),
        And(Forall(Forall(Implies(finite_ordinal_fm(1),
                           Implies(finite_ordinal_fm(0),
                            Implies(Equal_fm(1,0,v#+2),
                             Forall(Implies(Equal(0,z#+3), is_b))))))),
        And(Forall(Forall(Implies(mem_formula_fm(1),
                           Implies(mem_formula_fm(0),
                            Implies(Nand_fm(1,0,v#+2),
                             Forall(Implies(Equal(0,z#+3), is_c))))))),
        Forall(Implies(mem_formula_fm(0),
                       Implies(Forall_fm(0,succ(v)),
                             Forall(Implies(Equal(0,z#+2), is_d))))))))"

lemma is_formula_case_type [TC]:
     "[| is_a \<in> formula;  is_b \<in> formula;  is_c \<in> formula;  is_d \<in> formula;
         x \<in> nat; y \<in> nat |]
      ==> formula_case_fm(is_a, is_b, is_c, is_d, x, y) \<in> formula"
by (simp add: formula_case_fm_def)

lemma sats_formula_case_fm:
  assumes is_a_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> ISA(a2, a1, a0) \<longleftrightarrow> sats(A, is_a, Cons(a0,Cons(a1,Cons(a2,env))))"
  and is_b_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> ISB(a2, a1, a0) \<longleftrightarrow> sats(A, is_b, Cons(a0,Cons(a1,Cons(a2,env))))"
  and is_c_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> ISC(a2, a1, a0) \<longleftrightarrow> sats(A, is_c, Cons(a0,Cons(a1,Cons(a2,env))))"
  and is_d_iff_sats:
      "!!a0 a1.
        [|a0\<in>A; a1\<in>A|]
        ==> ISD(a1, a0) \<longleftrightarrow> sats(A, is_d, Cons(a0,Cons(a1,env)))"
  shows
      "[|x \<in> nat; y < length(env); env \<in> list(A)|]
       ==> sats(A, formula_case_fm(is_a,is_b,is_c,is_d,x,y), env) \<longleftrightarrow>
           is_formula_case(##A, ISA, ISB, ISC, ISD, nth(x,env), nth(y,env))"
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: formula_case_fm_def is_formula_case_def
                 is_a_iff_sats [THEN iff_sym] is_b_iff_sats [THEN iff_sym]
                 is_c_iff_sats [THEN iff_sym] is_d_iff_sats [THEN iff_sym])
done

lemma formula_case_iff_sats:
  assumes is_a_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> ISA(a2, a1, a0) \<longleftrightarrow> sats(A, is_a, Cons(a0,Cons(a1,Cons(a2,env))))"
  and is_b_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> ISB(a2, a1, a0) \<longleftrightarrow> sats(A, is_b, Cons(a0,Cons(a1,Cons(a2,env))))"
  and is_c_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> ISC(a2, a1, a0) \<longleftrightarrow> sats(A, is_c, Cons(a0,Cons(a1,Cons(a2,env))))"
  and is_d_iff_sats:
      "!!a0 a1.
        [|a0\<in>A; a1\<in>A|]
        ==> ISD(a1, a0) \<longleftrightarrow> sats(A, is_d, Cons(a0,Cons(a1,env)))"
  shows
      "[|nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j < length(env); env \<in> list(A)|]
       ==> is_formula_case(##A, ISA, ISB, ISC, ISD, x, y) \<longleftrightarrow>
           sats(A, formula_case_fm(is_a,is_b,is_c,is_d,i,j), env)"
by (simp add: sats_formula_case_fm [OF is_a_iff_sats is_b_iff_sats
                                       is_c_iff_sats is_d_iff_sats])

text\<open>The second argument of @{term is_a} gives it direct access to @{term x},
  which is essential for handling free variable references.  Treatment is
  based on that of \<open>is_nat_case_reflection\<close>.\<close>
theorem is_formula_case_reflection:
  assumes is_a_reflection:
    "!!h f g g'. REFLECTS[\<lambda>x. is_a(L, h(x), f(x), g(x), g'(x)),
                     \<lambda>i x. is_a(##Lset(i), h(x), f(x), g(x), g'(x))]"
  and is_b_reflection:
    "!!h f g g'. REFLECTS[\<lambda>x. is_b(L, h(x), f(x), g(x), g'(x)),
                     \<lambda>i x. is_b(##Lset(i), h(x), f(x), g(x), g'(x))]"
  and is_c_reflection:
    "!!h f g g'. REFLECTS[\<lambda>x. is_c(L, h(x), f(x), g(x), g'(x)),
                     \<lambda>i x. is_c(##Lset(i), h(x), f(x), g(x), g'(x))]"
  and is_d_reflection:
    "!!h f g g'. REFLECTS[\<lambda>x. is_d(L, h(x), f(x), g(x)),
                     \<lambda>i x. is_d(##Lset(i), h(x), f(x), g(x))]"
  shows "REFLECTS[\<lambda>x. is_formula_case(L, is_a(L,x), is_b(L,x), is_c(L,x), is_d(L,x), g(x), h(x)),
               \<lambda>i x. is_formula_case(##Lset(i), is_a(##Lset(i), x), is_b(##Lset(i), x), is_c(##Lset(i), x), is_d(##Lset(i), x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_formula_case_def)
apply (intro FOL_reflections function_reflections finite_ordinal_reflection
         mem_formula_reflection
         Member_reflection Equal_reflection Nand_reflection Forall_reflection
         is_a_reflection is_b_reflection is_c_reflection is_d_reflection)
done

subsection \<open>Absoluteness for the Function @{term satisfies}\<close>

definition
  is_depth_apply :: "[i=>o,i,i,i] => o" where
   \<comment>\<open>Merely a useful abbreviation for the sequel.\<close>
  "is_depth_apply(M,h,p,z) ==
    \<exists>dp[M]. \<exists>sdp[M]. \<exists>hsdp[M].
        finite_ordinal(M,dp) & is_depth(M,p,dp) & successor(M,dp,sdp) &
        fun_apply(M,h,sdp,hsdp) & fun_apply(M,hsdp,p,z)"

lemma (in M_datatypes) is_depth_apply_abs [simp]:
     "[|M(h); p \<in> formula; M(z)|]
      ==> is_depth_apply(M,h,p,z) \<longleftrightarrow> z = h ` succ(depth(p)) ` p"
by (simp add: is_depth_apply_def formula_into_M depth_type eq_commute)

text\<open>There is at present some redundancy between the relativizations in
 e.g. \<open>satisfies_is_a\<close> and those in e.g. \<open>Member_replacement\<close>.\<close>

text\<open>These constants let us instantiate the parameters @{term a}, @{term b},
      @{term c}, @{term d}, etc., of the locale \<open>Formula_Rec\<close>.\<close>
definition
  satisfies_a :: "[i,i,i]=>i" where
   "satisfies_a(A) ==
    \<lambda>x y. \<lambda>env \<in> list(A). bool_of_o (nth(x,env) \<in> nth(y,env))"

definition
  satisfies_is_a :: "[i=>o,i,i,i,i]=>o" where
   "satisfies_is_a(M,A) ==
    \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA,
                \<lambda>env z. is_bool_of_o(M,
                      \<exists>nx[M]. \<exists>ny[M].
                       is_nth(M,x,env,nx) & is_nth(M,y,env,ny) & nx \<in> ny, z),
                zz)"

definition
  satisfies_b :: "[i,i,i]=>i" where
   "satisfies_b(A) ==
    \<lambda>x y. \<lambda>env \<in> list(A). bool_of_o (nth(x,env) = nth(y,env))"

definition
  satisfies_is_b :: "[i=>o,i,i,i,i]=>o" where
   \<comment>\<open>We simplify the formula to have just @{term nx} rather than
       introducing @{term ny} with  @{term "nx=ny"}\<close>
  "satisfies_is_b(M,A) ==
    \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA,
                \<lambda>env z. is_bool_of_o(M,
                      \<exists>nx[M]. is_nth(M,x,env,nx) & is_nth(M,y,env,nx), z),
                zz)"

definition
  satisfies_c :: "[i,i,i,i,i]=>i" where
   "satisfies_c(A) == \<lambda>p q rp rq. \<lambda>env \<in> list(A). not(rp ` env and rq ` env)"

definition
  satisfies_is_c :: "[i=>o,i,i,i,i,i]=>o" where
   "satisfies_is_c(M,A,h) ==
    \<lambda>p q zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA, \<lambda>env z. \<exists>hp[M]. \<exists>hq[M].
                 (\<exists>rp[M]. is_depth_apply(M,h,p,rp) & fun_apply(M,rp,env,hp)) &
                 (\<exists>rq[M]. is_depth_apply(M,h,q,rq) & fun_apply(M,rq,env,hq)) &
                 (\<exists>pq[M]. is_and(M,hp,hq,pq) & is_not(M,pq,z)),
                zz)"

definition
  satisfies_d :: "[i,i,i]=>i" where
   "satisfies_d(A)
    == \<lambda>p rp. \<lambda>env \<in> list(A). bool_of_o (\<forall>x\<in>A. rp ` (Cons(x,env)) = 1)"

definition
  satisfies_is_d :: "[i=>o,i,i,i,i]=>o" where
   "satisfies_is_d(M,A,h) ==
    \<lambda>p zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA,
                \<lambda>env z. \<exists>rp[M]. is_depth_apply(M,h,p,rp) &
                    is_bool_of_o(M,
                           \<forall>x[M]. \<forall>xenv[M]. \<forall>hp[M].
                              x\<in>A \<longrightarrow> is_Cons(M,x,env,xenv) \<longrightarrow>
                              fun_apply(M,rp,xenv,hp) \<longrightarrow> number1(M,hp),
                  z),
               zz)"

definition
  satisfies_MH :: "[i=>o,i,i,i,i]=>o" where
    \<comment>\<open>The variable @{term u} is unused, but gives @{term satisfies_MH}
        the correct arity.\<close>
  "satisfies_MH ==
    \<lambda>M A u f z.
         \<forall>fml[M]. is_formula(M,fml) \<longrightarrow>
             is_lambda (M, fml,
               is_formula_case (M, satisfies_is_a(M,A),
                                satisfies_is_b(M,A),
                                satisfies_is_c(M,A,f), satisfies_is_d(M,A,f)),
               z)"

definition
  is_satisfies :: "[i=>o,i,i,i]=>o" where
  "is_satisfies(M,A) == is_formula_rec (M, satisfies_MH(M,A))"

text\<open>This lemma relates the fragments defined above to the original primitive
      recursion in @{term satisfies}.
      Induction is not required: the definitions are directly equal!\<close>
lemma satisfies_eq:
  "satisfies(A,p) =
   formula_rec (satisfies_a(A), satisfies_b(A),
                satisfies_c(A), satisfies_d(A), p)"
by (simp add: satisfies_formula_def satisfies_a_def satisfies_b_def
              satisfies_c_def satisfies_d_def)

text\<open>Further constraints on the class @{term M} in order to prove
      absoluteness for the constants defined above.  The ultimate goal
      is the absoluteness of the function @{term satisfies}.\<close>
locale M_satisfies = M_eclose +
 assumes
   Member_replacement:
    "[|M(A); x \<in> nat; y \<in> nat|]
     ==> strong_replacement
         (M, \<lambda>env z. \<exists>bo[M]. \<exists>nx[M]. \<exists>ny[M].
              env \<in> list(A) & is_nth(M,x,env,nx) & is_nth(M,y,env,ny) &
              is_bool_of_o(M, nx \<in> ny, bo) &
              pair(M, env, bo, z))"
 and
   Equal_replacement:
    "[|M(A); x \<in> nat; y \<in> nat|]
     ==> strong_replacement
         (M, \<lambda>env z. \<exists>bo[M]. \<exists>nx[M]. \<exists>ny[M].
              env \<in> list(A) & is_nth(M,x,env,nx) & is_nth(M,y,env,ny) &
              is_bool_of_o(M, nx = ny, bo) &
              pair(M, env, bo, z))"
 and
   Nand_replacement:
    "[|M(A); M(rp); M(rq)|]
     ==> strong_replacement
         (M, \<lambda>env z. \<exists>rpe[M]. \<exists>rqe[M]. \<exists>andpq[M]. \<exists>notpq[M].
               fun_apply(M,rp,env,rpe) & fun_apply(M,rq,env,rqe) &
               is_and(M,rpe,rqe,andpq) & is_not(M,andpq,notpq) &
               env \<in> list(A) & pair(M, env, notpq, z))"
 and
  Forall_replacement:
   "[|M(A); M(rp)|]
    ==> strong_replacement
        (M, \<lambda>env z. \<exists>bo[M].
              env \<in> list(A) &
              is_bool_of_o (M,
                            \<forall>a[M]. \<forall>co[M]. \<forall>rpco[M].
                               a\<in>A \<longrightarrow> is_Cons(M,a,env,co) \<longrightarrow>
                               fun_apply(M,rp,co,rpco) \<longrightarrow> number1(M, rpco),
                            bo) &
              pair(M,env,bo,z))"
 and
  formula_rec_replacement:
      \<comment>\<open>For the @{term transrec}\<close>
   "[|n \<in> nat; M(A)|] ==> transrec_replacement(M, satisfies_MH(M,A), n)"
 and
  formula_rec_lambda_replacement:
      \<comment>\<open>For the \<open>\<lambda>-abstraction\<close> in the @{term transrec} body\<close>
   "[|M(g); M(A)|] ==>
    strong_replacement (M,
       \<lambda>x y. mem_formula(M,x) &
             (\<exists>c[M]. is_formula_case(M, satisfies_is_a(M,A),
                                  satisfies_is_b(M,A),
                                  satisfies_is_c(M,A,g),
                                  satisfies_is_d(M,A,g), x, c) &
             pair(M, x, c, y)))"

lemma (in M_satisfies) Member_replacement':
    "[|M(A); x \<in> nat; y \<in> nat|]
     ==> strong_replacement
         (M, \<lambda>env z. env \<in> list(A) &
                     z = \<langle>env, bool_of_o(nth(x, env) \<in> nth(y, env))\<rangle>)"
by (insert Member_replacement, simp)

lemma (in M_satisfies) Equal_replacement':
    "[|M(A); x \<in> nat; y \<in> nat|]
     ==> strong_replacement
         (M, \<lambda>env z. env \<in> list(A) &
                     z = \<langle>env, bool_of_o(nth(x, env) = nth(y, env))\<rangle>)"
by (insert Equal_replacement, simp)

lemma (in M_satisfies) Nand_replacement':
    "[|M(A); M(rp); M(rq)|]
     ==> strong_replacement
         (M, \<lambda>env z. env \<in> list(A) & z = \<langle>env, not(rp`env and rq`env)\<rangle>)"
by (insert Nand_replacement, simp)

lemma (in M_satisfies) Forall_replacement':
   "[|M(A); M(rp)|]
    ==> strong_replacement
        (M, \<lambda>env z.
               env \<in> list(A) &
               z = \<langle>env, bool_of_o (\<forall>a\<in>A. rp ` Cons(a,env) = 1)\<rangle>)"
by (insert Forall_replacement, simp)

lemma (in M_satisfies) a_closed:
     "[|M(A); x\<in>nat; y\<in>nat|] ==> M(satisfies_a(A,x,y))"
apply (simp add: satisfies_a_def)
apply (blast intro: lam_closed2 Member_replacement')
done

lemma (in M_satisfies) a_rel:
     "M(A) ==> Relation2(M, nat, nat, satisfies_is_a(M,A), satisfies_a(A))"
apply (simp add: Relation2_def satisfies_is_a_def satisfies_a_def)
apply (auto del: iffI intro!: lambda_abs2 simp add: Relation1_def)
done

lemma (in M_satisfies) b_closed:
     "[|M(A); x\<in>nat; y\<in>nat|] ==> M(satisfies_b(A,x,y))"
apply (simp add: satisfies_b_def)
apply (blast intro: lam_closed2 Equal_replacement')
done

lemma (in M_satisfies) b_rel:
     "M(A) ==> Relation2(M, nat, nat, satisfies_is_b(M,A), satisfies_b(A))"
apply (simp add: Relation2_def satisfies_is_b_def satisfies_b_def)
apply (auto del: iffI intro!: lambda_abs2 simp add: Relation1_def)
done

lemma (in M_satisfies) c_closed:
     "[|M(A); x \<in> formula; y \<in> formula; M(rx); M(ry)|]
      ==> M(satisfies_c(A,x,y,rx,ry))"
apply (simp add: satisfies_c_def)
apply (rule lam_closed2)
apply (rule Nand_replacement')
apply (simp_all add: formula_into_M list_into_M [of _ A])
done

lemma (in M_satisfies) c_rel:
 "[|M(A); M(f)|] ==>
  Relation2 (M, formula, formula,
               satisfies_is_c(M,A,f),
               \<lambda>u v. satisfies_c(A, u, v, f ` succ(depth(u)) ` u,
                                          f ` succ(depth(v)) ` v))"
apply (simp add: Relation2_def satisfies_is_c_def satisfies_c_def)
apply (auto del: iffI intro!: lambda_abs2
            simp add: Relation1_def formula_into_M)
done

lemma (in M_satisfies) d_closed:
     "[|M(A); x \<in> formula; M(rx)|] ==> M(satisfies_d(A,x,rx))"
apply (simp add: satisfies_d_def)
apply (rule lam_closed2)
apply (rule Forall_replacement')
apply (simp_all add: formula_into_M list_into_M [of _ A])
done

lemma (in M_satisfies) d_rel:
 "[|M(A); M(f)|] ==>
  Relation1(M, formula, satisfies_is_d(M,A,f),
     \<lambda>u. satisfies_d(A, u, f ` succ(depth(u)) ` u))"
apply (simp del: rall_abs
            add: Relation1_def satisfies_is_d_def satisfies_d_def)
apply (auto del: iffI intro!: lambda_abs2 simp add: Relation1_def)
done

lemma (in M_satisfies) fr_replace:
      "[|n \<in> nat; M(A)|] ==> transrec_replacement(M,satisfies_MH(M,A),n)"
by (blast intro: formula_rec_replacement)

lemma (in M_satisfies) formula_case_satisfies_closed:
 "[|M(g); M(A); x \<in> formula|] ==>
  M(formula_case (satisfies_a(A), satisfies_b(A),
       \<lambda>u v. satisfies_c(A, u, v,
                         g ` succ(depth(u)) ` u, g ` succ(depth(v)) ` v),
       \<lambda>u. satisfies_d (A, u, g ` succ(depth(u)) ` u),
       x))"
by (blast intro: formula_case_closed a_closed b_closed c_closed d_closed)

lemma (in M_satisfies) fr_lam_replace:
   "[|M(g); M(A)|] ==>
    strong_replacement (M, \<lambda>x y. x \<in> formula &
            y = \<langle>x,
                 formula_rec_case(satisfies_a(A),
                                  satisfies_b(A),
                                  satisfies_c(A),
                                  satisfies_d(A), g, x)\<rangle>)"
apply (insert formula_rec_lambda_replacement)
apply (simp add: formula_rec_case_def formula_case_satisfies_closed
                 formula_case_abs [OF a_rel b_rel c_rel d_rel])
done

text\<open>Instantiate locale \<open>Formula_Rec\<close> for the
      Function @{term satisfies}\<close>

lemma (in M_satisfies) Formula_Rec_axioms_M:
   "M(A) ==>
    Formula_Rec_axioms(M, satisfies_a(A), satisfies_is_a(M,A),
                          satisfies_b(A), satisfies_is_b(M,A),
                          satisfies_c(A), satisfies_is_c(M,A),
                          satisfies_d(A), satisfies_is_d(M,A))"
apply (rule Formula_Rec_axioms.intro)
apply (assumption |
       rule a_closed a_rel b_closed b_rel c_closed c_rel d_closed d_rel
       fr_replace [unfolded satisfies_MH_def]
       fr_lam_replace) +
done

theorem (in M_satisfies) Formula_Rec_M:
    "M(A) ==>
     PROP Formula_Rec(M, satisfies_a(A), satisfies_is_a(M,A),
                         satisfies_b(A), satisfies_is_b(M,A),
                         satisfies_c(A), satisfies_is_c(M,A),
                         satisfies_d(A), satisfies_is_d(M,A))"
  apply (rule Formula_Rec.intro)
   apply (rule M_satisfies.axioms, rule M_satisfies_axioms)
  apply (erule Formula_Rec_axioms_M)
  done

lemmas (in M_satisfies)
    satisfies_closed' = Formula_Rec.formula_rec_closed [OF Formula_Rec_M]
and satisfies_abs'    = Formula_Rec.formula_rec_abs [OF Formula_Rec_M]

lemma (in M_satisfies) satisfies_closed:
  "[|M(A); p \<in> formula|] ==> M(satisfies(A,p))"
by (simp add: Formula_Rec.formula_rec_closed [OF Formula_Rec_M]
              satisfies_eq)

lemma (in M_satisfies) satisfies_abs:
  "[|M(A); M(z); p \<in> formula|]
   ==> is_satisfies(M,A,p,z) \<longleftrightarrow> z = satisfies(A,p)"
by (simp only: Formula_Rec.formula_rec_abs [OF Formula_Rec_M]
               satisfies_eq is_satisfies_def satisfies_MH_def)

subsection\<open>Internalizations Needed to Instantiate \<open>M_satisfies\<close>\<close>

subsubsection\<open>The Operator @{term is_depth_apply}, Internalized\<close>

(* is_depth_apply(M,h,p,z) ==
    \<exists>dp[M]. \<exists>sdp[M]. \<exists>hsdp[M].
      2        1         0
        finite_ordinal(M,dp) & is_depth(M,p,dp) & successor(M,dp,sdp) &
        fun_apply(M,h,sdp,hsdp) & fun_apply(M,hsdp,p,z) *)
definition
  depth_apply_fm :: "[i,i,i]=>i" where
    "depth_apply_fm(h,p,z) ==
       Exists(Exists(Exists(
        And(finite_ordinal_fm(2),
         And(depth_fm(p#+3,2),
          And(succ_fm(2,1),
           And(fun_apply_fm(h#+3,1,0), fun_apply_fm(0,p#+3,z#+3))))))))"

lemma depth_apply_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> depth_apply_fm(x,y,z) \<in> formula"
by (simp add: depth_apply_fm_def)

lemma sats_depth_apply_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, depth_apply_fm(x,y,z), env) \<longleftrightarrow>
        is_depth_apply(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: depth_apply_fm_def is_depth_apply_def)

lemma depth_apply_iff_sats:
    "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
        i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
     ==> is_depth_apply(##A, x, y, z) \<longleftrightarrow> sats(A, depth_apply_fm(i,j,k), env)"
by simp

lemma depth_apply_reflection:
     "REFLECTS[\<lambda>x. is_depth_apply(L,f(x),g(x),h(x)),
               \<lambda>i x. is_depth_apply(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_depth_apply_def)
apply (intro FOL_reflections function_reflections depth_reflection
             finite_ordinal_reflection)
done

subsubsection\<open>The Operator @{term satisfies_is_a}, Internalized\<close>

(* satisfies_is_a(M,A) ==
    \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA,
                \<lambda>env z. is_bool_of_o(M,
                      \<exists>nx[M]. \<exists>ny[M].
                       is_nth(M,x,env,nx) & is_nth(M,y,env,ny) & nx \<in> ny, z),
                zz)  *)

definition
  satisfies_is_a_fm :: "[i,i,i,i]=>i" where
  "satisfies_is_a_fm(A,x,y,z) ==
   Forall(
     Implies(is_list_fm(succ(A),0),
       lambda_fm(
         bool_of_o_fm(Exists(
                       Exists(And(nth_fm(x#+6,3,1),
                               And(nth_fm(y#+6,3,0),
                                   Member(1,0))))), 0),
         0, succ(z))))"

lemma satisfies_is_a_type [TC]:
     "[| A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> satisfies_is_a_fm(A,x,y,z) \<in> formula"
by (simp add: satisfies_is_a_fm_def)

lemma sats_satisfies_is_a_fm [simp]:
   "[| u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_is_a_fm(u,x,y,z), env) \<longleftrightarrow>
        satisfies_is_a(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=x in lt_length_in_nat, assumption)
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: satisfies_is_a_fm_def satisfies_is_a_def sats_lambda_fm
                 sats_bool_of_o_fm)
done

lemma satisfies_is_a_iff_sats:
  "[| nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
      u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)|]
   ==> satisfies_is_a(##A,nu,nx,ny,nz) \<longleftrightarrow>
       sats(A, satisfies_is_a_fm(u,x,y,z), env)"
by simp

theorem satisfies_is_a_reflection:
     "REFLECTS[\<lambda>x. satisfies_is_a(L,f(x),g(x),h(x),g'(x)),
               \<lambda>i x. satisfies_is_a(##Lset(i),f(x),g(x),h(x),g'(x))]"
apply (unfold satisfies_is_a_def)
apply (intro FOL_reflections is_lambda_reflection bool_of_o_reflection
             nth_reflection is_list_reflection)
done

subsubsection\<open>The Operator @{term satisfies_is_b}, Internalized\<close>

(* satisfies_is_b(M,A) ==
    \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA,
                \<lambda>env z. is_bool_of_o(M,
                      \<exists>nx[M]. is_nth(M,x,env,nx) & is_nth(M,y,env,nx), z),
                zz) *)

definition
  satisfies_is_b_fm :: "[i,i,i,i]=>i" where
 "satisfies_is_b_fm(A,x,y,z) ==
   Forall(
     Implies(is_list_fm(succ(A),0),
       lambda_fm(
         bool_of_o_fm(Exists(And(nth_fm(x#+5,2,0), nth_fm(y#+5,2,0))), 0),
         0, succ(z))))"

lemma satisfies_is_b_type [TC]:
     "[| A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> satisfies_is_b_fm(A,x,y,z) \<in> formula"
by (simp add: satisfies_is_b_fm_def)

lemma sats_satisfies_is_b_fm [simp]:
   "[| u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_is_b_fm(u,x,y,z), env) \<longleftrightarrow>
        satisfies_is_b(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=x in lt_length_in_nat, assumption)
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: satisfies_is_b_fm_def satisfies_is_b_def sats_lambda_fm
                 sats_bool_of_o_fm)
done

lemma satisfies_is_b_iff_sats:
  "[| nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
      u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)|]
   ==> satisfies_is_b(##A,nu,nx,ny,nz) \<longleftrightarrow>
       sats(A, satisfies_is_b_fm(u,x,y,z), env)"
by simp

theorem satisfies_is_b_reflection:
     "REFLECTS[\<lambda>x. satisfies_is_b(L,f(x),g(x),h(x),g'(x)),
               \<lambda>i x. satisfies_is_b(##Lset(i),f(x),g(x),h(x),g'(x))]"
apply (unfold satisfies_is_b_def)
apply (intro FOL_reflections is_lambda_reflection bool_of_o_reflection
             nth_reflection is_list_reflection)
done

subsubsection\<open>The Operator @{term satisfies_is_c}, Internalized\<close>

(* satisfies_is_c(M,A,h) ==
    \<lambda>p q zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA, \<lambda>env z. \<exists>hp[M]. \<exists>hq[M].
                 (\<exists>rp[M]. is_depth_apply(M,h,p,rp) & fun_apply(M,rp,env,hp)) &
                 (\<exists>rq[M]. is_depth_apply(M,h,q,rq) & fun_apply(M,rq,env,hq)) &
                 (\<exists>pq[M]. is_and(M,hp,hq,pq) & is_not(M,pq,z)),
                zz) *)

definition
  satisfies_is_c_fm :: "[i,i,i,i,i]=>i" where
 "satisfies_is_c_fm(A,h,p,q,zz) ==
   Forall(
     Implies(is_list_fm(succ(A),0),
       lambda_fm(
         Exists(Exists(
          And(Exists(And(depth_apply_fm(h#+7,p#+7,0), fun_apply_fm(0,4,2))),
          And(Exists(And(depth_apply_fm(h#+7,q#+7,0), fun_apply_fm(0,4,1))),
              Exists(And(and_fm(2,1,0), not_fm(0,3))))))),
         0, succ(zz))))"

lemma satisfies_is_c_type [TC]:
     "[| A \<in> nat; h \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> satisfies_is_c_fm(A,h,x,y,z) \<in> formula"
by (simp add: satisfies_is_c_fm_def)

lemma sats_satisfies_is_c_fm [simp]:
   "[| u \<in> nat; v \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_is_c_fm(u,v,x,y,z), env) \<longleftrightarrow>
        satisfies_is_c(##A, nth(u,env), nth(v,env), nth(x,env),
                            nth(y,env), nth(z,env))"
by (simp add: satisfies_is_c_fm_def satisfies_is_c_def sats_lambda_fm)

lemma satisfies_is_c_iff_sats:
  "[| nth(u,env) = nu; nth(v,env) = nv; nth(x,env) = nx; nth(y,env) = ny;
      nth(z,env) = nz;
      u \<in> nat; v \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
   ==> satisfies_is_c(##A,nu,nv,nx,ny,nz) \<longleftrightarrow>
       sats(A, satisfies_is_c_fm(u,v,x,y,z), env)"
by simp

theorem satisfies_is_c_reflection:
     "REFLECTS[\<lambda>x. satisfies_is_c(L,f(x),g(x),h(x),g'(x),h'(x)),
               \<lambda>i x. satisfies_is_c(##Lset(i),f(x),g(x),h(x),g'(x),h'(x))]"
apply (unfold satisfies_is_c_def)
apply (intro FOL_reflections function_reflections is_lambda_reflection
             extra_reflections nth_reflection depth_apply_reflection
             is_list_reflection)
done

subsubsection\<open>The Operator @{term satisfies_is_d}, Internalized\<close>

(* satisfies_is_d(M,A,h) ==
    \<lambda>p zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
             is_lambda(M, lA,
                \<lambda>env z. \<exists>rp[M]. is_depth_apply(M,h,p,rp) &
                    is_bool_of_o(M,
                           \<forall>x[M]. \<forall>xenv[M]. \<forall>hp[M].
                              x\<in>A \<longrightarrow> is_Cons(M,x,env,xenv) \<longrightarrow>
                              fun_apply(M,rp,xenv,hp) \<longrightarrow> number1(M,hp),
                  z),
               zz) *)

definition
  satisfies_is_d_fm :: "[i,i,i,i]=>i" where
 "satisfies_is_d_fm(A,h,p,zz) ==
   Forall(
     Implies(is_list_fm(succ(A),0),
       lambda_fm(
         Exists(
           And(depth_apply_fm(h#+5,p#+5,0),
               bool_of_o_fm(
                Forall(Forall(Forall(
                 Implies(Member(2,A#+8),
                  Implies(Cons_fm(2,5,1),
                   Implies(fun_apply_fm(3,1,0), number1_fm(0))))))), 1))),
         0, succ(zz))))"

lemma satisfies_is_d_type [TC]:
     "[| A \<in> nat; h \<in> nat; x \<in> nat; z \<in> nat |]
      ==> satisfies_is_d_fm(A,h,x,z) \<in> formula"
by (simp add: satisfies_is_d_fm_def)

lemma sats_satisfies_is_d_fm [simp]:
   "[| u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_is_d_fm(u,x,y,z), env) \<longleftrightarrow>
        satisfies_is_d(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
by (simp add: satisfies_is_d_fm_def satisfies_is_d_def sats_lambda_fm
              sats_bool_of_o_fm)

lemma satisfies_is_d_iff_sats:
  "[| nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
      u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
   ==> satisfies_is_d(##A,nu,nx,ny,nz) \<longleftrightarrow>
       sats(A, satisfies_is_d_fm(u,x,y,z), env)"
by simp

theorem satisfies_is_d_reflection:
     "REFLECTS[\<lambda>x. satisfies_is_d(L,f(x),g(x),h(x),g'(x)),
               \<lambda>i x. satisfies_is_d(##Lset(i),f(x),g(x),h(x),g'(x))]"
apply (unfold satisfies_is_d_def)
apply (intro FOL_reflections function_reflections is_lambda_reflection
             extra_reflections nth_reflection depth_apply_reflection
             is_list_reflection)
done

subsubsection\<open>The Operator @{term satisfies_MH}, Internalized\<close>

(* satisfies_MH ==
    \<lambda>M A u f zz.
         \<forall>fml[M]. is_formula(M,fml) \<longrightarrow>
             is_lambda (M, fml,
               is_formula_case (M, satisfies_is_a(M,A),
                                satisfies_is_b(M,A),
                                satisfies_is_c(M,A,f), satisfies_is_d(M,A,f)),
               zz) *)

definition
  satisfies_MH_fm :: "[i,i,i,i]=>i" where
 "satisfies_MH_fm(A,u,f,zz) ==
   Forall(
     Implies(is_formula_fm(0),
       lambda_fm(
         formula_case_fm(satisfies_is_a_fm(A#+7,2,1,0),
                         satisfies_is_b_fm(A#+7,2,1,0),
                         satisfies_is_c_fm(A#+7,f#+7,2,1,0),
                         satisfies_is_d_fm(A#+6,f#+6,1,0),
                         1, 0),
         0, succ(zz))))"

lemma satisfies_MH_type [TC]:
     "[| A \<in> nat; u \<in> nat; x \<in> nat; z \<in> nat |]
      ==> satisfies_MH_fm(A,u,x,z) \<in> formula"
by (simp add: satisfies_MH_fm_def)

lemma sats_satisfies_MH_fm [simp]:
   "[| u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_MH_fm(u,x,y,z), env) \<longleftrightarrow>
        satisfies_MH(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
by (simp add: satisfies_MH_fm_def satisfies_MH_def sats_lambda_fm
              sats_formula_case_fm)

lemma satisfies_MH_iff_sats:
  "[| nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
      u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
   ==> satisfies_MH(##A,nu,nx,ny,nz) \<longleftrightarrow>
       sats(A, satisfies_MH_fm(u,x,y,z), env)"
by simp

lemmas satisfies_reflections =
       is_lambda_reflection is_formula_reflection
       is_formula_case_reflection
       satisfies_is_a_reflection satisfies_is_b_reflection
       satisfies_is_c_reflection satisfies_is_d_reflection

theorem satisfies_MH_reflection:
     "REFLECTS[\<lambda>x. satisfies_MH(L,f(x),g(x),h(x),g'(x)),
               \<lambda>i x. satisfies_MH(##Lset(i),f(x),g(x),h(x),g'(x))]"
apply (unfold satisfies_MH_def)
apply (intro FOL_reflections satisfies_reflections)
done

subsection\<open>Lemmas for Instantiating the Locale \<open>M_satisfies\<close>\<close>

subsubsection\<open>The @{term "Member"} Case\<close>

lemma Member_Reflects:
 "REFLECTS[\<lambda>u. \<exists>v[L]. v \<in> B \<and> (\<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L].
          v \<in> lstA \<and> is_nth(L,x,v,nx) \<and> is_nth(L,y,v,ny) \<and>
          is_bool_of_o(L, nx \<in> ny, bo) \<and> pair(L,v,bo,u)),
   \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B \<and> (\<exists>bo \<in> Lset(i). \<exists>nx \<in> Lset(i). \<exists>ny \<in> Lset(i).
             v \<in> lstA \<and> is_nth(##Lset(i), x, v, nx) \<and>
             is_nth(##Lset(i), y, v, ny) \<and>
          is_bool_of_o(##Lset(i), nx \<in> ny, bo) \<and> pair(##Lset(i), v, bo, u))]"
by (intro FOL_reflections function_reflections nth_reflection
          bool_of_o_reflection)

lemma Member_replacement:
    "[|L(A); x \<in> nat; y \<in> nat|]
     ==> strong_replacement
         (L, \<lambda>env z. \<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L].
              env \<in> list(A) & is_nth(L,x,env,nx) & is_nth(L,y,env,ny) &
              is_bool_of_o(L, nx \<in> ny, bo) &
              pair(L, env, bo, z))"
apply (rule strong_replacementI)
apply (rule_tac u="{list(A),B,x,y}"
         in gen_separation_multi [OF Member_Reflects],
       auto simp add: nat_into_M list_closed)
apply (rule_tac env="[list(A),B,x,y]" in DPow_LsetI)
apply (rule sep_rules nth_iff_sats is_bool_of_o_iff_sats | simp)+
done

subsubsection\<open>The @{term "Equal"} Case\<close>

lemma Equal_Reflects:
 "REFLECTS[\<lambda>u. \<exists>v[L]. v \<in> B \<and> (\<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L].
          v \<in> lstA \<and> is_nth(L, x, v, nx) \<and> is_nth(L, y, v, ny) \<and>
          is_bool_of_o(L, nx = ny, bo) \<and> pair(L, v, bo, u)),
   \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B \<and> (\<exists>bo \<in> Lset(i). \<exists>nx \<in> Lset(i). \<exists>ny \<in> Lset(i).
             v \<in> lstA \<and> is_nth(##Lset(i), x, v, nx) \<and>
             is_nth(##Lset(i), y, v, ny) \<and>
          is_bool_of_o(##Lset(i), nx = ny, bo) \<and> pair(##Lset(i), v, bo, u))]"
by (intro FOL_reflections function_reflections nth_reflection
          bool_of_o_reflection)

lemma Equal_replacement:
    "[|L(A); x \<in> nat; y \<in> nat|]
     ==> strong_replacement
         (L, \<lambda>env z. \<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L].
              env \<in> list(A) & is_nth(L,x,env,nx) & is_nth(L,y,env,ny) &
              is_bool_of_o(L, nx = ny, bo) &
              pair(L, env, bo, z))"
apply (rule strong_replacementI)
apply (rule_tac u="{list(A),B,x,y}"
         in gen_separation_multi [OF Equal_Reflects],
       auto simp add: nat_into_M list_closed)
apply (rule_tac env="[list(A),B,x,y]" in DPow_LsetI)
apply (rule sep_rules nth_iff_sats is_bool_of_o_iff_sats | simp)+
done

subsubsection\<open>The @{term "Nand"} Case\<close>

lemma Nand_Reflects:
    "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and>
               (\<exists>rpe[L]. \<exists>rqe[L]. \<exists>andpq[L]. \<exists>notpq[L].
                 fun_apply(L, rp, u, rpe) \<and> fun_apply(L, rq, u, rqe) \<and>
                 is_and(L, rpe, rqe, andpq) \<and> is_not(L, andpq, notpq) \<and>
                 u \<in> list(A) \<and> pair(L, u, notpq, x)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and>
     (\<exists>rpe \<in> Lset(i). \<exists>rqe \<in> Lset(i). \<exists>andpq \<in> Lset(i). \<exists>notpq \<in> Lset(i).
       fun_apply(##Lset(i), rp, u, rpe) \<and> fun_apply(##Lset(i), rq, u, rqe) \<and>
       is_and(##Lset(i), rpe, rqe, andpq) \<and> is_not(##Lset(i), andpq, notpq) \<and>
       u \<in> list(A) \<and> pair(##Lset(i), u, notpq, x))]"
apply (unfold is_and_def is_not_def)
apply (intro FOL_reflections function_reflections)
done

lemma Nand_replacement:
    "[|L(A); L(rp); L(rq)|]
     ==> strong_replacement
         (L, \<lambda>env z. \<exists>rpe[L]. \<exists>rqe[L]. \<exists>andpq[L]. \<exists>notpq[L].
               fun_apply(L,rp,env,rpe) & fun_apply(L,rq,env,rqe) &
               is_and(L,rpe,rqe,andpq) & is_not(L,andpq,notpq) &
               env \<in> list(A) & pair(L, env, notpq, z))"
apply (rule strong_replacementI)
apply (rule_tac u="{list(A),B,rp,rq}"
         in gen_separation_multi [OF Nand_Reflects],
       auto simp add: list_closed)
apply (rule_tac env="[list(A),B,rp,rq]" in DPow_LsetI)
apply (rule sep_rules is_and_iff_sats is_not_iff_sats | simp)+
done

subsubsection\<open>The @{term "Forall"} Case\<close>

lemma Forall_Reflects:
 "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and> (\<exists>bo[L]. u \<in> list(A) \<and>
                 is_bool_of_o (L,
     \<forall>a[L]. \<forall>co[L]. \<forall>rpco[L]. a \<in> A \<longrightarrow>
                is_Cons(L,a,u,co) \<longrightarrow> fun_apply(L,rp,co,rpco) \<longrightarrow>
                number1(L,rpco),
                           bo) \<and> pair(L,u,bo,x)),
 \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and> (\<exists>bo \<in> Lset(i). u \<in> list(A) \<and>
        is_bool_of_o (##Lset(i),
 \<forall>a \<in> Lset(i). \<forall>co \<in> Lset(i). \<forall>rpco \<in> Lset(i). a \<in> A \<longrightarrow>
            is_Cons(##Lset(i),a,u,co) \<longrightarrow> fun_apply(##Lset(i),rp,co,rpco) \<longrightarrow>
            number1(##Lset(i),rpco),
                       bo) \<and> pair(##Lset(i),u,bo,x))]"
apply (unfold is_bool_of_o_def)
apply (intro FOL_reflections function_reflections Cons_reflection)
done

lemma Forall_replacement:
   "[|L(A); L(rp)|]
    ==> strong_replacement
        (L, \<lambda>env z. \<exists>bo[L].
              env \<in> list(A) &
              is_bool_of_o (L,
                            \<forall>a[L]. \<forall>co[L]. \<forall>rpco[L].
                               a\<in>A \<longrightarrow> is_Cons(L,a,env,co) \<longrightarrow>
                               fun_apply(L,rp,co,rpco) \<longrightarrow> number1(L, rpco),
                            bo) &
              pair(L,env,bo,z))"
apply (rule strong_replacementI)
apply (rule_tac u="{A,list(A),B,rp}"
         in gen_separation_multi [OF Forall_Reflects],
       auto simp add: list_closed)
apply (rule_tac env="[A,list(A),B,rp]" in DPow_LsetI)
apply (rule sep_rules is_bool_of_o_iff_sats Cons_iff_sats | simp)+
done

subsubsection\<open>The @{term "transrec_replacement"} Case\<close>

lemma formula_rec_replacement_Reflects:
 "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and> (\<exists>y[L]. pair(L, u, y, x) \<and>
             is_wfrec (L, satisfies_MH(L,A), mesa, u, y)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and> (\<exists>y \<in> Lset(i). pair(##Lset(i), u, y, x) \<and>
             is_wfrec (##Lset(i), satisfies_MH(##Lset(i),A), mesa, u, y))]"
by (intro FOL_reflections function_reflections satisfies_MH_reflection
          is_wfrec_reflection)

lemma formula_rec_replacement:
      \<comment>\<open>For the @{term transrec}\<close>
   "[|n \<in> nat; L(A)|] ==> transrec_replacement(L, satisfies_MH(L,A), n)"
apply (rule transrec_replacementI, simp add: nat_into_M)
apply (rule strong_replacementI)
apply (rule_tac u="{B,A,n,Memrel(eclose({n}))}"
         in gen_separation_multi [OF formula_rec_replacement_Reflects],
       auto simp add: nat_into_M)
apply (rule_tac env="[B,A,n,Memrel(eclose({n}))]" in DPow_LsetI)
apply (rule sep_rules satisfies_MH_iff_sats is_wfrec_iff_sats | simp)+
done

subsubsection\<open>The Lambda Replacement Case\<close>

lemma formula_rec_lambda_replacement_Reflects:
 "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B &
     mem_formula(L,u) &
     (\<exists>c[L].
         is_formula_case
          (L, satisfies_is_a(L,A), satisfies_is_b(L,A),
           satisfies_is_c(L,A,g), satisfies_is_d(L,A,g),
           u, c) &
         pair(L,u,c,x)),
  \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & mem_formula(##Lset(i),u) &
     (\<exists>c \<in> Lset(i).
         is_formula_case
          (##Lset(i), satisfies_is_a(##Lset(i),A), satisfies_is_b(##Lset(i),A),
           satisfies_is_c(##Lset(i),A,g), satisfies_is_d(##Lset(i),A,g),
           u, c) &
         pair(##Lset(i),u,c,x))]"
by (intro FOL_reflections function_reflections mem_formula_reflection
          is_formula_case_reflection satisfies_is_a_reflection
          satisfies_is_b_reflection satisfies_is_c_reflection
          satisfies_is_d_reflection)

lemma formula_rec_lambda_replacement:
      \<comment>\<open>For the @{term transrec}\<close>
   "[|L(g); L(A)|] ==>
    strong_replacement (L,
       \<lambda>x y. mem_formula(L,x) &
             (\<exists>c[L]. is_formula_case(L, satisfies_is_a(L,A),
                                  satisfies_is_b(L,A),
                                  satisfies_is_c(L,A,g),
                                  satisfies_is_d(L,A,g), x, c) &
             pair(L, x, c, y)))"
apply (rule strong_replacementI)
apply (rule_tac u="{B,A,g}"
         in gen_separation_multi [OF formula_rec_lambda_replacement_Reflects],
       auto)
apply (rule_tac env="[A,g,B]" in DPow_LsetI)
apply (rule sep_rules mem_formula_iff_sats
          formula_case_iff_sats satisfies_is_a_iff_sats
          satisfies_is_b_iff_sats satisfies_is_c_iff_sats
          satisfies_is_d_iff_sats | simp)+
done

subsection\<open>Instantiating \<open>M_satisfies\<close>\<close>

lemma M_satisfies_axioms_L: "M_satisfies_axioms(L)"
  apply (rule M_satisfies_axioms.intro)
       apply (assumption | rule
         Member_replacement Equal_replacement
         Nand_replacement Forall_replacement
         formula_rec_replacement formula_rec_lambda_replacement)+
  done

theorem M_satisfies_L: "PROP M_satisfies(L)"
  apply (rule M_satisfies.intro)
   apply (rule M_eclose_L)
  apply (rule M_satisfies_axioms_L)
  done

text\<open>Finally: the point of the whole theory!\<close>
lemmas satisfies_closed = M_satisfies.satisfies_closed [OF M_satisfies_L]
   and satisfies_abs = M_satisfies.satisfies_abs [OF M_satisfies_L]

end