(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Deterministic Transition Systems\<close>

theory DTS
  imports Main "HOL-Library.Omega_Words_Fun" "Auxiliary/Mapping2" KBPs.DFS
begin

\<comment> \<open>DTS are realised by functions\<close>

type_synonym ('a, 'b) DTS = "'a \<Rightarrow> 'b \<Rightarrow> 'a"
type_synonym ('a, 'b) transition = "('a \<times> 'b \<times> 'a)"

subsection \<open>Infinite Runs\<close>

fun run :: "('q,'a) DTS \<Rightarrow> 'q \<Rightarrow> 'a word \<Rightarrow> 'q word"
where
  "run \<delta> q\<^sub>0 w 0 = q\<^sub>0"
| "run \<delta> q\<^sub>0 w (Suc i) = \<delta> (run \<delta> q\<^sub>0 w i) (w i)"

fun run\<^sub>t :: "('q,'a) DTS \<Rightarrow> 'q \<Rightarrow> 'a word \<Rightarrow> ('q * 'a * 'q) word"
where
  "run\<^sub>t \<delta> q\<^sub>0 w i = (run \<delta> q\<^sub>0 w i, w i, run \<delta> q\<^sub>0 w (Suc i))"

lemma run_foldl:
  "run \<Delta> q\<^sub>0 w i = foldl \<Delta> q\<^sub>0 (map w [0..<i])"
  by (induction i; simp)

lemma run\<^sub>t_foldl:
  "run\<^sub>t \<Delta> q\<^sub>0 w i = (foldl \<Delta> q\<^sub>0 (map w [0..<i]), w i, foldl \<Delta> q\<^sub>0 (map w [0..<Suc i]))"
  unfolding run\<^sub>t.simps run_foldl ..

subsection \<open>Reachable States and Transitions\<close>

definition reach :: "'a set \<Rightarrow> ('b, 'a) DTS \<Rightarrow> 'b \<Rightarrow> 'b set"
where
  "reach \<Sigma> \<delta> q\<^sub>0 = {run \<delta> q\<^sub>0 w n | w n. range w \<subseteq> \<Sigma>}"

definition reach\<^sub>t :: "'a set \<Rightarrow> ('b, 'a) DTS \<Rightarrow> 'b \<Rightarrow> ('b, 'a) transition set"
where
  "reach\<^sub>t \<Sigma> \<delta> q\<^sub>0 = {run\<^sub>t \<delta> q\<^sub>0 w n | w n. range w \<subseteq> \<Sigma>}"

lemma reach_foldl_def:
  assumes "\<Sigma> \<noteq> {}"
  shows "reach \<Sigma> \<delta> q\<^sub>0 = {foldl \<delta> q\<^sub>0 w | w. set w \<subseteq> \<Sigma>}"
proof -
  {
    fix w assume "set w \<subseteq> \<Sigma>"
    moreover
    obtain a where "a \<in> \<Sigma>"
      using \<open>\<Sigma> \<noteq> {}\<close> by blast
    ultimately
    have "foldl \<delta> q\<^sub>0 w = foldl \<delta> q\<^sub>0 (prefix (length w) (w \<frown> (iter [a])))"
      and "range (w \<frown> (iter [a])) \<subseteq> \<Sigma>"
      by (unfold prefix_conc_length, auto simp add: iter_def conc_def)
    hence "\<exists>w' n. foldl \<delta> q\<^sub>0 w = run \<delta> q\<^sub>0 w' n \<and> range w' \<subseteq> \<Sigma>"
      unfolding run_foldl subsequence_def by blast
  }
  thus ?thesis
    by (fastforce simp add: reach_def run_foldl)
qed

lemma reach\<^sub>t_foldl_def:
  "reach\<^sub>t \<Sigma> \<delta> q\<^sub>0 = {(foldl \<delta> q\<^sub>0 w, \<nu>, foldl \<delta> q\<^sub>0 (w@[\<nu>])) | w \<nu>. set w \<subseteq> \<Sigma> \<and> \<nu> \<in> \<Sigma>}" (is "?lhs = ?rhs")
proof (cases "\<Sigma> \<noteq> {}")
  case True
    show ?thesis
    proof
      {
        fix w \<nu> assume "set w \<subseteq> \<Sigma>" "\<nu> \<in> \<Sigma>"
        moreover
        obtain a where "a \<in> \<Sigma>"
          using \<open>\<Sigma> \<noteq> {}\<close> by blast
        moreover
        have "w = map (\<lambda>n. if n < length w then w ! n else if n - length w = 0 then [\<nu>] ! (n - length w) else a) [0..<length w]"
          by (simp add: nth_equalityI)
        ultimately
        have "foldl \<delta> q\<^sub>0 w = foldl \<delta> q\<^sub>0 (prefix (length w) ((w @ [\<nu>]) \<frown> (iter [a])))"
          and"foldl \<delta> q\<^sub>0 (w @ [\<nu>]) = foldl \<delta> q\<^sub>0 (prefix (length (w @ [\<nu>])) ((w @ [\<nu>]) \<frown> (iter [a])))"
          and "range ((w @ [\<nu>]) \<frown> (iter [a])) \<subseteq> \<Sigma>"
          by (simp_all only: prefix_conc_length conc_conc[symmetric] iter_def)
             (auto simp add: subsequence_def conc_def upt_Suc_append[OF le0])
        moreover
        have "((w @ [\<nu>]) \<frown> (iter [a])) (length w) = \<nu>"
          by (simp add: conc_def)
        ultimately
        have "\<exists>w' n. (foldl \<delta> q\<^sub>0 w, \<nu>, foldl \<delta> q\<^sub>0 (w @ [\<nu>])) = run\<^sub>t \<delta> q\<^sub>0 w' n \<and> range w' \<subseteq> \<Sigma>"
          by (metis run\<^sub>t_foldl length_append_singleton subsequence_def)
      }
      thus "?lhs \<supseteq> ?rhs"
        unfolding reach\<^sub>t_def run\<^sub>t.simps by blast
    qed (unfold reach\<^sub>t_def run\<^sub>t_foldl, fastforce simp add: upt_Suc_append)
qed (simp add: reach\<^sub>t_def)

lemma reach_card_0:
  assumes "\<Sigma> \<noteq> {}"
  shows "infinite (reach \<Sigma> \<delta> q\<^sub>0) \<longleftrightarrow> card (reach \<Sigma> \<delta> q\<^sub>0) = 0"
proof -
  have "{run \<delta> q\<^sub>0 w n | w n. range w \<subseteq> \<Sigma>} \<noteq> {}"
    using assms by fast
  thus ?thesis
    unfolding reach_def card_eq_0_iff by auto
qed

lemma reach\<^sub>t_card_0:
  assumes "\<Sigma> \<noteq> {}"
  shows "infinite (reach\<^sub>t \<Sigma> \<delta> q\<^sub>0) \<longleftrightarrow> card (reach\<^sub>t \<Sigma> \<delta> q\<^sub>0) = 0"
proof -
  have "{run\<^sub>t \<delta> q\<^sub>0 w n | w n. range w \<subseteq> \<Sigma>} \<noteq> {}"
    using assms by fast
  thus ?thesis
    unfolding reach\<^sub>t_def card_eq_0_iff by blast
qed

subsubsection \<open>Relation to runs\<close>

lemma run_subseteq_reach:
  assumes "range w \<subseteq> \<Sigma>"
  shows "range (run \<delta> q\<^sub>0 w) \<subseteq> reach \<Sigma> \<delta> q\<^sub>0"
    and "range (run\<^sub>t \<delta> q\<^sub>0 w) \<subseteq> reach\<^sub>t \<Sigma> \<delta> q\<^sub>0"
  using assms unfolding reach_def reach\<^sub>t_def by blast+

lemma limit_subseteq_reach:
  assumes "range w \<subseteq> \<Sigma>"
  shows "limit (run \<delta> q\<^sub>0 w) \<subseteq> reach \<Sigma> \<delta> q\<^sub>0"
    and "limit (run\<^sub>t \<delta> q\<^sub>0 w) \<subseteq> reach\<^sub>t \<Sigma> \<delta> q\<^sub>0"
  using run_subseteq_reach[OF assms] limit_in_range by fast+

lemma run\<^sub>t_finite:
  assumes "finite (reach \<Sigma> \<delta> q\<^sub>0)"
  assumes "finite \<Sigma>"
  assumes "range w \<subseteq> \<Sigma>"
  defines "r \<equiv> run\<^sub>t \<delta> q\<^sub>0 w"
  shows "finite (range r)"
proof -
  let ?S = "(reach \<Sigma> \<delta> q\<^sub>0) \<times> \<Sigma> \<times> (reach \<Sigma> \<delta> q\<^sub>0)"
  have "\<And>i. w i \<in> \<Sigma>" and "\<And>i. set (map w [0..<i]) \<subseteq> \<Sigma>" and "\<Sigma> \<noteq> {}"
    using \<open>range w \<subseteq> \<Sigma>\<close> by auto
  hence "\<And>n. r n \<in> ?S"
    unfolding run\<^sub>t.simps run_foldl reach_foldl_def[OF \<open>\<Sigma> \<noteq> {}\<close>] r_def by blast
  hence "range r \<subseteq> ?S" and "finite ?S"
    using assms by blast+
  thus "finite (range r)"
    by (blast dest: finite_subset)
qed

subsubsection \<open>Compute reach Using DFS\<close>

definition Q\<^sub>L :: "'a list \<Rightarrow> ('b, 'a) DTS \<Rightarrow> 'b \<Rightarrow> 'b set"
where
  "Q\<^sub>L \<Sigma> \<delta> q\<^sub>0 = (if \<Sigma> \<noteq> [] then gen_dfs (\<lambda>q. map (\<delta> q) \<Sigma>) Set.insert (\<in>) {} [q\<^sub>0] else {})"

definition list_dfs :: "(('a, 'b) transition \<Rightarrow> ('a, 'b) transition list) \<Rightarrow> ('a, 'b) transition list => ('a, 'b) transition list => ('a, 'b) transition list"
where
  "list_dfs succ S start \<equiv> gen_dfs succ List.insert (\<lambda>x xs. x \<in> set xs) S start"

definition \<delta>\<^sub>L :: "'a list \<Rightarrow> ('b, 'a) DTS \<Rightarrow> 'b \<Rightarrow> ('b, 'a) transition set"
where
  "\<delta>\<^sub>L \<Sigma> \<delta> q\<^sub>0 = set (
    let
      start = map (\<lambda>\<nu>. (q\<^sub>0, \<nu>, \<delta> q\<^sub>0 \<nu>)) \<Sigma>;
      succ = \<lambda>(_, _, q). (map (\<lambda>\<nu>. (q, \<nu>, \<delta> q \<nu>)) \<Sigma>)
    in
      (list_dfs succ [] start))"

lemma Q\<^sub>L_reach:
  assumes "finite (reach (set \<Sigma>) \<delta> q\<^sub>0)"
  shows "Q\<^sub>L \<Sigma> \<delta> q\<^sub>0 = reach (set \<Sigma>) \<delta> q\<^sub>0"
proof (cases "\<Sigma> \<noteq> []")
  case True
    hence reach_redef: "reach (set \<Sigma>) \<delta> q\<^sub>0 = {foldl \<delta> q\<^sub>0 w | w. set w \<subseteq> set \<Sigma>}"
      using reach_foldl_def[of "set \<Sigma>"] unfolding set_empty[of \<Sigma>, symmetric] by force

    {
      fix x w y
      assume "set w \<subseteq> set \<Sigma>" "x = foldl \<delta> q\<^sub>0 w" "y \<in> set (map (\<delta> x) \<Sigma>)"
      moreover
      then obtain \<nu> where "y = \<delta> x \<nu>" and "\<nu> \<in> set \<Sigma>"
        by auto
      ultimately
      have "y = foldl \<delta> q\<^sub>0 (w@[\<nu>])" and "set (w@[\<nu>]) \<subseteq> set \<Sigma>"
        by simp+
      hence "\<exists>w'. set w' \<subseteq> set \<Sigma> \<and> y = foldl  \<delta> q\<^sub>0 w'"
        by blast
    }
    note extend_run = this

    interpret DFS "\<lambda>q. map (\<delta> q) \<Sigma>" "\<lambda>q. q \<in> reach (set \<Sigma>) \<delta> q\<^sub>0" "\<lambda>S. S \<subseteq> reach (set \<Sigma>) \<delta> q\<^sub>0" Set.insert "(\<in>)" "{}" id
      apply (unfold_locales; auto simp add: member_rec reach_redef list_all_iff elim: extend_run)
      apply (metis extend_run image_eqI set_map)
      apply (metis assms[unfolded reach_redef])
      done

    have Nil1: "set [] \<subseteq> set \<Sigma>" and Nil2: "q\<^sub>0 = foldl \<delta> q\<^sub>0 []"
      by simp+
    have list_all_init: "list_all (\<lambda>q. q \<in> reach (set \<Sigma>) \<delta> q\<^sub>0) [q\<^sub>0]"
      unfolding list_all_iff list.set reach_redef using Nil1 Nil2 by blast

    have "reach (set \<Sigma>) \<delta> q\<^sub>0 \<subseteq> reachable {q\<^sub>0}"
    proof rule
      fix x
      assume "x \<in> reach (set \<Sigma>) \<delta> q\<^sub>0"
      then obtain w where x_def: "x = foldl \<delta> q\<^sub>0 w" and "set w \<subseteq> set \<Sigma>"
        unfolding reach_redef by blast
      hence "foldl \<delta> q\<^sub>0 w \<in> reachable {q\<^sub>0}"
      proof (induction w arbitrary: x rule: rev_induct)
        case (snoc \<nu> w)
          hence "foldl \<delta> q\<^sub>0 w \<in> reachable {q\<^sub>0}" and "\<delta> (foldl \<delta> q\<^sub>0 w) \<nu> \<in> set (map (\<delta> (foldl \<delta> q\<^sub>0 w)) \<Sigma>)"
            by simp+
          thus ?case
            by (simp add: rtrancl.rtrancl_into_rtrancl reachable_def)
      qed (simp add: reachable_def)
      thus "x \<in> reachable {q\<^sub>0}"
        by (simp add: x_def)
    qed
    moreover
    have "reachable {q\<^sub>0} \<subseteq> reach (set \<Sigma>) \<delta> q\<^sub>0"
    proof rule
      fix x
      assume "x \<in> reachable {q\<^sub>0}"
      hence "(q\<^sub>0, x) \<in> {(x, y). y \<in> set (map (\<delta> x) \<Sigma>)}\<^sup>*"
        unfolding reachable_def by blast
      thus "x \<in> reach (set \<Sigma>) \<delta> q\<^sub>0"
        apply (induction)
        apply (insert reach_redef Nil1 Nil2; blast)
        apply (metis r_into_rtrancl succsr_def succsr_isNode)
        done
    qed
    ultimately
    have reachable_redef: "reachable {q\<^sub>0} = reach (set \<Sigma>) \<delta> q\<^sub>0"
      by blast

    moreover

    have "reachable {q\<^sub>0} \<subseteq> Q\<^sub>L \<Sigma> \<delta> q\<^sub>0"
      using reachable_imp_dfs[OF _ list_all_init] unfolding list.set reachable_redef
      unfolding  reach_redef Q\<^sub>L_def using \<open>\<Sigma> \<noteq> []\<close> by auto

    moreover

    have "Q\<^sub>L \<Sigma> \<delta> q\<^sub>0 \<subseteq> reach (set \<Sigma>) \<delta> q\<^sub>0"
      using dfs_invariant[of "{}", OF _ list_all_init]
      by (auto simp add: reach_redef Q\<^sub>L_def)

    ultimately
    show ?thesis
      using \<open>\<Sigma> \<noteq> []\<close> dfs_invariant[of "{}", OF _ list_all_init] by simp+
