(*
  Title:  Example Completeness Proof for a Natural Deduction Calculus for First-Order Logic
  Author: Asta Halkjær From
*)

chapter \<open>Example: First-Order Logic\<close>

theory Example_First_Order_Logic imports Derivations begin

section \<open>Syntax\<close>

datatype (params_tm: 'f) tm
  = Var nat (\<open>\<^bold>#\<close>)
  | Fun 'f \<open>'f tm list\<close> (\<open>\<^bold>\<dagger>\<close>)

abbreviation Const (\<open>\<^bold>\<star>\<close>) where \<open>\<^bold>\<star>a \<equiv> \<^bold>\<dagger>a []\<close>

datatype (params_fm: 'f, 'p) fm
  = Fls (\<open>\<^bold>\<bottom>\<close>)
  | Pre 'p \<open>'f tm list\<close> (\<open>\<^bold>\<ddagger>\<close>)
  | Imp \<open>('f, 'p) fm\<close> \<open>('f, 'p) fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
  | Uni \<open>('f, 'p) fm\<close> (\<open>\<^bold>\<forall>\<close>)

abbreviation Neg (\<open>\<^bold>\<not> _\<close> [70] 70) where \<open>\<^bold>\<not> p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

section \<open>Semantics\<close>

type_synonym ('a, 'f, 'p) model = \<open>(nat \<Rightarrow> 'a) \<times> ('f \<Rightarrow> 'a list \<Rightarrow> 'a) \<times> ('p \<Rightarrow> 'a list \<Rightarrow> bool)\<close>

fun semantics_tm :: \<open>(nat \<Rightarrow> 'a) \<times> ('f \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> 'f tm \<Rightarrow> 'a\<close> (\<open>\<lparr>_\<rparr>\<close>) where
  \<open>\<lparr>(E, _)\<rparr> (\<^bold>#n) = E n\<close>
| \<open>\<lparr>(E, F)\<rparr> (\<^bold>\<dagger>f ts) = F f (map \<lparr>(E, F)\<rparr> ts)\<close>

primrec add_env :: \<open>'a \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a\<close> (infix \<open>\<Zsemi>\<close> 0) where
  \<open>(t \<Zsemi> s) 0 = t\<close>
| \<open>(t \<Zsemi> s) (Suc n) = s n\<close>

fun semantics_fm :: \<open>('a, 'f, 'p) model \<Rightarrow> ('f, 'p) fm \<Rightarrow> bool\<close> (\<open>\<lbrakk>_\<rbrakk>\<close>) where
  \<open>\<lbrakk>_\<rbrakk> \<^bold>\<bottom> \<longleftrightarrow> False\<close>
| \<open>\<lbrakk>(E, F, G)\<rbrakk> (\<^bold>\<ddagger>P ts) \<longleftrightarrow> G P (map \<lparr>(E, F)\<rparr> ts)\<close>
| \<open>\<lbrakk>(E, F, G)\<rbrakk> (p \<^bold>\<longrightarrow> q) \<longleftrightarrow> \<lbrakk>(E, F, G)\<rbrakk> p \<longrightarrow> \<lbrakk>(E, F, G)\<rbrakk> q\<close>
| \<open>\<lbrakk>(E, F, G)\<rbrakk> (\<^bold>\<forall>p) \<longleftrightarrow> (\<forall>x. \<lbrakk>(x \<Zsemi> E, F, G)\<rbrakk> p)\<close>

section \<open>Operations\<close>

primrec lift_tm :: \<open>'f tm \<Rightarrow> 'f tm\<close> where
  \<open>lift_tm (\<^bold>#n) = \<^bold>#(n+1)\<close>
| \<open>lift_tm (\<^bold>\<dagger>f ts) = \<^bold>\<dagger>f (map lift_tm ts)\<close>

primrec sub_tm :: \<open>(nat \<Rightarrow> 'f tm) \<Rightarrow> 'f tm \<Rightarrow> 'f tm\<close> where
  \<open>sub_tm s (\<^bold>#n) = s n\<close>
| \<open>sub_tm s (\<^bold>\<dagger>f ts) = \<^bold>\<dagger>f (map (sub_tm s) ts)\<close>

primrec sub_fm :: \<open>(nat \<Rightarrow> 'f tm) \<Rightarrow> ('f, 'p) fm \<Rightarrow> ('f, 'p) fm\<close> where
  \<open>sub_fm _ \<^bold>\<bottom> = \<^bold>\<bottom>\<close>
| \<open>sub_fm s (\<^bold>\<ddagger>P ts) = \<^bold>\<ddagger>P (map (sub_tm s) ts)\<close>
| \<open>sub_fm s (p \<^bold>\<longrightarrow> q) = sub_fm s p \<^bold>\<longrightarrow> sub_fm s q\<close>
| \<open>sub_fm s (\<^bold>\<forall>p) = \<^bold>\<forall>(sub_fm (\<^bold>#0 \<Zsemi> \<lambda>n. lift_tm (s n)) p)\<close>

abbreviation inst_single :: \<open>'f tm \<Rightarrow> ('f, 'p) fm \<Rightarrow> ('f, 'p) fm\<close> (\<open>\<langle>_\<rangle>\<close>) where
  \<open>\<langle>t\<rangle> \<equiv> sub_fm (t \<Zsemi> \<^bold>#)\<close>

abbreviation \<open>params' S \<equiv> \<Union>p \<in> S. params_fm p\<close>

abbreviation \<open>params l \<equiv> params' (set l)\<close>

lemma upd_params_tm [simp]: \<open>f \<notin> params_tm t \<Longrightarrow> \<lparr>(E, F(f := x))\<rparr> t = \<lparr>(E, F)\<rparr> t\<close>
  by (induct t) (auto cong: map_cong)

lemma upd_params_fm [simp]: \<open>f \<notin> params_fm p \<Longrightarrow> \<lbrakk>(E, F(f := x), G)\<rbrakk> p = \<lbrakk>(E, F, G)\<rbrakk> p\<close>
  by (induct p arbitrary: E) (auto cong: map_cong)

lemma finite_params_tm [simp]: \<open>finite (params_tm t)\<close>
  by (induct t) simp_all

lemma finite_params_fm [simp]: \<open>finite (params_fm p)\<close>
  by (induct p) simp_all

lemma env [simp]: \<open>P ((x \<Zsemi> E) n) = (P x \<Zsemi> \<lambda>n. P (E n)) n\<close>
  by (induct n) simp_all

lemma lift_lemma: \<open>\<lparr>(x \<Zsemi> E, F)\<rparr> (lift_tm t) = \<lparr>(E, F)\<rparr> t\<close>
  by (induct t) (auto cong: map_cong)

lemma sub_tm_semantics: \<open>\<lparr>(E, F)\<rparr> (sub_tm s t) = \<lparr>(\<lambda>n. \<lparr>(E, F)\<rparr> (s n), F)\<rparr> t\<close>
  by (induct t) (auto cong: map_cong)

lemma sub_fm_semantics [simp]: \<open>\<lbrakk>(E, F, G)\<rbrakk> (sub_fm s p) = \<lbrakk>(\<lambda>n. \<lparr>(E, F)\<rparr> (s n), F, G)\<rbrakk> p\<close>
  by (induct p arbitrary: E s) (auto cong: map_cong simp: sub_tm_semantics lift_lemma)

lemma sub_tm_Var: \<open>sub_tm \<^bold># t = t\<close>
  by (induct t) (auto cong: map_cong)

lemma reduce_Var [simp]: \<open>(\<^bold># 0 \<Zsemi> \<lambda>n. \<^bold># (Suc n)) = \<^bold>#\<close>
proof (rule ext)
  fix n
  show \<open>(\<^bold># 0 \<Zsemi> \<lambda>n. \<^bold># (Suc n)) n = \<^bold>#n\<close>
    by (induct n) simp_all
qed

lemma sub_fm_Var [simp]:
  fixes p :: \<open>('f, 'p) fm\<close>
  shows \<open>sub_fm \<^bold># p = p\<close>
proof (induct p)
  case (Pre P ts)
  then show ?case
    by (auto cong: map_cong simp: sub_tm_Var)
qed simp_all

lemma semantics_tm_id [simp]: \<open>\<lparr>(\<^bold>#, \<^bold>\<dagger>)\<rparr> t = t\<close>
  by (induct t) (auto cong: map_cong)

lemma semantics_tm_id_map [simp]: \<open>map \<lparr>(\<^bold>#, \<^bold>\<dagger>)\<rparr> ts = ts\<close>
  by (auto cong: map_cong)

text \<open>The built-in \<open>size\<close> is not invariant under substitution.\<close>

primrec size_fm :: \<open>('f, 'p) fm \<Rightarrow> nat\<close> where
  \<open>size_fm \<^bold>\<bottom> = 1\<close>
| \<open>size_fm (\<^bold>\<ddagger>_ _) = 1\<close>
| \<open>size_fm (p \<^bold>\<longrightarrow> q) = 1 + size_fm p + size_fm q\<close>
| \<open>size_fm (\<^bold>\<forall>p) = 1 + size_fm p\<close>

lemma size_sub_fm [simp]: \<open>size_fm (sub_fm s p) = size_fm p\<close>
  by (induct p arbitrary: s) simp_all

section \<open>Calculus\<close>

inductive Calculus :: \<open>('f, 'p) fm list \<Rightarrow> ('f, 'p) fm \<Rightarrow> bool\<close> (\<open>_ \<turnstile>\<^sub>\<forall> _\<close> [50, 50] 50) where
  Assm [intro]: \<open>p \<in> set A \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p\<close>
| FlsE [elim]: \<open>A \<turnstile>\<^sub>\<forall> \<^bold>\<bottom> \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p\<close>
| ImpI [intro]: \<open>p # A \<turnstile>\<^sub>\<forall> q \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p \<^bold>\<longrightarrow> q\<close>
| ImpE [elim]: \<open>A \<turnstile>\<^sub>\<forall> p \<^bold>\<longrightarrow> q \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p \<Longrightarrow> A \<turnstile>\<^sub>\<forall> q\<close>
| UniI [intro]: \<open>A \<turnstile>\<^sub>\<forall> \<langle>\<^bold>\<star>a\<rangle>p \<Longrightarrow> a \<notin> params (p # A) \<Longrightarrow> A \<turnstile>\<^sub>\<forall> \<^bold>\<forall>p\<close>
| UniE [elim]: \<open>A \<turnstile>\<^sub>\<forall> \<^bold>\<forall>p \<Longrightarrow> A \<turnstile>\<^sub>\<forall> \<langle>t\<rangle>p\<close>
| Clas: \<open>(p \<^bold>\<longrightarrow> q) # A \<turnstile>\<^sub>\<forall> p \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p\<close>
| Weak: \<open>A \<turnstile>\<^sub>\<forall> p \<Longrightarrow> q # A \<turnstile>\<^sub>\<forall> p\<close>

section \<open>Soundness\<close>

theorem soundness: \<open>A \<turnstile>\<^sub>\<forall> p \<Longrightarrow> list_all \<lbrakk>(E, F, G)\<rbrakk> A \<Longrightarrow> \<lbrakk>(E, F, G)\<rbrakk> p\<close>
proof (induct p arbitrary: F rule: Calculus.induct)
  case (UniI A a p)
  moreover have \<open>list_all \<lbrakk>(E, F(a := x), G)\<rbrakk> A\<close> for x
    using UniI(3-4) by (simp add: list.pred_mono_strong)
  then have \<open>\<lbrakk>(E, F(a := x), G)\<rbrakk> (\<langle>\<^bold>\<star>a\<rangle>p)\<close> for x
    using UniI by blast
  ultimately show ?case
    by fastforce
qed (auto simp: list_all_iff)

corollary soundness': \<open>[] \<turnstile>\<^sub>\<forall> p \<Longrightarrow> \<lbrakk>M\<rbrakk> p\<close>
  using soundness by (cases M) fastforce

corollary \<open>\<not> ([] \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>)\<close>
  using soundness' by fastforce

section \<open>Admissible Rules\<close>

lemma Assm_head: \<open>p # A \<turnstile>\<^sub>\<forall> p\<close>
  by auto

lemma deduct1: \<open>A \<turnstile>\<^sub>\<forall> p \<^bold>\<longrightarrow> q \<Longrightarrow> p # A \<turnstile>\<^sub>\<forall> q\<close>
  by (meson ImpE Weak Assm_head)

lemma Boole: \<open>(\<^bold>\<not> p) # A \<turnstile>\<^sub>\<forall> \<^bold>\<bottom> \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p\<close>
  using Clas FlsE by blast

lemma Weak': \<open>A \<turnstile>\<^sub>\<forall> p \<Longrightarrow> B @ A \<turnstile>\<^sub>\<forall> p\<close>
  by (induct B) (simp, metis Weak append_Cons)

lemma Weaken: \<open>A \<turnstile>\<^sub>\<forall> p \<Longrightarrow> set A \<subseteq> set B \<Longrightarrow> B \<turnstile>\<^sub>\<forall> p\<close>
proof (induct A arbitrary: p)
  case Nil
  then show ?case
    using Weak' by fastforce
next
  case (Cons q A)
  then show ?case
    by (metis Assm ImpE ImpI list.set_intros(1-2) subset_code(1))
qed

interpretation Derivations Calculus
proof
  fix A B and p :: \<open>('f, 'p) fm\<close>
  assume \<open>A \<turnstile>\<^sub>\<forall> p\<close> \<open>set A \<subseteq> set B\<close>
  then show \<open>B \<turnstile>\<^sub>\<forall> p\<close>
    using Weaken by blast
qed

section \<open>Maximal Consistent Sets\<close>

definition consistent :: \<open>('f, 'p) fm set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>

fun witness :: \<open>('f, 'p) fm \<Rightarrow> ('f, 'p) fm set \<Rightarrow> ('f, 'p) fm set\<close> where
  \<open>witness (\<^bold>\<not> (\<^bold>\<forall>p)) S = {\<^bold>\<not> \<langle>\<^bold>\<star>(SOME a. a \<notin> params' ({p} \<union> S))\<rangle>p}\<close>
| \<open>witness _ _ = {}\<close>

lemma consistent_add_instance:
  assumes \<open>consistent S\<close> \<open>\<^bold>\<forall>p \<in> S\<close>
  shows \<open>consistent ({\<langle>t\<rangle>p} \<union> S)\<close>
  unfolding consistent_def
proof
  assume \<open>\<exists>S'. set S' \<subseteq> {\<langle>t\<rangle>p} \<union> S \<and> S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
  then obtain S' where \<open>set S' \<subseteq> S\<close> \<open>\<langle>t\<rangle>p # S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
    using assms derive_split1 by metis
  then have \<open>\<^bold>\<forall>p # S' \<turnstile>\<^sub>\<forall> \<^bold>\<not> \<langle>t\<rangle>p\<close>
    using Weak by blast
  moreover have \<open>\<^bold>\<forall>p # S' \<turnstile>\<^sub>\<forall> \<langle>t\<rangle>p\<close>
    using Assm_head by fast
  ultimately have \<open>\<^bold>\<forall>p # S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
    by fast
  moreover have \<open>set ((\<^bold>\<forall>p) # S') \<subseteq> S\<close>
    using \<open>set S' \<subseteq> S\<close> assms(2) by simp
  ultimately show False
    using assms(1) unfolding consistent_def by blast
qed

lemma consistent_add_witness:
  assumes \<open>consistent S\<close> \<open>\<^bold>\<not> (\<^bold>\<forall>p) \<in> S\<close> \<open>a \<notin> params' S\<close>
  shows \<open>consistent ({\<^bold>\<not> \<langle>\<^bold>\<star>a\<rangle>p} \<union> S)\<close>
  unfolding consistent_def
proof
  assume \<open>\<exists>S'. set S' \<subseteq> {\<^bold>\<not> \<langle>\<^bold>\<star>a\<rangle>p} \<union> S \<and> S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
  then obtain S' where \<open>set S' \<subseteq> S\<close> \<open>(\<^bold>\<not> \<langle>\<^bold>\<star>a\<rangle>p) # S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
    using assms derive_split1 by metis
  then have \<open>S' \<turnstile>\<^sub>\<forall> \<langle>\<^bold>\<star>a\<rangle>p\<close>
    using Boole by blast
  moreover have \<open>a \<notin> params_fm p\<close> \<open>\<forall>p \<in> set S'. a \<notin> params_fm p\<close>
    using \<open>set S' \<subseteq> S\<close> assms(2-3) by auto
  then have \<open>a \<notin> params' ({p} \<union> set S')\<close>
    using calculation by fast
  ultimately have \<open>S' \<turnstile>\<^sub>\<forall> \<^bold>\<forall>p\<close>
    by fastforce
  then have \<open>\<^bold>\<not> (\<^bold>\<forall>p) # S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
    using Weak Assm_head by fast
  moreover have \<open>set ((\<^bold>\<not> (\<^bold>\<forall>p)) # S') \<subseteq> S\<close>
    using \<open>set S' \<subseteq> S\<close> assms(2) by simp
  ultimately show False
    using assms(1) unfolding consistent_def by blast
qed

lemma consistent_witness':
  assumes \<open>consistent ({p} \<union> S)\<close> \<open>infinite (UNIV - params' S)\<close>
  shows \<open>consistent (witness p S \<union> {p} \<union> S)\<close>
  using assms
proof (induct p S rule: witness.induct)
  case (1 p S)
  have \<open>infinite (UNIV - params' ({p} \<union> S))\<close>
    using 1(2) finite_params_fm by (simp add: infinite_Diff_fin_Un)
  then have \<open>\<exists>a. a \<notin> params' ({p} \<union> S)\<close>
    by (simp add: not_finite_existsD set_diff_eq)
  then have \<open>(SOME a. a \<notin> params' ({p} \<union> S)) \<notin> params' ({p} \<union> S)\<close>
    by (rule someI_ex)
  then obtain a where a: \<open>witness (\<^bold>\<not> (\<^bold>\<forall>p)) S = {\<^bold>\<not> \<langle>\<^bold>\<star>a\<rangle>p}\<close> \<open>a \<notin> params' ({\<^bold>\<not>\<^bold>\<forall>p} \<union> S)\<close>
    by simp
  then show ?case
    using 1(1-2) a(1) consistent_add_witness[where S=\<open>{\<^bold>\<not>\<^bold>\<forall>p} \<union> S\<close>] by fastforce
qed (auto simp: assms)

interpretation MCS_Saturation consistent params_fm witness
proof
  fix S S' :: \<open>('f, 'p) fm set\<close>
  assume \<open>consistent S\<close> \<open>S' \<subseteq> S\<close>
  then show \<open>consistent S'\<close>
    unfolding consistent_def by fast
next
  fix S :: \<open>('f, 'p) fm set\<close>
  assume \<open>\<not> consistent S\<close>
  then show \<open>\<exists>S'\<subseteq>S. finite S' \<and> \<not> consistent S'\<close>
    unfolding consistent_def by blast
next
  fix p :: \<open>('f, 'p) fm\<close>
  show \<open>finite (params_fm p)\<close>
    by simp
next
  fix p and S :: \<open>('f, 'p) fm set\<close>
  show \<open>finite (params' (witness p S))\<close>
    by (induct p S rule: witness.induct) simp_all
next
  fix p and S :: \<open>('f, 'p) fm set\<close>
  assume \<open>consistent ({p} \<union> S)\<close> \<open>infinite (UNIV - params' S)\<close>
  then show \<open>consistent (witness p S \<union> {p} \<union> S)\<close>
    using consistent_witness' by fast
next
  show \<open>infinite (UNIV :: ('f, 'p) fm set)\<close>
    using infinite_UNIV_size[of \<open>\<lambda>p. p \<^bold>\<longrightarrow> p\<close>] by simp
qed

interpretation Derivations_MCS_Cut Calculus consistent \<open>\<^bold>\<bottom>\<close>
proof
  fix S :: \<open>('f, 'p) fm set\<close>
  show \<open>consistent S = (\<nexists>S'. set S' \<subseteq> S \<and> S' \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>)\<close>
    unfolding consistent_def ..
next
  fix A and p :: \<open>('f, 'p) fm\<close>
  assume \<open>p \<in> set A\<close>
  then show \<open>A \<turnstile>\<^sub>\<forall> p\<close>
    by blast
next
  fix A B and p q :: \<open>('f, 'p) fm\<close>
  assume \<open>A \<turnstile>\<^sub>\<forall> p\<close> \<open>p # B \<turnstile>\<^sub>\<forall> q\<close>
  then show \<open>A @ B \<turnstile>\<^sub>\<forall> q\<close>
    using Weaken ImpI ImpE by (metis Un_upper2 inf_sup_ord(3) set_append)
qed

section \<open>Truth Lemma\<close>

abbreviation hmodel :: \<open>('f, 'p) fm set \<Rightarrow> ('f tm, 'f, 'p) model\<close> where
  \<open>hmodel H \<equiv> (\<^bold>#, \<^bold>\<dagger>, \<lambda>P ts. \<^bold>\<ddagger>P ts \<in> H)\<close>

fun semics ::
  \<open>('a, 'f, 'p) model \<Rightarrow> (('a, 'f, 'p) model \<Rightarrow> ('f, 'p) fm \<Rightarrow> bool) \<Rightarrow> ('f, 'p) fm \<Rightarrow> bool\<close> where
  \<open>semics _ _ \<^bold>\<bottom> \<longleftrightarrow> False\<close>
| \<open>semics (E, F, G) _ (\<^bold>\<ddagger>P ts) \<longleftrightarrow> G P (map \<lparr>(E, F)\<rparr> ts)\<close>
| \<open>semics (E, F, G) rel (p \<^bold>\<longrightarrow> q) \<longleftrightarrow> rel (E, F, G) p \<longrightarrow> rel (E, F, G) q\<close>
| \<open>semics (E, F, G) rel (\<^bold>\<forall>p) \<longleftrightarrow> (\<forall>x. rel (x \<Zsemi> E, F, G) p)\<close>

fun rel :: \<open>('f, 'p) fm set \<Rightarrow> ('f tm, 'f, 'p) model \<Rightarrow> ('f, 'p) fm \<Rightarrow> bool\<close> where
  \<open>rel H (E, _, _) p = (sub_fm E p \<in> H)\<close>

theorem Hintikka_model':
  assumes \<open>\<And>p. semics (hmodel H) (rel H) p \<longleftrightarrow> p \<in> H\<close>
  shows \<open>p \<in> H \<longleftrightarrow> \<lbrakk>hmodel H\<rbrakk> p\<close>
proof (induct p rule: wf_induct[where r=\<open>measure size_fm\<close>])
  case 1
  then show ?case ..
next
  case (2 x)
  then show ?case
    using assms[of x] by (cases x) simp_all
qed

lemma Hintikka_Extend:
  assumes \<open>consistent H\<close> \<open>maximal H\<close> \<open>saturated H\<close>
  shows \<open>semics (hmodel H) (rel H) p \<longleftrightarrow> p \<in> H\<close>
proof (cases p)
  case Fls
  have \<open>\<^bold>\<bottom> \<notin> H\<close>
    using assms MCS_derive unfolding consistent_def by blast
  then show ?thesis
    using Fls by simp
next
  case (Imp p q)
  have \<open>p # A \<turnstile>\<^sub>\<forall> \<^bold>\<bottom> \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p \<^bold>\<longrightarrow> q\<close> \<open>A \<turnstile>\<^sub>\<forall> q \<Longrightarrow> A \<turnstile>\<^sub>\<forall> p \<^bold>\<longrightarrow> q\<close> for A
    by (auto simp: Weak)
  moreover have \<open>A \<turnstile>\<^sub>\<forall> p \<^bold>\<longrightarrow> q \<Longrightarrow> p # A \<turnstile>\<^sub>\<forall> q\<close> for A
    using deduct1 .
  ultimately have \<open>(p \<in> H \<longrightarrow> q \<in> H) \<longleftrightarrow> p \<^bold>\<longrightarrow> q \<in> H\<close>
    using assms(1-2) MCS_derive MCS_derive_fls by (metis insert_subset list.simps(15))
  then show ?thesis
    using Imp by simp
next
  case (Uni p)
  have \<open>(\<forall>x. \<langle>x\<rangle>p \<in> H) \<longleftrightarrow> (\<^bold>\<forall>p \<in> H)\<close>
  proof
    assume \<open>\<forall>x. \<langle>x\<rangle>p \<in> H\<close>
    show \<open>\<^bold>\<forall>p \<in> H\<close>
    proof (rule ccontr)
      assume \<open>\<^bold>\<forall>p \<notin> H\<close>
      then have \<open>consistent ({\<^bold>\<not> \<^bold>\<forall>p} \<union> H)\<close>
        using Boole assms(1-2) MCS_derive derive_split1 by (metis consistent_derive_fls)
      then have \<open>\<^bold>\<not> \<^bold>\<forall>p \<in> H\<close>
        using assms(2) unfolding maximal_def by blast
      then obtain a where \<open>\<^bold>\<not> \<langle>\<^bold>\<star>a\<rangle>p \<in> H\<close>
        using assms(3) unfolding saturated_def by fastforce
      moreover have \<open>\<langle>\<^bold>\<star>a\<rangle>p \<in> H\<close>
        using \<open>\<forall>x. \<langle>x\<rangle>p \<in> H\<close> by blast
      ultimately show False
        using assms(1-2) MCS_derive by (metis consistent_def deduct1 insert_subset list.simps(15))
    qed
  next
    assume \<open>\<^bold>\<forall>p \<in> H\<close>
    then show \<open>\<forall>x. \<langle>x\<rangle>p \<in> H\<close>
      using assms(1-2) consistent_add_instance maximal_def by blast
  qed
  then show ?thesis
    using Uni by simp
qed simp

interpretation Truth_Saturation
  consistent params_fm witness semics semantics_fm \<open>\<lambda>H. {hmodel H}\<close> rel
proof unfold_locales
  fix p and M :: \<open>('a tm, 'f, 'p) model\<close>
  show \<open>\<lbrakk>M\<rbrakk> p \<longleftrightarrow> semics M semantics_fm p\<close>
    by (cases M, induct p) auto
next
  fix p and H :: \<open>('f, 'p) fm set\<close> and M :: \<open>('f tm, 'f, 'p) model\<close>
  assume \<open>\<forall>M \<in> {hmodel H}. \<forall>p. semics M (rel H) p \<longleftrightarrow> rel H M p\<close> \<open>M \<in> {hmodel H}\<close>
  then show \<open>\<lbrakk>M\<rbrakk> p \<longleftrightarrow> rel H M p\<close>
    using Hintikka_model' by auto
next
  fix H :: \<open>('f, 'p) fm set\<close>
  assume \<open>consistent H\<close> \<open>maximal H\<close> \<open>saturated H\<close>
  then show \<open>\<forall>M \<in> {hmodel H}. \<forall>p. semics M (rel H) p \<longleftrightarrow> rel H M p\<close>
    using Hintikka_Extend by auto
qed

section \<open>Cardinalities\<close>

datatype marker = VarM | FunM | TmM | FlsM | PreM | ImpM | UniM

type_synonym ('f, 'p) enc = \<open>('f + 'p) + marker \<times> nat\<close>

abbreviation \<open>FUNS f \<equiv> Inl (Inl f)\<close>
abbreviation \<open>PRES p \<equiv> Inl (Inr p)\<close>

abbreviation \<open>VAR n \<equiv> Inr (VarM, n)\<close>
abbreviation \<open>FUN n \<equiv> Inr (FunM, n)\<close>
abbreviation \<open>TM n \<equiv> Inr (TmM, n)\<close>

abbreviation \<open>PRE n \<equiv> Inr (PreM, n)\<close>
abbreviation \<open>FLS \<equiv> Inr (FlsM, 0)\<close>
abbreviation \<open>IMP n \<equiv> Inr (FlsM, n)\<close>
abbreviation \<open>UNI \<equiv> Inr (UniM, 0)\<close>

primrec
  encode_tm :: \<open>'f tm \<Rightarrow> ('f, 'p) enc list\<close> and
  encode_tms :: \<open>'f tm list \<Rightarrow> ('f, 'p) enc list\<close> where
  \<open>encode_tm (\<^bold>#n) = [VAR n]\<close>
| \<open>encode_tm (\<^bold>\<dagger>f ts) = FUN (length ts) # FUNS f # encode_tms ts\<close>
| \<open>encode_tms [] = []\<close>
| \<open>encode_tms (t # ts) = TM (length (encode_tm t)) # encode_tm t @ encode_tms ts\<close>

lemma encode_tm_ne [simp]: \<open>encode_tm t \<noteq> []\<close>
  by (induct t) auto

lemma inj_encode_tm':
  \<open>(encode_tm t :: ('f, 'p) enc list) = encode_tm s \<Longrightarrow> t = s\<close>
  \<open>(encode_tms ts :: ('f, 'p) enc list) = encode_tms ss \<Longrightarrow> ts = ss\<close>
proof (induct t and ts arbitrary: s and ss rule: encode_tm.induct encode_tms.induct)
  case (Var n)
  then show ?case
    by (cases s) auto
next
  case (Fun f fts)
  then show ?case
    by (cases s) auto
next
  case Nil_tm
  then show ?case
    by (cases ss) auto
next
  case (Cons_tm t ts)
  then show ?case
    by (cases ss) auto
qed

lemma inj_encode_tm: \<open>inj encode_tm\<close>
  unfolding inj_def using inj_encode_tm' by blast

primrec encode_fm :: \<open>('f, 'p) fm \<Rightarrow> ('f, 'p) enc list\<close> where
  \<open>encode_fm \<^bold>\<bottom> = [FLS]\<close>
| \<open>encode_fm (\<^bold>\<ddagger>P ts) = PRE (length ts) # PRES P # encode_tms ts\<close>
| \<open>encode_fm (p \<^bold>\<longrightarrow> q) = IMP (length (encode_fm p)) # encode_fm p @ encode_fm q\<close>
| \<open>encode_fm (\<^bold>\<forall>p) = UNI # encode_fm p\<close>

lemma encode_fm_ne [simp]: \<open>encode_fm p \<noteq> []\<close>
  by (induct p) auto

lemma inj_encode_fm': \<open>encode_fm p = encode_fm q \<Longrightarrow> p = q\<close>
proof (induct p arbitrary: q)
  case Fls
  then show ?case
    by (cases q) auto
next
  case (Pre P ts)
  then show ?case
    by (cases q) (auto simp: inj_encode_tm')
next
  case (Imp p1 p2)
  then show ?case
    by (cases q) auto
next
  case (Uni p)
  then show ?case
    by (cases q) auto
qed

lemma inj_encode_fm: \<open>inj encode_fm\<close>
  unfolding inj_def using inj_encode_fm' by blast

lemma finite_marker: \<open>finite (UNIV :: marker set)\<close>
proof -
  have \<open>p \<in> {VarM, FunM, TmM, FlsM, PreM, ImpM, UniM}\<close> for p
    by (cases p) auto
  then show ?thesis
    by (meson ex_new_if_finite finite.emptyI finite_insert)
qed

lemma card_of_fm:
  assumes \<open>infinite (UNIV :: 'f set)\<close>
  shows \<open>|UNIV :: ('f, 'p) fm set| \<le>o |UNIV :: 'f set| +c |UNIV :: 'p set|\<close>
proof -
  have \<open>|UNIV :: marker set| \<le>o |UNIV :: nat set|\<close>
    using finite_marker by (simp add: ordLess_imp_ordLeq)
  moreover have \<open>infinite (UNIV :: ('f + 'p) set)\<close>
    using assms by simp
  ultimately have \<open>|UNIV :: ('f, 'p) enc list set| \<le>o |UNIV :: ('f + 'p) set|\<close>
    using card_of_params_marker_lists by blast
  moreover have \<open>|UNIV :: ('f, 'p) fm set| \<le>o |UNIV :: ('f, 'p) enc list set|\<close>
    using card_of_ordLeq inj_encode_fm by blast
  ultimately have \<open>|UNIV :: ('f, 'p) fm set| \<le>o |UNIV :: ('f + 'p) set|\<close>
    using ordLeq_transitive by blast
  then show ?thesis
    unfolding csum_def by simp
qed

section \<open>Completeness\<close>

theorem strong_completeness:
  assumes \<open>\<forall>M :: ('f tm, 'f, 'p) model. (\<forall>q \<in> X. \<lbrakk>M\<rbrakk> q) \<longrightarrow> \<lbrakk>M\<rbrakk> p\<close>
    \<open>infinite (UNIV :: 'f set)\<close>
    \<open>|UNIV :: 'f set| +c |UNIV :: 'p set| \<le>o |UNIV - params' X|\<close>
  shows \<open>\<exists>A. set A \<subseteq> X \<and> A \<turnstile>\<^sub>\<forall> p\<close>
proof (rule ccontr)
  assume \<open>\<nexists>A. set A \<subseteq> X \<and> A \<turnstile>\<^sub>\<forall> p\<close>
  then have *: \<open>\<nexists>A. set A \<subseteq> X \<and> \<^bold>\<not> p # A \<turnstile>\<^sub>\<forall> \<^bold>\<bottom>\<close>
    using Boole by blast

  let ?S = \<open>{\<^bold>\<not> p} \<union> X\<close>
  let ?H = \<open>Extend ?S\<close>

  have \<open>consistent ?S\<close>
    using * by (meson consistent_def derive_split1)
  moreover have \<open>infinite (UNIV - params' X)\<close>
    using assms(2-3)
    by (metis Cinfinite_csum Cnotzero_UNIV Field_card_of cinfinite_def cinfinite_mono)
  then have \<open>|UNIV :: 'f set| +c |UNIV :: 'p set| \<le>o |UNIV - params' X - params_fm (\<^bold>\<not> p)|\<close>
    using assms(3) finite_params_fm card_of_infinite_diff_finite
    by (metis ordIso_iff_ordLeq ordLeq_transitive)
  then have \<open>|UNIV :: 'f set| +c |UNIV :: 'p set| \<le>o |UNIV - (params' X \<union> params_fm (\<^bold>\<not> p))|\<close>
    by (metis Set_Diff_Un)
  then have \<open>|UNIV :: 'f set| +c |UNIV :: 'p set| \<le>o |UNIV - params' ?S|\<close>
    by (metis UN_insert insert_is_Un sup_commute)
  then have \<open>|UNIV :: ('f, 'p) fm set| \<le>o |UNIV - params' ?S|\<close>
    using assms card_of_fm ordLeq_transitive by blast
  ultimately have \<open>consistent ?H\<close> \<open>maximal ?H\<close> \<open>saturated ?H\<close>
    using MCS_Extend by fast+
  then have \<open>p \<in> ?H \<longleftrightarrow> \<lbrakk>hmodel ?H\<rbrakk> p\<close> for p
    using truth_lemma_saturation by fastforce
  then have \<open>p \<in> ?S \<longrightarrow> \<lbrakk>hmodel ?H\<rbrakk> p\<close> for p
    using Extend_subset by blast
  then have \<open>\<lbrakk>hmodel ?H\<rbrakk> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> X. \<lbrakk>hmodel ?H\<rbrakk> q\<close>
    by blast+
  moreover from this have \<open>\<lbrakk>hmodel ?H\<rbrakk> p\<close>
    using assms(1) by blast
  ultimately show False
    by simp
qed

abbreviation valid :: \<open>('f, 'p) fm \<Rightarrow> bool\<close> where
  \<open>valid p \<equiv> \<forall>M :: ('f tm, _, _) model. \<lbrakk>M\<rbrakk> p\<close>

theorem completeness:
  fixes p :: \<open>('f, 'p) fm\<close>
  assumes \<open>valid p\<close> \<open>infinite (UNIV :: 'f set)\<close> \<open>|UNIV :: 'p set| \<le>o |UNIV :: 'f set|\<close>
  shows \<open>[] \<turnstile>\<^sub>\<forall> p\<close>
proof -
  have \<open>|UNIV :: 'f set| +c |UNIV :: 'p set| \<le>o |UNIV :: 'f set|\<close>
    using assms(2-3) by (simp add: cinfinite_def csum_absorb1 ordIso_imp_ordLeq)
  then show ?thesis
    using assms strong_completeness[where X=\<open>{}\<close>] infinite_UNIV_listI by auto
qed

corollary completeness':
  fixes p :: \<open>('f, 'f) fm\<close>
  assumes \<open>valid p\<close> \<open>infinite (UNIV :: 'f set)\<close>
  shows \<open>[] \<turnstile>\<^sub>\<forall> p\<close>
  using assms completeness[of p] by simp

theorem main:
  fixes p :: \<open>('f, 'p) fm\<close>
  assumes \<open>infinite (UNIV :: 'f set)\<close> \<open>|UNIV :: 'p set| \<le>o |UNIV :: 'f set|\<close>
  shows \<open>valid p \<longleftrightarrow> [] \<turnstile>\<^sub>\<forall> p\<close>
  using assms completeness soundness' by blast

corollary main':
  fixes p :: \<open>('f, 'f) fm\<close>
  assumes \<open>infinite (UNIV :: 'f set)\<close>
  shows \<open>valid p \<longleftrightarrow> [] \<turnstile>\<^sub>\<forall> p\<close>
  using assms completeness' soundness' by blast

end


(*  Title:      HOL/Analysis/Norm_Arith.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section \<open>General linear decision procedure for normed spaces\<close>

theory Norm_Arith
imports "~~/src/HOL/Library/Sum_of_Squares"
begin

(* FIXME: move elsewhere *)
lemma sum_sqs_eq:
  fixes x::"'a::idom" shows "x * x + y * y = x * (y * 2) \<Longrightarrow> y = x"
  by algebra

lemma norm_cmul_rule_thm:
  fixes x :: "'a::real_normed_vector"
  shows "b \<ge> norm x \<Longrightarrow> \<bar>c\<bar> * b \<ge> norm (scaleR c x)"
  unfolding norm_scaleR
  apply (erule mult_left_mono)
  apply simp
  done

(* FIXME: Move all these theorems into the ML code using lemma antiquotation *)
lemma norm_add_rule_thm:
  fixes x1 x2 :: "'a::real_normed_vector"
  shows "norm x1 \<le> b1 \<Longrightarrow> norm x2 \<le> b2 \<Longrightarrow> norm (x1 + x2) \<le> b1 + b2"
  by (rule order_trans [OF norm_triangle_ineq add_mono])

lemma ge_iff_diff_ge_0:
  fixes a :: "'a::linordered_ring"
  shows "a \<ge> b \<equiv> a - b \<ge> 0"
  by (simp add: field_simps)

lemma pth_1:
  fixes x :: "'a::real_normed_vector"
  shows "x \<equiv> scaleR 1 x" by simp

lemma pth_2:
  fixes x :: "'a::real_normed_vector"
  shows "x - y \<equiv> x + -y"
  by (atomize (full)) simp

lemma pth_3:
  fixes x :: "'a::real_normed_vector"
  shows "- x \<equiv> scaleR (-1) x"
  by simp

lemma pth_4:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR 0 x \<equiv> 0"
    and "scaleR c 0 = (0::'a)"
  by simp_all

lemma pth_5:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c (scaleR d x) \<equiv> scaleR (c * d) x"
  by simp

lemma pth_6:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c (x + y) \<equiv> scaleR c x + scaleR c y"
  by (simp add: scaleR_right_distrib)

lemma pth_7:
  fixes x :: "'a::real_normed_vector"
  shows "0 + x \<equiv> x"
    and "x + 0 \<equiv> x"
  by simp_all

lemma pth_8:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d x \<equiv> scaleR (c + d) x"
  by (simp add: scaleR_left_distrib)

lemma pth_9:
  fixes x :: "'a::real_normed_vector"
  shows "(scaleR c x + z) + scaleR d x \<equiv> scaleR (c + d) x + z"
    and "scaleR c x + (scaleR d x + z) \<equiv> scaleR (c + d) x + z"
    and "(scaleR c x + w) + (scaleR d x + z) \<equiv> scaleR (c + d) x + (w + z)"
  by (simp_all add: algebra_simps)

lemma pth_a:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR 0 x + y \<equiv> y"
  by simp

lemma pth_b:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d y \<equiv> scaleR c x + scaleR d y"
    and "(scaleR c x + z) + scaleR d y \<equiv> scaleR c x + (z + scaleR d y)"
    and "scaleR c x + (scaleR d y + z) \<equiv> scaleR c x + (scaleR d y + z)"
    and "(scaleR c x + w) + (scaleR d y + z) \<equiv> scaleR c x + (w + (scaleR d y + z))"
  by (simp_all add: algebra_simps)

lemma pth_c:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d y \<equiv> scaleR d y + scaleR c x"
    and "(scaleR c x + z) + scaleR d y \<equiv> scaleR d y + (scaleR c x + z)"
    and "scaleR c x + (scaleR d y + z) \<equiv> scaleR d y + (scaleR c x + z)"
    and "(scaleR c x + w) + (scaleR d y + z) \<equiv> scaleR d y + ((scaleR c x + w) + z)"
  by (simp_all add: algebra_simps)

lemma pth_d:
  fixes x :: "'a::real_normed_vector"
  shows "x + 0 \<equiv> x"
  by simp

lemma norm_imp_pos_and_ge:
  fixes x :: "'a::real_normed_vector"
  shows "norm x \<equiv> n \<Longrightarrow> norm x \<ge> 0 \<and> n \<ge> norm x"
  by atomize auto

lemma real_eq_0_iff_le_ge_0:
  fixes x :: real
  shows "x = 0 \<equiv> x \<ge> 0 \<and> - x \<ge> 0"
  by arith

lemma norm_pths:
  fixes x :: "'a::real_normed_vector"
  shows "x = y \<longleftrightarrow> norm (x - y) \<le> 0"
    and "x \<noteq> y \<longleftrightarrow> \<not> (norm (x - y) \<le> 0)"
  using norm_ge_zero[of "x - y"] by auto

lemmas arithmetic_simps =
  arith_simps
  add_numeral_special
  add_neg_numeral_special
  mult_1_left
  mult_1_right

ML_file "normarith.ML"

method_setup norm = \<open>
  Scan.succeed (SIMPLE_METHOD' o NormArith.norm_arith_tac)
\<close> "prove simple linear statements about vector norms"

text \<open>Hence more metric properties.\<close>

lemma dist_triangle_add:
  fixes x y x' y' :: "'a::real_normed_vector"
  shows "dist (x + y) (x' + y') \<le> dist x x' + dist y y'"
  by norm

lemma dist_triangle_add_half:
  fixes x x' y y' :: "'a::real_normed_vector"
  shows "dist x x' < e / 2 \<Longrightarrow> dist y y' < e / 2 \<Longrightarrow> dist(x + y) (x' + y') < e"
  by norm

end


(*
 * Copyright 2018, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory Util
  imports Main "HOL-Word.Word"
begin

section \<open> Word related lemmas \<close>

definition
  checked_shift :: "(('a :: len) word \<Rightarrow> nat \<Rightarrow> 'a word) \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  where
    checked_shift_def[simp]:
    "checked_shift shifter x y = (if y < of_nat (len_of TYPE('a)) then shifter x (unat y) else 0)"

definition
  checked_div :: "'a \<Rightarrow> 'a \<Rightarrow> ('a :: {zero, Rings.divide})"
  where
    "checked_div x y = (if y = 0 then 0 else x div y)"

definition
  checked_mod :: "'a \<Rightarrow> 'a \<Rightarrow> ('a :: {zero, Rings.modulo})"
  where
    checked_mod_def[simp]:
    "checked_mod x y = (if y = 0 then 0 else x mod y)"

section \<open> Tuple lemmas \<close>

lemma map_snd_app [simp]:
  shows "map (snd \<circ> (\<lambda> (a , b). (a , f b))) l  =  map (f \<circ> snd) l"
  by (induct l, auto)

lemma map_snd_ignore [simp]:
  shows "map (snd \<circ> (\<lambda> (a , b). (f a , b))) l  =  map (snd) l"
  by (induct l, auto)

lemma map_fst_app [simp]:
  shows "map (fst \<circ> (\<lambda> (a , b). (f a , b))) l =  map (f \<circ> fst) l"
  by (induct l, auto)

lemma map_fst_ignore [simp]:
  shows "map (fst \<circ> (\<lambda> (a , b). (a , f b))) l = map fst l"
  by (induct l, auto)

lemma map_fst3_app2 [simp]:
  shows "map ((fst \<circ> snd) \<circ> (\<lambda> (a, b, c). (a, f b, c))) l = map (f \<circ> (fst \<circ> snd)) l"
  by (induct l, auto)

lemma map_fst3_ignore2[simp]:
  shows "map (fst \<circ> (\<lambda> (a, b, c). (a, f b, c))) l = map fst l"
  by (induct l, auto)

lemma map_snd3_ignore3[simp]:
  shows "map (fst \<circ> snd \<circ> (\<lambda> (a, b, c). (a, b, f c))) l = map (fst \<circ> snd) l"
  by (induct l, auto)

lemma map_fst3_keep:
  shows "(\<lambda>(a,b,c). (f a, b, c)) = apfst f"
  by fastforce

lemma map_snd3_keep:
  shows "(\<lambda>(a,b,c). (a, f b, c)) = apsnd (apfst f)"
  by fastforce

lemma map_thd3_keep:
  shows "(\<lambda>(a,b,c). (a, b, f c)) = apsnd (apsnd f)"
  by fastforce

lemma fst_apfst_compcomp: "f \<circ> fst \<circ> apfst g = f \<circ> g \<circ> fst"
  by (clarsimp simp add: comp_assoc)

lemma snd_apsnd_compcomp: "f \<circ> snd \<circ> apsnd g = f \<circ> g \<circ> snd"
  by (clarsimp simp add: comp_assoc)

(* making these simp makes the final force on specialise take forever? / v.jackson *)
lemma comp_tuple_in2_out2_fst: "fst \<circ> (\<lambda>(a,b). (f a b, g a b)) = (\<lambda>(a,b). f a b)"
  by force

lemma comp_tuple_in2_out2_snd: "snd \<circ> (\<lambda>(a,b). (f a b, g a b)) = (\<lambda>(a,b). g a b)"
  by force

lemma comp_tuple_in3_out2_fst: "fst \<circ> (\<lambda>(a,b,c). (f a b c, g a b c)) = (\<lambda>(a,b,c). f a b c)"
  by force

lemma comp_tuple_in3_out2_snd: "snd \<circ> (\<lambda>(a,b,c). (f a b c, g a b c)) = (\<lambda>(a,b,c). g a b c)"
  by force

lemma assoc_comp_fst_tuple_lambda: "h \<circ> fst \<circ> (\<lambda>(a,b). (f a b, g a b)) = h \<circ> (\<lambda>(a,b). f a b)"
  by force

lemma assoc_comp_snd_tuple_lambda: "h \<circ> snd \<circ> (\<lambda>(a,b). (f a b, g a b)) = h \<circ> (\<lambda>(a,b). g a b)"
  by force

lemma prod_split_asmE:
  "\<lbrakk> (a,b) = x; P (fst x) (snd x) \<rbrakk> \<Longrightarrow> P a b"
  by (clarsimp split: prod.split)

lemma prod_eq:
  "\<lbrakk> a = fst x ; b = snd x \<rbrakk> \<Longrightarrow> x = (a,b)"
  by simp

lemma if_args_cong_weak[cong]: "ab = bb \<Longrightarrow> at = bt \<Longrightarrow> af = bf \<Longrightarrow> (if ab then at else af) = (if bb then bt else bf)"
  by blast

section \<open> list related lemmas \<close>

lemma map_eq_iff_nth_eq: "(map f xs = map g ys) = (length xs = length ys \<and> (\<forall>i < length xs. f (xs ! i) = g (ys ! i)))"
  by (force simp add: list_eq_iff_nth_eq)

lemma map2_mapL: "List.map2 h (map f xs) xs = map (\<lambda>x. h (f x) x) xs"
  by (induction xs) (auto)

lemma map2_mapR: "List.map2 h xs (map g xs) = map (\<lambda>x. h x (g x)) xs"
  by (induction xs) (auto)

lemma map_fst_update:
  assumes "ts ! f = (t, x)"
    and     "f < length ts"
  shows "map fst (ts[f := (t,x')]) = map fst ts"
proof -
  from assms have  "map fst ts ! f = t" by (clarsimp)
  then show ?thesis by (auto simp add: map_update)
qed

lemma map_zip [simp]:
  shows "map (\<lambda> (a , b). (f a, g b)) (zip as bs) = zip (map f as) (map g bs)"
  by (induct as arbitrary:bs, simp, case_tac bs, simp_all)

lemma map_zip3 [simp]:
  shows "map (\<lambda> (a,b,c). (f a, g b, h c)) (zip as (zip bs cs)) = zip (map f as) (zip (map g bs) (map h cs))"
  by (induct as arbitrary: bs cs; case_tac bs; case_tac cs; simp)

lemma zip_eq_conv_sym: "length xs = length ys \<Longrightarrow> (zs = zip xs ys) = (map fst zs = xs \<and> map snd zs = ys)"
  using zip_eq_conv
  by metis

lemma replicate_eq_map_conv_nth: "length xs = n \<Longrightarrow> map f xs = replicate n x \<longleftrightarrow> (\<forall>i<length xs. f (xs ! i) = x)"
proof (induct xs arbitrary: n)
  case (Cons a as)
  moreover obtain n' where "n = Suc n'"
    using Cons.prems by auto
  moreover then have "(map f as = replicate n' x) = (length as = n' \<and> (\<forall>i<length as. f (as ! i) = x))"
    using Cons by simp
  ultimately show ?case
    by (force simp add: All_less_Suc2)
qed simp

lemma eq_updated_same_pace_imp_eq:
  assumes "length xs = length ys"
    and "i < length xs"
    and "xs[i := x] = ys[i := y]"
  shows "x = y"
  using assms
  by (induct "length xs" arbitrary: xs ys i; metis nth_list_update_eq)

lemma map_update_eq_if_indistinguishable:
  assumes
    "xs ! i = a"
    "i < length xs"
    "f (g (xs ! i)) = f (xs ! i)"
  shows "map f xs = map f (xs[i := g a])"
  using assms
  by (metis list_update_id map_update)

lemma map_proj_eq_set_zip_impl_proj_eq:
  "map P as = map Q bs \<Longrightarrow>
  (a,b) \<in> set (zip as bs) \<Longrightarrow>
  P a = Q b"
proof -
  assume A:
    "map P as = map Q bs"
    "(a,b) \<in> set (zip as bs)"
  have L: "length as = length bs"
    using A map_eq_imp_length_eq by auto
  from L A show "P a = Q b"
    by (induct as bs rule: list_induct2; auto)
qed

lemma list_all2_update_second:
  assumes "list_all2 f xs (ys[i := a])"
    and "f (xs ! i) a \<Longrightarrow> f (xs ! i) b"
  shows "list_all2 f xs (ys[i := b])"
  using assms
  by (clarsimp simp add: list_all2_conv_all_nth, metis nth_list_update_eq nth_list_update_neq)

lemma elem_in_list_set_update:
  assumes
    "x \<in> set xs \<or> x = y"
    "xs ! i \<noteq> x"
    "i < length xs"
  shows "x \<in> set (xs[i := y])"
proof -
  have "x \<in> insert y (set xs)"
    using assms by auto
  then show "x \<in> set (xs[i := y])"
    by (metis assms in_set_conv_nth length_list_update nth_list_update_neq set_update_memI)
qed

lemma distinct_fst_tags_update:
  assumes
    "distinct (map fst xs)"
    "fst (xs ! i) = a"
    "i < length xs"
  shows "distinct (map fst (xs[i := (a, b, c)]))"
  using assms
  apply (clarsimp simp add: map_update)
  apply (induct xs arbitrary: i)
   apply (simp split: nat.split add: image_set map_update[symmetric] del: image_set[symmetric])+
  done

lemma list_all_nil: "list_all P []" by simp
lemma list_all_cons: "P x \<Longrightarrow> list_all P xs \<Longrightarrow> list_all P (x # xs)" by simp

subsection \<open> list_all2 \<close>

lemmas list_all2_nil = List.list.rel_intros(1)
lemmas list_all2_cons = List.list.rel_intros(2)

lemma list_all2_eq_iff_map_eq: "list_all2 (\<lambda>x y. f x = g y) xs ys = (map f xs = map g ys)"
  by (induct xs arbitrary: ys; simp add: Cons_eq_map_conv list_all2_Cons1)

lemma list_all2_split_conj:
  shows "list_all2 (\<lambda>x y. P x y \<and> Q x y) xs ys \<longleftrightarrow> list_all2 P xs ys \<and> list_all2 Q xs ys"
  apply (rule iffI)
   apply (induct rule: list_all2_induct, simp+)
  apply (clarsimp, induct rule: list_all2_induct, simp+)
  done

lemma list_all2_split_all:
  shows "list_all2 (\<lambda>x y. \<forall>a. P x y a) xs ys \<longleftrightarrow> (\<forall>a. list_all2 (\<lambda>x y. P x y a) xs ys)"
  apply (rule iffI)
   apply (induct rule: list_all2_induct, simp+)
  apply (induct xs arbitrary: ys; case_tac ys; clarsimp)
  done

lemma list_all2_in_set1_impl_in_set_zip12_sat:
  assumes
    "list_all2 P xs ys"
    "x \<in> set xs"
  obtains y where
    "(x,y) \<in> set (zip xs ys)"
    "P x y"
  using assms by (metis fst_conv in_set_impl_in_set_zip1 in_set_zip list_all2_conv_all_nth snd_conv)

lemma list_all2_in_set_impl_sat:
  assumes
    "list_all2 P xs ys"
    "(x,y) \<in> set (zip xs ys)"
  shows
    "P x y"
  using assms
  by (metis fst_conv in_set_zip list_all2_nthD snd_conv)

lemma list_all_zip_iff_list_all2:
  assumes "length xs = length ys"
  shows "list_all P (zip xs ys) \<longleftrightarrow> list_all2 (curry P) xs ys"
  using assms
  by (induct xs ys rule: list_induct2) simp+

subsection \<open> list_all3 \<close>

inductive list_all3 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list \<Rightarrow> bool" where
  all3Nil : "list_all3 P [] [] []"
| all3Cons : "P x y z \<Longrightarrow> list_all3 P xs ys zs \<Longrightarrow> list_all3 P (x # xs) (y # ys) (z # zs)"

lemma list_all3_induct
  [consumes 1, case_names Nil Cons, induct set: list_all3]:
  assumes P: "list_all3 P xs ys zs"
  assumes Nil: "R [] [] []"
  assumes Cons: "\<And>x xs y ys z zs.
    \<lbrakk>P x y z; list_all3 P xs ys zs; R xs ys zs\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys) (z # zs)"
  shows "R xs ys zs"
  using P
  by (induct xs arbitrary: ys zs) (auto elim: list_all3.cases simp add: Nil Cons)

lemma list_induct3':
  "\<lbrakk> P [] [] [];
   \<And>x xs. P (x#xs) [] [];
   \<And>y ys. P [] (y#ys) [];
   \<And>z zs. P [] [] (z#zs);
   \<And>x xs y ys. P (x#xs) (y#ys) [];
   \<And>y ys z zs. P [] (y#ys) (z#zs);
   \<And>x xs z zs. P (x#xs) [] (z#zs);
   \<And>x xs y ys z zs. P xs ys zs  \<Longrightarrow> P (x#xs) (y#ys) (z # zs) \<rbrakk>
 \<Longrightarrow> P xs ys zs"
  apply (induct xs arbitrary: ys zs)
   apply (rename_tac ys zs, case_tac ys; case_tac zs; force)
  apply (rename_tac x xs ys zs, case_tac ys; case_tac zs; force)
  done

lemma list_all3_iff:
  "list_all3 P xs ys zs \<longleftrightarrow> length xs = length ys \<and> length ys = length zs \<and> (\<forall>(x, y, z) \<in> set (zip xs (zip ys zs)). P x y z)"
  apply (rule iffI)
   apply (induct xs ys zs rule: list_all3.induct; simp)
  apply (induct xs ys zs rule: list_induct3'; simp add: list_all3.intros)
  done

lemma list_all3_Nil1 [iff, code]: "list_all3 P [] ys zs = (ys = [] \<and> zs = [])"
  by (force simp add: list_all3_iff)

lemma list_all3_Nil2 [iff, code]: "list_all3 P xs [] zs = (xs = [] \<and> zs = [])"
  by (simp add: list_all3_iff)

lemma list_all3_Nil3 [iff, code]: "list_all3 P xs ys [] = (xs = [] \<and> ys = [])"
  by (force simp add: list_all3_iff)

lemma list_all3_Cons[iff, code]: "list_all3 P (x # xs) (y # ys) (z # zs) = (P x y z \<and> list_all3 P xs ys zs)"
  by (force simp add: list_all3_iff)

lemma list_all3_Cons1: "list_all3 P (x # xs') ys zs = (\<exists>y ys' z zs'. ys = y # ys' \<and> zs = z # zs'  \<and> (P x y z \<and> list_all3 P xs' ys' zs'))"
  by (cases ys; cases zs; force simp add: list_all3_iff)

lemma list_all3_Cons2: "list_all3 P xs (y # ys') zs = (\<exists>x xs' z zs'. xs = x # xs' \<and> zs = z # zs'  \<and> (P x y z \<and> list_all3 P xs' ys' zs'))"
  by (cases xs; cases zs; force simp add: list_all3_iff)

lemma list_all3_Cons3: "list_all3 P xs ys (z # zs') = (\<exists>x xs' y ys'. xs = x # xs' \<and> ys = y # ys'  \<and> (P x y z \<and> list_all3 P xs' ys' zs'))"
  by (cases xs; cases ys; force simp add: list_all3_iff)

lemma list_all3_mono[intro?]:
  assumes "list_all3 P xs ys zs"
    and "\<And>x y z. P x y z \<Longrightarrow> Q x y z"
  shows "list_all3 Q xs ys zs"
  using assms
  by (force simp add: list_all3_iff)

lemma list_all3_mono'[mono]: "P \<le> Q \<Longrightarrow> list_all3 P \<le> list_all3 Q"
  apply (clarsimp intro!: le_funI)
  apply (induct_tac rule: list_all3_induct)
    apply assumption
   apply (auto dest: le_funD)[2]
  done

lemma list_all3_conv_all_nth:
  "list_all3 P xs ys zs \<longleftrightarrow> length xs = length ys \<and> length ys = length zs \<and> (\<forall>i<length xs. P (xs ! i) (ys ! i) (zs ! i))"
  by (force simp add: list_all3_iff set_zip)

lemma list_all3_same:
  "list_all3 P xs xs xs = (\<forall>x\<in>set xs. P x x x)"
  by (induct xs; simp)

lemma list_all3_split_conj:
  shows "list_all3 (\<lambda> x y z. P x y z \<and> Q x y z) xs ys zs \<longleftrightarrow> list_all3 P xs ys zs \<and> list_all3 Q xs ys zs"
  apply (rule iffI)
   apply (induct rule: list_all3_induct, simp+)
  apply (clarsimp, induct rule: list_all3_induct, simp+)
  done

lemma list_all3_split_all:
  shows "list_all3 (\<lambda> x y z. \<forall>a. P x y z a) xs ys zs \<longleftrightarrow> (\<forall>a. list_all3 (\<lambda>x y z. P x y z a) xs ys zs)"
  apply (rule iffI)
   apply (induct rule: list_all3_induct, simp+)
  apply (induct xs arbitrary: ys zs; case_tac ys; case_tac zs; clarsimp)
  done

lemma list_all3_impD:
  assumes
    "list_all3 (\<lambda> x y z. P x y z \<longrightarrow> Q x y z) xs ys zs"
    "list_all3 P xs ys zs"
  shows
    "list_all3 Q xs ys zs"
  using assms
  by (induct rule: list_all3_induct, simp+)

lemma list_all3_comm1:
"list_all3 (\<lambda> x y z. P x y z) xs ys zs \<longleftrightarrow> list_all3 (\<lambda> x y z. P y x z) ys xs zs"
  by (metis (mono_tags, lifting) list_all3_conv_all_nth)

lemma list_all3_comm2:
"list_all3 (\<lambda> x y z. P x y z) xs ys zs \<longleftrightarrow> list_all3 (\<lambda> x y z. P x z y) xs zs ys"
  by (metis (mono_tags, lifting) list_all3_conv_all_nth)

lemma list_all3_comm3:
"list_all3 (\<lambda> x y z. P x y z) xs ys zs \<longleftrightarrow> list_all3 (\<lambda> x y z. P z y x) zs ys xs"
  by (metis (mono_tags, lifting) list_all3_conv_all_nth)

(* n.b. the conditions are essentially functor laws *)
lemma list_all3_map_over:
  assumes "list_all3 P xs ys zs"
  and "f [] = []" and "g [] = []" and "h [] = []"
  and "\<And>a as. f (a # as) = f' a # f as"
  and "\<And>a as. g (a # as) = g' a # g as"
  and "\<And>a as. h (a # as) = h' a # h as"
  and "\<And>x y z. P x y z \<Longrightarrow> Q (f' x) (g' y) (h' z)"
  shows "list_all3 Q (f xs) (g ys) (h zs)"
  using assms
  by (induct rule: list_all3_induct; simp)

lemma list_all3_product_over_list_all2:
  assumes "list_all3 P xs ys zs"
    and "\<And>a x y z. P x y z \<Longrightarrow> A a x \<Longrightarrow> A a y \<and> A a z"
    and "list_all2 A as xs"
  shows "list_all2 A as ys"
    and "list_all2 A as zs"
  using assms
  by (induct arbitrary: as rule: list_all3_induct, (clarsimp simp add: list_all2_Cons2)+)

subsection \<open> list_all4 \<close>

inductive list_all4 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list \<Rightarrow> 'd list \<Rightarrow> bool" where
  all4Nil : "list_all4 P [] [] [] []"
| all4Cons : "P x y z w \<Longrightarrow> list_all4 P xs ys zs ws \<Longrightarrow> list_all4 P (x # xs) (y # ys) (z # zs) (w # ws)"

lemma list_all4_induct
  [consumes 1, case_names Nil Cons, induct set: list_all4]:
  assumes P: "list_all4 P xs ys zs ws"
  assumes Nil: "R [] [] [] []"
  assumes Cons: "\<And>x xs y ys z zs  w ws.
    \<lbrakk>P x y z w; list_all4 P xs ys zs ws; R xs ys zs ws\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys) (z # zs) (w # ws)"
  shows "R xs ys zs ws"
  using P
  by (induct xs arbitrary: ys zs ws) (auto elim: list_all4.cases simp add: Nil Cons)

lemma list_induct4':
  "\<lbrakk> P [] [] [] [];
   \<And>x xs               . P (x#xs) []     []     [];
   \<And>     y ys          . P []     (y#ys) []     [];
   \<And>x xs y ys          . P (x#xs) (y#ys) []     [];
   \<And>          z zs     . P []     []     (z#zs) [];
   \<And>x xs      z zs     . P (x#xs) []     (z#zs) [];
   \<And>     y ys z zs     . P []     (y#ys) (z#zs) [];
   \<And>x xs y ys z zs     . P (x#xs) (y#ys) (z#zs) [];
   \<And>               w ws. P []     []     []     (w#ws);
   \<And>x xs           w ws. P (x#xs) []     []     (w#ws);
   \<And>     y ys      w ws. P []     (y#ys) []     (w#ws);
   \<And>x xs y ys      w ws. P (x#xs) (y#ys) []     (w#ws);
   \<And>          z zs w ws. P []     []     (z#zs) (w#ws);
   \<And>x xs      z zs w ws. P (x#xs) []     (z#zs) (w#ws);
   \<And>     y ys z zs w ws. P []     (y#ys) (z#zs) (w#ws);
   \<And>x xs y ys z zs w ws. P xs ys zs ws \<Longrightarrow> P (x#xs) (y#ys) (z#zs) (w#ws) \<rbrakk>
 \<Longrightarrow> P xs ys zs ws"
  by (induct xs arbitrary: ys zs ws; rename_tac ys zs ws, case_tac ys; case_tac zs; case_tac ws; simp)

lemma list_all4_iff:
  "list_all4 P xs ys zs ws \<longleftrightarrow>
    length xs = length ys \<and> length ys = length zs \<and> length zs = length ws \<and>
    (\<forall>(x, y, z, w) \<in> set (zip xs (zip ys (zip zs ws))). P x y z w)"
  apply (rule iffI)
   apply (induct xs ys zs ws rule: list_all4.induct; simp)
  apply (induct xs ys zs ws rule: list_induct4'; force intro!: list_all4.intros)
  done

lemma list_all4_Nil1 [iff, code]: "list_all4 P [] ys zs ws = (ys = [] \<and> zs = [] \<and> ws = [])"
  by (force simp add: list_all4_iff)

lemma list_all4_Nil2 [iff, code]: "list_all4 P xs [] zs ws = (xs = [] \<and> zs = [] \<and> ws = [])"
  by (force simp add: list_all4_iff)

lemma list_all4_Nil3 [iff, code]: "list_all4 P xs ys [] ws = (xs = [] \<and> ys = [] \<and> ws = [])"
  by (force simp add: list_all4_iff)

lemma list_all4_Nil4 [iff, code]: "list_all4 P xs ys zs [] = (xs = [] \<and> ys = [] \<and> zs = [])"
  by (force simp add: list_all4_iff)

lemma list_all4_Cons[iff, code]: "list_all4 P (x # xs) (y # ys) (z # zs) (w # ws) = (P x y z w \<and> list_all4 P xs ys zs ws)"
  by (force simp add: list_all4_iff)

lemma list_all4_Cons1: "list_all4 P (x # xs') ys zs ws =
  (\<exists>y ys' z zs' w ws'. ys = y # ys' \<and> zs = z # zs' \<and> ws = w # ws' \<and> (P x y z w \<and> list_all4 P xs' ys' zs' ws'))"
  by (cases ys; cases zs; cases ws; force simp add: list_all4_iff)

lemma list_all4_Cons2: "list_all4 P xs (y # ys') zs ws =
  (\<exists>x xs' z zs' w ws'. xs = x # xs' \<and> zs = z # zs' \<and> ws = w # ws' \<and> (P x y z w \<and> list_all4 P xs' ys' zs' ws'))"
  by (cases xs; cases zs; cases ws; force simp add: list_all4_iff)

lemma list_all4_Cons3: "list_all4 P xs ys (z # zs') ws =
  (\<exists>x xs' y ys' w ws'. xs = x # xs' \<and> ys = y # ys' \<and> ws = w # ws' \<and> (P x y z w \<and> list_all4 P xs' ys' zs' ws'))"
  by (cases xs; cases ys; cases ws; force simp add: list_all4_iff)

lemma list_all4_Cons4: "list_all4 P xs ys zs (w # ws') =
  (\<exists>x xs' y ys' z zs'. xs = x # xs' \<and> ys = y # ys' \<and> zs = z # zs' \<and> (P x y z w \<and> list_all4 P xs' ys' zs' ws'))"
  by (cases xs; cases ys; cases zs; force simp add: list_all4_iff)

lemma list_all4_mono[intro?]:
  assumes "list_all4 P xs ys zs ws"
    and "\<And>x y z w. P x y z w \<Longrightarrow> Q x y z w"
  shows "list_all4 Q xs ys zs ws"
  using assms
  by (clarsimp simp add: list_all4_iff split: prod.splits)

lemma list_all4_mono'[mono]: "P \<le> Q \<Longrightarrow> list_all4 P \<le> list_all4 Q"
  apply (clarsimp intro!: le_funI)
  apply (induct_tac rule: list_all4_induct)
    apply assumption
   apply (auto dest: le_funD)[2]
  done

lemma list_all4_conv_all_nth:
  "list_all4 P xs ys zs ws \<longleftrightarrow> length xs = length ys \<and> length ys = length zs \<and> length zs = length ws \<and>
    (\<forall>i<length xs. P (xs ! i) (ys ! i) (zs ! i) (ws ! i))"
  by (force simp add: list_all4_iff set_zip)

lemma list_all4_same:
  "list_all4 P xs xs xs xs = (\<forall>x\<in>set xs. P x x x x)"
  by (induct xs; simp)

lemma list_all4_split_conj:
  shows "list_all4 (\<lambda> x y z w. P x y z w \<and> Q x y z w) xs ys zs ws \<longleftrightarrow> list_all4 P xs ys zs ws \<and> list_all4 Q xs ys zs ws"
  apply (rule iffI)
   apply (induct rule: list_all4_induct, simp+)
  apply (clarsimp, induct rule: list_all4_induct, simp+)
  done

lemma list_all4_split_all:
  shows "list_all4 (\<lambda> x y z w. \<forall>a. P x y z w a) xs ys zs ws \<longleftrightarrow> (\<forall>a. list_all4 (\<lambda>x y z w. P x y z w a) xs ys zs ws)"
  apply (rule iffI)
   apply (induct rule: list_all4_induct, simp+)
  apply (induct xs arbitrary: ys zs ws; case_tac ys; case_tac zs; case_tac ws; clarsimp)
  done

lemma list_all4_impD:
  assumes
    "list_all4 (\<lambda>x y z w. P x y z w \<longrightarrow> Q x y z w) xs ys zs ws"
    "list_all4 P xs ys zs ws"
  shows
    "list_all4 Q xs ys zs ws"
  using assms
  by (induct rule: list_all4_induct, simp+)

section \<open> Misc lemmas \<close>

lemma distinct_fst:
  assumes "distinct (map fst xs)"
    and     "(a, b) \<in> set xs"
    and     "(a, b') \<in> set xs"
  shows   "b = b'"
  using assms image_iff
  by (induct xs, fastforce+)

lemma distinct_fst_nth:
  assumes "distinct (map fst xs)"
    and "i < length xs"
    and "xs ! i = (a, b)"
    and "j < length xs"
    and "xs ! j = (a, b')"
  shows
    "i = j"
    "b = b'"
  using assms
  by (induct xs arbitrary: i j)
      (fastforce dest: nth_mem simp add: image_iff less_Suc_eq_0_disj nth_Cons)+

lemma set_subset_map:
  assumes "set a \<subseteq> set b"
  shows   "set (map f a) \<subseteq> set (map f b)"
  using assms by auto

lemma prod_in_set:
  assumes "(a, b) \<in> set l"
  shows   "a \<in> set (map fst l)"
    and     "b \<in> set (map snd l)"
  using assms by (force intro: imageI)+

lemma filter_fst_ignore_tuple:
  shows "filter (\<lambda>x. P (fst x)) (map (\<lambda>(a,b). (a, f b)) ls)
     = map (\<lambda>(a,b). (a, f b)) (filter (\<lambda>x. P (fst x)) ls)"
  by (induct_tac ls, auto)

lemma filter_fst_ignore_triple:
  shows "filter (\<lambda>x. P (fst x)) (map (\<lambda>(a,b,c). (a, f b, c)) ls)
     = map (\<lambda>(a,b,c). (a, f b, c)) (filter (\<lambda>x. P (fst x)) ls)"
  by (induct_tac ls, auto)

lemma filter_fst_ignore_app2:
  shows "filter (\<lambda>x. P (fst x)) (map (\<lambda>(a,b,c). (a,f b,c)) ls)
     = map (\<lambda>(a,b,c). (a,f b,c)) (filter (\<lambda>x. P (fst x)) ls)"
  by (induct_tac ls, auto)

lemma filter_map_map_filter_thd3_app2:
  shows "filter (P \<circ> snd \<circ> snd) (map (\<lambda>(a, b, c). (a, f b, c)) ls) = map (\<lambda>(a, b, c). (a, f b, c)) (filter (P \<circ> snd \<circ> snd) ls)"
  by (induct_tac ls, (simp split: prod.splits)+)

lemma filter_empty_conv2: "([] = filter P xs) = (\<forall>x\<in>set xs. \<not> P x)"
  using filter_empty_conv by metis

lemma filter_eq_singleton_iff:
  shows "(filter P ys = [x]) = (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> (\<forall>u\<in>set vs. \<not> P u))"
  by (simp add: filter_eq_Cons_iff filter_empty_conv2)

lemma filter_eq_singleton_iff2:
  shows "([x] = filter P ys) = (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> (\<forall>u\<in>set vs. \<not> P u))"
  by (fastforce simp add: filter_eq_singleton_iff[symmetric])

lemma filter_member:
  assumes
    "filter P xs = ys"
    "y \<in> set ys"
  shows "y \<in> set xs"
  using assms
  apply (induct xs arbitrary: ys)
   apply clarsimp
  apply (case_tac "P a"; clarsimp)
  done

lemma filter_member2:
  assumes
    "ys = filter P xs"
    "y \<in> set ys"
  shows "y \<in> set xs"
  using assms filter_member
  by fast

lemma filter_member_unique_nth:
  assumes "filter P xs = [a]"
  shows "\<exists>!i. i < length xs \<and> xs ! i = a"
proof -
  obtain us vs where xs_decomp:
    "xs = us @ a # vs"
    "\<forall>u\<in>set us. \<not> P u"
    "P a"
    "\<forall>u\<in>set vs. \<not> P u"
    using assms
    by (clarsimp simp add: filter_eq_Cons_iff filter_empty_conv2)
  then have a_not_left_right:
    "a \<notin> set us"
    "a \<notin> set vs"
    by blast+

  have "\<And>i. \<lbrakk> i < length xs ; xs ! i = a \<rbrakk> \<Longrightarrow> i = length us"
    using a_not_left_right
    apply (clarsimp simp add: xs_decomp nth_append)
    apply (metis (no_types, lifting) add.right_neutral add_Suc_right add_diff_inverse_nat add_less_cancel_left less_Suc_eq_le nth_equal_first_eq nth_mem)
    done
  then show ?thesis
    apply (clarsimp simp add: Ex1_def Ex_less_Suc)
    apply (metis length_append length_pos_if_in_set less_add_same_cancel1 list.set_intros(1) nth_append_length xs_decomp(1))
    done
qed

lemma all_imp_conj_distrib: "(\<forall>x. P x \<longrightarrow> Q x \<and> R x) = ((\<forall>x. P x \<longrightarrow> Q x) \<and> (\<forall>x. P x \<longrightarrow> R x))"
  by blast

lemma imp2_conj_pull_out_common: "(A \<longrightarrow> B \<longrightarrow> C) \<and> (A' \<longrightarrow> B \<longrightarrow> C') \<longleftrightarrow> (B \<longrightarrow> (A \<longrightarrow> C) \<and> (A' \<longrightarrow> C'))"
  by blast

section \<open> TSum as map lemmas \<close>

abbreviation map_pairs :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) set" where
  "map_pairs m \<equiv> { z. m (fst z) = Some (snd z)}"

lemma map_pairs_map_of_set:
  assumes distinct_fst_xs: "distinct (map fst xs)"
  shows "map_pairs (map_of xs) = set xs"
  using assms
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  moreover then have "{z. ((fst z = fst x \<longrightarrow> snd x = snd z) \<and> (fst z \<noteq> fst x \<longrightarrow> map_of xs (fst z) = Some (snd z)))}
      = insert x ({z. fst z \<noteq> fst x} \<inter> set xs)"
    by force
  moreover have "set xs \<subseteq> {z. fst z \<noteq> fst x}"
    using Cons.prems prod_in_set(1) by force
  ultimately show ?case
    by (clarsimp, blast)
qed

lemma append_filter_fst_eqiv_map_update:
  assumes "set xs = map_pairs (map_of xs)"
  shows "(set ((fst z, f z) # [x\<leftarrow>xs. fst x \<noteq> fst z])) = (map_pairs ((map_of xs) (fst z \<mapsto> f z)))"
  using assms
  apply clarsimp
  apply (subst insert_def)
  apply (subst Collect_disj_eq[symmetric])
  apply force
  done

section \<open> Tagged List lemmas \<close>

subsection \<open> Tagged list update \<close>

primrec tagged_list_update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "tagged_list_update a' b' [] = []"
| "tagged_list_update a' b' (x # xs) = (case x of (a, b) \<Rightarrow>
                                      (if a = a'
                                       then (a, b') # xs
                                       else (a, b) # tagged_list_update a' b' xs))"

lemma tagged_list_update_tag_not_present[simp]:
  assumes "\<forall>i<length xs. fst (xs ! i) \<noteq> tag"
  shows "tagged_list_update tag b xs = xs"
  using assms
  by (induct xs, fastforce+)

lemma tagged_list_update_tag_present:
  assumes "\<forall>j<i. fst (xs ! j) \<noteq> tag"
    and "i<length xs"
    and "fst (xs ! i) = tag"
  shows "tagged_list_update tag b' xs = xs[i := (tag, b')]"
  using assms
proof (induct xs arbitrary: i)
  case (Cons x xs)
  then show ?case
  proof (cases i)
    case (Suc nat)
    then show ?thesis
      using Cons
    proof (cases "fst x = fst (xs ! nat)")
      case False
      then show ?thesis
        using Cons Suc
        by (simp add: case_prod_beta, metis Suc_mono nth_Cons_Suc)
    qed auto
  qed (simp add: case_prod_beta)
qed simp

lemma tagged_list_update_map_over1:
  fixes f g
  assumes inj_f: "inj f"
  shows "map (\<lambda>(tag,b). (f tag, g tag b)) (tagged_list_update tag b' xs) = tagged_list_update (f tag) (g tag b') (map (\<lambda>(tag,b). (f tag, g tag b)) xs)"
  by (induct xs, (simp add: inj_eq case_prod_beta inj_f)+)

lemma tagged_list_update_map_over2:
  assumes "\<And>tag b'. f (tag, b') = (tag, g b')"
  shows "map f (tagged_list_update tag b' xs) = tagged_list_update tag (g b') (map f xs)"
  using assms by (induct xs, clarsimp+)

lemma tagged_list_update_map_over_indistinguishable:
  assumes xs_at_i: "xs ! i = (tag, b)"
    and i_in_bounds: "i < length xs"
    and distinct_fst: "distinct (map fst xs)"
  shows "map (f \<circ> snd) (tagged_list_update tag b' xs) = (map (f \<circ> snd) xs)[i := (f b')]"
  using assms
proof (induct xs arbitrary: i)
  case (Cons x xs)
  then show ?case
  proof (cases i)
    case (Suc j)
    then show ?thesis
    proof (cases x)
      case (Pair tag' q)
      have "tag' \<noteq> tag"
        using Cons Suc Pair
        using nth_mem prod_in_set(1) by fastforce
      then show ?thesis
        using Cons Suc Pair
        by clarsimp
    qed
  qed simp
qed simp

lemma tagged_list_update_preserves_tags[simp]:
  shows "map fst (tagged_list_update tag b' xs) = map fst xs"
  by (induct xs, clarsimp+)

lemma tagged_list_update_different_tag_preserves_values1[simp]:
  "fst (xs ! i) \<noteq> tag \<Longrightarrow> (tagged_list_update tag b' xs) ! i = xs ! i"
  by (induct xs arbitrary: i, (fastforce simp add: nth_Cons')+)

lemma tagged_list_update_different_tag_preserves_values2:
  "tag \<noteq> tag' \<Longrightarrow> (tag, b) \<in> set xs \<longleftrightarrow> (tag, b) \<in> set (tagged_list_update tag' b' xs)"
proof (induct xs)
  case (Cons a xs)
  then show ?case
  proof (cases "a = (tag,b)")
    case False
    then show ?thesis
      by (clarsimp, metis Cons.hyps Cons.prems surj_pair)
  qed (simp add: Cons.prems)
qed simp+

lemma tagged_list_update_distinct:
  assumes "distinct (map fst xs)"
    and "i < length xs"
    and "fst (xs ! i) = tag"
  shows "(tagged_list_update tag b' xs) = (xs[i := (tag, b')])"
proof -
  have "\<And>j. j < length xs \<Longrightarrow> i \<noteq> j \<Longrightarrow> fst (xs ! j) \<noteq> tag"
    using assms
    by (clarsimp simp add: distinct_conv_nth)
  then have "\<forall>j<i. fst (xs ! j) \<noteq> tag"
    using assms(2) by auto
  then show ?thesis
    using assms
    by (simp add: tagged_list_update_tag_present)
qed

lemma tagged_list_update_same_distinct_is_equal:
  assumes distinct_fst_xs: "distinct (map fst xs)"
    and "i < length xs"
    and "(xs ! i) = (tag, b)"
  shows "tagged_list_update tag b xs = xs"
  using assms
proof (induct xs arbitrary: i)
  case (Cons a xs)
  then show ?case
    by (metis fst_conv list_update_id tagged_list_update_distinct)
qed simp+

lemma tagged_list_update_success_contains_updated_elem:
  assumes "i \<in> fst ` set xs"
  shows "(i, a) \<in> set (tagged_list_update i a xs)"
  using assms
  by (induct xs; fastforce)

end