section \<open>Minsky machines\<close>

theory Minsky
  imports Recursive_Inseparability "Abstract-Rewriting.Abstract_Rewriting" "Pure-ex.Guess"
begin

text \<open>We formalize Minksy machines, and relate them to recursive functions. In our flavor of
Minsky machines, a machine has a set of registers and a set of labels, and a program is a set of
labeled operations. There are two operations, @{term Inc} and @{term Dec}; the former takes a
register and a label, and the latter takes a register and two labels. When an @{term Inc}
instruction is executed, the register is incremented and execution continues at the provided label.
The @{term Dec} instruction checks the register. If it is non-zero, the register and continues
execution at the first label. Otherwise, the register remains at zero and execution continues at
the second label.

We continue to show that Minksy machines can implement any primitive recursive function. Based on
that, we encode recursively enumerable sets as Minsky machines, and finally show that
\begin{enumerate}
\item The set of Minsky configurations such that from state $1$, state $0$ can be reached,
  is undecidable;
\item There is a deterministic Minsky machine $U$ such that the set of values $x$ such that
  $(2, \lambda n.\, \text{if $n = 0$ then $x$ else $0$})$ reach state $0$ is recursively
  inseparable from those that reach state $1$; and
\item As a corollary, the set of Minsky configurations that reach state $0$ but not state $1$ is
  recursively inseparable from the configurations that reach state $1$ but not state $0$.
\end{enumerate}\<close>

subsection \<open>Deterministic relations\<close>

text \<open>A relation $\to$ is \emph{deterministic} if $t \from s \to u'$ implies $t = u$.
This abstract rewriting notion is useful for talking about deterministic Minsky machines.\<close>

definition
  "deterministic R \<longleftrightarrow> R\<inverse> O R \<subseteq> Id"

lemma deterministicD:
  "deterministic R \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (x, z) \<in> R \<Longrightarrow> y = z"
  by (auto simp: deterministic_def)

lemma deterministic_empty [simp]:
  "deterministic {}"
  by (auto simp: deterministic_def)

lemma deterministic_singleton [simp]:
  "deterministic {p}"
  by (auto simp: deterministic_def)

lemma deterministic_imp_weak_diamond [intro]:
  "deterministic R \<Longrightarrow> w\<diamond> R"
  by (auto simp: weak_diamond_def deterministic_def)

lemmas deterministic_imp_CR = deterministic_imp_weak_diamond[THEN weak_diamond_imp_CR]

lemma deterministic_union:
  "fst ` S \<inter> fst ` R = {} \<Longrightarrow> deterministic S \<Longrightarrow> deterministic R \<Longrightarrow> deterministic (S \<union> R)"
  by (fastforce simp add: deterministic_def disjoint_iff_not_equal)

lemma deterministic_map:
  "inj_on f (fst ` R) \<Longrightarrow> deterministic R \<Longrightarrow> deterministic (map_prod f g ` R)"
  by (auto simp add: deterministic_def dest!: inj_onD; force)

subsection \<open>Minsky machine definition\<close>

text \<open>A Minsky operation either decrements a register (testing for zero, with two possible
successor states), or increments a register (with one successor state). A Minsky machine is a
set of pairs of states and operations.\<close>

datatype ('s, 'v) Op = Dec (op_var: 'v) 's 's | Inc (op_var: 'v) 's

type_synonym ('s, 'v) minsky = "('s \<times> ('s, 'v) Op) set"

text \<open>Semantics: A Minsky machine operates on pairs consisting of a state and an assignment of
the registers; in each step, either a register is incremented, or a register is decremented,
provided it is non-zero. We write $\alpha$ for assignments; $\alpha[v]$ for the value of the
register $v$ in $\alpha$ and $\alpha[v := n]$ for the update of $v$ to $n$. Thus, the semantics
is as follows:
\begin{enumerate}
\item if $(s, Inc\ v\ s') \in M$ then $(s, \alpha) \to (s', \alpha[v := \alpha[v] + 1]$);
\item if $(s, Dec\ v\ s_n\ s_z) \in M$ and $\alpha[v] > 0$ then $(s, \alpha) \to (s_n, \alpha[v := \alpha[v] - 1]$); and
\item if $(s, Dec\ v\ s_n\ s_z) \in M$ and $\alpha[v] = 0$ then $(s, \alpha) \to (s_z, \alpha)$.
\end{enumerate}
A state is finite if there is no operation associated with it.\<close>

inductive_set step :: "('s, 'v) minsky \<Rightarrow> ('s \<times> ('v \<Rightarrow> nat)) rel" for M :: "('s, 'v) minsky" where
  inc: "(s, Inc v s') \<in> M \<Longrightarrow> ((s, vs), (s', \<lambda>x. if x = v then Suc (vs v) else vs x)) \<in> step M"
| decn: "(s, Dec v sn sz) \<in> M \<Longrightarrow> vs v = Suc n \<Longrightarrow> ((s, vs), (sn, \<lambda>x. if x = v then n else vs x)) \<in> step M"
| decz: "(s, Dec v sn sz) \<in> M \<Longrightarrow> vs v = 0 \<Longrightarrow> ((s, vs), (sz, vs)) \<in> step M"

lemma step_mono:
  "M \<subseteq> M' \<Longrightarrow> step M \<subseteq> step M'"
  by (auto elim: step.cases intro: step.intros)

lemmas steps_mono = rtrancl_mono[OF step_mono]

text \<open>A Minsky machine has deterministic steps if its defining relation between states and
operations is deterministic.\<close>

lemma deterministic_stepI [intro]:
  assumes "deterministic M" shows "deterministic (step M)"
proof -
  { fix s vs s1 vs1 s2 vs2
    assume s: "((s, vs), (s1, vs1)) \<in> step M" "((s, vs), (s2, vs2)) \<in> step M"
    have "(s1, vs1) = (s2, vs2)" using deterministicD[OF assms]
      by (cases rule: step.cases[OF s(1)]; cases rule: step.cases[OF s(2)]) fastforce+ }
  then show ?thesis by (auto simp: deterministic_def)
qed

text \<open>A Minksy machine halts when it reaches a state with no associated operation.\<close>

lemma NF_stepI [intro]:
  "s \<notin> fst ` M \<Longrightarrow> (s, vs) \<in> NF (step M)"
  by (auto intro!: no_step elim!: step.cases simp: rev_image_eqI)

text \<open>Deterministic Minsky machines enjoy unique normal forms.\<close>

lemmas deterministic_minsky_UN =
  join_NF_imp_eq[OF CR_divergence_imp_join[OF deterministic_imp_CR[OF deterministic_stepI]] NF_stepI NF_stepI]

text \<open>We will rename states and variables.\<close>

definition map_minsky where
  "map_minsky f g M = map_prod f (map_Op f g) ` M"

lemma map_minsky_id:
  "map_minsky id id M = M"
  by (simp add: map_minsky_def Op.map_id0 map_prod.id)

lemma map_minsky_comp:
  "map_minsky f g (map_minsky f' g' M) = map_minsky (f \<circ> f') (g \<circ> g') M"
  unfolding map_minsky_def image_comp Op.map_comp map_prod.comp comp_def[of "map_Op _ _"] ..

text \<open>When states and variables are renamed, computations carry over from the original machine,
provided that variables are renamed injectively.\<close>

lemma map_step:
  assumes "inj g" "vs = vs' \<circ> g" "((s, vs), (t, ws)) \<in> step M"
  shows "((f s, vs'), (f t, \<lambda>x. if x \<in> range g then ws (inv g x) else vs' x)) \<in> step (map_minsky f g M)"
  using assms(3)
proof (cases rule: step.cases)
  case (inc v) note [simp] = inc(1)
  let ?ws' = "\<lambda>w. if w = g v then Suc (vs' (g v)) else vs' w"
  have "((f s, vs'), (f t, ?ws')) \<in> step (map_minsky f g M)"
    using inc(2) step.inc[of "f s" "g v" "f t" "map_minsky f g M" vs']
    by (force simp: map_minsky_def)
  moreover have "(\<lambda>x. if x \<in> range g then ws (inv g x) else vs' x) = ?ws'"
    using assms(1,2) by (auto intro!: ext simp: injD image_def)
  ultimately show ?thesis by auto
next
  case (decn v sz n) note [simp] = decn(1)
  let ?ws' = "\<lambda>x. if x = g v then n else vs' x"
  have "((f s, vs'), (f t, ?ws')) \<in> step (map_minsky f g M)"
    using assms(2) decn(2-) step.decn[of "f s" "g v" "f t" "f sz" "map_minsky f g M" vs' n]
    by (force simp: map_minsky_def)
  moreover have "(\<lambda>x. if x \<in> range g then ws (inv g x) else vs' x) = ?ws'"
    using assms(1,2) by (auto intro!: ext simp: injD image_def)
  ultimately show ?thesis by auto
next
  case (decz v sn) note [simp] = decz(1)
  have "((f s, vs'), (f t, vs')) \<in> step (map_minsky f g M)"
    using assms(2) decz(2-) step.decz[of "f s" "g v" "f sn" "f t" "map_minsky f g M" vs']
    by (force simp: map_minsky_def)
  moreover have "(\<lambda>x. if x \<in> range g then ws (inv g x) else vs' x) = vs'"
    using assms(1,2) by (auto intro!: ext simp: injD image_def)
  ultimately show ?thesis by auto
qed

lemma map_steps:
  assumes "inj g" "vs = ws \<circ> g" "((s, vs), (t, vs')) \<in> (step M)\<^sup>*"
  shows "((f s, ws), (f t, \<lambda>x. if x \<in> range g then vs' (inv g x) else ws x)) \<in> (step (map_minsky f g M))\<^sup>*"
  using assms(3,2)
proof (induct "(s, vs)" arbitrary: s vs ws rule: converse_rtrancl_induct)
  case base
  then have "(\<lambda>x. if x \<in> range g then vs' (inv g x) else ws x) = ws"
    using assms(1) by (auto intro!: ext simp: injD image_def)
  then show ?case by auto
next
  case (step y)
  have "snd y = (\<lambda>x. if x \<in> range g then snd y (inv g x) else ws x) \<circ> g" (is "_ = ?ys' \<circ> _")
    using assms(1) by auto
  then show ?case  using map_step[OF assms(1) step(4), of s "fst y" "snd y" M f] step(1)
    step(3)[OF prod.collapse[symmetric], of ?ys'] by (auto cong: if_cong)
qed

subsection \<open>Concrete Minsky machines\<close>

text \<open>The following definition expresses when a Minsky machine $M$ implements a specification $P$.
We adopt the convention that computations always start out in state $1$ and end in state $0$, which
must be a final state. The specification $P$ relates initial assignments to final assignments.\<close>

definition mk_minsky_wit :: "(nat, nat) minsky \<Rightarrow> ((nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool) \<Rightarrow> bool" where
  "mk_minsky_wit M P \<equiv> finite M \<and> deterministic M \<and> 0 \<notin> fst ` M \<and>
     (\<forall>vs. \<exists>vs'. ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>* \<and> P vs vs')"

abbreviation mk_minsky :: "((nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool) \<Rightarrow> bool" where
  "mk_minsky P \<equiv> \<exists>M. mk_minsky_wit M P"

lemmas mk_minsky_def = mk_minsky_wit_def

lemma mk_minsky_mono:
  shows "mk_minsky P \<Longrightarrow> (\<And>vs vs'. P vs vs' \<Longrightarrow> Q vs vs') \<Longrightarrow> mk_minsky Q"
  unfolding mk_minsky_def by meson

lemma mk_minsky_sound:
  assumes "mk_minsky_wit M P" "((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>*"
  shows "P vs vs'"
proof -
  have M: "deterministic M" "0 \<notin> fst ` M" "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and> P vs vs'"
    using assms(1) by (auto simp: mk_minsky_wit_def)
  obtain vs'' where vs'': "((Suc 0, vs), (0, vs'')) \<in> (step M)\<^sup>*" "P vs vs''" using M(3) by blast
  have "(0 :: nat, vs') = (0, vs'')" using M(1,2)
    by (intro deterministic_minsky_UN[OF _ assms(2) vs''(1)])
  then show ?thesis using vs''(2) by simp
qed

text \<open>Realizability of $n$-ary functions for $n = 1 \dots 3$. Here we use the convention that the
arguments are passed in registers $1 \dots 3$, and the result is stored in register $0$.\<close>

abbreviation mk_minsky1 where
  "mk_minsky1 f \<equiv> mk_minsky (\<lambda>vs vs'. vs' 0 = f (vs 1))"

abbreviation mk_minsky2 where
  "mk_minsky2 f \<equiv> mk_minsky (\<lambda>vs vs'. vs' 0 = f (vs 1) (vs 2))"

abbreviation mk_minsky3 where
  "mk_minsky3 f \<equiv> mk_minsky (\<lambda>vs vs'. vs' 0 = f (vs 1) (vs 2) (vs 3))"

subsection \<open>Trivial building blocks\<close>

text \<open>We can increment and decrement any register.\<close>

lemma mk_minsky_inc:
  shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then Suc (vs v) else vs x))"
  using step.inc[of "Suc 0" v 0]
  by (auto simp: deterministic_def mk_minsky_def intro!: exI[of _ "{(1, Inc v 0)} :: (nat, nat) minsky"])

lemma mk_minsky_dec:
  shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then vs v - 1 else vs x))"