qed (simp add: reach_def Q\<^sub>L_def)

lemma \<delta>\<^sub>L_reach:
  assumes "finite (reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0)"
  shows "\<delta>\<^sub>L \<Sigma> \<delta> q\<^sub>0 = reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0"
proof -
  {
    fix x w y
    assume "set w \<subseteq> set \<Sigma>" "x = foldl \<delta> q\<^sub>0 w" "y \<in> set (map (\<delta> x) \<Sigma>)"
    moreover
    then obtain \<nu> where "y = \<delta> x \<nu>" and "\<nu> \<in> set \<Sigma>"
      by auto
    ultimately
    have "y = foldl \<delta> q\<^sub>0 (w@[\<nu>])" and "set (w@[\<nu>]) \<subseteq> set \<Sigma>"
      by simp+
    hence "\<exists>w'. set w' \<subseteq> set \<Sigma> \<and> y = foldl  \<delta> q\<^sub>0 w'"
      by blast
  }
  note extend_run = this

  let ?succs = "\<lambda>(_, _, q). (map (\<lambda>\<nu>. (q, \<nu>, \<delta> q \<nu>)) \<Sigma>)"

  interpret DFS "\<lambda>(_, _, q). (map (\<lambda>\<nu>. (q, \<nu>, \<delta> q \<nu>)) \<Sigma>)" "\<lambda>t. t \<in> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0" "\<lambda>S. set S \<subseteq> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0" List.insert "\<lambda>x xs. x \<in> set xs" "[]" id
    apply (unfold_locales; auto simp add: member_rec reach\<^sub>t_foldl_def list_all_iff elim: extend_run)
    apply (metis extend_run image_eqI set_map)
    using  assms unfolding reach\<^sub>t_foldl_def by simp

  have Nil1: "set [] \<subseteq> set \<Sigma>" and Nil2: "q\<^sub>0 = foldl \<delta> q\<^sub>0 []"
    by simp+
  have list_all_init: "list_all (\<lambda>q. q \<in> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0) (map (\<lambda>\<nu>. (q\<^sub>0, \<nu>, \<delta> q\<^sub>0 \<nu>)) \<Sigma>)"
    unfolding list_all_iff reach\<^sub>t_foldl_def set_map image_def using Nil2 by fastforce

  let ?q\<^sub>0 = "set (map (\<lambda>\<nu>. (q\<^sub>0, \<nu>, \<delta> q\<^sub>0 \<nu>)) \<Sigma>)"

  {
    fix q \<nu> q'
    assume "(q, \<nu>, q') \<in> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0"
    then obtain w where q_def: "q = foldl \<delta> q\<^sub>0 w" and q'_def: "q' = foldl \<delta> q\<^sub>0 (w@[\<nu>])"
      and "set w \<subseteq> set \<Sigma>" and "\<nu> \<in> set \<Sigma>"
      unfolding reach\<^sub>t_foldl_def by blast
    hence "(foldl \<delta> q\<^sub>0 w, \<nu>, foldl \<delta> q\<^sub>0 (w@[\<nu>])) \<in> reachable ?q\<^sub>0"
    proof (induction w arbitrary: q q' \<nu> rule: rev_induct)
      case (snoc \<nu>' w)
        hence "(foldl \<delta> q\<^sub>0 w, \<nu>', foldl \<delta> q\<^sub>0 (w@[\<nu>'])) \<in> reachable ?q\<^sub>0" (is "(?q, \<nu>', ?q') \<in> _")
          and "\<And>q. \<delta> q \<nu> \<in> set (map (\<delta> q) \<Sigma>)"
          and "\<nu> \<in> set \<Sigma>"
          by simp+
        then obtain x\<^sub>0 where 1: "(x\<^sub>0, (?q, \<nu>', ?q')) \<in> {(x, y). y \<in> set (?succs x)}\<^sup>*" and 2: "x\<^sub>0 \<in> ?q\<^sub>0"
          unfolding reachable_def by auto
        moreover
        have 3: "((?q, \<nu>', ?q'), (?q', \<nu>, \<delta> ?q' \<nu>)) \<in> {(x, y). y \<in> set (?succs x)}"
          using snoc \<open>\<And>q. \<delta> q \<nu> \<in> set (map (\<delta> q) \<Sigma>)\<close> by simp
        ultimately
        show ?case
          using rtrancl.rtrancl_into_rtrancl[OF 1 3] 2 unfolding reachable_def foldl_append foldl.simps  by auto
    qed (auto simp add: reachable_def)
    hence "(q, \<nu>, q') \<in> reachable ?q\<^sub>0"
      by (simp add: q_def q'_def)
  }
  hence "reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0 \<subseteq> reachable ?q\<^sub>0"
    by auto
  moreover
  {
    fix y
    assume "y \<in> reachable ?q\<^sub>0"
    then obtain x where "(x, y) \<in> {(x, y). y \<in> set (case x of (_, _, q) \<Rightarrow> map (\<lambda>\<nu>. (q, \<nu>, \<delta> q \<nu>)) \<Sigma>)}\<^sup>*"
      and "x \<in> ?q\<^sub>0"
      unfolding reachable_def by auto
    hence "y \<in> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0"
    proof induction
      case base
        have "\<forall>p ps. list_all p ps = (\<forall>pa. pa \<in> set ps \<longrightarrow> p pa)"
          by (meson list_all_iff)
        hence "x \<in> {(foldl \<delta> (foldl \<delta> q\<^sub>0 []) bs, b, foldl \<delta> (foldl \<delta> q\<^sub>0 []) (bs @ [b])) | bs b. set bs \<subseteq> set \<Sigma> \<and> b \<in> set \<Sigma>}"
          using base by (metis (no_types) Nil2 list_all_init reach\<^sub>t_foldl_def)
        thus ?case
          unfolding reach\<^sub>t_foldl_def by auto
    next
      case (step x' y')
        thus ?case using succsr_def succsr_isNode by blast
    qed
  }
  hence "reachable ?q\<^sub>0 \<subseteq> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0"
     by blast
  ultimately
  have reachable_redef: "reachable ?q\<^sub>0 = reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0"
    by blast

  moreover

  have "reachable ?q\<^sub>0 \<subseteq> (\<delta>\<^sub>L \<Sigma> \<delta> q\<^sub>0)"
    using reachable_imp_dfs[OF _ list_all_init] unfolding \<delta>\<^sub>L_def reachable_redef list_dfs_def
    by (simp; blast)

  moreover

  have "\<delta>\<^sub>L \<Sigma> \<delta> q\<^sub>0 \<subseteq> reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0"
    using dfs_invariant[of "[]", OF _ list_all_init]
    by (auto simp add: reach\<^sub>t_foldl_def \<delta>\<^sub>L_def list_dfs_def)

  ultimately
  show ?thesis
    by simp
qed

lemma reach_reach\<^sub>t_fst:
  "reach \<Sigma> \<delta> q\<^sub>0 = fst ` reach\<^sub>t \<Sigma> \<delta> q\<^sub>0"
  unfolding reach\<^sub>t_def reach_def image_def by fastforce

lemma finite_reach:
  "finite (reach\<^sub>t \<Sigma> \<delta> q\<^sub>0) \<Longrightarrow> finite (reach \<Sigma> \<delta> q\<^sub>0)"
  by (simp add: reach_reach\<^sub>t_fst)

lemma finite_reach\<^sub>t:
  assumes "finite (reach \<Sigma> \<delta> q\<^sub>0)"
  assumes "finite \<Sigma>"
  shows "finite (reach\<^sub>t \<Sigma> \<delta> q\<^sub>0)"
proof -
  have "reach\<^sub>t \<Sigma> \<delta> q\<^sub>0 \<subseteq> reach \<Sigma> \<delta> q\<^sub>0 \<times> \<Sigma> \<times> reach \<Sigma> \<delta> q\<^sub>0"
    unfolding reach\<^sub>t_def reach_def run\<^sub>t.simps by blast
  thus ?thesis
    using assms finite_subset by blast
qed

lemma Q\<^sub>L_eq_\<delta>\<^sub>L:
  assumes "finite (reach\<^sub>t (set \<Sigma>) \<delta> q\<^sub>0)"
  shows "Q\<^sub>L \<Sigma> \<delta> q\<^sub>0 = fst ` (\<delta>\<^sub>L \<Sigma> \<delta> q\<^sub>0)"
  unfolding set_map \<delta>\<^sub>L_reach[OF assms] Q\<^sub>L_reach[OF finite_reach[OF assms]] reach_reach\<^sub>t_fst ..

subsection \<open>Product of DTS\<close>

fun simple_product :: "('a, 'c) DTS \<Rightarrow> ('b, 'c) DTS \<Rightarrow> ('a \<times> 'b, 'c) DTS" ("_ \<times> _")
where
  "\<delta>\<^sub>1 \<times> \<delta>\<^sub>2 = (\<lambda>(q\<^sub>1, q\<^sub>2) \<nu>. (\<delta>\<^sub>1 q\<^sub>1 \<nu>, \<delta>\<^sub>2 q\<^sub>2 \<nu>))"

lemma simple_product_run:
  fixes \<delta>\<^sub>1 \<delta>\<^sub>2 w q\<^sub>1 q\<^sub>2
  defines "\<rho> \<equiv> run (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) w"
  defines "\<rho>\<^sub>1 \<equiv> run \<delta>\<^sub>1 q\<^sub>1 w"
  defines "\<rho>\<^sub>2 \<equiv> run \<delta>\<^sub>2 q\<^sub>2 w"
  shows "\<rho> i = (\<rho>\<^sub>1 i, \<rho>\<^sub>2 i)"
  by (induction i) (insert assms, auto)

theorem finite_reach_simple_product:
  assumes "finite (reach \<Sigma> \<delta>\<^sub>1 q\<^sub>1)"
  assumes "finite (reach \<Sigma> \<delta>\<^sub>2 q\<^sub>2)"
  shows "finite (reach \<Sigma> (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2))"
proof -
  have "reach \<Sigma> (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) \<subseteq> reach \<Sigma> \<delta>\<^sub>1 q\<^sub>1 \<times> reach \<Sigma> \<delta>\<^sub>2 q\<^sub>2"
    unfolding reach_def simple_product_run by blast
  thus ?thesis
    using assms finite_subset by blast
qed

subsection \<open>(Generalised) Product of DTS\<close>

fun product :: "('a \<Rightarrow> ('b, 'c) DTS) \<Rightarrow> ('a \<rightharpoonup> 'b, 'c) DTS" ("\<Delta>\<^sub>\<times>")
where
  "\<Delta>\<^sub>\<times> \<delta>\<^sub>m = (\<lambda>q \<nu>. (\<lambda>x. case q x of None \<Rightarrow> None | Some y \<Rightarrow> Some (\<delta>\<^sub>m x y \<nu>)))"

lemma product_run_None:
  fixes \<iota>\<^sub>m \<delta>\<^sub>m w
  defines "\<rho> \<equiv> run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w"
  assumes "\<iota>\<^sub>m k = None"
  shows "\<rho> i k = None"
  by (induction i) (insert assms, auto)

lemma product_run_Some:
  fixes \<iota>\<^sub>m \<delta>\<^sub>m w q\<^sub>0 k
  defines "\<rho> \<equiv> run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w"
  defines "\<rho>' \<equiv> run (\<delta>\<^sub>m k) q\<^sub>0 w"
  assumes "\<iota>\<^sub>m k = Some q\<^sub>0"
  shows "\<rho> i k = Some (\<rho>' i)"
  by (induction i) (insert assms, auto)

theorem finite_reach_product:
  assumes "finite (dom \<iota>\<^sub>m)"
  assumes "\<And>x. x \<in> dom \<iota>\<^sub>m \<Longrightarrow> finite (reach \<Sigma> (\<delta>\<^sub>m x) (the (\<iota>\<^sub>m x)))"
  shows "finite (reach \<Sigma> (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m)"
  using assms(1,2)
proof (induction "dom \<iota>\<^sub>m" arbitrary: \<iota>\<^sub>m)
  case empty
    hence "\<iota>\<^sub>m = Map.empty"
      by auto
    hence "\<And>w i. run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w i = (\<lambda>x. None)"
      using product_run_None by fast
    thus ?case
      unfolding reach_def by simp
next
  case (insert k K)
    define f where "f = (\<lambda>(q :: 'b, m :: 'a \<rightharpoonup> 'b). m(k := Some q))"
    define Reach where "Reach = (reach \<Sigma> (\<delta>\<^sub>m k) (the (\<iota>\<^sub>m k))) \<times> ((reach \<Sigma> (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) (\<iota>\<^sub>m(k := None))))"

    have "(reach \<Sigma> (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m) \<subseteq> f ` Reach"
    proof
      fix x
      assume "x \<in> reach \<Sigma> (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m"
      then obtain w n where x_def: "x = run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w n" and "range w \<subseteq> \<Sigma>"
        unfolding reach_def by blast
      {
        fix k'
        have "k' \<notin> dom \<iota>\<^sub>m \<Longrightarrow> x k' = run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) (\<iota>\<^sub>m(k := None)) w n k'"
          unfolding x_def dom_def using product_run_None[of _ _ \<delta>\<^sub>m] by simp
        moreover
        have "k' \<in> dom \<iota>\<^sub>m - {k} \<Longrightarrow> x k' = run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) (\<iota>\<^sub>m(k := None)) w n k'"
          unfolding x_def dom_def using product_run_Some[of _ _ _ \<delta>\<^sub>m] by auto
        ultimately
        have "k' \<noteq> k \<Longrightarrow> x k' = run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) (\<iota>\<^sub>m(k := None)) w n k'"
          by blast
      }
      hence "x(k := None) = run (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) (\<iota>\<^sub>m(k := None)) w n"
        using product_run_None[of _ _ \<delta>\<^sub>m] by auto
      moreover
      have "x k = Some (run (\<delta>\<^sub>m k) (the (\<iota>\<^sub>m k)) w n)"
        unfolding x_def using product_run_Some[of \<iota>\<^sub>m k _ \<delta>\<^sub>m] insert.hyps(4) by force
      ultimately
      have "(the (x k), x(k := None)) \<in> Reach"
        unfolding Reach_def reach_def using \<open>range w \<subseteq> \<Sigma>\<close> by auto
      moreover
      have "x = f (the (x k), x(k := None))"
        unfolding f_def using \<open>x k = Some (run (\<delta>\<^sub>m k) (the (\<iota>\<^sub>m k)) w n)\<close> by auto
      ultimately
      show "x \<in> f ` Reach"
         by simp
    qed
    moreover
    have "finite (reach \<Sigma> (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) (\<iota>\<^sub>m (k := None)))"
      using insert insert(3)[of "\<iota>\<^sub>m (k:=None)"] by auto
    hence "finite Reach"
      using insert Reach_def by blast
    hence "finite (f ` Reach)"
      ..
    ultimately
    show ?case
      by (rule finite_subset)
qed

subsection \<open>Simple Product Construction Helper Functions and Lemmas\<close>

fun embed_transition_fst :: "('a, 'c) transition \<Rightarrow> ('a \<times> 'b, 'c) transition set"
where
  "embed_transition_fst (q, \<nu>, q') = {((q, x), \<nu>, (q', y)) | x y. True}"

fun embed_transition_snd :: "('b, 'c) transition \<Rightarrow> ('a \<times> 'b, 'c) transition set"
where
  "embed_transition_snd (q, \<nu>, q') = {((x, q), \<nu>, (y, q')) | x y. True}"

lemma embed_transition_snd_unfold:
  "embed_transition_snd t = {((x, fst t), fst (snd t), (y, snd (snd t))) | x y. True}"
  unfolding embed_transition_snd.simps[symmetric] by simp

fun project_transition_fst :: "('a \<times> 'b, 'c) transition \<Rightarrow> ('a, 'c) transition"
where
  "project_transition_fst (x, \<nu>, y) = (fst x, \<nu>, fst y)"

fun project_transition_snd :: "('a \<times> 'b, 'c) transition \<Rightarrow> ('b, 'c) transition"
where
  "project_transition_snd (x, \<nu>, y) = (snd x, \<nu>, snd y)"

lemma
  fixes \<delta>\<^sub>1 \<delta>\<^sub>2 w q\<^sub>1 q\<^sub>2
  defines "\<rho> \<equiv> run\<^sub>t (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) w"
  defines "\<rho>\<^sub>1 \<equiv> run\<^sub>t \<delta>\<^sub>1 q\<^sub>1 w"
  defines "\<rho>\<^sub>2 \<equiv> run\<^sub>t \<delta>\<^sub>2 q\<^sub>2 w"
  shows product_run_project_fst: "project_transition_fst (\<rho> i) = \<rho>\<^sub>1 i"
    and product_run_project_snd: "project_transition_snd (\<rho> i) = \<rho>\<^sub>2 i"
    and product_run_embed_fst: "\<rho> i \<in> embed_transition_fst (\<rho>\<^sub>1 i)"
    and product_run_embed_snd: "\<rho> i \<in> embed_transition_snd (\<rho>\<^sub>2 i)"
  unfolding assms run\<^sub>t.simps simple_product_run by simp_all

lemma
  fixes \<delta>\<^sub>1 \<delta>\<^sub>2 w q\<^sub>1 q\<^sub>2
  defines "\<rho> \<equiv> run\<^sub>t (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) w"
  defines "\<rho>\<^sub>1 \<equiv> run\<^sub>t \<delta>\<^sub>1 q\<^sub>1 w"
  defines "\<rho>\<^sub>2 \<equiv> run\<^sub>t \<delta>\<^sub>2 q\<^sub>2 w"
  assumes "finite (range \<rho>)"
  shows product_run_finite_fst: "finite (range \<rho>\<^sub>1)"
    and product_run_finite_snd: "finite (range \<rho>\<^sub>2)"
proof -
  have "\<And>k. project_transition_fst (\<rho> k) = \<rho>\<^sub>1 k"
    and "\<And>k. project_transition_snd (\<rho> k) = \<rho>\<^sub>2 k"
    unfolding assms product_run_project_fst product_run_project_snd by simp+
  hence "project_transition_fst ` range \<rho> = range \<rho>\<^sub>1"
    and "project_transition_snd ` range \<rho> = range \<rho>\<^sub>2"
    using range_composition[symmetric, of project_transition_fst \<rho>]
    using range_composition[symmetric, of project_transition_snd \<rho>] by presburger+
  thus "finite (range \<rho>\<^sub>1)" and "finite (range \<rho>\<^sub>2)"
    using assms finite_imageI by metis+
qed

lemma
  fixes \<delta>\<^sub>1 \<delta>\<^sub>2 w q\<^sub>1 q\<^sub>2
  defines "\<rho> \<equiv> run\<^sub>t (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) w"
  defines "\<rho>\<^sub>1 \<equiv> run\<^sub>t \<delta>\<^sub>1 q\<^sub>1 w"
  assumes "finite (range \<rho>)"
  shows product_run_project_limit_fst: "project_transition_fst ` limit \<rho> = limit \<rho>\<^sub>1"
    and product_run_embed_limit_fst: "limit \<rho> \<subseteq> \<Union> (embed_transition_fst ` (limit \<rho>\<^sub>1))"
proof -
  have "finite (range \<rho>\<^sub>1)"
    using assms product_run_finite_fst by metis

  then obtain i where "limit \<rho> = range (suffix i \<rho>)" and "limit \<rho>\<^sub>1 = range (suffix i \<rho>\<^sub>1)"
    using common_range_limit assms by metis
  moreover
  have "\<And>k. project_transition_fst (suffix i \<rho> k) = (suffix i \<rho>\<^sub>1 k)"
    by (simp only: assms run\<^sub>t.simps) (metis \<rho>\<^sub>1_def product_run_project_fst suffix_nth)
  hence "project_transition_fst ` range (suffix i \<rho>) = (range (suffix i \<rho>\<^sub>1))"
    using range_composition[symmetric, of "project_transition_fst" "suffix i \<rho>"] by presburger
  moreover
  have "\<And>k. (suffix i \<rho> k) \<in> embed_transition_fst (suffix i \<rho>\<^sub>1 k)"
    using assms product_run_embed_fst by simp
  ultimately
  show "project_transition_fst ` limit \<rho> = limit \<rho>\<^sub>1"
    and "limit \<rho> \<subseteq> \<Union> (embed_transition_fst ` (limit \<rho>\<^sub>1))"
    by auto
qed

lemma
  fixes \<delta>\<^sub>1 \<delta>\<^sub>2 w q\<^sub>1 q\<^sub>2
  defines "\<rho> \<equiv> run\<^sub>t (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) w"
  defines "\<rho>\<^sub>2 \<equiv> run\<^sub>t \<delta>\<^sub>2 q\<^sub>2 w"
  assumes "finite (range \<rho>)"
  shows product_run_project_limit_snd: "project_transition_snd ` limit \<rho> = limit \<rho>\<^sub>2"
    and product_run_embed_limit_snd: "limit \<rho> \<subseteq> \<Union> (embed_transition_snd ` (limit \<rho>\<^sub>2))"
proof -
  have "finite (range \<rho>\<^sub>2)"
    using assms product_run_finite_snd by metis

  then obtain i where "limit \<rho> = range (suffix i \<rho>)" and "limit \<rho>\<^sub>2 = range (suffix i \<rho>\<^sub>2)"
    using common_range_limit assms by metis
  moreover
  have "\<And>k. project_transition_snd (suffix i \<rho> k) = (suffix i \<rho>\<^sub>2 k)"
    by (simp only: assms run\<^sub>t.simps) (metis \<rho>\<^sub>2_def product_run_project_snd suffix_nth)
  hence "project_transition_snd ` range ((suffix i \<rho>)) = (range (suffix i \<rho>\<^sub>2))"
    using range_composition[symmetric, of "project_transition_snd" "(suffix i \<rho>)"] by presburger
  moreover
  have "\<And>k. (suffix i \<rho> k) \<in> embed_transition_snd (suffix i \<rho>\<^sub>2 k)"
    using assms product_run_embed_snd by simp
  ultimately
  show "project_transition_snd ` limit \<rho> = limit \<rho>\<^sub>2"
    and "limit \<rho> \<subseteq> \<Union> (embed_transition_snd ` (limit \<rho>\<^sub>2))"
    by auto
qed

lemma
  fixes \<delta>\<^sub>1 \<delta>\<^sub>2 w q\<^sub>1 q\<^sub>2
  defines "\<rho> \<equiv> run\<^sub>t (\<delta>\<^sub>1 \<times> \<delta>\<^sub>2) (q\<^sub>1, q\<^sub>2) w"
  defines "\<rho>\<^sub>1 \<equiv> run\<^sub>t \<delta>\<^sub>1 q\<^sub>1 w"
  defines "\<rho>\<^sub>2 \<equiv> run\<^sub>t \<delta>\<^sub>2 q\<^sub>2 w"
  assumes "finite (range \<rho>)"
  shows product_run_embed_limit_finiteness_fst: "limit \<rho> \<inter> (\<Union> (embed_transition_fst ` S)) = {} \<longleftrightarrow> limit \<rho>\<^sub>1 \<inter> S = {}" (is "?thesis1")
    and product_run_embed_limit_finiteness_snd: "limit \<rho> \<inter> (\<Union> (embed_transition_snd ` S')) = {} \<longleftrightarrow> limit \<rho>\<^sub>2 \<inter> S' = {}" (is "?thesis2")
proof -
  show ?thesis1
    using assms product_run_project_limit_fst by fastforce
  show ?thesis2
    using assms product_run_project_limit_snd by fastforce
qed

subsection \<open>Product Construction Helper Functions and Lemmas\<close>

fun embed_transition :: "'a \<Rightarrow> ('b, 'c) transition \<Rightarrow> ('a \<rightharpoonup> 'b, 'c) transition set" ("\<upharpoonleft>\<^sub>_")
where
  "\<upharpoonleft>\<^sub>x (q, \<nu>, q') = {(m, \<nu>, m') | m m'. m x = Some q \<and> m' x = Some q'}"

fun project_transition :: "'a \<Rightarrow> ('a \<rightharpoonup> 'b, 'c) transition \<Rightarrow> ('b, 'c) transition" ("\<downharpoonleft>\<^sub>_")
where
  "\<downharpoonleft>\<^sub>x (m, \<nu>, m') = (the (m x), \<nu>, the (m' x))"

fun embed_pair :: "'a \<Rightarrow> (('b, 'c) transition set \<times> ('b, 'c) transition set) \<Rightarrow> (('a \<rightharpoonup> 'b, 'c) transition set \<times> ('a \<rightharpoonup> 'b, 'c) transition set)" ("\<^bold>\<upharpoonleft>\<^sub>_")
where
  "\<^bold>\<upharpoonleft>\<^sub>x (S, S') = (\<Union>(\<upharpoonleft>\<^sub>x ` S), \<Union>(\<upharpoonleft>\<^sub>x ` S'))"

fun project_pair :: "'a \<Rightarrow> (('a \<rightharpoonup> 'b, 'c) transition set \<times> ('a \<rightharpoonup> 'b, 'c) transition set) \<Rightarrow> (('b, 'c) transition set \<times> ('b, 'c) transition set)" ("\<^bold>\<downharpoonleft>\<^sub>_")
where
  "\<^bold>\<downharpoonleft>\<^sub>x (S, S') = (\<downharpoonleft>\<^sub>x ` S, \<downharpoonleft>\<^sub>x ` S')"

lemma embed_transition_unfold:
  "embed_transition x t = {(m, fst (snd t), m') | m m'. m x = Some (fst t) \<and> m' x = Some (snd (snd t))}"
  unfolding embed_transition.simps[symmetric] by simp

lemma
  fixes \<iota>\<^sub>m \<delta>\<^sub>m w q\<^sub>0
  fixes x :: "'a"
  defines "\<rho> \<equiv> run\<^sub>t (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w"
  defines "\<rho>' \<equiv> run\<^sub>t (\<delta>\<^sub>m x) q\<^sub>0 w"
  assumes "\<iota>\<^sub>m x = Some q\<^sub>0"
  shows product_run_project: "\<downharpoonleft>\<^sub>x (\<rho> i) = \<rho>' i"
    and product_run_embed: "\<rho> i \<in> \<upharpoonleft>\<^sub>x (\<rho>' i)"
  using assms product_run_Some[of _ _ _ \<delta>\<^sub>m] by simp+

lemma
  fixes \<iota>\<^sub>m \<delta>\<^sub>m w q\<^sub>0 x
  defines "\<rho> \<equiv> run\<^sub>t (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w"
  defines "\<rho>' \<equiv> run\<^sub>t (\<delta>\<^sub>m x) q\<^sub>0 w"
  assumes "\<iota>\<^sub>m x = Some q\<^sub>0"
  assumes "finite (range \<rho>)"
  shows product_run_project_limit: "\<downharpoonleft>\<^sub>x ` limit \<rho> = limit \<rho>'"
    and product_run_embed_limit: "limit \<rho> \<subseteq> \<Union> (\<upharpoonleft>\<^sub>x ` (limit \<rho>'))"
proof -
  have "\<And>k. \<downharpoonleft>\<^sub>x (\<rho> k) = \<rho>' k"
    using assms product_run_embed[of _ _ _ \<delta>\<^sub>m] by simp
  hence "\<downharpoonleft>\<^sub>x ` range \<rho> = range \<rho>'"
    using range_composition[symmetric, of "\<downharpoonleft>\<^sub>x" \<rho>] by presburger
  hence "finite (range \<rho>')"
    using assms finite_imageI by metis

  then obtain i where "limit \<rho> = range (suffix i \<rho>)" and "limit \<rho>' = range (suffix i \<rho>')"
    using common_range_limit assms by metis
  moreover
  have "\<And>k. \<downharpoonleft>\<^sub>x (suffix i \<rho> k) = (suffix i \<rho>' k)"
    using assms product_run_embed[of _ _ _ \<delta>\<^sub>m] by simp
  hence "\<downharpoonleft>\<^sub>x ` range ((suffix i \<rho>)) = (range (suffix i \<rho>'))"
    using range_composition[symmetric, of "\<downharpoonleft>\<^sub>x" "(suffix i  \<rho>)"] by presburger
  moreover
  have "\<And>k. (suffix i \<rho> k) \<in> \<upharpoonleft>\<^sub>x (suffix i \<rho>' k)"
    using assms product_run_embed[of _ _ _ \<delta>\<^sub>m] by simp
  ultimately
  show "\<downharpoonleft>\<^sub>x ` limit \<rho> = limit \<rho>'" and "limit \<rho> \<subseteq> \<Union> (\<upharpoonleft>\<^sub>x ` (limit \<rho>'))"
    by auto
qed

lemma product_run_embed_limit_finiteness:
  fixes \<iota>\<^sub>m \<delta>\<^sub>m w q\<^sub>0 k
  defines "\<rho> \<equiv> run\<^sub>t (\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w"
  defines "\<rho>' \<equiv> run\<^sub>t (\<delta>\<^sub>m k) q\<^sub>0 w"
  assumes "\<iota>\<^sub>m k = Some q\<^sub>0"
  assumes "finite (range \<rho>)"
  shows "limit \<rho> \<inter> (\<Union> (\<upharpoonleft>\<^sub>k ` S)) = {} \<longleftrightarrow> limit \<rho>' \<inter> S = {}"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have "\<downharpoonleft>\<^sub>k ` limit \<rho> \<inter> S \<noteq> {} \<longrightarrow> limit \<rho> \<inter> (\<Union> (\<upharpoonleft>\<^sub>k ` S)) \<noteq> {}"
  proof
    assume "\<downharpoonleft>\<^sub>k ` limit \<rho> \<inter> S \<noteq> {}"
    then obtain q \<nu> q' where "(q, \<nu>, q') \<in> \<downharpoonleft>\<^sub>k ` limit \<rho>" and "(q, \<nu>, q') \<in> S"
      by auto
    moreover
    have "\<And>m \<nu> m' i. (m, \<nu>, m') = \<rho> i \<Longrightarrow> \<exists>p p'. m k = Some p \<and> m' k = Some p'"
      using assms product_run_Some[of \<iota>\<^sub>m , OF assms(3)] by auto
    hence "\<And>m \<nu> m'. (m, \<nu>, m') \<in> limit \<rho> \<Longrightarrow> \<exists>p p'. m k = Some p \<and> m' k = Some p'"
      using limit_in_range by fast
    ultimately
    obtain m m' where "m k = Some q" and "m' k = Some q'" and "(m, \<nu>, m') \<in> limit \<rho>"
      by auto
    moreover
    hence "(m, \<nu>, m') \<in> \<Union> (\<upharpoonleft>\<^sub>k ` S)"
      using \<open>(q, \<nu>, q') \<in> S\<close> by force
    ultimately
    show "limit \<rho> \<inter> (\<Union> (\<upharpoonleft>\<^sub>k ` S)) \<noteq> {}"
      by blast
  qed
  hence "?lhs \<longleftrightarrow> \<downharpoonleft>\<^sub>k ` limit \<rho> \<inter> S = {}"
    by auto
  also
  have "\<dots> \<longleftrightarrow> ?rhs"
    using assms product_run_project_limit[of _ _ _ \<delta>\<^sub>m] by simp
  finally
  show ?thesis
    by simp
qed

subsection \<open>Transfer Rules\<close>

context includes lifting_syntax
begin

lemma product_parametric [transfer_rule]:
  "((A ===> B ===> C ===> B) ===> (A ===> rel_option B) ===> C ===> A ===> rel_option B) product product"
  by (auto simp add: rel_fun_def rel_option_iff split: option.split)

lemma run_parametric [transfer_rule]:
  "((A ===> B ===> A) ===> A ===> ((=) ===> B) ===> (=) ===> A) run run"
proof -
  {
    fix \<delta> \<delta>' q q' n w
    fix w' :: "nat \<Rightarrow> 'd"
    assume "(A ===> B ===> A) \<delta> \<delta>'" "A q q'" "((=) ===> B) w w'"
    hence "A (run \<delta> q w n) (run \<delta>' q' w' n)"
      by (induction n) (simp_all add: rel_fun_def)
  }
  thus ?thesis
    by blast
qed

lemma reach_parametric [transfer_rule]:
  assumes "bi_total B"
  assumes "bi_unique B"
  shows "(rel_set B ===> (A ===> B ===> A) ===> A ===> rel_set A) reach reach"
proof standard+
  fix \<Sigma> \<Sigma>' \<delta> \<delta>' q q'
  assume "rel_set B \<Sigma> \<Sigma>'" "(A ===> B ===> A) \<delta> \<delta>'" "A q q'"

  {
    fix z
    assume "z \<in> reach \<Sigma> \<delta> q"
    then obtain w n where "z = run \<delta> q w n" and "range w \<subseteq> \<Sigma>"
      unfolding reach_def by auto

    define w' where "w' n = (SOME x. B (w n) x)" for n

    have "\<And>n. w n \<in> \<Sigma>"
      using \<open>range w \<subseteq> \<Sigma>\<close> by blast
    hence "\<And>n. w' n \<in> \<Sigma>'"
      using assms \<open>rel_set B \<Sigma> \<Sigma>'\<close> by (simp add: w'_def bi_unique_def rel_set_def; metis someI)
    hence "run \<delta>' q' w' n \<in> reach \<Sigma>' \<delta>' q'"
      unfolding reach_def by auto

    moreover

    have "A z (run \<delta>' q' w' n)"
      apply (unfold \<open>z = run \<delta> q w n\<close>)
      apply (insert \<open>A q q'\<close> \<open>(A ===> B ===> A) \<delta> \<delta>'\<close> assms(1))
      apply (induction n)
      apply (simp_all add: rel_fun_def bi_total_def w'_def)
      by (metis tfl_some)

    ultimately

    have "\<exists>z' \<in> reach \<Sigma>' \<delta>' q'. A z z'"
      by blast
  }

  moreover

  {
    fix z
    assume "z \<in> reach \<Sigma>' \<delta>' q'"
    then obtain w n where "z = run \<delta>' q' w n" and "range w \<subseteq> \<Sigma>'"
      unfolding reach_def by auto

    define w' where "w' n = (SOME x. B x (w n))" for n

    have "\<And>n. w n \<in> \<Sigma>'"
      using \<open>range w \<subseteq> \<Sigma>'\<close> by blast
    hence "\<And>n. w' n \<in> \<Sigma>"
      using assms \<open>rel_set B \<Sigma> \<Sigma>'\<close> by (simp add: w'_def bi_unique_def rel_set_def; metis someI)
    hence "run \<delta> q w' n \<in> reach \<Sigma> \<delta> q"
      unfolding reach_def by auto

    moreover

    have "A (run \<delta> q w' n) z"
      apply (unfold \<open>z = run \<delta>' q' w n\<close>)
      apply (insert \<open>A q q'\<close> \<open>(A ===> B ===> A) \<delta> \<delta>'\<close> assms(1))
      apply (induction n)
      apply (simp_all add: rel_fun_def bi_total_def w'_def)
      by (metis tfl_some)

    ultimately

    have "\<exists>z' \<in> reach \<Sigma> \<delta> q. A z' z"
      by blast
  }
  ultimately
  show "rel_set A (reach \<Sigma> \<delta> q) (reach \<Sigma>' \<delta>' q')"
    unfolding rel_set_def by blast
qed

end

subsection \<open>Lift to Mapping\<close>

lift_definition product_abs :: "('a \<Rightarrow> ('b, 'c) DTS) \<Rightarrow> (('a, 'b) mapping, 'c) DTS" ("\<up>\<Delta>\<^sub>\<times>") is product
  parametric product_parametric .

lemma product_abs_run_None:
  "Mapping.lookup \<iota>\<^sub>m k = None \<Longrightarrow> Mapping.lookup (run (\<up>\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w i) k = None"
  by (transfer; insert product_run_None)

lemma product_abs_run_Some:
  "Mapping.lookup \<iota>\<^sub>m k = Some q\<^sub>0 \<Longrightarrow> Mapping.lookup (run (\<up>\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m w i) k = Some (run (\<delta>\<^sub>m k) q\<^sub>0 w i)"
  by (transfer; insert product_run_Some)

theorem finite_reach_product_abs:
  assumes "finite (Mapping.keys \<iota>\<^sub>m)"
  assumes "\<And>x. x \<in> (Mapping.keys \<iota>\<^sub>m) \<Longrightarrow> finite (reach \<Sigma> (\<delta>\<^sub>m x) (the (Mapping.lookup \<iota>\<^sub>m x)))"
  shows "finite (reach \<Sigma> (\<up>\<Delta>\<^sub>\<times> \<delta>\<^sub>m) \<iota>\<^sub>m)"
  using assms by (transfer; blast intro: finite_reach_product)

end


(* Title: thys/Turing.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter \<open>Turing Machines\<close>

theory Turing
  imports Main
begin

section \<open>Basic definitions of Turing machine\<close>

datatype action = W0 | W1 | L | R | Nop

datatype cell = Bk | Oc

type_synonym tape = "cell list \<times> cell list"

type_synonym state = nat

type_synonym instr = "action \<times> state"

type_synonym tprog = "instr list \<times> nat"

type_synonym tprog0 = "instr list"

type_synonym config = "state \<times> tape"

fun nth_of where
  "nth_of xs i = (if i \<ge> length xs then None else Some (xs ! i))"

lemma nth_of_map [simp]:
  shows "nth_of (map f p) n = (case (nth_of p n) of None \<Rightarrow> None | Some x \<Rightarrow> Some (f x))"
  by simp

fun
  fetch :: "instr list \<Rightarrow> state \<Rightarrow> cell \<Rightarrow> instr"
  where
    "fetch p 0 b = (Nop, 0)"
  | "fetch p (Suc s) Bk =
     (case nth_of p (2 * s) of
        Some i \<Rightarrow> i
      | None \<Rightarrow> (Nop, 0))"
  |"fetch p (Suc s) Oc =
     (case nth_of p ((2 * s) + 1) of
         Some i \<Rightarrow> i
       | None \<Rightarrow> (Nop, 0))"

lemma fetch_Nil [simp]:
  shows "fetch [] s b = (Nop, 0)"
  by (cases s,force) (cases b;force)

fun
  update :: "action \<Rightarrow> tape \<Rightarrow> tape"
  where
    "update W0 (l, r) = (l, Bk # (tl r))"
  | "update W1 (l, r) = (l, Oc # (tl r))"
  | "update L (l, r) = (if l = [] then ([], Bk # r) else (tl l, (hd l) # r))"
  | "update R (l, r) = (if r = [] then (Bk # l, []) else ((hd r) # l, tl r))"
  | "update Nop (l, r) = (l, r)"

abbreviation
  "read r == if (r = []) then Bk else hd r"

fun step :: "config \<Rightarrow> tprog \<Rightarrow> config"
  where
    "step (s, l, r) (p, off) =
     (let (a, s') = fetch p (s - off) (read r) in (s', update a (l, r)))"

abbreviation
  "step0 c p \<equiv> step c (p, 0)"

fun steps :: "config \<Rightarrow> tprog \<Rightarrow> nat \<Rightarrow> config"
  where
    "steps c p 0 = c" |
    "steps c p (Suc n) = steps (step c p) p n"

abbreviation
  "steps0 c p n \<equiv> steps c (p, 0) n"

lemma steps_add [simp]:
  shows "steps c p (m + n) = steps (steps c p m) p n"
  by (induct m arbitrary: c) (auto)

lemma step_0 [simp]:
  shows "step (0, (l, r)) p = (0, (l, r))"
  by (cases p, simp)

lemma steps_0 [simp]:
  shows "steps (0, (l, r)) p n = (0, (l, r))"
  by (induct n) (simp_all)

fun
  is_final :: "config \<Rightarrow> bool"
  where
    "is_final (s, l, r) = (s = 0)"

lemma is_final_eq:
  shows "is_final (s, tp) = (s = 0)"
  by (cases tp) (auto)

lemma is_finalI [intro]:
  shows "is_final (0, tp)"
  by (simp add: is_final_eq)

lemma after_is_final:
  assumes "is_final c"
  shows "is_final (steps c p n)"
  using assms
  by(induct n;cases c;auto)

lemma is_final:
  assumes a: "is_final (steps c p n1)"
    and b: "n1 \<le> n2"
  shows "is_final (steps c p n2)"
proof -
  obtain n3 where eq: "n2 = n1 + n3" using b by (metis le_iff_add)
  from a show "is_final (steps c p n2)" unfolding eq
    by (simp add: after_is_final)
qed

lemma not_is_final:
  assumes a: "\<not> is_final (steps c p n1)"
    and b: "n2 \<le> n1"
  shows "\<not> is_final (steps c p n2)"
proof (rule notI)
  obtain n3 where eq: "n1 = n2 + n3" using b by (metis le_iff_add)
  assume "is_final (steps c p n2)"
  then have "is_final (steps c p n1)" unfolding eq
    by (simp add: after_is_final)
  with a show "False" by simp
qed

(* if the machine is in the halting state, there must have
   been a state just before the halting state *)
lemma before_final:
  assumes "steps0 (1, tp) A n = (0, tp')"
  shows "\<exists> n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')"
  using assms
proof(induct n arbitrary: tp')
  case (0 tp')
  have asm: "steps0 (1, tp) A 0 = (0, tp')" by fact
  then show "\<exists>n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')"
    by simp
next
  case (Suc n tp')
  have ih: "\<And>tp'. steps0 (1, tp) A n = (0, tp') \<Longrightarrow>
    \<exists>n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')" by fact
  have asm: "steps0 (1, tp) A (Suc n) = (0, tp')" by fact
  obtain s l r where cases: "steps0 (1, tp) A n = (s, l, r)"
    by (auto intro: is_final.cases)
  then show "\<exists>n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')"
  proof (cases "s = 0")
    case True (* in halting state *)
    then have "steps0 (1, tp) A n = (0, tp')"
      using asm cases by (simp del: steps.simps)
    then show ?thesis using ih by simp
  next
    case False (* not in halting state *)
    then have "\<not> is_final (steps0 (1, tp) A n) \<and> steps0 (1, tp) A (Suc n) = (0, tp')"
      using asm cases by simp
    then show ?thesis by auto
  qed
qed

lemma least_steps:
  assumes "steps0 (1, tp) A n = (0, tp')"
  shows "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tp) A n'')) \<and>
               (\<forall>n'' \<ge> n'. is_final (steps0 (1, tp) A n''))"
proof -
  from before_final[OF assms]
  obtain n' where
    before: "\<not> is_final (steps0 (1, tp) A n')" and
    final: "steps0 (1, tp) A (Suc n') = (0, tp')" by auto
  from before
  have "\<forall>n'' < Suc n'. \<not> is_final (steps0 (1, tp) A n'')"
    using not_is_final by auto
  moreover
  from final
  have "\<forall>n'' \<ge> Suc n'. is_final (steps0 (1, tp) A n'')"
    using is_final[of _ _ "Suc n'"] by (auto simp add: is_final_eq)
  ultimately
  show "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tp) A n'')) \<and> (\<forall>n'' \<ge> n'. is_final (steps0 (1, tp) A n''))"
    by blast
qed

(* well-formedness of Turing machine programs *)
abbreviation "is_even n \<equiv> (n::nat) mod 2 = 0"

fun
  tm_wf :: "tprog \<Rightarrow> bool"
  where
    "tm_wf (p, off) = (length p \<ge> 2 \<and> is_even (length p) \<and>
                    (\<forall>(a, s) \<in> set p. s \<le> length p div 2 + off \<and> s \<ge> off))"

abbreviation
  "tm_wf0 p \<equiv> tm_wf (p, 0)"

abbreviation exponent :: "'a \<Rightarrow> nat \<Rightarrow> 'a list" ("_ \<up> _" [100, 99] 100)
  where "x \<up> n == replicate n x"

lemma hd_repeat_cases:
  "P (hd (a \<up> m @ r)) \<longleftrightarrow> (m = 0 \<longrightarrow> P (hd r)) \<and> (\<forall>nat. m = Suc nat \<longrightarrow> P a)"
  by (cases m,auto)

class tape =
  fixes tape_of :: "'a \<Rightarrow> cell list" ("<_>" 100)

instantiation nat::tape begin
definition tape_of_nat where "tape_of_nat (n::nat) \<equiv> Oc \<up> (Suc n)"
instance by standard
end

type_synonym nat_list = "nat list"

instantiation list::(tape) tape begin
fun tape_of_nat_list :: "('a::tape) list \<Rightarrow> cell list"
  where
    "tape_of_nat_list [] = []" |
    "tape_of_nat_list [n] = <n>" |
    "tape_of_nat_list (n#ns) = <n> @ Bk # (tape_of_nat_list ns)"
definition tape_of_list where "tape_of_list \<equiv> tape_of_nat_list"
instance by standard
end

instantiation prod:: (tape, tape) tape begin
fun tape_of_nat_prod :: "('a::tape) \<times> ('b::tape) \<Rightarrow> cell list"
  where "tape_of_nat_prod (n, m) = <n> @ [Bk] @ <m>"
definition tape_of_prod where "tape_of_prod \<equiv> tape_of_nat_prod"
instance by standard
end

fun
  shift :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
  where
    "shift p n = (map (\<lambda> (a, s). (a, (if s = 0 then 0 else s + n))) p)"

fun
  adjust :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
  where
    "adjust p e = map (\<lambda> (a, s). (a, if s = 0 then e else s)) p"

abbreviation
  "adjust0 p \<equiv> adjust p (Suc (length p div 2))"

lemma length_shift [simp]:
  shows "length (shift p n) = length p"
  by simp

lemma length_adjust [simp]:
  shows "length (adjust p n) = length p"
  by (induct p) (auto)

(* composition of two Turing machines *)
fun
  tm_comp :: "instr list \<Rightarrow> instr list \<Rightarrow> instr list" ("_ |+| _" [0, 0] 100)
  where
    "tm_comp p1 p2 = ((adjust0 p1) @ (shift p2 (length p1 div 2)))"

lemma tm_comp_length:
  shows "length (A |+| B) = length A + length B"
  by auto

lemma tm_comp_wf[intro]:
  "\<lbrakk>tm_wf (A, 0); tm_wf (B, 0)\<rbrakk> \<Longrightarrow> tm_wf (A |+| B, 0)"
  by (fastforce)

lemma tm_comp_step:
  assumes unfinal: "\<not> is_final (step0 c A)"
  shows "step0 c (A |+| B) = step0 c A"
proof -
  obtain s l r where eq: "c = (s, l, r)" by (metis is_final.cases)
  have "\<not> is_final (step0 (s, l, r) A)" using unfinal eq by simp
  then have "case (fetch A s (read r)) of (a, s) \<Rightarrow> s \<noteq> 0"
    by (auto simp add: is_final_eq)
  then have "fetch (A |+| B) s (read r) = fetch A s (read r)"
    apply (cases "read r";cases s)
    by (auto simp: tm_comp_length nth_append)
  then show "step0 c (A |+| B) = step0 c A" by (simp add: eq)
qed

lemma tm_comp_steps:
  assumes "\<not> is_final (steps0 c A n)"
  shows "steps0 c (A |+| B) n = steps0 c A n"
  using assms
proof(induct n)
  case 0
  then show "steps0 c (A |+| B) 0 = steps0 c A 0" by auto
next
  case (Suc n)
  have ih: "\<not> is_final (steps0 c A n) \<Longrightarrow> steps0 c (A |+| B) n = steps0 c A n" by fact
  have fin: "\<not> is_final (steps0 c A (Suc n))" by fact
  then have fin1: "\<not> is_final (step0 (steps0 c A n) A)"
    by (auto simp only: step_red)
  then have fin2: "\<not> is_final (steps0 c A n)"
    by (metis is_final_eq step_0 surj_pair)

  have "steps0 c (A |+| B) (Suc n) = step0 (steps0 c (A |+| B) n) (A |+| B)"
    by (simp only: step_red)
  also have "... = step0 (steps0 c A n) (A |+| B)" by (simp only: ih[OF fin2])
  also have "... = step0 (steps0 c A n) A" by (simp only: tm_comp_step[OF fin1])
  finally show "steps0 c (A |+| B) (Suc n) = steps0 c A (Suc n)"
    by (simp only: step_red)
qed

lemma tm_comp_fetch_in_A:
  assumes h1: "fetch A s x = (a, 0)"
    and h2: "s \<le> length A div 2"
    and h3: "s \<noteq> 0"
  shows "fetch (A |+| B) s x = (a, Suc (length A div 2))"
  using h1 h2 h3
  apply(cases s;cases x)
  by(auto simp: tm_comp_length nth_append)

lemma tm_comp_exec_after_first:
  assumes h1: "\<not> is_final c"
    and h2: "step0 c A = (0, tp)"
    and h3: "fst c \<le> length A div 2"
  shows "step0 c (A |+| B) = (Suc (length A div 2), tp)"
  using h1 h2 h3
  apply(case_tac c)
  apply(auto simp del: tm_comp.simps)
   apply(case_tac "fetch A a Bk")
   apply(simp del: tm_comp.simps)
   apply(subst tm_comp_fetch_in_A;force)
  apply(case_tac "fetch A a (hd ca)")
  apply(simp del: tm_comp.simps)
  apply(subst tm_comp_fetch_in_A)
     apply(auto)[4]
  done

lemma step_in_range:
  assumes h1: "\<not> is_final (step0 c A)"
    and h2: "tm_wf (A, 0)"
  shows "fst (step0 c A) \<le> length A div 2"
  using h1 h2
  apply(cases c;cases "fst c";cases "hd (snd (snd c))")
  by(auto simp add: Let_def case_prod_beta')

lemma steps_in_range:
  assumes h1: "\<not> is_final (steps0 (1, tp) A stp)"
    and h2: "tm_wf (A, 0)"
  shows "fst (steps0 (1, tp) A stp) \<le> length A div 2"
  using h1
proof(induct stp)
  case 0
  then show "fst (steps0 (1, tp) A 0) \<le> length A div 2" using h2
    by (auto)
next
  case (Suc stp)
  have ih: "\<not> is_final (steps0 (1, tp) A stp) \<Longrightarrow> fst (steps0 (1, tp) A stp) \<le> length A div 2" by fact
  have h: "\<not> is_final (steps0 (1, tp) A (Suc stp))" by fact
  from ih h h2 show "fst (steps0 (1, tp) A (Suc stp)) \<le> length A div 2"
    by (metis step_in_range step_red)
qed

(* if A goes into the final state, then A |+| B will go into the first state of B *)
lemma tm_comp_next:
  assumes a_ht: "steps0 (1, tp) A n = (0, tp')"
    and a_wf: "tm_wf (A, 0)"
  obtains n' where "steps0 (1, tp) (A |+| B) n' = (Suc (length A div 2), tp')"
proof -
  assume a: "\<And>n. steps (1, tp) (A |+| B, 0) n = (Suc (length A div 2), tp') \<Longrightarrow> thesis"
  obtain stp' where fin: "\<not> is_final (steps0 (1, tp) A stp')" and h: "steps0 (1, tp) A (Suc stp') = (0, tp')"
    using before_final[OF a_ht] by blast
  from fin have h1:"steps0 (1, tp) (A |+| B) stp' = steps0 (1, tp) A stp'"
    by (rule tm_comp_steps)
  from h have h2: "step0 (steps0 (1, tp) A stp') A = (0, tp')"
    by (simp only: step_red)

  have "steps0 (1, tp) (A |+| B) (Suc stp') = step0 (steps0 (1, tp) (A |+| B) stp') (A |+| B)"
    by (simp only: step_red)
  also have "... = step0 (steps0 (1, tp) A stp') (A |+| B)" using h1 by simp
  also have "... = (Suc (length A div 2), tp')"
    by (rule tm_comp_exec_after_first[OF fin h2 steps_in_range[OF fin a_wf]])
  finally show thesis using a by blast
qed

lemma tm_comp_fetch_second_zero:
  assumes h1: "fetch B s x = (a, 0)"
    and hs: "tm_wf (A, 0)" "s \<noteq> 0"
  shows "fetch (A |+| B) (s + (length A div 2)) x = (a, 0)"
  using h1 hs
  by(cases x; cases s; fastforce simp: tm_comp_length nth_append)

lemma tm_comp_fetch_second_inst:
  assumes h1: "fetch B sa x = (a, s)"
    and hs: "tm_wf (A, 0)" "sa \<noteq> 0" "s \<noteq> 0"
  shows "fetch (A |+| B) (sa + length A div 2) x = (a, s + length A div 2)"
  using h1 hs
  by(cases x; cases sa; fastforce simp: tm_comp_length nth_append)

lemma tm_comp_second:
  assumes a_wf: "tm_wf (A, 0)"
    and steps: "steps0 (1, l, r) B stp = (s', l', r')"
  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp
    = (if s' = 0 then 0 else s' + length A div 2, l', r')"
  using steps
proof(induct stp arbitrary: s' l' r')
  case 0
  then show ?case by simp
next
  case (Suc stp s' l' r')
  obtain s'' l'' r'' where a: "steps0 (1, l, r) B stp = (s'', l'', r'')"
    by (metis is_final.cases)
  then have ih1: "s'' = 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (0, l'', r'')"
    and ih2: "s'' \<noteq> 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (s'' + length A div 2, l'', r'')"
    using Suc by (auto)
  have h: "steps0 (1, l, r) B (Suc stp) = (s', l', r')" by fact

  { assume "s'' = 0"
    then have ?case using a h ih1 by (simp del: steps.simps)
  } moreover
  { assume as: "s'' \<noteq> 0" "s' = 0"
    from as a h
    have "step0 (s'', l'', r'') B = (0, l', r')" by (simp del: steps.simps)
    with as have ?case
      apply(cases "fetch B s'' (read r'')")
      by (auto simp add: tm_comp_fetch_second_zero[OF _ a_wf] ih2[OF as(1)]
          simp del: tm_comp.simps steps.simps)
  } moreover
  { assume as: "s'' \<noteq> 0" "s' \<noteq> 0"
    from as a h
    have "step0 (s'', l'', r'') B = (s', l', r')" by (simp del: steps.simps)
    with as have ?case
      apply(simp add: ih2[OF as(1)] del: tm_comp.simps steps.simps)
      apply(case_tac "fetch B s'' (read r'')")
      apply(auto simp add: tm_comp_fetch_second_inst[OF _ a_wf as] simp del: tm_comp.simps)
      done
  }
  ultimately show ?case by blast
qed

lemma tm_comp_final:
  assumes "tm_wf (A, 0)"
    and "steps0 (1, l, r) B stp = (0, l', r')"
  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp = (0, l', r')"
  using tm_comp_second[OF assms] by (simp)

end


section \<open> Closed Mereology \<close>

(*<*)
theory CM
  imports M
begin
(*>*)

text \<open> The theory of \emph{closed mereology} adds to ground mereology conditions guaranteeing the
existence of sums and products.\footnote{See @{cite "masolo_atomicity_1999"} p. 238. @{cite "varzi_parts_1996"} p. 263
and @{cite "casati_parts_1999"} p. 43 give a slightly weaker version of the sum closure axiom, which is
equivalent given axioms considered later.} \<close>

locale CM = M +
  assumes sum_eq: "x \<oplus> y = (THE z. \<forall>v. O v z \<longleftrightarrow> O v x \<or> O v y)"
  assumes sum_closure: "\<exists>z. \<forall>v. O v z \<longleftrightarrow> O v x \<or> O v y"
  assumes product_eq:
    "x \<otimes> y = (THE z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y)"
  assumes product_closure:
    "O x y \<Longrightarrow> \<exists>z. \<forall>v. P v z \<longleftrightarrow> P v x \<and> P v y"
begin

subsection \<open> Products \<close>

lemma product_intro:
  "(\<forall>w. P w z \<longleftrightarrow> (P w x \<and> P w y)) \<Longrightarrow> x \<otimes> y = z"
proof -
  assume z: "\<forall>w. P w z \<longleftrightarrow> (P w x \<and> P w y)"
  hence "(THE v. \<forall>w. P w v \<longleftrightarrow> P w x \<and> P w y) = z"
  proof (rule the_equality)
    fix v
    assume v: "\<forall>w. P w v \<longleftrightarrow> (P w x \<and> P w y)"
    have "\<forall>w. P w v \<longleftrightarrow> P w z"
    proof
      fix w
      from z have "P w z \<longleftrightarrow> (P w x \<and> P w y)"..
      moreover from v have "P w v \<longleftrightarrow> (P w x \<and> P w y)"..
      ultimately show "P w v \<longleftrightarrow> P w z" by (rule ssubst)
    qed
    with part_extensionality show "v = z"..
  qed
  thus "x \<otimes> y = z"
    using product_eq by (rule subst)
qed

lemma product_idempotence: "x \<otimes> x = x"
proof -
  have "\<forall>w. P w x \<longleftrightarrow> P w x \<and> P w x"
  proof
    fix w
    show "P w x \<longleftrightarrow> P w x \<and> P w x"
    proof
      assume "P w x"
      thus "P w x \<and> P w x" using `P w x`..
    next
      assume "P w x \<and> P w x"
      thus "P w x"..
    qed
  qed
  thus "x \<otimes> x = x" by (rule product_intro)
qed

lemma product_character:
  "O x y \<Longrightarrow> (\<forall>w. P w (x \<otimes> y) \<longleftrightarrow> (P w x \<and> P w y))"
proof -
  assume "O x y"
  hence "\<exists>z. \<forall>w. P w z \<longleftrightarrow> (P w x \<and> P w y)" by (rule product_closure)
  then obtain z where z: "\<forall>w. P w z \<longleftrightarrow> (P w x \<and> P w y)"..
  hence "x \<otimes> y = z" by (rule product_intro)
  thus "\<forall>w. P w (x \<otimes> y) \<longleftrightarrow> P w x \<and> P w y"
    using z by (rule ssubst)
qed

lemma product_commutativity: "O x y \<Longrightarrow> x \<otimes> y = y \<otimes> x"
proof -
  assume "O x y"
  hence "O y x" by (rule overlap_symmetry)
  hence "\<forall>w. P w (y \<otimes> x) \<longleftrightarrow> (P w y \<and> P w x)" by (rule product_character)
  hence "\<forall>w. P w (y \<otimes> x) \<longleftrightarrow> (P w x \<and> P w y)" by auto
  thus "x \<otimes> y = y \<otimes> x" by (rule product_intro)
qed

lemma product_in_factors: "O x y \<Longrightarrow> P (x \<otimes> y) x \<and> P (x \<otimes> y) y"
proof -
  assume "O x y"
  hence "\<forall>w. P w (x \<otimes> y) \<longleftrightarrow> P w x \<and> P w y" by (rule product_character)
  hence "P (x \<otimes> y) (x \<otimes> y) \<longleftrightarrow> P (x \<otimes> y) x \<and> P (x \<otimes> y) y"..
  moreover have "P (x \<otimes> y) (x \<otimes> y)" by (rule part_reflexivity)
  ultimately show "P (x \<otimes> y) x \<and> P (x \<otimes> y) y"..
qed

lemma product_in_first_factor: "O x y \<Longrightarrow> P (x \<otimes> y) x"
proof -
  assume "O x y"
  hence "P (x \<otimes> y) x \<and> P (x \<otimes> y) y" by (rule product_in_factors)
  thus "P (x \<otimes> y) x"..
qed

lemma product_in_second_factor: "O x y \<Longrightarrow> P (x \<otimes> y) y"
proof -
  assume "O x y"
  hence "P (x \<otimes> y) x \<and> P (x \<otimes> y) y" by (rule product_in_factors)
  thus "P (x \<otimes> y) y"..
qed

lemma nonpart_implies_proper_product:
  "\<not> P x y \<and> O x y \<Longrightarrow> PP (x \<otimes> y) x"
proof -
  assume antecedent: "\<not> P x y \<and> O x y"
  hence "\<not> P x y"..
  from antecedent have "O x y"..
  hence "P (x \<otimes> y) x" by (rule product_in_first_factor)
  moreover have "(x \<otimes> y) \<noteq> x"
  proof
    assume "(x \<otimes> y) = x"
    hence "\<not> P (x \<otimes> y) y"
      using `\<not> P x y` by (rule ssubst)
    moreover have "P (x \<otimes> y) y"
      using `O x y` by (rule product_in_second_factor)
    ultimately show "False"..
  qed
  ultimately have "P (x \<otimes> y) x \<and> x \<otimes> y \<noteq> x"..
  with nip_eq show "PP (x \<otimes> y) x"..
qed

lemma common_part_in_product: "P z x \<and> P z y \<Longrightarrow> P z (x \<otimes> y)"
proof -
  assume antecedent: "P z x \<and> P z y"
  hence "\<exists>z. P z x \<and> P z y"..
  with overlap_eq have "O x y"..
  hence "\<forall>w. P w (x \<otimes> y) \<longleftrightarrow> (P w x \<and> P w y)"
    by (rule product_character)
  hence "P z (x \<otimes> y) \<longleftrightarrow> (P z x \<and> P z y)"..
  thus "P z (x \<otimes> y)"
    using `P z x \<and> P z y`..
qed

lemma product_part_in_factors:
  "O x y \<Longrightarrow> P z (x \<otimes> y) \<Longrightarrow> P z x \<and> P z y"
proof -
  assume "O x y"
  hence "\<forall>w. P w (x \<otimes> y) \<longleftrightarrow> (P w x \<and> P w y)"
    by (rule product_character)
  hence "P z (x \<otimes> y) \<longleftrightarrow> (P z x \<and> P z y)"..
  moreover assume "P z (x \<otimes> y)"
  ultimately show "P z x \<and> P z y"..
qed

corollary product_part_in_first_factor:
  "O x y \<Longrightarrow> P z (x \<otimes> y) \<Longrightarrow> P z x"
proof -
  assume "O x y"
  moreover assume "P z (x \<otimes> y)"
  ultimately have "P z x \<and> P z y"
    by (rule product_part_in_factors)
  thus "P z x"..
qed

corollary product_part_in_second_factor:
  "O x y \<Longrightarrow> P z (x \<otimes> y) \<Longrightarrow> P z y"
proof -
  assume "O x y"
  moreover assume "P z (x \<otimes> y)"
  ultimately have "P z x \<and> P z y"
    by (rule product_part_in_factors)
  thus "P z y"..
qed

lemma part_product_identity: "P x y \<Longrightarrow> x \<otimes> y = x"
proof -
  assume "P x y"
  with part_reflexivity have "P x x \<and> P x y"..
  hence "P x (x \<otimes> y)" by (rule common_part_in_product)
  have "O x y" using `P x y` by (rule part_implies_overlap)
  hence  "P (x \<otimes> y) x" by (rule product_in_first_factor)
  thus "x \<otimes> y = x" using `P x (x \<otimes> y)` by (rule part_antisymmetry)
qed

lemma product_overlap: "P z x \<Longrightarrow> O z y \<Longrightarrow> O z (x \<otimes> y)"
proof -
  assume "P z x"
  assume "O z y"
  with overlap_eq have "\<exists>v. P v z \<and> P v y"..
  then obtain v where v: "P v z \<and> P v y"..
  hence "P v y"..
  from v have "P v z"..
  hence "P v x" using `P z x` by (rule part_transitivity)
  hence "P v x \<and> P v y" using `P v y`..
  hence "P v (x \<otimes> y)" by (rule common_part_in_product)
  with `P v z` have "P v z \<and> P v (x \<otimes> y)"..
  hence "\<exists>v. P v z \<and> P v (x \<otimes> y)"..
  with overlap_eq show "O z (x \<otimes> y)"..
qed

lemma disjoint_from_second_factor:
  "P x y \<and> \<not> O x (y \<otimes> z) \<Longrightarrow> \<not> O x z"
proof -
  assume antecedent: "P x y \<and> \<not> O x (y \<otimes> z)"
  hence "\<not> O x (y \<otimes> z)"..
  show "\<not> O x z"
  proof
    from antecedent have "P x y"..
    moreover assume "O x z"
    ultimately have "O x (y \<otimes> z)"
      by (rule product_overlap)
    with `\<not> O x (y \<otimes> z)` show "False"..
  qed
qed

lemma converse_product_overlap:
  "O x y \<Longrightarrow> O z (x \<otimes> y) \<Longrightarrow> O z y"
proof -
  assume "O x y"
  hence "P (x \<otimes> y) y" by (rule product_in_second_factor)
  moreover assume "O z (x \<otimes> y)"
  ultimately show "O z y"
    by (rule overlap_monotonicity)
qed

lemma part_product_in_whole_product:
  "O x y \<Longrightarrow> P x v \<and> P y z \<Longrightarrow> P (x \<otimes> y) (v \<otimes> z)"
proof -
  assume "O x y"
  assume "P x v \<and> P y z"
  have "\<forall>w. P w (x \<otimes> y) \<longrightarrow> P w (v \<otimes> z)"
  proof
    fix w
    show "P w (x \<otimes> y) \<longrightarrow> P w (v \<otimes> z)"
    proof
      assume "P w (x \<otimes> y)"
      with `O x y` have "P w x \<and> P w y"
        by (rule product_part_in_factors)
      have "P w v \<and> P w z"
      proof
        from `P w x \<and> P w y` have "P w x"..
        moreover from `P x v \<and> P y z` have "P x v"..
        ultimately show "P w v" by (rule part_transitivity)
      next
        from `P w x \<and> P w y` have "P w y"..
        moreover from `P x v \<and> P y z` have "P y z"..
        ultimately show "P w z" by (rule part_transitivity)
      qed
      thus "P w (v \<otimes> z)" by (rule common_part_in_product)
    qed
  qed
  hence "P (x \<otimes> y) (x \<otimes> y) \<longrightarrow> P (x \<otimes> y) (v \<otimes> z)"..
  moreover have "P (x \<otimes> y) (x \<otimes> y)" by (rule part_reflexivity)
  ultimately show "P (x \<otimes> y) (v \<otimes> z)"..
qed

lemma right_associated_product: "(\<exists>w. P w x \<and> P w y \<and> P w z) \<Longrightarrow>
  (\<forall>w. P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w x \<and> (P w y \<and> P w z))"
proof -
  assume antecedent: "(\<exists>w. P w x \<and> P w y \<and> P w z)"
  then obtain w where w: "P w x \<and> P w y \<and> P w z"..
  hence "P w x"..
  from w have "P w y \<and> P w z"..
  hence "\<exists>w. P w y \<and> P w z"..
  with overlap_eq have "O y z"..
  hence yz: "\<forall>w. P w (y \<otimes> z) \<longleftrightarrow> (P w y \<and> P w z)"
    by (rule product_character)
  hence "P w (y \<otimes> z) \<longleftrightarrow> (P w y \<and> P w z)"..
  hence "P w (y \<otimes> z)"
    using `P w y \<and> P w z`..
  with `P w x` have "P w x \<and> P w (y \<otimes> z)"..
  hence "\<exists>w. P w x \<and> P w (y \<otimes> z)"..
  with overlap_eq have "O x (y \<otimes> z)"..
  hence xyz: "\<forall>w. P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w x \<and> P w (y \<otimes> z)"
    by (rule product_character)
  show "\<forall>w. P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w x \<and> (P w y \<and> P w z)"
  proof
    fix w
    from yz have wyz: "P w (y \<otimes> z) \<longleftrightarrow> (P w y \<and> P w z)"..
    moreover from xyz have
      "P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w x \<and> P w (y \<otimes> z)"..
    ultimately show
      "P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w x \<and> (P w y \<and> P w z)"
      by (rule subst)
  qed
qed

lemma left_associated_product: "(\<exists>w. P w x \<and> P w y \<and> P w z) \<Longrightarrow>
  (\<forall>w. P w ((x \<otimes> y) \<otimes> z) \<longleftrightarrow> (P w x \<and> P w y) \<and> P w z)"
proof -
  assume antecedent: "(\<exists>w. P w x \<and> P w y \<and> P w z)"
  then obtain w where w: "P w x \<and> P w y \<and> P w z"..
  hence "P w y \<and> P w z"..
  hence "P w y"..
  have "P w z"
    using `P w y \<and> P w z`..
  from w have "P w x"..
  hence "P w x \<and> P w y"
    using `P w y`..
  hence "\<exists>z. P z x \<and> P z y"..
  with overlap_eq have "O x y"..
  hence xy: "\<forall>w. P w (x \<otimes> y) \<longleftrightarrow> (P w x \<and> P w y)"
    by (rule product_character)
  hence "P w (x \<otimes> y) \<longleftrightarrow> (P w x \<and> P w y)"..
  hence "P w (x \<otimes> y)"
    using `P w x \<and> P w y`..
  hence "P w (x \<otimes> y) \<and> P w z"
    using `P w z`..
  hence "\<exists>w. P w (x \<otimes> y) \<and> P w z"..
  with overlap_eq have "O (x \<otimes> y) z"..
  hence xyz: "\<forall>w. P w ((x \<otimes> y) \<otimes> z) \<longleftrightarrow> P w (x \<otimes> y) \<and> P w z"
    by (rule product_character)
  show "\<forall>w. P w ((x \<otimes> y) \<otimes> z) \<longleftrightarrow> (P w x \<and> P w y) \<and> P w z"
  proof
    fix v
    from xy have vxy: "P v (x \<otimes> y) \<longleftrightarrow> (P v x \<and> P v y)"..
    moreover from xyz have
      "P v ((x \<otimes> y) \<otimes> z) \<longleftrightarrow> P v (x \<otimes> y) \<and> P v z"..
    ultimately show "P v ((x \<otimes> y) \<otimes> z) \<longleftrightarrow> (P v x \<and> P v y) \<and> P v z"
      by (rule subst)
  qed
qed

theorem product_associativity:
  "(\<exists>w. P w x \<and> P w y \<and> P w z) \<Longrightarrow> x \<otimes> (y \<otimes> z) = (x \<otimes> y) \<otimes> z"
proof -
  assume ante:"(\<exists>w. P w x \<and> P w y \<and> P w z)"
  hence "(\<forall>w. P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w x \<and> (P w y \<and> P w z))"
    by (rule right_associated_product)
  moreover from ante have
    "(\<forall>w. P w ((x \<otimes> y) \<otimes> z) \<longleftrightarrow> (P w x \<and> P w y) \<and> P w z)"
    by (rule left_associated_product)
  ultimately have "\<forall>w. P w (x \<otimes> (y \<otimes> z)) \<longleftrightarrow> P w ((x \<otimes> y) \<otimes> z)"
    by simp
  with part_extensionality show "x \<otimes> (y \<otimes> z) = (x \<otimes> y) \<otimes> z"..
qed

end

subsection \<open> Differences  \<close>

text \<open> Some writers also add to closed mereology the axiom of difference closure.\footnote{See, for example,
@{cite "varzi_parts_1996"} p. 263 and @{cite "masolo_atomicity_1999"} p. 238.} \<close>

locale CMD = CM +
  assumes difference_eq:
    "x \<ominus> y = (THE z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y)"
  assumes difference_closure:
    "(\<exists>w. P w x \<and> \<not> O w y) \<Longrightarrow> (\<exists>z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y)"
begin

lemma difference_intro:
  "(\<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y) \<Longrightarrow> x \<ominus> y = z"
proof -
  assume antecedent: "(\<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y)"
  hence "(THE z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y) = z"
  proof (rule the_equality)
    fix v
    assume v: "(\<forall>w. P w v \<longleftrightarrow> P w x \<and> \<not> O w y)"
    have "\<forall>w. P w v \<longleftrightarrow> P w z"
    proof
      fix w
      from antecedent have "P w z \<longleftrightarrow> P w x \<and> \<not> O w y"..
      moreover from v have "P w v \<longleftrightarrow> P w x \<and> \<not> O w y"..
      ultimately show "P w v \<longleftrightarrow> P w z" by (rule ssubst)
    qed
    with part_extensionality show "v = z"..
  qed
  with difference_eq show "x \<ominus> y = z" by (rule ssubst)
qed

lemma difference_idempotence: "\<not> O x y \<Longrightarrow> (x \<ominus> y) = x"
proof -
  assume "\<not> O x y"
  hence "\<not> O y x" by (rule disjoint_symmetry)
  have "\<forall>w. P w x \<longleftrightarrow> P w x \<and> \<not> O w y"
  proof
    fix w
    show "P w x \<longleftrightarrow> P w x \<and> \<not> O w y"
    proof
      assume "P w x"
      hence "\<not> O y w" using `\<not> O y x`
        by (rule disjoint_demonotonicity)
      hence "\<not> O w y" by (rule disjoint_symmetry)
      with `P w x` show "P w x \<and> \<not> O w y"..
    next
      assume "P w x \<and> \<not> O w y"
      thus "P w x"..
    qed
  qed
  thus "(x \<ominus> y) = x" by (rule difference_intro)
qed

lemma difference_character: "(\<exists>w. P w x \<and> \<not> O w y) \<Longrightarrow>
  (\<forall>w. P w (x \<ominus> y) \<longleftrightarrow> P w x \<and> \<not> O w y)"
proof -
  assume "\<exists>w. P w x \<and> \<not> O w y"
  hence "\<exists>z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y" by (rule difference_closure)
  then obtain z where z: "\<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y"..
  hence "(x \<ominus> y) = z" by (rule difference_intro)
  thus "\<forall>w. P w (x \<ominus> y) \<longleftrightarrow> P w x \<and> \<not> O w y" using z by (rule ssubst)
qed

lemma difference_disjointness:
  "(\<exists>z. P z x \<and> \<not> O z y) \<Longrightarrow> \<not> O y (x \<ominus> y)"
proof -
  assume "\<exists>z. P z x \<and> \<not> O z y"
  hence xmy: "\<forall>w. P w (x \<ominus> y) \<longleftrightarrow> (P w x \<and> \<not> O w y)"
    by (rule difference_character)
  show "\<not> O y (x \<ominus> y)"
  proof
    assume "O y (x \<ominus> y)"
    with overlap_eq have "\<exists>v. P v y \<and> P v (x \<ominus> y)"..
    then obtain v where v: "P v y \<and> P v (x \<ominus> y)"..
    from xmy have "P v (x \<ominus> y) \<longleftrightarrow> (P v x \<and> \<not> O v y)"..
    moreover from v have "P v (x \<ominus> y)"..
    ultimately have "P v x \<and> \<not> O v y"..
    hence "\<not> O v y"..
    moreover from v have "P v y"..
    hence "O v y" by (rule part_implies_overlap)
    ultimately show "False"..
  qed
qed

end

subsection \<open> The Universe \<close>

text \<open> Another closure condition sometimes considered is the existence of the universe.\footnote{
See, for example, @{cite "varzi_parts_1996"} p. 264 and @{cite "casati_parts_1999"} p. 45.}  \<close>

locale CMU = CM +
  assumes universe_eq: "u = (THE z. \<forall>w. P w z)"
  assumes universe_closure: "\<exists>y. \<forall>x. P x y"
begin

lemma universe_intro: "(\<forall>w. P w z) \<Longrightarrow> u = z"
proof -
  assume z: "\<forall>w. P w z"
  hence "(THE z. \<forall>w. P w z) = z"
  proof (rule the_equality)
    fix v
    assume v: "\<forall>w. P w v"
    have "\<forall>w. P w v \<longleftrightarrow> P w z"
    proof
      fix w
      show "P w v \<longleftrightarrow> P w z"
      proof
        assume "P w v"
        from z show "P w z"..
      next
        assume "P w z"
        from v show "P w v"..
      qed
    qed
    with part_extensionality show "v = z"..
  qed
  thus "u = z" using universe_eq by (rule subst)
qed

lemma universe_character: "P x u"
proof -
  from universe_closure obtain y where y: "\<forall>x. P x y"..
  hence "u = y" by (rule universe_intro)
  hence "\<forall>x. P x u" using y by (rule ssubst)
  thus "P x u"..
qed

lemma "\<not> PP u x"
proof
  assume "PP u x"
  hence "\<not> P x u" by (rule proper_implies_not_part)
  thus "False" using universe_character..
qed

lemma product_universe_implies_factor_universe:
  "O x y \<Longrightarrow> x \<otimes> y = u \<Longrightarrow> x = u"
proof -
  assume "x \<otimes> y = u"
  moreover assume "O x y"
  hence "P (x \<otimes> y) x"
    by (rule product_in_first_factor)
  ultimately have "P u x"
    by (rule subst)
  with universe_character show "x = u"
    by (rule part_antisymmetry)
qed

end

subsection \<open> Complements \<close>

text \<open> As is a condition ensuring the existence of complements.\footnote{See, for example,
 @{cite "varzi_parts_1996"} p. 264 and @{cite "casati_parts_1999"} p. 45.} \<close>

locale CMC = CM +
  assumes complement_eq: "\<midarrow>x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
  assumes complement_closure:
    "(\<exists>w. \<not> O w x) \<Longrightarrow> (\<exists>z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
  assumes difference_eq:
    "x \<ominus> y = (THE z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y)"
begin

lemma complement_intro:
  "(\<forall>w. P w z \<longleftrightarrow> \<not> O w x) \<Longrightarrow> \<midarrow>x = z"
proof -
  assume antecedent: "\<forall>w. P w z \<longleftrightarrow> \<not> O w x"
  hence "(THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x) = z"
  proof (rule the_equality)
    fix v
    assume v: "\<forall>w. P w v \<longleftrightarrow> \<not> O w x"
    have "\<forall>w. P w v \<longleftrightarrow> P w z"
    proof
      fix w
      from antecedent have "P w z \<longleftrightarrow> \<not> O w x"..
      moreover from v have "P w v \<longleftrightarrow> \<not> O w x"..
      ultimately show "P w v \<longleftrightarrow> P w z" by (rule ssubst)
    qed
    with part_extensionality show "v = z"..
  qed
  with complement_eq show "\<midarrow>x = z" by (rule ssubst)
qed

lemma complement_character:
  "(\<exists>w. \<not> O w x) \<Longrightarrow> (\<forall>w. P w (\<midarrow>x) \<longleftrightarrow> \<not> O w x)"
proof -
  assume "\<exists>w. \<not> O w x"
  hence "(\<exists>z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)" by (rule complement_closure)
  then obtain z where z: "\<forall>w. P w z \<longleftrightarrow> \<not> O w x"..
  hence "\<midarrow>x = z" by (rule complement_intro)
  thus "\<forall>w. P w (\<midarrow>x) \<longleftrightarrow> \<not> O w x"
    using z by (rule ssubst)
qed

lemma not_complement_part: "\<exists>w. \<not> O w x \<Longrightarrow> \<not> P x (\<midarrow>x)"
proof -
  assume "\<exists>w. \<not> O w x"
  hence "\<forall>w. P w (\<midarrow>x) \<longleftrightarrow> \<not> O w x"
    by (rule complement_character)
  hence "P x (\<midarrow>x) \<longleftrightarrow> \<not> O x x"..
  show "\<not> P x (\<midarrow>x)"
  proof
    assume "P x (\<midarrow>x)"
    with `P x (\<midarrow>x) \<longleftrightarrow> \<not> O x x` have "\<not> O x x"..
    thus "False" using overlap_reflexivity..
  qed
qed

lemma complement_part: "\<not> O x y \<Longrightarrow> P x (\<midarrow>y)"
proof -
  assume "\<not> O x y"
  hence "\<exists>z. \<not> O z y"..
  hence "\<forall>w. P w (\<midarrow>y) \<longleftrightarrow> \<not> O w y"
    by (rule complement_character)
  hence "P x (\<midarrow>y) \<longleftrightarrow> \<not> O x y"..
  thus "P x (\<midarrow>y)" using `\<not> O x y`..
qed

lemma complement_overlap: "\<not> O x y \<Longrightarrow> O x (\<midarrow>y)"
proof -
  assume "\<not> O x y"
  hence "P x (\<midarrow>y)"
    by (rule complement_part)
  thus "O x (\<midarrow>y)"
    by (rule part_implies_overlap)
qed

lemma or_complement_overlap: "\<forall>y. O y x \<or> O y (\<midarrow>x)"
proof
  fix y
  show "O y x \<or> O y (\<midarrow>x)"
  proof cases
    assume "O y x"
    thus "O y x \<or> O y (\<midarrow>x)"..
  next
    assume "\<not> O y x"
    hence "O y (\<midarrow>x)"
      by (rule complement_overlap)
    thus "O y x \<or> O y (\<midarrow>x)"..
  qed
qed

lemma complement_disjointness: "\<exists>v. \<not> O v x \<Longrightarrow> \<not> O x (\<midarrow>x)"
proof -
  assume "\<exists>v. \<not> O v x"
  hence w: "\<forall>w. P w (\<midarrow>x) \<longleftrightarrow> \<not> O w x"
    by (rule complement_character)
  show "\<not> O x (\<midarrow>x)"
  proof
    assume "O x (\<midarrow>x)"
    with overlap_eq have "\<exists>v. P v x \<and> P v (\<midarrow>x)"..
    then obtain v where v: "P v x \<and> P v (\<midarrow>x)"..
    from w have "P v (\<midarrow>x) \<longleftrightarrow> \<not> O v x"..
    moreover from v have  "P v (\<midarrow>x)"..
    ultimately have "\<not> O v x"..
    moreover from v have "P v x"..
    hence "O v x" by (rule part_implies_overlap)
    ultimately show "False"..
  qed
qed

lemma part_disjoint_from_complement:
  "\<exists>v. \<not> O v x \<Longrightarrow> P y x \<Longrightarrow> \<not> O y (\<midarrow>x)"
proof
  assume "\<exists>v. \<not> O v x"
  hence "\<not> O x (\<midarrow>x)" by (rule complement_disjointness)
  assume "P y x"
  assume "O y (\<midarrow>x)"
  with overlap_eq have "\<exists>v. P v y \<and> P v (\<midarrow>x)"..
  then obtain v where v: "P v y \<and> P v (\<midarrow>x)"..
  hence "P v y"..
  hence "P v x" using `P y x` by (rule part_transitivity)
  moreover from v have "P v (\<midarrow>x)"..
  ultimately have "P v x \<and> P v (\<midarrow>x)"..
  hence "\<exists>v. P v x \<and> P v (\<midarrow>x)"..
  with overlap_eq have "O x (\<midarrow>x)"..
  with `\<not> O x (\<midarrow>x)` show "False"..
qed

lemma product_complement_character: "(\<exists>w. P w x \<and> \<not> O w y) \<Longrightarrow>
  (\<forall>w. P w (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> (P w x \<and> (\<not> O w y)))"
proof -
  assume antecedent: "\<exists>w. P w x \<and> \<not> O w y"
  then obtain w where w: "P w x \<and> \<not> O w y"..
  hence "P w x"..
  moreover from w have "\<not> O w y"..
  hence "P w (\<midarrow>y)" by (rule complement_part)
  ultimately have  "P w x \<and> P w (\<midarrow>y)"..
  hence "\<exists>w. P w x \<and> P w (\<midarrow>y)"..
  with overlap_eq have "O x (\<midarrow>y)"..
  hence prod: "(\<forall>w. P w (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> (P w x \<and> P w (\<midarrow>y)))"
    by (rule product_character)
  show "\<forall>w. P w (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> (P w x \<and> (\<not> O w y))"
  proof
    fix v
    from w have "\<not> O w y"..
    hence "\<exists>w. \<not> O w y"..
    hence "\<forall>w. P w (\<midarrow>y) \<longleftrightarrow> \<not> O w y"
      by (rule complement_character)
    hence "P v (\<midarrow>y) \<longleftrightarrow> \<not> O v y"..
    moreover have "P v (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> (P v x \<and> P v (\<midarrow>y))"
      using prod..
    ultimately show "P v (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> (P v x \<and> (\<not> O v y))"
      by (rule subst)
  qed
qed

theorem difference_closure: "(\<exists>w. P w x \<and> \<not> O w y) \<Longrightarrow>
  (\<exists>z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y)"
proof -
  assume "\<exists>w. P w x \<and> \<not> O w y"
  hence "\<forall>w. P w (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> P w x \<and> \<not> O w y"
    by (rule product_complement_character)
  thus "(\<exists>z. \<forall>w. P w z \<longleftrightarrow> P w x \<and> \<not> O w y)" by (rule exI)
qed

end

sublocale CMC \<subseteq> CMD
proof
  fix x y
  show "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
    using difference_eq.
  show "(\<exists>w. P w x \<and> \<not> O w y) \<Longrightarrow>
    (\<exists>z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
    using difference_closure.
qed

corollary (in CMC) difference_is_product_of_complement:
  "(\<exists>w. P w x \<and> \<not> O w y) \<Longrightarrow> (x \<ominus> y) = x \<otimes> (\<midarrow>y)"
proof -
  assume antecedent: "\<exists>w. P w x \<and> \<not> O w y"
  hence "\<forall>w. P w (x \<otimes> (\<midarrow>y)) \<longleftrightarrow> P w x \<and> \<not> O w y"
    by (rule product_complement_character)
  thus "(x \<ominus> y) = x \<otimes> (\<midarrow>y)" by (rule difference_intro)
qed

text \<open> Universe and difference closure entail complement closure, since the difference of an individual
and the universe is the individual's complement. \<close>

locale CMUD = CMU + CMD +
  assumes complement_eq: "\<midarrow>x = (THE z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
begin

lemma universe_difference:
  "(\<exists>w. \<not> O w x) \<Longrightarrow> (\<forall>w. P w (u \<ominus> x) \<longleftrightarrow> \<not> O w x)"
proof -
  assume "\<exists>w. \<not> O w x"
  then obtain w where w: "\<not> O w x"..
  from universe_character have "P w u".
  hence "P w u \<and> \<not> O w x" using `\<not> O w x`..
  hence "\<exists>z. P z u \<and> \<not> O z x"..
  hence ux: "\<forall>w. P w (u \<ominus> x) \<longleftrightarrow> (P w u \<and> \<not> O w x)"
    by (rule difference_character)
  show "\<forall>w. P w (u \<ominus> x) \<longleftrightarrow> \<not> O w x"
  proof
    fix w
    from ux have wux: "P w (u \<ominus> x) \<longleftrightarrow> (P w u \<and> \<not> O w x)"..
    show "P w (u \<ominus> x) \<longleftrightarrow> \<not> O w x"
    proof
      assume "P w (u \<ominus> x)"
      with wux have "P w u \<and> \<not> O w x"..
      thus "\<not> O w x"..
    next
      assume "\<not> O w x"
      from universe_character have "P w u".
      hence "P w u \<and> \<not> O w x" using `\<not> O w x`..
      with wux show "P w (u \<ominus> x)"..
    qed
  qed
qed

theorem complement_closure:
  "(\<exists>w. \<not> O w x) \<Longrightarrow> (\<exists>z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x)"
proof -
  assume "\<exists>w. \<not> O w x"
  hence "\<forall>w. P w (u \<ominus> x) \<longleftrightarrow> \<not> O w x"
    by (rule universe_difference)
  thus "\<exists>z. \<forall>w. P w z \<longleftrightarrow> \<not> O w x"..
qed

end

sublocale CMUD \<subseteq> CMC
proof
  fix x y
  show "\<midarrow>x = (THE z. \<forall>w. P w z \<longleftrightarrow> (\<not> O w x))"
    using complement_eq.
  show "\<exists>w. \<not> O w x \<Longrightarrow> \<exists>z. \<forall>w. P w z \<longleftrightarrow> (\<not> O w x)"
    using complement_closure.
  show "x \<ominus> y = (THE z. \<forall>w. P w z = (P w x \<and> \<not> O w y))"
    using difference_eq.
qed

corollary (in CMUD) complement_universe_difference:
  "(\<exists>y. \<not> O y x) \<Longrightarrow> \<midarrow>x = (u \<ominus> x)"
proof -
  assume "\<exists>w. \<not> O w x"
  hence "\<forall>w. P w (u \<ominus> x) \<longleftrightarrow> \<not> O w x"
    by (rule universe_difference)
  thus " \<midarrow>x = (u \<ominus> x)"
    by (rule complement_intro)
qed

(*<*) end (*>*)


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>Results on Infinite Sequences\<close>

(* TODO: Move to Abstract-Rewriting.Seq -- maybe this is of very general interest... *)
theory Seq_More
  imports
    "Abstract-Rewriting.Seq"
    Transitive_Closure_More
begin

lemma down_chain_imp_eq:
  fixes f :: "nat seq"
  assumes "\<forall>i. f i \<ge> f (Suc i)"
  shows "\<exists>N. \<forall>i > N. f i = f (Suc i)"
proof -
  let ?F = "{f i | i. True}"
  from wf_less [unfolded wf_eq_minimal, THEN spec, of ?F]
    obtain x where "x \<in> ?F" and *: "\<forall>y. y < x \<longrightarrow> y \<notin> ?F" by auto
  obtain N where "f N = x" using \<open>x \<in> ?F\<close> by auto
  moreover have "\<forall>i > N. f i \<in> ?F" by auto
  ultimately have "\<forall>i > N. \<not> f i < x" using * by auto
  moreover have "\<forall>i > N. f N \<ge> f i"
    using chainp_imp_rtranclp [of "(\<ge>)" f, OF assms] by simp
  ultimately have "\<forall>i > N. f i = f (Suc i)"
    using \<open>f N = x\<close> by (auto) (metis less_SucI order.not_eq_order_implies_strict)
  then show ?thesis ..
qed

lemma inc_seq_greater:
  fixes f :: "nat seq"
  assumes "\<forall>i. f i < f (Suc i)"
  shows "\<exists>i. f i > N"
  using assms
  apply (induct N)
   apply (auto)
   apply (metis neq0_conv)
  by (metis Suc_lessI)

end


(*
 * Copyright 2014, NICTA
 *
 * 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(NICTA_BSD)
 *)

section "Normalising Word Numerals"

theory Norm_Words
imports Signed_Words
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval @{text "[0..2^len_of 'a)"}. Only for concrete word lengths.
\<close>

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (len_of TYPE('a)) (-numeral x))"
  by (simp only: word_ubin.Abs_norm word_neg_numeral_alt)

ML \<open>
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT (Type (@{type_name word}, [Type (@{type_name signed}, [T])])) = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

declare word_pow_0 [simp]

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ len_of TYPE('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

lemma "f (7 :: 2 word) = f 3" by simp

lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

lemma "(-1 :: 2 word) = 3" by simp

lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

lemma "f (-1) = f (15 :: 4 word)" by simp

lemma "f (-1) = f (7 :: 3 word)" by simp

lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end


section \<open>Nested datatypes\<close>

theory Nested_Datatype
imports Main
begin

subsection \<open>Terms and substitution\<close>

datatype ('a, 'b) "term" =
  Var 'a
| App 'b "('a, 'b) term list"

primrec subst_term :: "('a \<Rightarrow> ('a, 'b) term) \<Rightarrow> ('a, 'b) term \<Rightarrow> ('a, 'b) term"
  and subst_term_list :: "('a \<Rightarrow> ('a, 'b) term) \<Rightarrow> ('a, 'b) term list \<Rightarrow> ('a, 'b) term list"
where
  "subst_term f (Var a) = f a"
| "subst_term f (App b ts) = App b (subst_term_list f ts)"
| "subst_term_list f [] = []"
| "subst_term_list f (t # ts) = subst_term f t # subst_term_list f ts"

lemmas subst_simps = subst_term.simps subst_term_list.simps

text \<open>\<^medskip> A simple lemma about composition of substitutions.\<close>

lemma
  "subst_term (subst_term f1 \<circ> f2) t =
    subst_term f1 (subst_term f2 t)"
  and
  "subst_term_list (subst_term f1 \<circ> f2) ts =
    subst_term_list f1 (subst_term_list f2 ts)"
  by (induct t and ts rule: subst_term.induct subst_term_list.induct) simp_all

lemma "subst_term (subst_term f1 \<circ> f2) t = subst_term f1 (subst_term f2 t)"
proof -
  let "?P t" = ?thesis
  let ?Q = "\<lambda>ts. subst_term_list (subst_term f1 \<circ> f2) ts =
    subst_term_list f1 (subst_term_list f2 ts)"
  show ?thesis
  proof (induct t rule: subst_term.induct)
    show "?P (Var a)" for a by simp
    show "?P (App b ts)" if "?Q ts" for b ts
      using that by (simp only: subst_simps)
    show "?Q []" by simp
    show "?Q (t # ts)" if "?P t" "?Q ts" for t ts
      using that by (simp only: subst_simps)
  qed
qed

subsection \<open>Alternative induction\<close>

lemma "subst_term (subst_term f1 \<circ> f2) t = subst_term f1 (subst_term f2 t)"
proof (induct t rule: term.induct)
  case (Var a)
  show ?case by (simp add: o_def)
next
  case (App b ts)
  then show ?case by (induct ts) simp_all
qed

end