proof -
  let ?M = "{(1, Dec v 0 0)} :: (nat, nat) minsky"
  show ?thesis unfolding mk_minsky_def
  proof (intro exI[of _ ?M] allI conjI, goal_cases)
    case (4 vs)
    have [simp]: "vs v = 0 \<Longrightarrow> (\<lambda>x. if x = v then 0 else vs x) = vs" by auto
    show ?case using step.decz[of "Suc 0" v 0 0 ?M] step.decn[of "Suc 0" v 0 0 ?M]
      by (cases "vs v") (auto cong: if_cong)
  qed auto
qed

subsection \<open>Sequential composition\<close>

text \<open>The following lemma has two useful corollaries (which we prove simultaneously because they
share much of the proof structure): First, if $P$ and $Q$ are realizable, then so is $P \circ Q$.
Secondly, if we rename variables by an injective function $f$ in a Minksy machine, then the
variables outside the range of $f$ remain unchanged.\<close>

lemma mk_minsky_seq_map:
  assumes "mk_minsky P" "mk_minsky Q" "inj g"
    "\<And>vs vs' vs''. P vs vs' \<Longrightarrow> Q vs' vs'' \<Longrightarrow> R vs vs''"
  shows "mk_minsky (\<lambda>vs vs'. R (vs \<circ> g) (vs' \<circ> g) \<and> (\<forall>x. x \<notin> range g \<longrightarrow> vs x = vs' x))"
proof -
  obtain M where M: "finite M" "deterministic M" "0 \<notin> fst ` M"
    "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and> P vs vs'"
    using assms(1) by (auto simp: mk_minsky_def)
  obtain N where N: "finite N" "deterministic N" "0 \<notin> fst ` N"
    "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step N)\<^sup>* \<and> Q vs vs'"
    using assms(2) by (auto simp: mk_minsky_def)
  let ?fM = "\<lambda>s. if s = 0 then 2 else if s = 1 then 1 else 2 * s + 1" \<comment> \<open>M: from 1 to 2\<close>
  let ?fN = "\<lambda>s. 2 * s"                                               \<comment> \<open>N: from 2 to 0\<close>
  let ?M = "map_minsky ?fM g M \<union> map_minsky ?fN g N"
  show ?thesis unfolding mk_minsky_def
  proof (intro exI[of _ ?M] conjI allI, goal_cases)
    case 1 show ?case using M(1) N(1) by (auto simp: map_minsky_def)
  next
    case 2 show ?case using M(2,3) N(2) unfolding map_minsky_def
      by (intro deterministic_union deterministic_map)
        (auto simp: inj_on_def rev_image_eqI Suc_double_not_eq_double split: if_splits)
  next
    case 3 show ?case using N(3) by (auto simp: rev_image_eqI map_minsky_def split: if_splits)
  next
    case (4 vs)
    obtain vsM where M': "((Suc 0, vs \<circ> g), 0, vsM) \<in> (step M)\<^sup>*" "P (vs \<circ> g) vsM"
      using M(4) by blast
    obtain vsN where N': "((Suc 0, vsM), 0, vsN) \<in> (step N)\<^sup>*" "Q vsM vsN"
      using N(4) by blast
    note * = subsetD[OF steps_mono, of _ ?M]
      map_steps[OF _ _ M'(1), of g vs ?fM, simplified]
      map_steps[OF _ _ N'(1), of g _ ?fN, simplified]
    show ?case
      using assms(3,4) M'(2) N'(2) rtrancl_trans[OF *(1)[OF _ *(2)] *(1)[OF _ *(3)]]
      by (auto simp: comp_def)
  qed
qed

text \<open>Sequential composition.\<close>

lemma mk_minsky_seq:
  assumes "mk_minsky P" "mk_minsky Q"
    "\<And>vs vs' vs''. P vs vs' \<Longrightarrow> Q vs' vs'' \<Longrightarrow> R vs vs''"
  shows "mk_minsky R"
  using mk_minsky_seq_map[OF assms(1,2), of id] assms(3) by simp

lemma mk_minsky_seq':
  assumes "mk_minsky P" "mk_minsky Q"
  shows "mk_minsky (\<lambda>vs vs''. (\<exists>vs'. P vs vs' \<and> Q vs' vs''))"
  by (intro mk_minsky_seq[OF assms]) blast

text \<open>We can do nothing (besides transitioning from state 1 to state 0).\<close>

lemma mk_minsky_nop:
  "mk_minsky (\<lambda>vs vs'. vs = vs')"
  by (intro mk_minsky_seq[OF mk_minsky_inc mk_minsky_dec]) auto

text \<open>Renaming variables.\<close>

lemma mk_minsky_map:
  assumes "mk_minsky P" "inj f"
  shows "mk_minsky (\<lambda>vs vs'. P (vs \<circ> f) (vs' \<circ> f) \<and> (\<forall>x. x \<notin> range f \<longrightarrow> vs x = vs' x))"
  using mk_minsky_seq_map[OF assms(1) mk_minsky_nop assms(2)] by simp

lemma inj_shift [simp]:
  fixes a b :: nat
  assumes "a < b"
  shows "inj (\<lambda>x. if x = 0 then a else x + b)"
  using assms by (auto simp: inj_on_def)

subsection \<open>Bounded loop\<close>

text \<open>In the following lemma, $P$ is the specification of a loop body, and $Q$ the specification
of the loop itself (a loop invariant). The loop variable is $v$. $Q$ can be realized provided that
\begin{enumerate}
\item $P$ can be realized;
\item $P$ ensures that the loop variable is not changed by the loop body; and
\item $Q$ follows by induction on the loop variable:
  \begin{enumerate}
  \item $\alpha\,Q\,\alpha$ holds when $\alpha[v] = 0$; and
  \item $\alpha[v := n]\,P\,\alpha'$ and $\alpha'\,Q\,\alpha''$ imply $\alpha\,Q\,alpha''$
    when $\alpha[v] = n+1$.
  \end{enumerate}
\end{enumerate}\<close>

lemma mk_minsky_loop:
  assumes "mk_minsky P"
    "\<And>vs vs'. P vs vs' \<Longrightarrow> vs' v = vs v"
    "\<And>vs. vs v = 0 \<Longrightarrow> Q vs vs"
    "\<And>n vs vs' vs''. vs v = Suc n \<Longrightarrow> P (\<lambda>x. if x = v then n else vs x) vs' \<Longrightarrow> Q vs' vs'' \<Longrightarrow> Q vs vs''"
  shows "mk_minsky Q"
proof -
  obtain M where M: "finite M" "deterministic M" "0 \<notin> fst ` M"
    "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and> P vs vs'"
    using assms(1) by (auto simp: mk_minsky_def)
  let ?M = "{(1, Dec v 2 0)} \<union> map_minsky Suc id M"
  show ?thesis unfolding mk_minsky_def
  proof (intro exI[of _ ?M] conjI allI, goal_cases)
    case 1 show ?case using M(1) by (auto simp: map_minsky_def)
  next
    case 2 show ?case using M(2,3) unfolding map_minsky_def
      by (intro deterministic_union deterministic_map) (auto simp: rev_image_eqI)
  next
    case 3 show ?case by (auto simp: map_minsky_def)
  next
    case (4 vs) show ?case
    proof (induct "vs v" arbitrary: vs)
      case 0 then show ?case using assms(3)[of vs] step.decz[of 1 v 2 0 ?M vs]
        by (auto simp: id_def)
    next
      case (Suc n)
      obtain vs' where M': "((Suc 0, \<lambda>x. if x = v then n else vs x), 0, vs') \<in> (step M)\<^sup>*"
        "P (\<lambda>x. if x = v then n else vs x) vs'" using M(4) by blast
      obtain vs'' where D: "((Suc 0, vs'), 0, vs'') \<in> (step ?M)\<^sup>*" "Q vs' vs''"
        using Suc(1)[of vs'] assms(2)[OF M'(2)] by auto
      note * = subsetD[OF steps_mono, of _ ?M]
        r_into_rtrancl[OF decn[of "Suc 0" v 2 0 ?M vs n]]
        map_steps[OF _ _ M'(1), of id _ Suc, simplified, OF refl, simplified, folded numeral_2_eq_2]
      show ?case using rtrancl_trans[OF rtrancl_trans, OF *(2) *(1)[OF _ *(3)] D(1)]
        D(2) Suc(2) assms(4)[OF _ M'(2), of vs''] by auto
    qed
  qed
qed

subsection \<open>Copying values\<close>

text \<open>We work up to copying values in several steps.
\begin{enumerate}
\item Clear a register. This is a loop that decrements the register until it reaches $0$.
\item Add a register to another one. This is a loop that decrements one register, and increments
  the other register, until the first register reaches 0.
\item Add a register to two others. This is the same, except that two registers are incremented.
\item Move a register: set a register to 0, then add another register to it.
\item Copy a register destructively: clear two registers, then add another register to them.
\end{enumerate}\<close>

lemma mk_minsky_zero:
  shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then 0 else vs x))"
  by (intro mk_minsky_loop[where v = v, OF \<comment> \<open> while v[v]$--$: \<close>
    mk_minsky_nop]) auto                   \<comment> \<open>   pass          \<close>

lemma mk_minsky_add1:
  assumes "v \<noteq> w"
  shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then 0 else if x = w then vs v + vs w else vs x))"
  using assms by (intro mk_minsky_loop[where v = v, OF \<comment> \<open> while v[v]$--$: \<close>
    mk_minsky_inc[of w]]) auto                         \<comment> \<open>   v[w]++        \<close>

lemma mk_minsky_add2:
  assumes "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
  shows "mk_minsky (\<lambda>vs vs'. vs' =
    (\<lambda>x. if x = u then 0 else if x = v then vs u + vs v else if x = w then vs u + vs w else vs x))"
  using assms by (intro mk_minsky_loop[where v = u, OF mk_minsky_seq'[OF \<comment> \<open> while v[u]$--$: \<close>
    mk_minsky_inc[of v]                                                  \<comment> \<open>   v[v]++        \<close>
    mk_minsky_inc[of w]]]) auto                                          \<comment> \<open>   v[w]++        \<close>

lemma mk_minsky_copy1:
  assumes "v \<noteq> w"
  shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then 0 else if x = w then vs v else vs x))"
  using assms by (intro mk_minsky_seq[OF
    mk_minsky_zero[of w]          \<comment> \<open> v[w] := 0                      \<close>
    mk_minsky_add1[of v w]]) auto \<comment> \<open> v[w] := v[w] + v[v], v[v] := 0 \<close>

lemma mk_minsky_copy2:
  assumes "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
  shows "mk_minsky (\<lambda>vs vs'. vs' =
    (\<lambda>x. if x = u then 0 else if x = v then vs u else if x = w then vs u else vs x))"
  using assms by (intro mk_minsky_seq[OF mk_minsky_seq', OF
    mk_minsky_zero[of v]            \<comment> \<open> v[v] := 0                                           \<close>
    mk_minsky_zero[of w]            \<comment> \<open> v[w] := 0                                           \<close>
    mk_minsky_add2[of u v w]]) auto \<comment> \<open> v[v] := v[v] + v[u], v[w] := v[w] + v[u], v[u] := 0 \<close>

lemma mk_minsky_copy:
  assumes "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
  shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then vs u else if x = w then 0 else vs x))"
  using assms by (intro mk_minsky_seq[OF
    mk_minsky_copy2[of u v w]      \<comment> \<open> v[v] := v[u], v[w] := v[u], v[u] := 0 \<close>
    mk_minsky_copy1[of w u]]) auto \<comment> \<open> v[u] := v[w], v[w] := 0               \<close>

subsection \<open>Primitive recursive functions\<close>

text \<open>Nondestructive apply: compute $f$ on arguments $\alpha[u]$, $\alpha[v]$, $\alpha[w]$,
storing the result in $\alpha[t]$ and preserving all other registers below $k$. This is easy
now that we can copy values.\<close>

lemma mk_minsky_apply3:
  assumes "mk_minsky3 f" "t < k" "u < k" "v < k" "w < k"
  shows "mk_minsky (\<lambda>vs vs'. \<forall>x < k. vs' x = (if x = t then f (vs u) (vs v) (vs w) else vs x))"
  using assms(2-)
  by (intro mk_minsky_seq[OF mk_minsky_seq'[OF mk_minsky_seq'], OF
    mk_minsky_copy[of u "1 + k" k] \<comment> \<open> v[1+k] := v[u] \<close>
    mk_minsky_copy[of v "2 + k" k] \<comment> \<open> v[2+k] := v[v] \<close>
    mk_minsky_copy[of w "3 + k" k] \<comment> \<open> v[3+k] := v[w] \<close>
    mk_minsky_map[OF assms(1), of "\<lambda>x. if x = 0 then t else x + k"]]) (auto 0 2)
                                   \<comment> \<open> v[t] := f v[1+k] v[2+k] v[3+k] \<close>

text \<open>Composition is just four non-destructive applies.\<close>

lemma mk_minsky_comp3_3:
  assumes "mk_minsky3 f" "mk_minsky3 g" "mk_minsky3 h" "mk_minsky3 k"
  shows "mk_minsky3 (\<lambda>x y z. f (g x y z) (h x y z) (k x y z))"
  by (rule mk_minsky_seq[OF mk_minsky_seq'[OF mk_minsky_seq'], OF
    mk_minsky_apply3[OF assms(2), of 4 7 1 2 3]        \<comment> \<open> v[4] := g v[1] v[2] v[3] \<close>
    mk_minsky_apply3[OF assms(3), of 5 7 1 2 3]        \<comment> \<open> v[5] := h v[1] v[2] v[3] \<close>
    mk_minsky_apply3[OF assms(4), of 6 7 1 2 3]        \<comment> \<open> v[6] := k v[1] v[2] v[3] \<close>
    mk_minsky_apply3[OF assms(1), of 0 7 4 5 6]]) auto \<comment> \<open> v[0] := f v[4] v[5] v[6] \<close>

text \<open>Primitive recursion is a non-destructive apply followed by a loop with another
non-destructive apply. The key to the proof is the loop invariant, which we can specify
as part of composing the various \<open>mk_minsky_*\<close> lemmas.\<close>

lemma mk_minsky_prim_rec:
  assumes "mk_minsky1 g" "mk_minsky3 h"
  shows "mk_minsky2 (PrimRecOp g h)"
  by (intro mk_minsky_seq[OF mk_minsky_seq', OF
    mk_minsky_apply3[OF assms(1), of 0 4 2 2 2]       \<comment> \<open> v[0] := g v[2]             \<close>
    mk_minsky_zero[of 3]                              \<comment> \<open> v[3] := 0                  \<close>
    mk_minsky_loop[where v = 1, OF mk_minsky_seq', OF \<comment> \<open> while v[1]$--$:            \<close>
      mk_minsky_apply3[OF assms(2), of 0 4 3 0 2]     \<comment> \<open>   v[0] := h v[3] v[0] v[2] \<close>
      mk_minsky_inc[of 3],                            \<comment> \<open>   v[3]++                   \<close>
      of "\<lambda>vs vs'. vs 0 = PrimRecOp g h (vs 3) (vs 2) \<longrightarrow> vs' 0 = PrimRecOp g h (vs 3 + vs 1) (vs 2)"
    ]]) auto

text \<open>With these building blocks we can easily show that all primitive recursive functions can
be realized by a Minsky machine.\<close>

lemma mk_minsky_PrimRec:
  "f \<in> PrimRec1 \<Longrightarrow> mk_minsky1 f"
  "g \<in> PrimRec2 \<Longrightarrow> mk_minsky2 g"
  "h \<in> PrimRec3 \<Longrightarrow> mk_minsky3 h"
proof (goal_cases)
  have *: "(f \<in> PrimRec1 \<longrightarrow> mk_minsky1 f) \<and> (g \<in> PrimRec2 \<longrightarrow> mk_minsky2 g) \<and> (h \<in> PrimRec3 \<longrightarrow> mk_minsky3 h)"
  proof (induction rule: PrimRec1_PrimRec2_PrimRec3.induct)
    case zero show ?case by (intro mk_minsky_mono[OF mk_minsky_zero]) auto
  next
    case suc show ?case by (intro mk_minsky_seq[OF mk_minsky_copy1[of 1 0] mk_minsky_inc[of 0]]) auto
  next
    case id1_1 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 1 0]]) auto
  next
    case id2_1 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 1 0]]) auto
  next
    case id2_2 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 2 0]]) auto
  next
    case id3_1 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 1 0]]) auto
  next
    case id3_2 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 2 0]]) auto
  next
    case id3_3 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 3 0]]) auto
  next
    case (comp1_1 f g) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp1_2 f g) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp1_3 f g) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp2_1 f g h) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp3_1 f g h k) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp2_2 f g h) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp2_3 f g h) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp3_2 f g h k) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (comp3_3 f g h k) then show ?case using mk_minsky_comp3_3 by fast
  next
    case (prim_rec g h) then show ?case using mk_minsky_prim_rec by blast
  qed
  { case 1 thus ?case using * by blast next
    case 2 thus ?case using * by blast next
    case 3 thus ?case using * by blast }
qed

subsection \<open>Recursively enumerable sets as Minsky machines\<close>

text \<open>The following is the most complicated lemma of this theory: Given two r.e.\ sets $A$ and $B$
we want to construct a Minsky machine that reaches the final state $0$ for input $x$ if $x \in A$
and final state $1$ if $x \in B$, and never reaches either of these states if $x \notin A \cup B$.
(If $x \in A \cap B$, then either state $0$ or state $1$ may be reached.) We consider two
r.e.\ sets rather than one because we target recursive inseparability.

For the r.e.\ set $A$, there is a primitive recursive function $f$ such that
$x \in A \iff \exists y.\, f(x,y) = 0$. Similarly there is a primitive recursive function $g$ for
$B$ such that $x \in B \iff \exists y.\, f(x,y) = 0$. Our Minsky machine takes $x$ in register
$0$ and $y$ in register $1$ (initially $0$) and works as follows.
\begin{enumerate}
\item evaluate $f(x,y)$; if the result is $0$, transition to state $0$; otherwise,
\item evaluate $g(x,y)$; if the result is $0$, transition to state $1$; otherwise,
\item increment $y$ and start over.
\end{enumerate}\<close>

lemma ce_set_pair_by_minsky:
  assumes "A \<in> ce_sets" "B \<in> ce_sets"
  obtains M :: "(nat, nat) minsky" where
    "finite M" "deterministic M" "0 \<notin> fst ` M" "Suc 0 \<notin> fst ` M"
    "\<And>x vs. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> x \<in> A \<union> B \<Longrightarrow>
     \<exists>vs'. ((2, vs), (0, vs')) \<in> (step M)\<^sup>* \<or> ((2, vs), (Suc 0, vs')) \<in> (step M)\<^sup>*"
    "\<And>x vs vs'. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> ((2, vs), (0, vs')) \<in> (step M)\<^sup>* \<Longrightarrow> x \<in> A"
    "\<And>x vs vs'. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> ((2, vs), (Suc 0, vs')) \<in> (step M)\<^sup>* \<Longrightarrow> x \<in> B"
proof -
  obtain g where g: "g \<in> PrimRec2" "\<And>x. x \<in> A \<longleftrightarrow> (\<exists>y. g x y = 0)"
    using assms(1) by (auto simp: ce_sets_def fn_to_set_def)
  obtain h where h: "h \<in> PrimRec2" "\<And>x. x \<in> B \<longleftrightarrow> (\<exists>y. h x y = 0)"
    using assms(2) by (auto simp: ce_sets_def fn_to_set_def)
  have "mk_minsky (\<lambda>vs vs'. vs' 0 = vs 0 \<and> vs' 1 = vs 1 \<and> vs' 2 = g (vs 0) (vs 1))"
    using mk_minsky_seq[OF
      mk_minsky_apply3[OF mk_minsky_PrimRec(2)[OF g(1)], of 2 3 0 1 0] \<comment> \<open> v[2] := g v[0] v[1] \<close>
      mk_minsky_nop] by auto                                           \<comment> \<open> pass                \<close>
  then obtain M :: "(nat, nat) minsky" where M: "finite M" "deterministic M" "0 \<notin> fst ` M"
    "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and>
    vs' 0 = vs 0 \<and> vs' 1 = vs 1 \<and> vs' 2 = g (vs 0) (vs 1)"
    unfolding mk_minsky_def by blast
  have "mk_minsky (\<lambda>vs vs'. vs' 0 = vs 0 \<and> vs' 1 = vs 1 + 1 \<and> vs' 2 = h (vs 0) (vs 1))"
    using mk_minsky_seq[OF
      mk_minsky_apply3[OF mk_minsky_PrimRec(2)[OF h(1)], of 2 3 0 1 0] \<comment> \<open> v[2] := h v[0] v[1] \<close>
      mk_minsky_inc[of 1]] by auto                                     \<comment> \<open> v[1] := v[1] + 1    \<close>
  then obtain N :: "(nat, nat) minsky" where N: "finite N" "deterministic N" "0 \<notin> fst ` N"
    "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step N)\<^sup>* \<and>
    vs' 0 = vs 0 \<and> vs' 1 = vs 1 + 1 \<and> vs' 2 = h (vs 0) (vs 1)"
    unfolding mk_minsky_def by blast
  let ?f = "\<lambda>s. if s = 0 then 3 else 2 * s" \<comment> \<open>M: from state 4 to state 3\<close>
  let ?g = "\<lambda>s. 2 * s + 5"                  \<comment> \<open>N: from state 7 to state 5\<close>
  define X where "X = map_minsky ?f id M \<union> map_minsky ?g id N \<union> {(3, Dec 2 7 0)} \<union> {(5, Dec 2 2 1)}"
  have MX: "map_minsky ?f id M \<subseteq> X" by (auto simp: X_def)
  have NX: "map_minsky ?g id N \<subseteq> X" by (auto simp: X_def)
  have DX: "(3, Dec 2 7 0) \<in> X" "(5, Dec 2 2 1) \<in> X" by (auto simp: X_def)
  have X1: "finite X" using M(1) N(1) by (auto simp: map_minsky_def X_def)
  have X2: "deterministic X" unfolding X_def using M(2,3) N(2,3)
    apply (intro deterministic_union)
    by (auto simp: map_minsky_def rev_image_eqI inj_on_def split: if_splits
      intro!: deterministic_map) presburger+
  have X3: "0 \<notin> fst ` X" "Suc 0 \<notin> fst ` X" using M(3) N(3)
    by (auto simp: X_def map_minsky_def split: if_splits)
  have X4: "\<exists>vs'. g (vs 0) (vs 1) = 0 \<and> ((2, vs), (0, vs')) \<in> (step X)\<^sup>* \<or>
    h (vs 0) (vs 1) = 0 \<and> ((2, vs), (1, vs')) \<in> (step X)\<^sup>* \<or>
    g (vs 0) (vs 1) \<noteq> 0 \<and> h (vs 0) (vs 1) \<noteq> 0 \<and> vs' 0 = vs 0 \<and> vs' 1 = vs 1 + 1 \<and>
    ((2, vs), (2, vs')) \<in> (step X)\<^sup>+" for vs
  proof -
    guess vs' using M(4)[of vs] by (elim exE conjE) note vs' = this
    have 1: "((2, vs), (3, vs')) \<in> (step X)\<^sup>*"
      using subsetD[OF steps_mono[OF MX], OF map_steps[OF _ _ vs'(1), of id vs ?f]] by simp
    show ?thesis
    proof (cases "vs' 2")
      case 0 then show ?thesis using decz[OF DX(1), of vs'] vs' 1
        by (auto intro: rtrancl_into_rtrancl)
    next
      case (Suc n) note Suc' = Suc
      let ?vs = "\<lambda>x. if x = 2 then n else vs' x"
      have 2: "((2, vs), (7, ?vs)) \<in> (step X)\<^sup>*"
        using 1 decn[OF DX(1), of vs'] Suc by (auto intro: rtrancl_into_rtrancl)
      guess vs'' using N(4)[of "?vs"] by (elim exE conjE) note vs'' = this
      have 3: "((2, vs), (5, vs'')) \<in> (step X)\<^sup>*"
        using 2 subsetD[OF steps_mono[OF NX], OF map_steps[OF _ _ vs''(1), of id ?vs ?g]] by simp
      show ?thesis
      proof (cases "vs'' 2")
        case 0 then show ?thesis using 3 decz[OF DX(2), of vs''] vs''(2-) vs'(2-)
          by (auto intro: rtrancl_into_rtrancl)
      next
        case (Suc m)
        let ?vs = "\<lambda>x. if x = 2 then m else vs'' x"
        have 4: "((2, vs), (2, ?vs)) \<in> (step X)\<^sup>+" using 3 decn[OF DX(2), of vs'' m] Suc by auto
        then show ?thesis using vs''(2-) vs'(2-) Suc Suc' by (auto intro!: exI[of _ ?vs])
      qed
    qed
  qed
  have *: "vs 1 \<le> y \<Longrightarrow> g (vs 0) y = 0 \<or> h (vs 0) y = 0 \<Longrightarrow>
    \<exists>vs'. ((2, vs), (0, vs')) \<in> (step X)\<^sup>* \<or> ((2, vs), (1, vs')) \<in> (step X)\<^sup>*" for vs y
  proof (induct "vs 1" arbitrary: vs rule: inc_induct, goal_cases base step)
    case (base vs) then show ?case using X4[of vs] by auto
  next
    case (step vs)
    guess vs' using X4[of vs] by (elim exE)
    then show ?case unfolding ex_disj_distrib using step(4) step(3)[of vs']
      by (auto dest!: trancl_into_rtrancl) (meson rtrancl_trans)+
  qed
  have **: "((s, vs), (t, ws)) \<in> (step X)\<^sup>* \<Longrightarrow> t \<in> {0, 1} \<Longrightarrow> ((s, vs), (2, ws')) \<in> (step X)\<^sup>* \<Longrightarrow>
    \<exists>y. if t = 0 then g (ws' 0) y = 0 else h (ws' 0) y = 0" for s t vs ws' ws
  proof (induct arbitrary: ws' rule: converse_rtrancl_induct2)
    case refl show ?case using refl(1) NF_not_suc[OF refl(2) NF_stepI] X3 by auto
  next
    case (step s vs s' vs')
    show ?case using step(5)
    proof (cases rule: converse_rtranclE[case_names base' step'])
      case base'
      note *** = deterministic_minsky_UN[OF X2 _ _ X3]
      show ?thesis using X4[of ws']
      proof (elim exE disjE conjE, goal_cases)
        case (1 vs'') then show ?case using step(1,2,4) ***[of "(2,ws')" vs'' ws]
          by (auto simp: base' intro: converse_rtrancl_into_rtrancl)
      next
        case (2 vs'') then show ?case using step(1,2,4) ***[of "(2,ws')" ws vs'']
          by (auto simp: base' intro: converse_rtrancl_into_rtrancl)
      next
        case (3 vs'') then show ?case using step(2) step(3)[of vs'', OF step(4)]
          deterministicD[OF deterministic_stepI[OF X2], OF _ step(1)]
          by (auto simp: base' if_bool_eq_conj trancl_unfold_left)
      qed
    next
      case (step' y) then show ?thesis
        by (metis deterministicD[OF deterministic_stepI[OF X2]] step(1) step(3)[OF step(4)])
    qed
  qed
  show ?thesis
  proof (intro that[of X] X1 X2 X3, goal_cases)
    case (1 x vs) then show ?case using *[of vs] by (auto simp: g(2) h(2))
  next
    case (2 x vs vs') then show ?case using **[of 2 vs 0 vs' vs] by (auto simp: g(2) h(2))
  next
    case (3 x vs vs') then show ?case using **[of 2 vs 1 vs' vs] by (auto simp: g(2) h(2))
  qed
qed

text \<open>For r.e.\ sets we obtain the following lemma as a special case (taking $B = \varnothing$,
and swapping states $1$ and $2$).\<close>

lemma ce_set_by_minsky:
  assumes "A \<in> ce_sets"
  obtains M :: "(nat, nat) minsky" where
    "finite M" "deterministic M" "0 \<notin> fst ` M"
    "\<And>x vs. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> x \<in> A \<Longrightarrow> \<exists>vs'. ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>*"
    "\<And>x vs vs'. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>* \<Longrightarrow> x \<in> A"
proof -
  guess M using ce_set_pair_by_minsky[OF assms(1) ce_empty] . note M = this
  let ?f = "\<lambda>s. if s = 1 then 2 else if s = 2 then 1 else s" \<comment> \<open>swap states 1 and 2\<close>
  have "?f \<circ> ?f = id" by auto
  define N where "N = map_minsky ?f id M"
  have M_def: "M = map_minsky ?f id N"
    unfolding N_def map_minsky_comp \<open>?f \<circ> ?f = id\<close> map_minsky_id o_id ..
  show ?thesis using M(1-3)
  proof (intro that[of N], goal_cases)
    case (4 x vs) show ?case using M(5)[OF 4(4,5)] 4(6) M(7)[OF 4(4,5)]
      map_steps[of id vs vs 2 0 _ M ?f] by (auto simp: N_def)
  next
    case (5 x vs vs') show ?case
      using M(6)[OF 5(4,5)] 5(6) map_steps[of id vs vs 1 0 _ N ?f] by (auto simp: M_def)
  qed (auto simp: N_def map_minsky_def inj_on_def rev_image_eqI deterministic_map split: if_splits)
qed

subsection \<open>Encoding of Minsky machines\<close>

text \<open>So far, Minsky machines have been sets of pairs of states and operations. We now provide an
encoding of Minsky machines as natural numbers, so that we can talk about them as r.e.\ or
computable sets. First we encode operations.\<close>

primrec encode_Op :: "(nat, nat) Op \<Rightarrow> nat" where
  "encode_Op (Dec v s s') = c_pair 0 (c_pair v (c_pair s s'))"
| "encode_Op (Inc v s) = c_pair 1 (c_pair v s)"

definition decode_Op :: "nat \<Rightarrow> (nat, nat) Op" where
  "decode_Op n = (if c_fst n = 0
   then Dec (c_fst (c_snd n)) (c_fst (c_snd (c_snd n))) (c_snd (c_snd (c_snd n)))
   else Inc (c_fst (c_snd n)) (c_snd (c_snd n)))"

lemma encode_Op_inv [simp]:
  "decode_Op (encode_Op x) = x"
  by (cases x) (auto simp: decode_Op_def)

text \<open>Minsky machines are encoded via lists of pairs of states and operations.\<close>

definition encode_minsky :: "(nat \<times> (nat, nat) Op) list \<Rightarrow> nat" where
  "encode_minsky M = list_to_nat (map (\<lambda>x. c_pair (fst x) (encode_Op (snd x))) M)"

definition decode_minsky :: "nat \<Rightarrow> (nat \<times> (nat, nat) Op) list" where
  "decode_minsky n = map (\<lambda>n. (c_fst n, decode_Op (c_snd n))) (nat_to_list n)"

lemma encode_minsky_inv [simp]:
  "decode_minsky (encode_minsky M) = M"
  by (auto simp: encode_minsky_def decode_minsky_def comp_def)

text \<open>Assignments are stored as lists (starting with register 0).\<close>

definition decode_regs :: "nat \<Rightarrow> (nat \<Rightarrow> nat)" where
  "decode_regs n = (\<lambda>i. let xs = nat_to_list n in if i < length xs then nat_to_list n ! i else 0)"

text \<open>The undecidability results talk about Minsky configurations (pairs of Minsky machines and
assignments). This means that we do not have to construct any recursive functions that modify
Minsky machines (for example in order to initialize variables), keeping the proofs simple.\<close>

definition decode_minsky_state :: "nat \<Rightarrow> ((nat, nat) minsky \<times> (nat \<Rightarrow> nat))" where
  "decode_minsky_state n = (set (decode_minsky (c_fst n)), (decode_regs (c_snd n)))"

subsection \<open>Undecidablity results\<close>

text \<open>We conclude with some undecidability results. First we show that it is undecidable whether
a Minksy machine starting at state 1 terminates in state 0.\<close>

definition minsky_reaching_0 where
  "minsky_reaching_0 = {n |n M vs vs'. (M, vs) = decode_minsky_state n \<and> ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>*}"

lemma minsky_reaching_0_not_computable:
  "\<not> computable minsky_reaching_0"
proof -
  guess U using ce_set_by_minsky[OF univ_is_ce] . note U = this
  obtain us where [simp]: "set us = U" using finite_list[OF U(1)] by blast
  let ?f = "\<lambda>n. c_pair (encode_minsky us) (c_cons n 0)"
  have "?f \<in> PrimRec1"
    using comp2_1[OF c_pair_is_pr const_is_pr comp2_1[OF c_cons_is_pr id1_1 const_is_pr]] by simp
  moreover have "?f x \<in> minsky_reaching_0 \<longleftrightarrow> x \<in> univ_ce" for x
    using U(4,5)[of "\<lambda>i. if i = 0 then x else 0"]
    by (auto simp: minsky_reaching_0_def decode_minsky_state_def decode_regs_def c_cons_def cong: if_cong)
  ultimately have "many_reducible_to univ_ce minsky_reaching_0"
    by (auto simp: many_reducible_to_def many_reducible_to_via_def dest: pr_is_total_rec)
  then show ?thesis by (rule many_reducible_lm_1)
qed

text \<open>The remaining results are resursive inseparability results. We start be showing that there
is a Minksy machine $U$ with final states $0$ and $1$ such that it is not possible to recursively
separate inputs reaching state $0$ from inputs reaching state $1$.\<close>

lemma rec_inseparable_0not1_1not0:
  "rec_inseparable {p. 0 \<in> nat_to_ce_set p \<and> 1 \<notin> nat_to_ce_set p} {p. 0 \<notin> nat_to_ce_set p \<and> 1 \<in> nat_to_ce_set p}"
proof -
  obtain n where n: "nat_to_ce_set n = {0}" using nat_to_ce_set_srj[OF ce_finite[of "{0}"]] by auto
  obtain m where m: "nat_to_ce_set m = {1}" using nat_to_ce_set_srj[OF ce_finite[of "{1}"]] by auto
  show ?thesis by (rule rec_inseparable_mono[OF Rice_rec_inseparable[of n m]]) (auto simp: n m)
qed

lemma ce_sets_containing_n_ce:
  "{p. n \<in> nat_to_ce_set p} \<in> ce_sets"
  using ce_set_lm_5[OF univ_is_ce comp2_1[OF c_pair_is_pr id1_1 const_is_pr[of n]]]
  by (auto simp: univ_ce_lm_1)

lemma rec_inseparable_fixed_minsky_reaching_0_1:
  obtains U :: "(nat, nat) minsky" where
    "finite U" "deterministic U" "0 \<notin> fst ` U" "1 \<notin> fst ` U"
    "rec_inseparable {x |x vs'. ((2, (\<lambda>n. if n = 0 then x else 0)), (0, vs')) \<in> (step U)\<^sup>*}
      {x |x vs'. ((2, (\<lambda>n. if n = 0 then x else 0)), (1, vs')) \<in> (step U)\<^sup>*}"
proof -
  guess U using ce_set_pair_by_minsky[OF ce_sets_containing_n_ce ce_sets_containing_n_ce, of 0 1] .
  from this(1-4) this(5-7)[of "\<lambda>n. if n = 0 then _ else 0"]
  show ?thesis by (auto 0 0 intro!: that[of U] rec_inseparable_mono[OF rec_inseparable_0not1_1not0]
      pr_is_total_rec simp: rev_image_eqI cong: if_cong) meson+
qed

text \<open>Consequently, it is impossible to separate Minsky configurations with determistic machines
and final states $0$ and $1$ that reach state $0$ from those that reach state $1$.\<close>

definition minsky_reaching_s where
  "minsky_reaching_s s = {m |M m vs vs'. (M, vs) = decode_minsky_state m \<and>
    deterministic M \<and> 0 \<notin> fst ` M \<and> 1 \<notin> fst ` M \<and> ((2, vs), (s, vs')) \<in> (step M)\<^sup>*}"

lemma rec_inseparable_minsky_reaching_0_1:
  "rec_inseparable (minsky_reaching_s 0) (minsky_reaching_s 1)"
proof -
  guess U using rec_inseparable_fixed_minsky_reaching_0_1 . note U = this
  obtain us where [simp]: "set us = U" using finite_list[OF U(1)] by blast
  let ?f = "\<lambda>n. c_pair (encode_minsky us) (c_cons n 0)"
  have "?f \<in> PrimRec1"
    using comp2_1[OF c_pair_is_pr const_is_pr comp2_1[OF c_cons_is_pr id1_1 const_is_pr]] by simp
  then show ?thesis
    using U(1-4) rec_inseparable_many_reducible[of ?f, OF _ rec_inseparable_mono[OF U(5)]]
    by (auto simp: pr_is_total_rec minsky_reaching_s_def decode_minsky_state_def rev_image_eqI
      decode_regs_def c_cons_def cong: if_cong)
qed

text \<open>As a corollary, it is impossible to separate Minsky configurations that reach state 0 but not
state 1 from those that reach state 1 but not state 0.\<close>

definition minsky_reaching_s_not_t where
  "minsky_reaching_s_not_t s t = {m |M m vs vs'. (M, vs) = decode_minsky_state m \<and>
    ((2, vs), (s, vs')) \<in> (step M)\<^sup>* \<and> ((2, vs), (t, vs')) \<notin> (step M)\<^sup>*}"

lemma minsky_reaching_s_imp_minsky_reaching_s_not_t:
  assumes "s \<in> {0,1}" "t \<in> {0,1}" "s \<noteq> t"
  shows "minsky_reaching_s s \<subseteq> minsky_reaching_s_not_t s t"
proof -
  have [dest!]: "((2, vs), (0, vs')) \<notin> (step M)\<^sup>* \<or> ((2, vs), (1, vs')) \<notin> (step M)\<^sup>*"
    if "deterministic M" "0 \<notin> fst ` M" "1 \<notin> fst ` M" for M :: "(nat, nat) minsky" and vs vs'
    using deterministic_minsky_UN[OF that(1) _ _ that(2,3)] by auto
  show ?thesis using assms
    by (auto simp: minsky_reaching_s_def minsky_reaching_s_not_t_def rev_image_eqI)
qed

lemma rec_inseparable_minsky_reaching_0_not_1_1_not_0:
  "rec_inseparable (minsky_reaching_s_not_t 0 1) (minsky_reaching_s_not_t 1 0)"
  by (intro rec_inseparable_mono[OF rec_inseparable_minsky_reaching_0_1]
    minsky_reaching_s_imp_minsky_reaching_s_not_t) simp_all

end


(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section \<open>Diagonalizing matrices in JNF and HOL Analysis\<close>

theory Diagonalize
  imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin

text \<open>This section presents a @{text "locale"} that assumes a sound operation to make a matrix
diagonal. Then, the result is transferred to HOL Analysis.\<close>

subsection \<open>Diagonalizing matrices in JNF\<close>

text \<open>We assume a @{text "diagonalize_JNF"} operation in JNF, which is applied to matrices over
a B\'ezout ring. However, probably a more restrictive type class is required.\<close>

locale diagonalize =
  fixes diagonalize_JNF :: "'a::bezout_ring mat \<Rightarrow> 'a bezout \<Rightarrow> ('a mat \<times> 'a mat \<times> 'a mat)"
  assumes soundness_diagonalize_JNF:
    "\<forall>A bezout. A \<in> carrier_mat m n \<and> is_bezout_ext bezout \<longrightarrow>
     (case diagonalize_JNF A bezout of (P,S,Q) \<Rightarrow>
      P \<in> carrier_mat m m \<and> Q \<in> carrier_mat n n \<and> S \<in> carrier_mat m n
      \<and> invertible_mat P \<and> invertible_mat Q \<and> isDiagonal_mat S \<and> S = P*A*Q)"
begin

lemma soundness_diagonalize_JNF':
  fixes A::"'a mat"
  assumes "is_bezout_ext bezout" and "A \<in> carrier_mat m n"
  and "diagonalize_JNF A bezout = (P,S,Q)"
  shows "P \<in> carrier_mat m m \<and> Q \<in> carrier_mat n n \<and> S \<in> carrier_mat m n
      \<and> invertible_mat P \<and> invertible_mat Q \<and> isDiagonal_mat S \<and> S = P*A*Q"
  using soundness_diagonalize_JNF assms unfolding case_prod_beta by (metis fst_conv snd_conv)

subsection \<open>Implementation and soundness result moved to HOL Analysis.\<close>

definition diagonalize :: "'a::bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type
     \<Rightarrow> 'a bezout \<Rightarrow>
    (('a ^ 'nr :: mod_type ^ 'nr :: mod_type)
    \<times> ('a ^ 'nc :: mod_type ^ 'nr :: mod_type)
    \<times> ('a ^ 'nc :: mod_type ^ 'nc :: mod_type))"
  where "diagonalize A bezout = (
    let (P,S,Q) = diagonalize_JNF (Mod_Type_Connect.from_hma\<^sub>m A) bezout
    in (Mod_Type_Connect.to_hma\<^sub>m P,Mod_Type_Connect.to_hma\<^sub>m S,Mod_Type_Connect.to_hma\<^sub>m Q)
  )"

lemma soundness_diagonalize:
  assumes b: "is_bezout_ext bezout"
  and d: "diagonalize A bezout = (P,S,Q)"
shows "invertible P \<and> invertible Q \<and> isDiagonal S \<and> S = P**A**Q"
proof -
  define A' where "A' = Mod_Type_Connect.from_hma\<^sub>m A"
  obtain P' S' Q' where d_JNF: "(P',S',Q') = diagonalize_JNF A' bezout"
    by (metis prod_cases3)
  define m and n where "m = dim_row A'" and "n = dim_col A'"
  hence A': "A' \<in> carrier_mat m n" by auto
  have res_JNF: "P' \<in> carrier_mat m m \<and> Q' \<in> carrier_mat n n \<and> S' \<in> carrier_mat m n
      \<and> invertible_mat P' \<and> invertible_mat Q' \<and> isDiagonal_mat S' \<and> S' = P'*A'*Q'"
    by (rule soundness_diagonalize_JNF'[OF b A' d_JNF[symmetric]])
  have "Mod_Type_Connect.to_hma\<^sub>m P' = P" using d unfolding diagonalize_def Let_def
    by (metis A'_def d_JNF fst_conv old.prod.case)
  hence "P' = Mod_Type_Connect.from_hma\<^sub>m P" using A'_def m_def res_JNF by auto
  hence [transfer_rule]: "Mod_Type_Connect.HMA_M P' P"
    unfolding Mod_Type_Connect.HMA_M_def by auto
  have "Mod_Type_Connect.to_hma\<^sub>m Q' = Q" using d unfolding diagonalize_def Let_def
    by (metis A'_def d_JNF snd_conv old.prod.case)
  hence "Q' = Mod_Type_Connect.from_hma\<^sub>m Q" using A'_def n_def res_JNF by auto
  hence [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q"
    unfolding Mod_Type_Connect.HMA_M_def by auto
  have "Mod_Type_Connect.to_hma\<^sub>m S' = S" using d unfolding diagonalize_def Let_def
    by (metis A'_def d_JNF snd_conv old.prod.case)
  hence "S' = Mod_Type_Connect.from_hma\<^sub>m S" using A'_def m_def n_def res_JNF by auto
  hence [transfer_rule]: "Mod_Type_Connect.HMA_M S' S"
    unfolding Mod_Type_Connect.HMA_M_def by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_M A' A"
    using A'_def unfolding Mod_Type_Connect.HMA_M_def by auto
  have "invertible P" using res_JNF by (transfer, simp)
  moreover have "invertible Q" using res_JNF by (transfer, simp)
  moreover have "isDiagonal S" using res_JNF by (transfer, simp)
  moreover have "S = P**A**Q" using res_JNF by (transfer, simp)
  ultimately show ?thesis by simp
qed
end

end


theory Simulink_Integrated
imports Main Complex_Main
begin

(*fun Gain :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "Gain x y = mult x y"*)

primrec feedback :: "nat \<Rightarrow> nat" where
  "feedback 0 = Suc(0)"|
  "feedback (Suc t) = (feedback t)*3"

fun simulink :: "real \<Rightarrow> real" where
  "simulink 0 = 1"|
  "simulink(t+h) = simulink(t) + h*(1/simulink(t))"

fun y :: "nat \<Rightarrow> nat" where
  "y 0 = Suc(0)"|
  "y(Suc(t)) = y(t) + (y(t))"

lemma int_th2: "\<not>(t>5) \<or> ((y t) > 30)"
proof (induct t)
  case 0
  show ?case by simp
next
  case (Suc t)
  thus ?case
  proof
    assume "\<not>t > 5"
    moreover have "y 6 = 64" by code_simp
      -- \<open>"simp add: eval_nat_numeral" would also work\<close>
    ultimately show ?thesis
      by (cases "t = 5") auto
  next
    assume "y t > 30"
    thus ?thesis by simp
  qed
qed

lemma th1: "threegains 3 4 5 6 = 360"
  apply(simp)
  done

(*
lemma th3: "feedback t = pow 3 t"
  apply(induct t)
  apply(simp)
  apply(auto)
  apply(sym)
done *)
(*\<lbrakk> if foo then a \<noteq> a else b \<noteq> b \<rbrakk>*)

(*
lemma th2: "\<not>(t>5) \<or> ((feedback t) > 200)" (is "?H(t)" is "?P(t)\<or>?Q(t)" is "(?P(t))\<or>(?F(t) > 200)")
proof(induct t)
    case 0 show "?P 0 \<or> ?Q 0" by simp
  next
    have b: "?F (Suc(t)) \<ge> ?F(t)" by simp
    assume a:" ?F(t) > 200"
    from b and a have c: "?F(Suc(t)) > 200" by simp
    from c have e: "?Q(Suc(t))" by simp
    assume d: "?P(t) = False"
    from d have f:"?P(Suc(t)) = False" by simp
    from f and e have g: "?P(Suc(t))\<or>?Q(Suc(t))" by simp
    from a and d and g have h: "?P(t)\<or>?Q(t) \<Longrightarrow> ?P(Suc(t))\<or>?Q(Suc(t))" by simp
    from a and d have "?H(Suc(t))" by simp
  qed
*)
lemma th2: "\<not>(t>5) \<or> ((feedback t) > 200)"
proof (induct t)
  case 0
  show ?case by simp
next
  case (Suc t)
  thus ?case
  proof
    assume "\<not>t > 5"
    moreover have "feedback 6 = 729" by code_simp
      -- \<open>"simp add: eval_nat_numeral" would also work\<close>
    ultimately show ?thesis
      by (cases "t = 5") auto
  next
    assume "feedback t > 200"
    thus ?thesis by simp
  qed
qed

lemma th3: "\<not>(t>5) \<or> ((feedback t) > 200)"
proof (induct t)
  case (Suc t)
  moreover have "feedback 6 = 729" by code_simp
  ultimately show ?case by (cases "t = 5") auto
qed simp_all


(*  Title:      HOL/Library/Stream.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012, 2013

Infinite streams.
*)

section {* Infinite Streams *}

theory Stream
imports "~~/src/HOL/Library/Nat_Bijection"
begin

codatatype (sset: 'a) stream =
  SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)
for
  map: smap
  rel: stream_all2

(*for code generation only*)
definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
  [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"

lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
  unfolding smember_def by auto

hide_const (open) smember

lemmas smap_simps[simp] = stream.map_sel
lemmas shd_sset = stream.set_sel(1)
lemmas stl_sset = stream.set_sel(2)

theorem sset_induct[consumes 1, case_names shd stl, induct set: sset]:
  assumes "y \<in> sset s" and "\<And>s. P (shd s) s" and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
  shows "P y s"
using assms by induct (metis stream.sel(1), auto)

lemma smap_ctr: "smap f s = x ## s' \<longleftrightarrow> f (shd s) = x \<and> smap f (stl s) = s'"
  by (cases s) simp

subsection {* prepend list to stream *}

primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr "@-" 65) where
  "shift [] s = s"
| "shift (x # xs) s = x ## shift xs s"

lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
  by (induct xs) auto

lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
  by (induct xs) auto

lemma shift_simps[simp]:
   "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
   "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
  by (induct xs) auto

lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
  by (induct xs) auto

lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
  by (induct xs) auto

subsection {* set of streams with elements in some fixed set *}

coinductive_set
  streams :: "'a set \<Rightarrow> 'a stream set"
  for A :: "'a set"
where
  Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"

lemma in_streams: "stl s \<in> streams S \<Longrightarrow> shd s \<in> S \<Longrightarrow> s \<in> streams S"
  by (cases s) auto

lemma streamsE: "s \<in> streams A \<Longrightarrow> (shd s \<in> A \<Longrightarrow> stl s \<in> streams A \<Longrightarrow> P) \<Longrightarrow> P"
  by (erule streams.cases) simp_all

lemma Stream_image: "x ## y \<in> (op ## x') ` Y \<longleftrightarrow> x = x' \<and> y \<in> Y"
  by auto

lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
  by (induct w) auto

lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
  by (auto elim: streams.cases)

lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
  by (cases s) (auto simp: streams_Stream)

lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
  by (cases s) (auto simp: streams_Stream)

lemma sset_streams:
  assumes "sset s \<subseteq> A"
  shows "s \<in> streams A"
using assms proof (coinduction arbitrary: s)
  case streams then show ?case by (cases s) simp
qed

lemma streams_sset:
  assumes "s \<in> streams A"
  shows "sset s \<subseteq> A"
proof
  fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
    by (induct s) (auto intro: streams_shd streams_stl)
qed

lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
  by (metis sset_streams streams_sset)

lemma streams_mono:  "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
  unfolding streams_iff_sset by auto

lemma streams_mono2: "S \<subseteq> T \<Longrightarrow> streams S \<subseteq> streams T"
  by (auto intro: streams_mono)

lemma smap_streams: "s \<in> streams A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> smap f s \<in> streams B"
  unfolding streams_iff_sset stream.set_map by auto

lemma streams_empty: "streams {} = {}"
  by (auto elim: streams.cases)

lemma streams_UNIV[simp]: "streams UNIV = UNIV"
  by (auto simp: streams_iff_sset)

subsection {* nth, take, drop for streams *}

primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
  "s !! 0 = shd s"
| "s !! Suc n = stl s !! n"

lemma snth_Stream: "(x ## s) !! Suc i = s !! i"
  by simp

lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
  by (induct n arbitrary: s) auto

lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
  by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)

lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
  by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)

lemma shift_snth: "(xs @- s) !! n = (if n < length xs then xs ! n else s !! (n - length xs))"
  by auto

lemma snth_sset[simp]: "s !! n \<in> sset s"
  by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)

lemma sset_range: "sset s = range (snth s)"
proof (intro equalityI subsetI)
  fix x assume "x \<in> sset s"
  thus "x \<in> range (snth s)"
  proof (induct s)
    case (stl s x)
    then obtain n where "x = stl s !! n" by auto
    thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
  qed (auto intro: range_eqI[of _ _ 0])
qed auto

lemma streams_iff_snth: "s \<in> streams X \<longleftrightarrow> (\<forall>n. s !! n \<in> X)"
  by (force simp: streams_iff_sset sset_range)

lemma snth_in: "s \<in> streams X \<Longrightarrow> s !! n \<in> X"
  by (simp add: streams_iff_snth)

primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
  "stake 0 s = []"
| "stake (Suc n) s = shd s # stake n (stl s)"

lemma length_stake[simp]: "length (stake n s) = n"
  by (induct n arbitrary: s) auto

lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
  by (induct n arbitrary: s) auto

lemma take_stake: "take n (stake m s) = stake (min n m) s"
proof (induct m arbitrary: s n)
  case (Suc m) thus ?case by (cases n) auto
qed simp

primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  "sdrop 0 s = s"
| "sdrop (Suc n) s = sdrop n (stl s)"

lemma sdrop_simps[simp]:
  "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
  by (induct n arbitrary: s)  auto

lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
  by (induct n arbitrary: s) auto

lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
  by (induct n) auto

lemma drop_stake: "drop n (stake m s) = stake (m - n) (sdrop n s)"
proof (induct m arbitrary: s n)
  case (Suc m) thus ?case by (cases n) auto
qed simp

lemma stake_sdrop: "stake n s @- sdrop n s = s"
  by (induct n arbitrary: s) auto

lemma id_stake_snth_sdrop:
  "s = stake i s @- s !! i ## sdrop (Suc i) s"
  by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)

lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
proof
  assume ?R
  then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
    by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
  then show ?L using sdrop.simps(1) by metis
qed auto

lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
  by (induct n) auto

lemma sdrop_shift: "sdrop i (w @- s) = drop i w @- sdrop (i - length w) s"
  by (induct i arbitrary: w s) (auto simp: drop_tl drop_Suc neq_Nil_conv)

lemma stake_shift: "stake i (w @- s) = take i w @ stake (i - length w) s"
  by (induct i arbitrary: w s) (auto simp: neq_Nil_conv)

lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
  by (induct m arbitrary: s) auto

lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
  by (induct m arbitrary: s) auto

lemma sdrop_snth: "sdrop n s !! m = s !! (n + m)"
  by (induct n arbitrary: m s) auto

partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"

lemma sdrop_while_SCons[code]:
  "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
  by (subst sdrop_while.simps) simp

lemma sdrop_while_sdrop_LEAST:
  assumes "\<exists>n. P (s !! n)"
  shows "sdrop_while (Not o P) s = sdrop (LEAST n. P (s !! n)) s"
proof -
  from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
    and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
  thus ?thesis unfolding *
  proof (induct m arbitrary: s)
    case (Suc m)
    hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
      by (metis (full_types) not_less_eq_eq snth.simps(2))
    moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
    ultimately show ?case by (subst sdrop_while.simps) simp
  qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
qed

primcorec sfilter where
  "shd (sfilter P s) = shd (sdrop_while (Not o P) s)"
| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not o P) s))"

lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
proof (cases "P x")
  case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
next
  case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
qed

subsection {* unary predicates lifted to streams *}

definition "stream_all P s = (\<forall>p. P (s !! p))"

lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
  unfolding stream_all_def sset_range by auto

lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
  unfolding stream_all_iff list_all_iff by auto

lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
  by simp

subsection {* recurring stream out of a list *}

primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
  "shd (cycle xs) = hd xs"
| "stl (cycle xs) = cycle (tl xs @ [hd xs])"

lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
proof (coinduction arbitrary: u)
  case Eq_stream then show ?case using stream.collapse[of "cycle u"]
    by (auto intro!: exI[of _ "tl u @ [hd u]"])
qed

lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
  by (subst cycle.ctr) simp

lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
  by (auto dest: arg_cong[of _ _ stl])

lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
proof (induct n arbitrary: u)
  case (Suc n) thus ?case by (cases u) auto
qed auto

lemma stake_cycle_le[simp]:
  assumes "u \<noteq> []" "n < length u"
  shows "stake n (cycle u) = take n u"
using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
  by (subst cycle_decomp[OF assms(1)], subst stake_append) auto

lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
  by (subst cycle_decomp) (auto simp: stake_shift)

lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
  by (subst cycle_decomp) (auto simp: sdrop_shift)

lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
   stake n (cycle u) = concat (replicate (n div length u) u)"
  by (induct "n div length u" arbitrary: n u) (auto simp: stake_add[symmetric])

lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
   sdrop n (cycle u) = cycle u"
  by (induct "n div length u" arbitrary: n u) (auto simp: sdrop_add[symmetric])

lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
   stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
  by (subst mod_div_equality[of n "length u", symmetric], unfold stake_add[symmetric]) auto

lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
  by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])

subsection {* iterated application of a function *}

primcorec siterate where
  "shd (siterate f x) = x"
| "stl (siterate f x) = siterate f (f x)"

lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
  by (induct n arbitrary: s) auto

lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
  by (induct n arbitrary: x) (auto simp: funpow_swap1)

lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
  by (induct n arbitrary: x) (auto simp: funpow_swap1)

lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)

lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  by (auto simp: sset_range)

lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
  by (coinduction arbitrary: x) auto

subsection {* stream repeating a single element *}

abbreviation "sconst \<equiv> siterate id"

lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
  by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)

lemma sset_sconst[simp]: "sset (sconst x) = {x}"
  by (simp add: sset_siterate)

lemma sconst_alt: "s = sconst x \<longleftrightarrow> sset s = {x}"
proof
  assume "sset s = {x}"
  then show "s = sconst x"
  proof (coinduction arbitrary: s)
    case Eq_stream
    then have "shd s = x" "sset (stl s) \<subseteq> {x}" by (case_tac [!] s) auto
    then have "sset (stl s) = {x}" by (cases "stl s") auto
    with `shd s = x` show ?case by auto
  qed
qed simp

lemma sconst_cycle: "sconst x = cycle [x]"
  by coinduction auto

lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
  by coinduction auto

lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
  by (simp add: streams_iff_sset)

subsection {* stream of natural numbers *}

abbreviation "fromN \<equiv> siterate Suc"

abbreviation "nats \<equiv> fromN 0"

lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
  by (auto simp add: sset_siterate le_iff_add)

lemma stream_smap_fromN: "s = smap (\<lambda>j. let i = j - n in s !! i) (fromN n)"
  by (coinduction arbitrary: s n)
    (force simp: neq_Nil_conv Let_def snth.simps(2)[symmetric] Suc_diff_Suc
      intro: stream.map_cong split: if_splits simp del: snth.simps(2))

lemma stream_smap_nats: "s = smap (snth s) nats"
  using stream_smap_fromN[where n = 0] by simp

subsection {* flatten a stream of lists *}

primcorec flat where
  "shd (flat ws) = hd (shd ws)"
| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"

lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
  by (subst flat.ctr) simp

lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
  by (induct xs) auto

lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
  by (cases ws) auto

lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then
  shd s ! n else flat (stl s) !! (n - length (shd s)))"
  by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)

lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow>
  sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
proof safe
  fix x assume ?P "x : ?L"
  then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
  with `?P` obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
  proof (atomize_elim, induct m arbitrary: s rule: less_induct)
    case (less y)
    thus ?case
    proof (cases "y < length (shd s)")
      case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
    next
      case False
      hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
      moreover
      { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
        with False have "y > 0" by (cases y) simp_all
        with * have "y - length (shd s) < y" by simp
      }
      moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
      ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
      thus ?thesis by (metis snth.simps(2))
    qed
  qed
  thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
next
  fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
    by (induct rule: sset_induct)
      (metis UnI1 flat_unfold shift.simps(1) sset_shift,
       metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
qed

subsection {* merge a stream of streams *}

definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
  "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"

lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
  by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))

lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
proof (cases "n \<le> m")
  case False thus ?thesis unfolding smerge_def
    by (subst sset_flat)
      (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
        intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
next
  case True thus ?thesis unfolding smerge_def
    by (subst sset_flat)
      (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
        intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
qed

lemma sset_smerge: "sset (smerge ss) = UNION (sset ss) sset"
proof safe
  fix x assume "x \<in> sset (smerge ss)"
  thus "x \<in> UNION (sset ss) sset"
    unfolding smerge_def by (subst (asm) sset_flat)
      (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
next
  fix s x assume "s \<in> sset ss" "x \<in> sset s"
  thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
qed

subsection {* product of two streams *}

definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
  "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"

lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
  unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)

subsection {* interleave two streams *}

primcorec sinterleave where
  "shd (sinterleave s1 s2) = shd s1"
| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"

lemma sinterleave_code[code]:
  "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
  by (subst sinterleave.ctr) simp

lemma sinterleave_snth[simp]:
  "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
  "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
  by (induct n arbitrary: s1 s2) simp_all

lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
proof (intro equalityI subsetI)
  fix x assume "x \<in> sset (sinterleave s1 s2)"
  then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
  thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
next
  fix x assume "x \<in> sset s1 \<union> sset s2"
  thus "x \<in> sset (sinterleave s1 s2)"
  proof
    assume "x \<in> sset s1"
    then obtain n where "x = s1 !! n" unfolding sset_range by blast
    hence "sinterleave s1 s2 !! (2 * n) = x" by simp
    thus ?thesis unfolding sset_range by blast
  next
    assume "x \<in> sset s2"
    then obtain n where "x = s2 !! n" unfolding sset_range by blast
    hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
    thus ?thesis unfolding sset_range by blast
  qed
qed

subsection {* zip *}

primcorec szip where
  "shd (szip s1 s2) = (shd s1, shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
  by (subst szip.ctr) simp

lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
  by (induct n arbitrary: s1 s2) auto

lemma stake_szip[simp]:
  "stake n (szip s1 s2) = zip (stake n s1) (stake n s2)"
  by (induct n arbitrary: s1 s2) auto

lemma sdrop_szip[simp]: "sdrop n (szip s1 s2) = szip (sdrop n s1) (sdrop n s2)"
  by (induct n arbitrary: s1 s2) auto

lemma smap_szip_fst:
  "smap (\<lambda>x. f (fst x)) (szip s1 s2) = smap f s1"
  by (coinduction arbitrary: s1 s2) auto

lemma smap_szip_snd:
  "smap (\<lambda>x. g (snd x)) (szip s1 s2) = smap g s2"
  by (coinduction arbitrary: s1 s2) auto

subsection {* zip via function *}

primcorec smap2 where
  "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"

lemma smap2_unfold[code]:
  "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
  by (subst smap2.ctr) simp

lemma smap2_szip:
  "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
  by (coinduction arbitrary: s1 s2) auto

lemma smap_smap2[simp]:
  "smap f (smap2 g s1 s2) = smap2 (\<lambda>x y. f (g x y)) s1 s2"
  unfolding smap2_szip stream.map_comp o_def split_def ..

lemma smap2_alt:
  "(smap2 f s1 s2 = s) = (\<forall>n. f (s1 !! n) (s2 !! n) = s !! n)"
  unfolding smap2_szip smap_alt by auto

lemma snth_smap2[simp]:
  "smap2 f s1 s2 !! n = f (s1 !! n) (s2 !! n)"
  by (induct n arbitrary: s1 s2) auto

lemma stake_smap2[simp]:
  "stake n (smap2 f s1 s2) = map (split f) (zip (stake n s1) (stake n s2))"
  by (induct n arbitrary: s1 s2) auto

lemma sdrop_smap2[simp]:
  "sdrop n (smap2 f s1 s2) = smap2 f (sdrop n s1) (sdrop n s2)"
  by (induct n arbitrary: s1 s2) auto

end


section \<open>Tseitin Transformation - Verification and Optimization\<close>

text \<open>
Since most SAT solvers insist on formulas in conjunctive normal form (CNF) as input,
but in general the CNF of a given formula may be exponentially larger, there is interest
in efficient transformations that produce a small equisatisfiable CNF for a given formula.
Probably the earliest and most well-known of these transformation is due to Tseitin.

In this project you will implement several transformations of propositional formulas
into equisatisfiable CNFs and formally prove results about their complexity and that
the resulting CNFs are indeed equisatisfiable to the original formula.
\<close>

theory Project_Tseitin
  imports Main
begin

subsection \<open>Syntax and Semantics\<close>

text \<open>
For the purposes of this project propositional formulas (with atoms of an arbitrary type)
are restricted to the following (functionally complete) connectives:
\<close>
datatype 'a form =
  Bot \<comment> \<open>the "always false" formula\<close>
  | Atm 'a \<comment> \<open>propositional atoms\<close>
  | Neg "'a form" \<comment> \<open>negation\<close>
  | Imp "'a form" "'a form" \<comment> \<open>implication\<close>

text \<open>
Define a function \<open>eval\<close> that evaluates the truth value of a formula with respect
to a given truth assignment \<open>\<alpha> :: 'a \<Rightarrow>bool\<close>.
\<close>
fun eval :: "('a \<Rightarrow> bool) \<Rightarrow> 'a form \<Rightarrow> bool"
  where
    "eval _ Bot = False"
  | "eval \<alpha> (Atm p) = \<alpha> p"
  | "eval \<alpha> (Neg \<phi>) = (\<not>(eval \<alpha> \<phi>))"
  | "eval \<alpha> (Imp \<phi> \<psi>) = ((\<not>(eval \<alpha> \<phi>)) \<or> eval \<alpha> \<psi>)"
print_theorems

text \<open>
Define a predicate \<open>sat\<close> that captures satisfiable formulas.
\<close>
definition sat :: "'a form \<Rightarrow> bool"
  where
    "sat \<phi> \<longleftrightarrow> (\<exists>\<alpha>. eval \<alpha> \<phi> = True)"

subsection \<open>Conjunctive Normal Forms\<close>

text \<open>
Literals are positive or negative atoms.
\<close>
datatype 'a literal = P 'a | N 'a

text \<open>
Function \<open>of_literals\<close> that turns a given literal (of @{typ "'a literal"}) into
the corresponding formula (of @{typ "'a form"}).
\<close>
fun of_literal :: "'a literal \<Rightarrow> 'a form"
  where
    "of_literal (P p) = Atm p"
  | "of_literal (N p) = Neg (Atm p)"

text \<open>
A clause is a disjunction of literals, represented as a list of literals.
\<close>
type_synonym 'a clause = "'a literal list"

text \<open>
Function \<open>of_clause\<close> that turns a given clause (of @{typ "'a clause"}) into an
equivalent formula (of @{typ "'a form"}).
\<close>
fun of_clause :: "'a clause \<Rightarrow> 'a form"
  where
    "of_clause [] = Bot"
  | "of_clause (c # cs) = Imp (Neg (of_literal c)) (of_clause cs)"

text \<open>
A CNF is a conjunction of clauses, represented as list of clauses.
\<close>
type_synonym 'a cnf = "'a clause list"

text \<open>
Implement a function \<open>of_cnf\<close> that, given a CNF (of @{typ "'a cnf"}), computes
a logically equivalent formula (of @{typ "'a form"}).
\<close>

fun of_cnf :: "'a cnf \<Rightarrow> 'a form"
  where
    "of_cnf [] = Neg Bot"
  | "of_cnf (c # cs) = Neg (Imp (of_clause c) (Neg (of_cnf cs)))"
print_theorems

subsection \<open>Tseitin Transformation\<close>

text \<open>
The idea of Tseitin's transformation is to assign to each subformula \<open>\<phi>\<close>
a label \<open>a\<^sub>\<phi>\<close> and use the following definitions

\<^item> \<open>a\<^sub>\<bottom> \<longleftrightarrow> \<bottom>\<close>
\<^item> \<open>a\<^sub>\<not>\<^sub>\<phi> \<longleftrightarrow> \<not> \<phi>\<close>
\<^item> \<open>a\<^sub>\<phi>\<^sub>\<longrightarrow>\<^sub>\<psi> \<longleftrightarrow> \<phi> \<longrightarrow> \<psi>\<close>

to recursively compute clauses \<open>tseitin \<phi>\<close> such that \<open>a\<^sub>\<phi> \<and> tseitin \<phi>\<close> and \<open>\<phi>\<close>
are equisatisfiable (that is, the former is satisfiable iff the latter is).

Define a function \<open>tseitin\<close> that computes the clauses corresponding to the above idea.
\<close>
fun tseitin :: "'a form \<Rightarrow> ('a form) cnf"
  where
    "tseitin (Bot) = [[N Bot]]"
  | "tseitin (Atm \<phi>) = []"
  | "tseitin (Neg \<phi>) = [(N (Neg \<phi>)), (N \<phi>)] # [(P (Neg \<phi>)), (P \<phi>)] # tseitin \<phi>"
  | "tseitin (Imp \<phi> \<psi>) = [(N (Imp \<phi> \<psi>)), (N \<phi>), (P \<psi>)] # [(P (Imp \<phi> \<psi>)), (P \<phi>)]
                         # [(N \<psi>), (P (Imp \<phi> \<psi>))] # (tseitin \<phi> @ tseitin \<psi>)"

lemma [simp]: "eval (eval \<alpha>) (of_cnf(tseitin \<phi>))"
  by (induction \<phi>) auto

(*(\<lambda>x. True)*)
value "eval (\<lambda>x. True) (of_cnf (tseitin (Imp \<phi> \<psi>)))"

lemma "eval \<alpha> \<phi> \<Longrightarrow> eval (eval \<alpha>) (of_cnf ([P \<phi>] # tseitin \<phi>))"
  by auto

lemma [simp]: "v \<phi> \<Longrightarrow> eval (v \<circ> Atm) \<phi>"
sorry

(*insert type that fits for b*)
lemma "eval v (of_cnf ([P \<phi>] # tseitin \<phi>)) \<Longrightarrow> eval (v \<circ> Atm) \<phi>"
proof -
  assume  "eval v (of_cnf ([P \<phi>] # tseitin \<phi>))"
  from \<open> eval v (of_cnf ([P \<phi>] # tseitin \<phi>)) \<close>
  have  "eval v (of_cnf ([[P \<phi>]])) \<and> eval v (of_cnf(tseitin \<phi>)) " by auto
  then have  "eval v (of_cnf ([[P \<phi>]] ))" ..
  then show ?thesis by simp

lemma equalitiy:
  "eval \<alpha> \<phi> \<Longrightarrow> \<alpha> \<phi> \<and> eval \<alpha> (of_cnf (tseitin \<phi>))"
  by auto

text \<open>
Prove that \<open>a\<^sub>\<phi> \<and> tseitin \<phi>\<close> and \<open>\<phi>\<close> are equisatisfiable.
\<close>
lemma tseitin_equisat:
  "sat (of_cnf ([P \<phi>] # tseitin \<phi>)) \<longleftrightarrow> sat \<phi>"
proof
  assume "sat (of_cnf ([P \<phi>] # tseitin \<phi>))"
  from \<open>sat (of_cnf ([P \<phi>] # tseitin \<phi>))\<close>
  have "\<exists>\<alpha>. eval \<alpha> (of_cnf ([P \<phi>] # tseitin \<phi>)) = True"
    by (simp add: sat_def)
  show "sat \<phi>"
  proof (rule ccontr)
    assume "\<not>sat \<phi>"
    from \<open>\<not>sat \<phi>\<close> have "\<forall>\<alpha>. eval \<alpha> \<phi> = False" by (simp add: sat_def)
    from \<open>\<exists>\<alpha>. eval \<alpha> (of_cnf ([P \<phi>] # tseitin \<phi>)) = True\<close>
    have "\<exists>\<alpha>. (\<alpha> \<phi> \<and> eval \<alpha> (of_cnf (tseitin \<phi>))) = True"
      sorry

text \<open>
Prove linear bounds on the number of clauses and literals by suitably
replacing \<open>n\<close> and \<open>num_literals\<close> below:
\<close>
lemma tseitin_num_clauses:
  "length (tseitin \<phi>) \<le> n * size \<phi>"
  sorry

lemma tseitin_num_literals:
  "num_literals (tseitin \<phi>) \<le> n * size \<phi>"
  sorry

text \<open>
Implement a function \<open>t_tseitin\<close> that computes the number of recursive calls of your
earlier definition of @{const tseitin} and prove a linear bound in the size of the formula
(by suitably replacing \<open>n\<close>):
\<close>
fun t_tseitin :: "'a form \<Rightarrow> nat"
  where
    "t_tseitin \<phi> = undefined"

lemma tseitin_linear:
  "t_tseitin \<phi> \<le> n * size \<phi>"
  sorry

text \<open>
Implement a tail recursive variant of @{const tseitin} and prove the lemma below:
\<close>
fun tseitin2 :: "'a form \<Rightarrow> ('a form) cnf \<Rightarrow> ('a form) cnf"
  where
    "tseitin2 \<phi> acc = undefined"

lemma tseitin2_equisat:
  "sat (of_cnf ([P \<phi>] # tseitin2 \<phi> [])) \<longleftrightarrow> sat \<phi>"
  sorry

subsection \<open>A Transformation due to Plaisted and Greenbaum\<close>

text \<open>
Plaisted and Greenbaum had the idea to take the polarity of a subformula into account in order
to reduce the number of clauses and literals needed for an equisatisfiable CNF.
Here, the polarity at the root is positive and it flips whenever we move down to the (first)
argument of a(n) negation (implication).

Implement a variant \<open>plaisted\<close> of @{const tseitin} that takes the polarity of subformulas
into account and prove that \<open>a\<^sub>\<phi> \<and> plaisted True \<phi>\<close> and \<open>\<phi>\<close> are equisatisfiable.
\<close>
fun plaisted :: "bool \<Rightarrow> 'a form \<Rightarrow> ('a form) cnf"
  where
    "plaisted p \<phi> = undefined"

lemma plaisted_equisat:
  "sat (of_cnf ([P \<phi>] # plaisted True \<phi>)) \<longleftrightarrow> sat \<phi>"
  sorry

text \<open>
Prove linear bounds on the number of clauses and literals by suitably
replacing \<open>n\<close> and \<open>num_literals\<close> below:
\<close>
lemma plaisted_num_clauses:
  "length (plaisted p \<phi>) \<le> n * size \<phi>"
  sorry

lemma plaisted_num_literals:
  "num_literals (plaisted p \<phi>) \<le> n * size \<phi>"
  sorry

text \<open>
Prove that with respect to the number of literals and clauses in the resulting CNF,
@{const plaisted} is at least as good as @{const tseitin}.
\<close>
lemma plaisted_le_tseitin_num_clauses:
  "length (plaisted p \<phi>) \<le> length (tseitin \<phi>)"
  sorry

lemma plaisted_le_tseitin_num_literals:
  "num_literals (plaisted p \<phi>) \<le> num_literals (tseitin \<phi>)"
  sorry

end


subsection\<open>Semantics\<close>
theory Sema
imports Formulas
begin

type_synonym 'a valuation = "'a \<Rightarrow> bool"
text\<open>The implicit statement here is that an assignment or valuation is always defined on all atoms (because HOL is a total logic).
Thus, there are no unsuitable assignments.\<close>

primrec formula_semantics :: "'a valuation \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "\<Turnstile>" 51) where
"\<A> \<Turnstile> Atom k = \<A> k" |
"_ \<Turnstile> \<bottom> = False" |
"\<A> \<Turnstile> Not F = (\<not> \<A> \<Turnstile> F)" |
"\<A> \<Turnstile> And F G = (\<A> \<Turnstile> F \<and> \<A> \<Turnstile> G)" |
"\<A> \<Turnstile> Or F G = (\<A> \<Turnstile> F \<or> \<A> \<Turnstile> G)" |
"\<A> \<Turnstile> Imp F G = (\<A> \<Turnstile> F \<longrightarrow> \<A> \<Turnstile> G)"

abbreviation valid ("\<Turnstile> _" 51) where
"\<Turnstile> F \<equiv> \<forall>A. A \<Turnstile> F"

lemma irrelevant_atom[simp]: "A \<notin> atoms F \<Longrightarrow> (\<A>(A := V)) \<Turnstile> F \<longleftrightarrow> \<A> \<Turnstile> F"
  by (induction F; simp)
lemma relevant_atoms_same_semantics: "\<forall>k \<in> atoms F. \<A>\<^sub>1 k = \<A>\<^sub>2 k \<Longrightarrow> \<A>\<^sub>1 \<Turnstile> F \<longleftrightarrow> \<A>\<^sub>2 \<Turnstile> F"
  by(induction F; simp)

context begin
text\<open>Just a definition more similar to~\cite[p. 5]{schoening1987logik}.
Unfortunately, using this as the main definition would get in the way of automated reasoning all the time.\<close>
private primrec formula_semantics_alt where
"formula_semantics_alt \<A> (Atom k) = \<A> k" |
"formula_semantics_alt \<A> (Bot) = False" |
"formula_semantics_alt \<A> (Not a) = (if formula_semantics_alt \<A> a then False else True)" |
"formula_semantics_alt \<A> (And a b) = (if formula_semantics_alt \<A> a then formula_semantics_alt \<A> b else False)" |
"formula_semantics_alt \<A> (Or a b) = (if formula_semantics_alt \<A> a then True else formula_semantics_alt \<A> b)" |
"formula_semantics_alt \<A> (Imp a b) = (if formula_semantics_alt \<A> a then formula_semantics_alt \<A> b else True)"
private lemma "formula_semantics_alt \<A> F \<longleftrightarrow> \<A> \<Turnstile> F"
  by(induction F; simp)

text\<open>If you fancy a definition more similar to~\cite[p. 39]{gallier2015logic},
this is probably the closest you can go without going incredibly ugly.\<close>
private primrec formula_semantics_tt where
"formula_semantics_tt \<A> (Atom k) = \<A> k" |
"formula_semantics_tt \<A> (Bot) = False" |
"formula_semantics_tt \<A> (Not a) = (case formula_semantics_tt \<A> a of True \<Rightarrow> False | False \<Rightarrow> True)" |
"formula_semantics_tt \<A> (And a b) = (case (formula_semantics_tt \<A> a, formula_semantics_tt \<A> b) of
  (False, False) \<Rightarrow> False
| (False, True) \<Rightarrow> False
| (True, False) \<Rightarrow> False
| (True, True) \<Rightarrow> True)" |
"formula_semantics_tt \<A> (Or a b) = (case (formula_semantics_tt \<A> a, formula_semantics_tt \<A> b) of
  (False, False) \<Rightarrow> False
| (False, True) \<Rightarrow> True
| (True, False) \<Rightarrow> True
| (True, True) \<Rightarrow> True)" |
"formula_semantics_tt \<A> (Imp a b) = (case (formula_semantics_tt \<A> a, formula_semantics_tt \<A> b) of
  (False, False) \<Rightarrow> True
| (False, True) \<Rightarrow> True
| (True, False) \<Rightarrow> False
| (True, True) \<Rightarrow> True)"
private lemma "A \<Turnstile> F \<longleftrightarrow> formula_semantics_tt A F"
  by(induction F; simp split: prod.splits bool.splits)
end

definition entailment :: "'a formula set \<Rightarrow> 'a formula \<Rightarrow> bool" ("(_ \<TTurnstile>/ _)" (* \TTurnstile *) [53,53] 53) where
"\<Gamma> \<TTurnstile> F \<equiv> (\<forall>\<A>. ((\<forall>G \<in> \<Gamma>. \<A> \<Turnstile> G) \<longrightarrow> (\<A> \<Turnstile> F)))"
text\<open>We write entailment differently than semantics (\<open>\<Turnstile>\<close> vs. \<open>\<TTurnstile>\<close>).
For humans, it is usually pretty clear what is meant in a specific situation,
but it often needs to be decided from context that Isabelle/HOL does not have.\<close>

text\<open>Some helpers for the derived connectives\<close>
lemma top_semantics[simp,intro!]: "A \<Turnstile> \<top>" unfolding Top_def by simp
lemma BigAnd_semantics[simp]: "A \<Turnstile> \<^bold>\<And>F \<longleftrightarrow> (\<forall>f \<in> set F. A \<Turnstile> f)" by(induction F; simp)
lemma BigOr_semantics[simp]: "A \<Turnstile> \<^bold>\<Or>F \<longleftrightarrow> (\<exists>f \<in> set F. A \<Turnstile> f)" by(induction F; simp)

text\<open>Definitions for sets of formulae, used for compactness and model existence.\<close>

definition "sat S \<equiv> \<exists>\<A>. \<forall>F \<in> S. \<A> \<Turnstile> F"
definition "fin_sat S \<equiv> (\<forall>s \<subseteq> S. finite s \<longrightarrow> sat s)"

lemma pn_atoms_updates: "p \<notin> snd (pn_atoms F) \<Longrightarrow> n \<notin> fst (pn_atoms F) \<Longrightarrow>
  ((M \<Turnstile> F \<longrightarrow> (M(p := True) \<Turnstile> F \<and> M(n := False) \<Turnstile> F))) \<and> ((\<not>(M \<Turnstile> F)) \<longrightarrow> \<not>(M(n := True) \<Turnstile> F) \<and> \<not>(M(p := False) \<Turnstile> F))"
proof(induction F arbitrary: n p)
  case (Imp F G)
  from Imp.prems have prems:
     "p \<notin> fst (pn_atoms F)" "p \<notin> snd (pn_atoms G)"
     "n \<notin> snd (pn_atoms F)" "n \<notin> fst (pn_atoms G)"
    by(simp_all add: prod_unions_def split: prod.splits)
  have IH1: "M \<Turnstile> F \<Longrightarrow> M(n := True) \<Turnstile> F" " M \<Turnstile> F \<Longrightarrow> M(p := False) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(p := True) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(n := False) \<Turnstile> F"
    using Imp.IH(1)[OF prems(3) prems(1)] by blast+
  have IH2: "M \<Turnstile> G \<Longrightarrow> M(p := True) \<Turnstile> G" "M \<Turnstile> G \<Longrightarrow> M(n := False) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(n := True) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(p := False) \<Turnstile> G"
    using Imp.IH(2)[OF prems(2) prems(4)] by blast+
   show ?case proof(intro conjI; intro impI)
     assume "M \<Turnstile> F \<^bold>\<rightarrow> G"
     then consider "\<not> M \<Turnstile> F" | "M \<Turnstile>G" by auto
     thus "M(p := True) \<Turnstile> F \<^bold>\<rightarrow> G \<and> M(n := False) \<Turnstile> F \<^bold>\<rightarrow> G" using IH1(3,4) IH2(1,2) by cases simp_all
   next
     assume "\<not>(M \<Turnstile> F \<^bold>\<rightarrow> G)"
     hence "M \<Turnstile> F" "\<not>M \<Turnstile> G" by simp_all
     thus "\<not> M(n := True) \<Turnstile> F \<^bold>\<rightarrow> G \<and> \<not> M(p := False) \<Turnstile> F \<^bold>\<rightarrow> G" using IH1(1,2) IH2(3,4) by simp
   qed
 next
  case (And F G)
  from And.prems have prems:
     "p \<notin> snd (pn_atoms F)" "p \<notin> snd (pn_atoms G)"
     "n \<notin> fst (pn_atoms F)" "n \<notin> fst (pn_atoms G)"
    by(simp_all add: prod_unions_def split: prod.splits)
  have IH1: "M \<Turnstile> F \<Longrightarrow> M(p := True) \<Turnstile> F" " M \<Turnstile> F \<Longrightarrow> M(n := False) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(n := True) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(p := False) \<Turnstile> F"
    using And.IH(1)[OF prems(1) prems(3)] by blast+
  have IH2: "M \<Turnstile> G \<Longrightarrow> M(p := True) \<Turnstile> G" "M \<Turnstile> G \<Longrightarrow> M(n := False) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(n := True) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(p := False) \<Turnstile> G"
    using And.IH(2)[OF prems(2) prems(4)] by blast+
  show ?case proof(intro conjI; intro impI)
    assume "\<not>M \<Turnstile> F \<^bold>\<and> G"
    then consider "\<not> M \<Turnstile> F" | "\<not> M \<Turnstile>G" by auto
    thus "\<not> M(n := True) \<Turnstile> F \<^bold>\<and> G \<and> \<not> M(p := False) \<Turnstile> F \<^bold>\<and> G" using IH1 IH2 by cases simp_all
  next
    assume "M \<Turnstile> F \<^bold>\<and> G"
    hence "M \<Turnstile> F" "M \<Turnstile> G" by simp_all
    thus "M(p := True) \<Turnstile> F \<^bold>\<and> G \<and> M(n := False) \<Turnstile> F \<^bold>\<and> G " using IH1 IH2 by simp
  qed
next
  case (Or F G)
  from Or.prems have prems:
     "p \<notin> snd (pn_atoms F)" "p \<notin> snd (pn_atoms G)"
     "n \<notin> fst (pn_atoms F)" "n \<notin> fst (pn_atoms G)"
    by(simp_all add: prod_unions_def split: prod.splits)
  have IH1: "M \<Turnstile> F \<Longrightarrow> M(p := True) \<Turnstile> F" " M \<Turnstile> F \<Longrightarrow> M(n := False) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(n := True) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(p := False) \<Turnstile> F"
    using Or.IH(1)[OF prems(1) prems(3)] by blast+
  have IH2: "M \<Turnstile> G \<Longrightarrow> M(p := True) \<Turnstile> G" "M \<Turnstile> G \<Longrightarrow> M(n := False) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(n := True) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(p := False) \<Turnstile> G"
    using Or.IH(2)[OF prems(2) prems(4)] by blast+
  show ?case proof(intro conjI; intro impI)
    assume "M \<Turnstile> F \<^bold>\<or> G"
    then consider "M \<Turnstile> F" | "M \<Turnstile>G" by auto
    thus "M(p := True) \<Turnstile> F \<^bold>\<or> G \<and> M(n := False) \<Turnstile> F \<^bold>\<or> G" using IH1 IH2 by cases simp_all
  next
    assume "\<not>M \<Turnstile> F \<^bold>\<or> G"
    hence "\<not>M \<Turnstile> F" "\<not>M \<Turnstile> G" by simp_all
    thus "\<not>M(n := True) \<Turnstile> F \<^bold>\<or> G \<and> \<not>M(p := False) \<Turnstile> F \<^bold>\<or> G " using IH1 IH2 by simp
  qed
qed simp_all

lemma const_simplifier_correct: "\<A> \<Turnstile> simplify_consts F \<longleftrightarrow> \<A> \<Turnstile> F"
  by (induction F) (auto simp add: Let_def isstop_def Top_def split: formula.splits)

end


section \<open>The MRU Vote Model\<close>

theory MRU_Vote
imports Same_Vote
begin

context quorum_process
begin

text \<open>This model is identical to Same Vote, except that it replaces
  the @{term safe} guard with the following one, which says that \<open>v\<close> is the
  most recently used (MRU) vote of a quorum:
\<close>

definition mru_guard :: "v_state \<Rightarrow> process set \<Rightarrow> val \<Rightarrow> bool" where
  "mru_guard s Q v \<equiv> Q \<in> Quorum \<and> (let mru = mru_of_set (votes s) Q in
    mru = None \<or> (\<exists>r. mru = Some (r, v)))"

text \<open>The concrete algorithms will not refine the MRU Voting model directly, but its optimized
  version instead. For simplicity, we thus do not create the model explicitly, but just prove guard
  strengthening. We will show later that the optimized model refines the Same Vote model.\<close>

lemma mru_vote_implies_safe:
  assumes
    inv4: "s \<in> SV_inv4"
    and inv1: "s \<in> Vinv1"
    and mru_vote: "mru_guard s Q v"
    and is_Quorum: "Q \<in> Quorum"
  shows "safe s (v_state.next_round s) v" using mru_vote
proof(clarsimp simp add: mru_guard_def mru_of_set_def option_Max_by_def)
  \<comment> \<open>The first case: some votes have been cast. We prove that the most recently used one is
    safe.\<close>
  fix r
  assume
    nempty: "vote_set (votes s) Q \<noteq> {}"
    and max: "Max_by fst (vote_set (votes s) Q) = (r, v)"

  from Max_by_in[OF Vinv1_finite_vote_set[OF inv1] nempty] max
  have in_votes: "(r, v) \<in> vote_set (votes s) Q" by metis

  have no_larger: "\<forall>a'\<in>Q. \<forall>r'>r. votes s r' a' = None"
  proof(safe, rule ccontr, clarsimp)
    fix a' r' w
    assume "a' \<in> Q"  "votes s r' a' = Some w" and gt: "r' > r"
    hence "(r', w) \<in> vote_set (votes s) Q"
      by(auto simp add: vote_set_def)
    thus False
      using Max_by_ge[where f=fst, OF Vinv1_finite_vote_set[where Q=Q, OF inv1]] max gt
      by(clarsimp simp add: not_le[symmetric])
  qed

  have "safe s (Suc r) v" using inv4 in_votes and SV_inv4_def
    by(clarsimp simp add: vote_set_def)

  thus "safe s (v_state.next_round s) v" using no_larger is_Quorum[THEN qintersect]
    apply(clarsimp simp add: safe_def quorum_for_def)
    by (metis IntE all_not_in_conv not_less_eq option.distinct(1))

next
  assume "vote_set (votes s) Q = {}"
  thus "safe s (v_state.next_round s) v" using is_Quorum[THEN qintersect]
    by(force simp add: vote_set_def safe_def quorum_for_def)
qed

end (* context quorum_process *)

end