theory Lasso_Freeness_Certificates_Complete
  imports Main "HOL-Library.Countable" Graph_Library_Adaptor
begin

text \<open>
  This theory gives two valid ways of generating a certificate that proves that the given
  graph does not contain an accepting lasso.
\<close>

locale Contract_Downward =
  fixes E :: "'a :: countable \<Rightarrow> 'a \<Rightarrow> bool" and F :: "'a \<Rightarrow> bool"
  fixes f :: "'a \<Rightarrow> nat"
  assumes f_topo: "E a b \<Longrightarrow> if F a then f a > f b else f a \<ge> f b"
begin

lemma f_downward:
  assumes "E a b"
  shows "f a \<ge> f b"
  using assms f_topo by (cases "F a") (auto simp: less_imp_le)

lemma f_strict:
  assumes "E a b" "F a"
  shows "f a > f b"
  using assms f_topo by (auto simp: less_imp_le)

text \<open>We do not even need this property any more.\<close>
lemma no_trivial_lasso:
  assumes "F a" "E a a"
  shows False
  using assms f_topo by (meson less_irrefl)

lemma reaches_f_mono:
  assumes "E\<^sup>*\<^sup>* a b"
  shows "f a \<ge> f b"
  using assms by induction (auto intro: f_downward order.trans)

lemma no_accepting_cycle:
  assumes "E\<^sup>+\<^sup>+ x x"
  shows "\<not> F x"
proof (rule ccontr, simp)
  assume "F x"
  from \<open>E\<^sup>+\<^sup>+ x x\<close> obtain y where "E x y" "E\<^sup>*\<^sup>* y x"
    including graph_automation_aggressive by auto
  from \<open>E x y\<close> \<open>F x\<close> have "f x > f y"
    by (rule f_strict)
  moreover from \<open>E\<^sup>*\<^sup>* y x\<close> have "f y \<ge> f x"
    by (rule reaches_f_mono)
  ultimately show False
    by simp
qed

sublocale Graph_Defs .

lemma run_f_mono:
  assumes "run (x ## xs)" "c \<ge> f x"
  shows "pred_stream (\<lambda>a. c \<ge> f a) xs"
  using assms
  by (coinduction arbitrary: x xs) (metis f_downward order.trans run.cases stream.inject)

lemma no_Buechi_run:
  assumes "run xs" "infs F xs"
  shows False
proof -
  let ?S = "f ` sset xs" let ?T = "f ` sset (sfilter F xs)"
  obtain x ys where "xs = x ## ys"
    by (cases xs)
  let ?ub = "f x"
  from \<open>run xs\<close> have "run ys" "f (shd ys) \<le> ?ub"
    unfolding \<open>xs = _\<close> by (force elim: run.cases dest: f_downward)+
  then have "pred_stream (\<lambda>x. f x \<le> ?ub) ys"
    by (coinduction arbitrary: ys) (fastforce elim: run.cases dest: f_downward intro: order.trans)
  then have "finite ?S"
    unfolding stream.pred_set \<open>xs = _\<close> finite_nat_set_iff_bounded_le by auto
  from \<open>run xs\<close> \<open>infs F xs\<close> have "sdistinct (smap f (sfilter F xs))"
  proof (coinduction arbitrary: xs)
    case (sdistinct x xs ys)
    obtain y xs' where [simp]: "xs = y ## xs'"
      by (cases xs)
    obtain as bs x' y' ys' where eqs:
      "F x'" "F y'" "x = f x'" "y = f y'"
      "ys = as @- x' ## bs @- y' ## ys'" "xs' = smap f (sfilter F ys')"
      "list_all (Not o F) as" "list_all (Not o F) bs"
    proof (atomize_elim, goal_cases)
      case 1
      from sdistinct have "ev (holds F) ys"
        by auto
      from \<open>x ## xs = _\<close> have "x ## y ## xs' = smap f (sfilter F ys)"
        by simp
      then obtain x' y' ys' where "x = f x'" "y = f y'" "sfilter F ys = x' ## y' ## ys'"
        "xs' = smap f ys'"
        apply atomize_elim
        unfolding scons_eq_smap
        apply (elim conjE)
        apply (intro exI conjI)
          apply assumption+
        apply (subst stream.collapse)+
        ..
      with \<open>ev (holds F) ys\<close> show ?case
        apply -
        apply (drule (1) sfilter_SCons_decomp)
        apply (elim conjE exE)
        apply (drule sfilter_SCons_decomp, metis alw.cases alw_shift sdistinct(3) stream.sel(2))
        by force
    qed
    have "run (y' ## ys')"
      using \<open>run ys\<close> unfolding \<open>ys = _\<close> (* XXX This should be solved by automation *)
      by (metis alw.cases alw_iff_sdrop alw_shift run_sdrop stream.sel(2))
    from eqs \<open>run ys\<close> have "steps (as @ x' # bs @ [y'])"
      by (simp add: run_decomp)
    then have "steps (x' # bs @ [y'])"
      using steps_appendD2 by blast
    then have "E\<^sup>+\<^sup>+ x' y'"
      using steps_reaches1 by blast
    with \<open>F x'\<close> have "f x' > f y'"
      using f_strict reaches1_reaches_iff1 reaches_f_mono by fastforce
    moreover have "pred_stream (\<lambda>a. f y' \<ge> f a) ys'"
      by (rule run_f_mono[where c = "f y'"]) (auto intro: \<open>run (y' ## ys')\<close>)
    ultimately have "x \<notin> f ` sset ys'"
      unfolding stream.pred_set eqs by auto
    from \<open>infs F ys\<close> have "infs F ys'"
      unfolding eqs by auto
    then have "sset (sfilter F ys') \<subseteq> sset ys'"
      by (rule sset_sfilter)
    with \<open>x \<notin> _\<close> \<open>f x' > f y'\<close> have "x \<notin> sset xs"
      unfolding stream.pred_set eqs \<open>xs = _\<close> by auto
    with \<open>run (y' ## ys')\<close> \<open>infs F ys'\<close> eqs \<open>xs' = _\<close> show ?case
      by - (safe, rule exI[where x = "y'##ys'"], auto)
  qed
  then have "infinite ?T"
    by - (drule sdistinct_infinite_sset, simp)
  moreover have "?T \<subseteq> ?S"
    by (rule image_mono sset_sfilter assms)+
  ultimately show ?thesis
    using \<open>finite ?S\<close> finite_subset by auto
qed

end (* Fixed numbering *)

context
  fixes E :: "'a :: countable \<Rightarrow> 'a \<Rightarrow> bool" and F :: "'a \<Rightarrow> bool"
begin

context
  fixes f :: "'a \<Rightarrow> nat"
  assumes f_topo: "E a b \<Longrightarrow> if F a then f a < f b else f a \<le> f b"
begin

lemma f_forward:
  assumes "E a b"
  shows "f a \<le> f b"
  using assms f_topo by (cases "F a") (auto simp: less_imp_le)

lemma f_strict:
  assumes "E a b" "F a"
  shows "f a < f b"
  using assms f_topo by (auto simp: less_imp_le)

text \<open>We do not even need this property any more.\<close>
lemma no_trivial_lasso:
  assumes "F a" "E a a"
  shows False
  using assms f_topo by (meson less_irrefl)

lemma reaches_f_mono:
  assumes "E\<^sup>*\<^sup>* a b"
  shows "f a \<le> f b"
  using assms by induction (auto intro: f_forward order.trans)

lemma no_accepting_cycle:
  assumes "E\<^sup>+\<^sup>+ x x"
  shows "\<not> F x"
proof (rule ccontr, simp)
  assume "F x"
  from \<open>E\<^sup>+\<^sup>+ x x\<close> obtain y where "E x y" "E\<^sup>*\<^sup>* y x"
    including graph_automation_aggressive by auto
  from \<open>E x y\<close> \<open>F x\<close> have "f x < f y"
    by (rule f_strict)
  moreover from \<open>E\<^sup>*\<^sup>* y x\<close> have "f y \<le> f x"
    by (rule reaches_f_mono)
  ultimately show False
    by simp
qed

end (* Fixed numbering *)

context
  assumes no_accepting_cycle: "E\<^sup>+\<^sup>+ x x \<Longrightarrow> \<not> F x"
begin

definition
  "reach x \<equiv> card {y. F y \<and> E\<^sup>*\<^sup>* x y}"

context
  assumes finite: "finite {y. E\<^sup>*\<^sup>* x y}"
begin

lemma reach_mono:
  assumes "E x y"
  shows "reach x \<ge> reach y"
  using assms unfolding reach_def by (intro card_mono finite_subset[OF _ finite]) auto

lemma reach_strict:
  assumes "E x y" "F x"
  shows "reach x > reach y"
  using assms unfolding reach_def
  apply (intro psubset_card_mono finite_subset[OF _ finite])
  apply auto
  subgoal premises prems
  proof -
    from prems have "E\<^sup>*\<^sup>* y x"
      by auto
    with \<open>E x y\<close> have "E\<^sup>+\<^sup>+ x x"
      by auto
    with \<open>F x\<close> no_accepting_cycle show False
      by auto
  qed
  done

end (* Finite reachable set *)

end

end

context Finite_Graph
begin

context
  assumes no_accepting_cycle: "E\<^sup>+\<^sup>+ x x \<Longrightarrow> \<not> F x"
begin

private definition
  "f x \<equiv> scc_num (THE V. is_max_scc V \<and> x \<in> V)"

lemma f_topo:
  assumes "E a b"
  shows "if F a then f a < f b else f a \<le> f b"
proof -
  from assms obtain A where A: "is_max_scc A" "a \<in> A"
    by - (rule max_sccI, auto simp: vertices_def)
  from assms obtain B where B: "is_max_scc B" "b \<in> B"
    by - (rule max_sccI[where a = b], auto simp: vertices_def)
  from A B have [simp]: "f a = scc_num A" "f b = scc_num B"
    unfolding f_def using is_max_scc_disjoint
    by (intro arg_cong[where f = scc_num] the_equality, auto)+
  have "f a \<le> f b"
  proof (cases "A = B")
    case True
    then show ?thesis
      by simp
  next
    case False
    with \<open>E a b\<close> \<open>a \<in> A\<close> \<open>b \<in> B\<close> have "edge A B"
      unfolding edge_def by auto
    then have "f a < f b"
      using A B scc_num_topological by simp
    then show ?thesis
      by simp
  qed
  moreover have "f a \<noteq> f b" if "F a"
  proof (rule ccontr)
    assume "\<not> f a \<noteq> f b"
    with A B have "A = B"
      using scc_num_inj unfolding inj_on_def by simp
    with A \<open>b \<in> B\<close> have "E\<^sup>*\<^sup>* b a"
      unfolding is_max_scc_def by auto
    with \<open>E a b\<close> have "E\<^sup>+\<^sup>+ a a"
      by auto
    with \<open>F a\<close> no_accepting_cycle show False
      by auto
  qed
  ultimately show ?thesis
    by auto
qed

end (* No accepting cycle *)

end (* Fixed graph & final state predicate *)

end


theory relaxedprefix_is_prefix_3
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype It = A | B | C

fun eq :: "It => It => bool" where
"eq (A) y =
   case y of
     | other => False
     | A => True
   end"
| "eq (B) y =
     case y of
       | other => False
       | B => True
     end"
| "eq (C) y =
     case y of
       | other => False
       | C => True
     end"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (Nil2) y = True"
| "isPrefix (Cons2 z x2) (Nil2) = False"
| "isPrefix (Cons2 z x2) (Cons2 x3 x4) =
     (if eq z x3 then isPrefix x2 x4 else False)"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (Nil2) y = True"
| "isRelaxedPrefix (Cons2 z (Nil2)) y = True"
| "isRelaxedPrefix (Cons2 z (Cons2 x3 x4)) (Nil2) = False"
| "isRelaxedPrefix (Cons2 z (Cons2 x3 x4)) (Cons2 x5 x6) =
     (if eq z x5 then isRelaxedPrefix (Cons2 x3 x4) x6 else
        isPrefix (Cons2 x3 x4) (Cons2 x5 x6))"

fun append :: "It list => It list => It list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

(*hipster eq isPrefix isRelaxedPrefix append *)

theorem x0 :
  "!! (x :: It) (xs :: It list) (ys :: It list) .
     isRelaxedPrefix (append xs (Cons2 x (Nil2))) (append xs ys)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


subsection \<open> ETP definitions \<close>

text \<open> We define Extended Trapdoor Permutations (ETPs) following \cite{DBLP:books/sp/17/Lindell17} and \cite{DBLP:books/cu/Goldreich2004}.
In particular we consider the property of Hard Core Predicates (HCPs). \<close>

theory ETP imports
  CryptHOL.CryptHOL
begin

type_synonym ('index,'range) dist2 = "(bool \<times> 'index \<times> bool \<times> bool) \<Rightarrow> bool spmf"

type_synonym ('index,'range) advP2 = "'index \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ('index,'range) dist2 \<Rightarrow> 'range \<Rightarrow> bool spmf"

locale etp =
  fixes I :: "('index \<times> 'trap) spmf" \<comment> \<open>samples index and trapdoor\<close>
    and domain :: "'index \<Rightarrow> 'range set"
    and range :: "'index \<Rightarrow> 'range set"
    and F :: "'index \<Rightarrow> ('range \<Rightarrow> 'range)" \<comment> \<open>permutation\<close>
    and F\<^sub>i\<^sub>n\<^sub>v :: "'index \<Rightarrow> 'trap \<Rightarrow> 'range \<Rightarrow> 'range" \<comment> \<open>must be efficiently computable\<close>
    and B :: "'index \<Rightarrow> 'range \<Rightarrow> bool" \<comment> \<open>hard core predicate\<close>
  assumes dom_eq_ran: "y \<in> set_spmf I \<longrightarrow> domain (fst y) = range (fst y)"
    and finite_range: "y \<in> set_spmf I \<longrightarrow> finite (range (fst y))"
    and non_empty_range: "y \<in> set_spmf I \<longrightarrow> range (fst y) \<noteq> {}"
    and bij_betw: "y \<in> set_spmf I \<longrightarrow> bij_betw (F (fst y)) (domain (fst y)) (range (fst y))"
    and lossless_I: "lossless_spmf I"
    and F_f_inv: "y \<in> set_spmf I \<longrightarrow> x \<in> range (fst y) \<longrightarrow> F\<^sub>i\<^sub>n\<^sub>v (fst y) (snd y) (F (fst y) x) = x"
begin

definition S :: "'index \<Rightarrow> 'range spmf"
  where "S \<alpha> = spmf_of_set (range \<alpha>)"

lemma lossless_S: "y \<in> set_spmf I \<longrightarrow>  lossless_spmf (S (fst y))"
  by(simp add: lossless_spmf_def S_def finite_range non_empty_range)

lemma set_spmf_S [simp]: "y \<in> set_spmf I \<longrightarrow> set_spmf (S (fst y)) = range (fst y)"
  by (simp add: S_def finite_range)

lemma f_inj_on: "y \<in> set_spmf I \<longrightarrow> inj_on (F (fst y)) (range (fst y))"
  by(metis bij_betw_def bij_betw dom_eq_ran bij_betw_def bij_betw dom_eq_ran)

lemma range_f: "y \<in> set_spmf I \<longrightarrow>  x \<in> range (fst y) \<longrightarrow> F (fst y) x \<in> range (fst y)"
  by (metis bij_betw bij_betw dom_eq_ran bij_betwE)

lemma f_inv_f [simp]: "y \<in> set_spmf I \<longrightarrow> x \<in> range (fst y) \<longrightarrow> F\<^sub>i\<^sub>n\<^sub>v (fst y) (snd y) (F (fst y) x) = x"
  by (metis bij_betw bij_betw_inv_into_left dom_eq_ran F_f_inv)

lemma f_inv_f' [simp]: "y \<in> set_spmf I \<longrightarrow> x \<in> range (fst y) \<longrightarrow> Hilbert_Choice.inv_into (range (fst y)) (F (fst y)) (F (fst y) x) = x"
  by (metis bij_betw bij_betw_inv_into_left bij_betw dom_eq_ran)

lemma B_F_inv_rewrite: "(B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = (B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = m1)) = m1"
  by auto

lemma uni_set_samp:
  assumes "y \<in> set_spmf I"
  shows "map_spmf (\<lambda> x. F (fst y) x) (S (fst y)) = (S (fst y))"
(is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set (range (fst y))"
    unfolding S_def by(simp)
  also have "map_spmf (\<lambda> x. F (fst y) x) (spmf_of_set (range (fst y))) = spmf_of_set ((\<lambda> x. F (fst y) x) ` (range (fst y)))"
    using f_inj_on assms
    by (metis map_spmf_of_set_inj_on)
  also have "(\<lambda> x. F (fst y) x) ` (range (fst y)) = range (fst y)"
    apply(rule endo_inj_surj)
    using bij_betw
      by (auto simp add: bij_betw_def dom_eq_ran f_inj_on bij_betw finite_range assms)
  finally show ?thesis by(simp add: rhs)
qed

text\<open>We define the security property of the hard core predicate (HCP) using a game.\<close>

definition HCP_game :: "('index,'range) advP2 \<Rightarrow>  bool \<Rightarrow> bool \<Rightarrow> ('index,'range) dist2 \<Rightarrow> bool spmf"
  where "HCP_game A = (\<lambda> \<sigma> b\<^sub>\<sigma> D. do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x \<leftarrow> S \<alpha>;
    b' \<leftarrow> A \<alpha> \<sigma> b\<^sub>\<sigma> D x;
    let b = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    return_spmf (b = b')})"

definition "HCP_adv A \<sigma> b\<^sub>\<sigma> D = \<bar>((spmf (HCP_game A \<sigma> b\<^sub>\<sigma> D) True) - 1/2)\<bar>"

end

end


theory HOModel
imports Main
begin

declare if_split_asm [split]

section "Heard-Of Algorithms"

subsection "The Consensus Problem"

text \<open>
  We are interested in the verification of fault-tolerant distributed algorithms.
  The Consensus problem is paradigmatic in this area. Stated
  informally, it assumes that all processes participating in the algorithm
  initially propose some value, and that they may at some point decide some value.
  It is required that every process eventually decides, and that all processes
  must decide the same value.

  More formally, we represent runs of algorithms as `\<omega>`-sequences of
  configurations (vectors of process states). Hence, a run is modeled as
  a function of type `nat => 'proc => 'pst` where type variables
  `'proc` and `'pst` represent types of processes and process
  states, respectively.
\<close>

datatype 'msg message = Content "'msg" | Bot | Void
datatype 'pst proc_state = Active "'pst" | Asleep

fun the_state where
  "the_state (Active s) = s"
| "the_state Asleep = undefined"

text \<open>Predicate that holds if process @{text p} always sleeps in run @{text rho}.\<close>
definition always_asleep where
  "always_asleep rho p == ALL n. rho n p = Asleep"

text \<open>Round in which a process that is not always asleep wakes up.\<close>
definition first_awake where
  "first_awake rho p == LEAST n. rho n p ~= Asleep"

definition get_init_state :: "(nat => 'proc => 'pst proc_state) => 'proc => 'pst proc_state" where
  "get_init_state rho p ==
    if always_asleep rho p then Asleep
    else rho (first_awake rho p) p"
(* rho (Max ({n + 1 | n. rho n p = Asleep } \<union> {0})) p" *)

text \<open>
  The Consensus property is expressed with respect
  to a collection `val` of initially proposed values (one per process)
  and an observer function `dec::'pst => val option` that retrieves the decision
  (if any) from a process state. The Consensus problem is stated as the conjunction
  of the following properties:
  \begin{description}
  \item[Integrity.] Processes can only decide initially proposed values.
  \item[Agreement.] Whenever processes `p` and `q` decide,
    their decision values must be the same. (In particular, process `p`
    may never change the value it decides, which is referred to as Irrevocability.)
  \item[Termination.] Every process decides eventually.
  \end{description}

  The above properties are sometimes only required of non-faulty processes, since
  nothing can be required of a faulty process.
  The Heard-Of model does not attribute faults to processes, and therefore the
  above formulation is appropriate in this framework.
\<close>
definition
  consensus :: "('proc => 'val) => ('pst => 'val option) => (nat => 'proc => 'pst proc_state) => bool"
where
  "consensus vals dec rho ==
     (ALL n p v s. rho n p = Active s --> dec s = Some v --> v : range vals)
   & (ALL m n p q v w sp sq. rho m p = Active sp --> dec sp = Some v
         --> rho n q = Active sq --> dec sq = Some w --> v = w)
   & (ALL p. ~always_asleep rho p --> (EX n s. rho n p = Active s & dec s ~= None))"

text \<open>
  A variant of the Consensus problem replaces the Integrity requirement by
  \begin{description}
  \item[Validity.] If all processes initially propose the same value `v`
    then every process may only decide `v`.
  \end{description}
\<close>

definition weak_consensus where
  "weak_consensus vals dec rho ==
     (ALL v. (ALL p. vals p = v) --> (ALL n p w s. rho n p = Active s --> dec s = Some w --> w = v))
   & (ALL m n p q v w sp sq. rho m p = Active sp --> dec sp = Some v
         --> rho n q = Active sq --> dec sq = Some w --> v = w)
   & (ALL p. ~always_asleep rho p --> (EX n s. rho n p = Active s & dec s ~= None))"

text \<open>
  Clearly, `consensus` implies `weak_consensus`.
\<close>

lemma consensus_then_weak_consensus:
  assumes "consensus vals dec rho"
  shows "weak_consensus vals dec rho"
  using assms unfolding consensus_def weak_consensus_def
  by (smt rangeE)

text \<open>
  Over Boolean values (``binary Consensus''), `weak_consensus`
  implies `consensus`, hence the two problems are equivalent.
  In fact, this theorem holds more generally whenever at most two
  different values are proposed initially (i.e., `card (range vals) \<le> 2`).
\<close>

lemma binary_weak_consensus_then_consensus:
  assumes bc: "weak_consensus (vals::'proc => bool) dec rho"
  shows "consensus vals dec rho"
proof -
  text \<open>Show the Integrity property, the other conjuncts are the same.\<close>
  {
    fix n p v s
    assume act: "rho n p = Active s" and dec: "dec s = Some v"
    have "v : range vals"
    proof (cases "EX b. ALL p. vals p = b")
      case True with bc act dec show ?thesis
        unfolding weak_consensus_def by (smt range_eqI)
    next
      case False
      text \<open>In this case both possible values occur in @{text "vals"}, and the result is trivial.\<close>
      thus ?thesis by (auto simp: image_def)
    qed
  }
  with bc show ?thesis
    unfolding consensus_def weak_consensus_def by meson
qed

text \<open>
  The algorithms that we are going to verify solve the Consensus or weak Consensus
  problem, under different hypotheses about the kinds and number of faults.
\<close>

subsection "A Generic Representation of Heard-Of Algorithms"

text \<open>
  Charron-Bost and Schiper~\cite{charron:heardof} introduce
  the Heard-Of (HO) model for representing fault-tolerant
  distributed algorithms. In this model, algorithms execute in communication-closed
  rounds: at any round~$r$, processes only receive messages that were sent for
  that round. For every process~$p$ and round~$r$, the ``heard-of set'' $HO(p,r)$
  denotes the set of processes from which~$p$ receives a message in round~$r$.
  Since every process is assumed to send a message to all processes in each round,
  the complement of $HO(p,r)$ represents the set of faults that may affect~$p$ in
  round~$r$ (messages that were not received, e.g. because the sender crashed,
  because of a network problem etc.).

  The HO model expresses hypotheses on the faults tolerated by an algorithm
  through ``communication predicates'' that constrain the sets $HO(p,r)$
  that may occur during an execution. Charron-Bost and Schiper show that
  standard fault models can be represented in this form.

  The original HO model is sufficient for representing algorithms
  tolerating benign failures such as process crashes or message loss. A later
  extension for algorithms tolerating Byzantine (or value) failures~\cite{biely:tolerating}
  adds a second collection of sets $SHO(p,r) \subseteq HO(p,r)$ that contain those
  processes $q$ from which process $p$ receives the message that $q$ was indeed
  supposed to send for round $r$ according to the algorithm. In other words,
  messages from processes in $HO(p,r) \setminus SHO(p,r)$ were corrupted, be it
  due to errors during message transmission or because of the sender was faulty or
  lied deliberately. For both benign and Byzantine errors, the HO model registers
  the fault but does not try to identify the faulty component (i.e., designate the
  sending or receiving process, or the communication channel as the ``culprit'').

  Executions of HO algorithms are defined with respect to collections
  $HO(p,r)$ and $SHO(p,r)$. However, the code of a process does not have
  access to these sets. In particular, process $p$ has no way of determining
  if a message it received from another process $q$ corresponds to what $q$
  should have sent or if it has been corrupted.

  Certain algorithms rely on the assignment of ``coordinator'' processes for
  each round. Just as the collections $HO(p,r)$, the definitions assume an
  external coordinator assignment such that $coord(p,r)$ denotes the coordinator
  of process $p$ and round $r$. Again, the correctness of algorithms may depend
  on hypotheses about coordinator assignments -- e.g., it may be assumed that
  processes agree sufficiently often on who the current coordinator is.

  The following definitions provide a generic representation of HO and SHO algorithms
  in Isabelle/HOL. A (coordinated) HO algorithm is described by the following parameters:
  \begin{itemize}
  \item a finite type `'proc` of processes,
  \item a type `'pst` of local process states,
  \item a type `'msg` of messages sent in the course of the algorithm,
  \item a predicate `CinitState` such that `CinitState p st crd` is
    true precisely of the initial states `st` of process `p`, assuming
    that `crd` is the initial coordinator of `p`,
  \item a function `sendMsg` where `sendMsg r p q st` yields
    the message that process `p` sends to process `q` at round
    `r`, given its local state `st`, and
  \item a predicate `CnextState` where `CnextState r p st msgs crd st'`
    characterizes the successor states `st'` of process `p` at round
    `r`, given current state `st`, the vector
    `msgs :: 'proc => 'msg option` of messages that `p` received at
    round `r` (`msgs q = None` indicates that no message has been
    received from process `q`),
    and process `crd` as the coordinator for the following round.
  \end{itemize}
  Note that every process can store the coordinator for the current round in its
  local state, and it is therefore not necessary to make the coordinator a parameter
  of the message sending function `sendMsg`.

  We represent an algorithm by a record as follows.
\<close>

record ('proc, 'pst, 'msg) CHOAlgorithm =
  CinitState ::  "'proc => 'pst => 'proc => bool"
  sendMsg ::   "'proc => 'proc => 'pst => 'msg"
  CnextState :: "'proc => 'pst => ('proc => 'msg message) => 'proc => 'pst => bool"

text \<open>
  For non-coordinated HO algorithms, the coordinator argument of functions
  `CinitState` and `CnextState` is irrelevant, and we
  define utility functions that trivialize that argument.
\<close>

definition isNCAlgorithm where
  "isNCAlgorithm alg ==
     (ALL p st crd crd'. CinitState alg p st crd = CinitState alg p st crd')
   & (ALL p st msgs crd crd' st'. CnextState alg p st msgs crd st'
                               = CnextState alg p st msgs crd' st')"

definition initState where
  "initState alg p st == CinitState alg p st undefined"

definition nextState where
  "nextState alg p st msgs st' == CnextState alg p st msgs undefined st'"

text \<open>
  A \emph{heard-of assignment} associates a set of processes with each
  process. The following type is used to represent the collections $HO(p,r)$
  and $SHO(p,r)$ for fixed round $r$.
%
  Similarly, a \emph{coordinator assignment} associates a process (its coordinator)
  to each process.
\<close>

type_synonym
  'proc HO = "'proc => 'proc set"

type_synonym
  'proc coord = "'proc => 'proc"

text \<open>
  An execution of an HO algorithm is defined with respect to HO and SHO
  assignments that indicate, for every round `r` and every process `p`,
  from which sender processes `p` receives messages (resp., uncorrupted
  messages) at round `r`.

%% That's the intention, but we don't enforce this in the definitions.
%  Obviously, SHO sets are always included in HO sets, for the same process and round.

  The following definitions formalize this idea. We define ``coarse-grained''
  executions whose unit of atomicity is the round of execution. At each round,
  the entire collection of processes performs a transition according to the
  `CnextState` function of the algorithm. Consequently, a system state is
  simply described by a configuration, i.e. a function assigning a process state
  to every process. This definition of executions may appear surprising for an
  asynchronous distributed system, but it simplifies system verification,
  compared to a ``fine-grained'' execution model that records individual events
  such as message sending and reception or local transitions. We will justify
  later why the ``coarse-grained'' model is sufficient for verifying interesting
  correctness properties of HO algorithms.

  The predicate `CSHOinitConfig` describes the possible initial configurations
  for algorithm `A` (remember that a configuration is a function that assigns
  local states to every process).
\<close>

text \<open>
  Given the current configuration `cfg` and the HO and SHO sets `HOp`
  and `SHOp` for process `p` at round `r`, the function
  `SHOmsgVectors` computes the set of possible vectors of messages that
  process `p` may receive. For processes `q \<notin> HOp`, `p`
  receives no message (represented as value `None`). For processes
  `q : SHOp`, `p` receives the message that `q` computed
  according to the `sendMsg` function of the algorithm. For the remaining
  processes `q : HOp - SHOp`, `p` may receive some arbitrary value.
\<close>

text \<open>
  Predicate `CSHOnextConfig` uses the preceding function and the algorithm's
  `CnextState` function to characterize the possible successor configurations
  in a coarse-grained step, and predicate `CSHORun` defines (coarse-grained)
  executions `rho` of an HO algorithm.
\<close>

fun HOrcvMsgs_q :: "'proc => ('proc, 'pst, 'msg) CHOAlgorithm  => 'proc =>
                         'pst proc_state => 'msg message" where
  "HOrcvMsgs_q q A p (Active s) = Content (sendMsg A q p s)"
| "HOrcvMsgs_q q A p Asleep = Bot"

definition HOrcvdMsgs :: "('proc, 'pst, 'msg) CHOAlgorithm => 'proc =>
                          'proc set => ('proc => 'pst proc_state)
                          => 'proc => 'msg message" where
  "HOrcvdMsgs A p HO cfg ==
   %q. if q : HO then HOrcvMsgs_q q A p (cfg q) else Void"

definition CHOnextConfig where
  "CHOnextConfig A cfg HO coord cfg' ==
   ALL p s.       cfg  p = Active s -->
         (EX s'. cfg' p = Active s' & CnextState A p s (HOrcvdMsgs A p (HO p) cfg) (coord p) s')"

definition CHOinitConfig where
  "CHOinitConfig A rho coord ==
   ALL p. (always_asleep rho p) |
       (let k = first_awake rho p
        in  CinitState A p (the_state (rho k p)) (coord k p))"
(*  ALL p (n::nat) s. (n > 0 --> rho (n-1) p = Asleep) --> rho n p = Active s --> CinitState A p s (coord n p)" *)

definition CHORun where
  "CHORun A rho HOs coords ==
     CHOinitConfig A rho coords
  & (ALL p n. p : HOs n p)
  & (ALL r. CHOnextConfig A (rho r) (HOs (Suc r)) (coords (Suc r)) (rho (Suc r)))"

lemma nonAsleepAgain :
  assumes "rho n p ~= Asleep" and "CHORun A rho HO coord"
  shows "EX s. rho (n+(m::nat)) p = Active s"
proof (induction m)
  case 0
  show ?case using assms by (cases "rho n p") auto
next
  case (Suc x)
  hence "EX s. rho (n + x) p = Active s" by (cases "rho (n+x) p") auto
  thus "EX s. rho (n + Suc x) p = Active s"
    using assms CHORun_def CHORun_def CHOnextConfig_def by (metis add_Suc_right)
qed

lemma first_awake:
  assumes run: "CHORun A rho HO coord"
    and prev: "0 < n --> rho (n-1) p = Asleep"
    and act: "rho n p = Active s"
  shows "first_awake rho p = n"
  unfolding first_awake_def
proof  (rule Least_equality)
  from act show "rho n p ~= Asleep" by simp
next
  fix m
  assume m: "rho m p ~= Asleep"
  show "n \<le> m"
  proof (rule ccontr)
    assume "~(n \<le> m)"
    hence "m < n" by simp
    then obtain k where k: "n-1 = m+k"
      by (metis Suc_eq_plus1_left add_diff_cancel_left' less_imp_Suc_add)
    with m run have "EX s'. rho (n-1) p = Active s'" by (auto dest: nonAsleepAgain)
    with `m < n` prev show "False" by simp
  qed
qed

text \<open>
  For non-coordinated algorithms. the `coord` arguments of the above functions
  are irrelevant. We define similar functions that omit that argument, and relate
  them to the above utility functions for these algorithms.
\<close>
definition HOinitConfig where
  "HOinitConfig A cfg == CHOinitConfig A cfg (%_ _. undefined)"

definition HOnextConfig where
  "HOnextConfig A cfg HO cfg' ==
   CHOnextConfig A cfg HO (%_. undefined) cfg'"

definition HORun :: "('proc, 'pst, 'msg) CHOAlgorithm =>
                      (nat => 'proc => 'pst proc_state) => (nat => 'proc => 'proc set) => bool" where
  "HORun A rho HOs ==
   CHORun A rho HOs (%_ _. undefined)"

lemma HORun_eq:
  "HORun A rho HOs =
   (HOinitConfig A rho
    & (ALL p n. p : HOs n p)
    & (ALL r. HOnextConfig A (rho r) (HOs (Suc r)) (rho (Suc r))))"
  by (auto simp: HORun_def CHORun_def HOinitConfig_def HOnextConfig_def)

lemma first_awake_HO:
  assumes run: "HORun A rho HO"
    and prev: "0 < n --> rho (n-1) p = Asleep"
    and act: "rho n p = Active s"
  shows "first_awake rho p = n"
  using assms unfolding HORun_def by (rule first_awake)

(*
text `
  The following derived proof rules are immediate consequences of
  the definition of `CHORun`; they simplify automatic reasoning.
`

lemma CHORun_0:
  assumes "CHORun A rho HOs coords"
      and "\<And>cfg. CHOinitConfig A cfg (coords 0) ==> P cfg"
  shows "P (rho 0)"
using assms unfolding CHORun_eq by blast

lemma CHORun_Suc:
  assumes "CHORun A rho HOs coords"
  and "\<And>r. CHOnextConfig A r (rho r) (HOs r) (coords (Suc r)) (rho (Suc r))
            ==> P r"
  shows "P n"
using assms unfolding CHORun_eq by blast

lemma CHORun_induct:
  assumes run: "CHORun A rho HOs coords"
  and init: "CHOinitConfig A (rho 0) (coords 0) ==> P 0"
  and step: "\<And>r. \<lbrakk> P r; CHOnextConfig A r (rho r) (HOs r) (coords (Suc r))
                                      (rho (Suc r)) \<rbrakk> ==> P (Suc r)"
  shows "P n"
using run unfolding CHORun_eq by (induct n, auto elim: init step)
*)

text \<open>
  Because algorithms will not operate for arbitrary HO, SHO, and coordinator
  assignments, these are constrained by a \emph{communication predicate}.
  For convenience, we split this predicate into a \emph{per Round} part that
  is expected to hold at every round and a \emph{global} part that must hold
  of the sequence of (S)HO assignments and may thus express liveness assumptions.

  In the parlance of~\cite{charron:heardof}, a \emph{HO machine} is an HO algorithm
  augmented with a communication predicate. We therefore define (C)(S)HO machines as
  the corresponding extensions of the record defining an HO algorithm.
\<close>

definition Schedule :: "(nat => 'proc => 'pst proc_state) => nat => 'proc set" where
  "Schedule rho n == {p. rho n p ~= Asleep}"

record ('proc, 'pst, 'msg) HOMachine = "('proc, 'pst, 'msg) CHOAlgorithm" +
  HOcommPerRd :: "'proc HO => bool"
  HOcommGlobal :: "(nat => 'proc HO) => bool"
  HOcommSchedule :: "(nat => 'proc set) => bool"

(* should probably also add a "Schedule" predicate here *)
record ('proc, 'pst, 'msg) CHOMachine = "('proc, 'pst, 'msg) CHOAlgorithm" +
  CHOcommPerRd :: "nat => 'proc HO => 'proc coord => bool"
  CHOcommGlobal::"(nat => 'proc HO) => (nat => 'proc coord) => bool"

end


(*  Title:      HOL/UNITY/Union.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Partly from Misra's Chapter 5: Asynchronous Compositions of Programs.
*)

section{*Unions of Programs*}

theory Union imports SubstAx FP begin

  (*FIXME: conjoin Init F \<inter> Init G \<noteq> {} *)
definition
  ok :: "['a program, 'a program] => bool"      (infixl "ok" 65)
  where "F ok G == Acts F \<subseteq> AllowedActs G &
               Acts G \<subseteq> AllowedActs F"

  (*FIXME: conjoin (\<Inter>i \<in> I. Init (F i)) \<noteq> {} *)
definition
  OK  :: "['a set, 'a => 'b program] => bool"
  where "OK I F = (\<forall>i \<in> I. \<forall>j \<in> I-{i}. Acts (F i) \<subseteq> AllowedActs (F j))"

definition
  JOIN  :: "['a set, 'a => 'b program] => 'b program"
  where "JOIN I F = mk_program (\<Inter>i \<in> I. Init (F i), \<Union>i \<in> I. Acts (F i),
                             \<Inter>i \<in> I. AllowedActs (F i))"

definition
  Join :: "['a program, 'a program] => 'a program"      (infixl "Join" 65)
  where "F Join G = mk_program (Init F \<inter> Init G, Acts F \<union> Acts G,
                             AllowedActs F \<inter> AllowedActs G)"

definition
  SKIP :: "'a program"
  where "SKIP = mk_program (UNIV, {}, UNIV)"

  (*Characterizes safety properties.  Used with specifying Allowed*)
definition
  safety_prop :: "'a program set => bool"
  where "safety_prop X <-> SKIP: X & (\<forall>G. Acts G \<subseteq> UNION X Acts --> G \<in> X)"

notation (xsymbols)
  SKIP  ("\<bottom>") and
  Join  (infixl "\<squnion>" 65)

syntax
  "_JOIN1"     :: "[pttrns, 'b set] => 'b set"         ("(3JN _./ _)" 10)
  "_JOIN"      :: "[pttrn, 'a set, 'b set] => 'b set"  ("(3JN _:_./ _)" 10)
syntax (xsymbols)
  "_JOIN1" :: "[pttrns, 'b set] => 'b set"              ("(3\<Squnion> _./ _)" 10)
  "_JOIN"  :: "[pttrn, 'a set, 'b set] => 'b set"       ("(3\<Squnion> _\<in>_./ _)" 10)

translations
  "JN x: A. B" == "CONST JOIN A (%x. B)"
  "JN x y. B" == "JN x. JN y. B"
  "JN x. B" == "CONST JOIN (CONST UNIV) (%x. B)"

subsection{*SKIP*}

lemma Init_SKIP [simp]: "Init SKIP = UNIV"
by (simp add: SKIP_def)

lemma Acts_SKIP [simp]: "Acts SKIP = {Id}"
by (simp add: SKIP_def)

lemma AllowedActs_SKIP [simp]: "AllowedActs SKIP = UNIV"
by (auto simp add: SKIP_def)

lemma reachable_SKIP [simp]: "reachable SKIP = UNIV"
by (force elim: reachable.induct intro: reachable.intros)

subsection{*SKIP and safety properties*}

lemma SKIP_in_constrains_iff [iff]: "(SKIP \<in> A co B) = (A \<subseteq> B)"
by (unfold constrains_def, auto)

lemma SKIP_in_Constrains_iff [iff]: "(SKIP \<in> A Co B) = (A \<subseteq> B)"
by (unfold Constrains_def, auto)

lemma SKIP_in_stable [iff]: "SKIP \<in> stable A"
by (unfold stable_def, auto)

declare SKIP_in_stable [THEN stable_imp_Stable, iff]

subsection{*Join*}

lemma Init_Join [simp]: "Init (F\<squnion>G) = Init F \<inter> Init G"
by (simp add: Join_def)

lemma Acts_Join [simp]: "Acts (F\<squnion>G) = Acts F \<union> Acts G"
by (auto simp add: Join_def)

lemma AllowedActs_Join [simp]:
     "AllowedActs (F\<squnion>G) = AllowedActs F \<inter> AllowedActs G"
by (auto simp add: Join_def)

subsection{*JN*}

lemma JN_empty [simp]: "(\<Squnion>i\<in>{}. F i) = SKIP"
by (unfold JOIN_def SKIP_def, auto)

lemma JN_insert [simp]: "(\<Squnion>i \<in> insert a I. F i) = (F a)\<squnion>(\<Squnion>i \<in> I. F i)"
apply (rule program_equalityI)
apply (auto simp add: JOIN_def Join_def)
done

lemma Init_JN [simp]: "Init (\<Squnion>i \<in> I. F i) = (\<Inter>i \<in> I. Init (F i))"
by (simp add: JOIN_def)

lemma Acts_JN [simp]: "Acts (\<Squnion>i \<in> I. F i) = insert Id (\<Union>i \<in> I. Acts (F i))"
by (auto simp add: JOIN_def)

lemma AllowedActs_JN [simp]:
     "AllowedActs (\<Squnion>i \<in> I. F i) = (\<Inter>i \<in> I. AllowedActs (F i))"
by (auto simp add: JOIN_def)

lemma JN_cong [cong]:
    "[| I=J;  !!i. i \<in> J ==> F i = G i |] ==> (\<Squnion>i \<in> I. F i) = (\<Squnion>i \<in> J. G i)"
by (simp add: JOIN_def)

subsection{*Algebraic laws*}

lemma Join_commute: "F\<squnion>G = G\<squnion>F"
by (simp add: Join_def Un_commute Int_commute)

lemma Join_assoc: "(F\<squnion>G)\<squnion>H = F\<squnion>(G\<squnion>H)"
by (simp add: Un_ac Join_def Int_assoc insert_absorb)

lemma Join_left_commute: "A\<squnion>(B\<squnion>C) = B\<squnion>(A\<squnion>C)"
by (simp add: Un_ac Int_ac Join_def insert_absorb)

lemma Join_SKIP_left [simp]: "SKIP\<squnion>F = F"
apply (unfold Join_def SKIP_def)
apply (rule program_equalityI)
apply (simp_all (no_asm) add: insert_absorb)
done

lemma Join_SKIP_right [simp]: "F\<squnion>SKIP = F"
apply (unfold Join_def SKIP_def)
apply (rule program_equalityI)
apply (simp_all (no_asm) add: insert_absorb)
done

lemma Join_absorb [simp]: "F\<squnion>F = F"
apply (unfold Join_def)
apply (rule program_equalityI, auto)
done

lemma Join_left_absorb: "F\<squnion>(F\<squnion>G) = F\<squnion>G"
apply (unfold Join_def)
apply (rule program_equalityI, auto)
done

(*Join is an AC-operator*)
lemmas Join_ac = Join_assoc Join_left_absorb Join_commute Join_left_commute

subsection{*Laws Governing @{text "\<Squnion>"}*}

(*Also follows by JN_insert and insert_absorb, but the proof is longer*)
lemma JN_absorb: "k \<in> I ==> F k\<squnion>(\<Squnion>i \<in> I. F i) = (\<Squnion>i \<in> I. F i)"
by (auto intro!: program_equalityI)

lemma JN_Un: "(\<Squnion>i \<in> I \<union> J. F i) = ((\<Squnion>i \<in> I. F i)\<squnion>(\<Squnion>i \<in> J. F i))"
by (auto intro!: program_equalityI)

lemma JN_constant: "(\<Squnion>i \<in> I. c) = (if I={} then SKIP else c)"
by (rule program_equalityI, auto)

lemma JN_Join_distrib:
     "(\<Squnion>i \<in> I. F i\<squnion>G i) = (\<Squnion>i \<in> I. F i) \<squnion> (\<Squnion>i \<in> I. G i)"
by (auto intro!: program_equalityI)

lemma JN_Join_miniscope:
     "i \<in> I ==> (\<Squnion>i \<in> I. F i\<squnion>G) = ((\<Squnion>i \<in> I. F i)\<squnion>G)"
by (auto simp add: JN_Join_distrib JN_constant)

(*Used to prove guarantees_JN_I*)
lemma JN_Join_diff: "i \<in> I ==> F i\<squnion>JOIN (I - {i}) F = JOIN I F"
apply (unfold JOIN_def Join_def)
apply (rule program_equalityI, auto)
done

subsection{*Safety: co, stable, FP*}

(*Fails if I={} because it collapses to SKIP \<in> A co B, i.e. to A \<subseteq> B.  So an
  alternative precondition is A \<subseteq> B, but most proofs using this rule require
  I to be nonempty for other reasons anyway.*)
lemma JN_constrains:
    "i \<in> I ==> (\<Squnion>i \<in> I. F i) \<in> A co B = (\<forall>i \<in> I. F i \<in> A co B)"
by (simp add: constrains_def JOIN_def, blast)

lemma Join_constrains [simp]:
     "(F\<squnion>G \<in> A co B) = (F \<in> A co B & G \<in> A co B)"
by (auto simp add: constrains_def Join_def)

lemma Join_unless [simp]:
     "(F\<squnion>G \<in> A unless B) = (F \<in> A unless B & G \<in> A unless B)"
by (simp add: unless_def)

(*Analogous weak versions FAIL; see Misra [1994] 5.4.1, Substitution Axiom.
  reachable (F\<squnion>G) could be much bigger than reachable F, reachable G
*)

lemma Join_constrains_weaken:
     "[| F \<in> A co A';  G \<in> B co B' |]
      ==> F\<squnion>G \<in> (A \<inter> B) co (A' \<union> B')"
by (simp, blast intro: constrains_weaken)

(*If I={}, it degenerates to SKIP \<in> UNIV co {}, which is false.*)
lemma JN_constrains_weaken:
     "[| \<forall>i \<in> I. F i \<in> A i co A' i;  i \<in> I |]
      ==> (\<Squnion>i \<in> I. F i) \<in> (\<Inter>i \<in> I. A i) co (\<Union>i \<in> I. A' i)"
apply (simp (no_asm_simp) add: JN_constrains)
apply (blast intro: constrains_weaken)
done

lemma JN_stable: "(\<Squnion>i \<in> I. F i) \<in> stable A = (\<forall>i \<in> I. F i \<in> stable A)"
by (simp add: stable_def constrains_def JOIN_def)

lemma invariant_JN_I:
     "[| !!i. i \<in> I ==> F i \<in> invariant A;  i \<in> I |]
       ==> (\<Squnion>i \<in> I. F i) \<in> invariant A"
by (simp add: invariant_def JN_stable, blast)

lemma Join_stable [simp]:
     "(F\<squnion>G \<in> stable A) =
      (F \<in> stable A & G \<in> stable A)"
by (simp add: stable_def)

lemma Join_increasing [simp]:
     "(F\<squnion>G \<in> increasing f) =
      (F \<in> increasing f & G \<in> increasing f)"
by (auto simp add: increasing_def)

lemma invariant_JoinI:
     "[| F \<in> invariant A; G \<in> invariant A |]
      ==> F\<squnion>G \<in> invariant A"
by (auto simp add: invariant_def)

lemma FP_JN: "FP (\<Squnion>i \<in> I. F i) = (\<Inter>i \<in> I. FP (F i))"
by (simp add: FP_def JN_stable INTER_eq)

subsection{*Progress: transient, ensures*}

lemma JN_transient:
     "i \<in> I ==>
    (\<Squnion>i \<in> I. F i) \<in> transient A = (\<exists>i \<in> I. F i \<in> transient A)"
by (auto simp add: transient_def JOIN_def)

lemma Join_transient [simp]:
     "F\<squnion>G \<in> transient A =
      (F \<in> transient A | G \<in> transient A)"
by (auto simp add: bex_Un transient_def Join_def)

lemma Join_transient_I1: "F \<in> transient A ==> F\<squnion>G \<in> transient A"
by simp

lemma Join_transient_I2: "G \<in> transient A ==> F\<squnion>G \<in> transient A"
by simp

(*If I={} it degenerates to (SKIP \<in> A ensures B) = False, i.e. to ~(A \<subseteq> B) *)
lemma JN_ensures:
     "i \<in> I ==>
      (\<Squnion>i \<in> I. F i) \<in> A ensures B =
      ((\<forall>i \<in> I. F i \<in> (A-B) co (A \<union> B)) & (\<exists>i \<in> I. F i \<in> A ensures B))"
by (auto simp add: ensures_def JN_constrains JN_transient)

lemma Join_ensures:
     "F\<squnion>G \<in> A ensures B =
      (F \<in> (A-B) co (A \<union> B) & G \<in> (A-B) co (A \<union> B) &
       (F \<in> transient (A-B) | G \<in> transient (A-B)))"
by (auto simp add: ensures_def)

lemma stable_Join_constrains:
    "[| F \<in> stable A;  G \<in> A co A' |]
     ==> F\<squnion>G \<in> A co A'"
apply (unfold stable_def constrains_def Join_def)
apply (simp add: ball_Un, blast)
done

(*Premise for G cannot use Always because  F \<in> Stable A  is weaker than
  G \<in> stable A *)
lemma stable_Join_Always1:
     "[| F \<in> stable A;  G \<in> invariant A |] ==> F\<squnion>G \<in> Always A"
apply (simp (no_asm_use) add: Always_def invariant_def Stable_eq_stable)
apply (force intro: stable_Int)
done

(*As above, but exchanging the roles of F and G*)
lemma stable_Join_Always2:
     "[| F \<in> invariant A;  G \<in> stable A |] ==> F\<squnion>G \<in> Always A"
apply (subst Join_commute)
apply (blast intro: stable_Join_Always1)
done

lemma stable_Join_ensures1:
     "[| F \<in> stable A;  G \<in> A ensures B |] ==> F\<squnion>G \<in> A ensures B"
apply (simp (no_asm_simp) add: Join_ensures)
apply (simp add: stable_def ensures_def)
apply (erule constrains_weaken, auto)
done

(*As above, but exchanging the roles of F and G*)
lemma stable_Join_ensures2:
     "[| F \<in> A ensures B;  G \<in> stable A |] ==> F\<squnion>G \<in> A ensures B"
apply (subst Join_commute)
apply (blast intro: stable_Join_ensures1)
done

subsection{*the ok and OK relations*}

lemma ok_SKIP1 [iff]: "SKIP ok F"
by (simp add: ok_def)

lemma ok_SKIP2 [iff]: "F ok SKIP"
by (simp add: ok_def)

lemma ok_Join_commute:
     "(F ok G & (F\<squnion>G) ok H) = (G ok H & F ok (G\<squnion>H))"
by (auto simp add: ok_def)

lemma ok_commute: "(F ok G) = (G ok F)"
by (auto simp add: ok_def)

lemmas ok_sym = ok_commute [THEN iffD1]

lemma ok_iff_OK:
     "OK {(0::int,F),(1,G),(2,H)} snd = (F ok G & (F\<squnion>G) ok H)"
apply (simp add: Ball_def conj_disj_distribR ok_def Join_def OK_def insert_absorb
              all_conj_distrib)
apply blast
done

lemma ok_Join_iff1 [iff]: "F ok (G\<squnion>H) = (F ok G & F ok H)"
by (auto simp add: ok_def)

lemma ok_Join_iff2 [iff]: "(G\<squnion>H) ok F = (G ok F & H ok F)"
by (auto simp add: ok_def)

(*useful?  Not with the previous two around*)
lemma ok_Join_commute_I: "[| F ok G; (F\<squnion>G) ok H |] ==> F ok (G\<squnion>H)"
by (auto simp add: ok_def)

lemma ok_JN_iff1 [iff]: "F ok (JOIN I G) = (\<forall>i \<in> I. F ok G i)"
by (auto simp add: ok_def)

lemma ok_JN_iff2 [iff]: "(JOIN I G) ok F =  (\<forall>i \<in> I. G i ok F)"
by (auto simp add: ok_def)

lemma OK_iff_ok: "OK I F = (\<forall>i \<in> I. \<forall>j \<in> I-{i}. (F i) ok (F j))"
by (auto simp add: ok_def OK_def)

lemma OK_imp_ok: "[| OK I F; i \<in> I; j \<in> I; i \<noteq> j|] ==> (F i) ok (F j)"
by (auto simp add: OK_iff_ok)

subsection{*Allowed*}

lemma Allowed_SKIP [simp]: "Allowed SKIP = UNIV"
by (auto simp add: Allowed_def)

lemma Allowed_Join [simp]: "Allowed (F\<squnion>G) = Allowed F \<inter> Allowed G"
by (auto simp add: Allowed_def)

lemma Allowed_JN [simp]: "Allowed (JOIN I F) = (\<Inter>i \<in> I. Allowed (F i))"
by (auto simp add: Allowed_def)

lemma ok_iff_Allowed: "F ok G = (F \<in> Allowed G & G \<in> Allowed F)"
by (simp add: ok_def Allowed_def)

lemma OK_iff_Allowed: "OK I F = (\<forall>i \<in> I. \<forall>j \<in> I-{i}. F i \<in> Allowed(F j))"
by (auto simp add: OK_iff_ok ok_iff_Allowed)

subsection{*@{term safety_prop}, for reasoning about
 given instances of "ok"*}

lemma safety_prop_Acts_iff:
     "safety_prop X ==> (Acts G \<subseteq> insert Id (UNION X Acts)) = (G \<in> X)"
by (auto simp add: safety_prop_def)

lemma safety_prop_AllowedActs_iff_Allowed:
     "safety_prop X ==> (UNION X Acts \<subseteq> AllowedActs F) = (X \<subseteq> Allowed F)"
by (auto simp add: Allowed_def safety_prop_Acts_iff [symmetric])

lemma Allowed_eq:
     "safety_prop X ==> Allowed (mk_program (init, acts, UNION X Acts)) = X"
by (simp add: Allowed_def safety_prop_Acts_iff)

(*For safety_prop to hold, the property must be satisfiable!*)
lemma safety_prop_constrains [iff]: "safety_prop (A co B) = (A \<subseteq> B)"
by (simp add: safety_prop_def constrains_def, blast)

lemma safety_prop_stable [iff]: "safety_prop (stable A)"
by (simp add: stable_def)

lemma safety_prop_Int [simp]:
  "safety_prop X \<Longrightarrow> safety_prop Y \<Longrightarrow> safety_prop (X \<inter> Y)"
  by (simp add: safety_prop_def) blast

lemma safety_prop_INTER [simp]:
  "(\<And>i. i \<in> I \<Longrightarrow> safety_prop (X i)) \<Longrightarrow> safety_prop (\<Inter>i\<in>I. X i)"
  by (simp add: safety_prop_def) blast

lemma safety_prop_INTER1 [simp]:
  "(\<And>i. safety_prop (X i)) \<Longrightarrow> safety_prop (\<Inter>i. X i)"
  by (rule safety_prop_INTER) simp

lemma def_prg_Allowed:
     "[| F == mk_program (init, acts, UNION X Acts) ; safety_prop X |]
      ==> Allowed F = X"
by (simp add: Allowed_eq)

lemma Allowed_totalize [simp]: "Allowed (totalize F) = Allowed F"
by (simp add: Allowed_def)

lemma def_total_prg_Allowed:
     "[| F = mk_total_program (init, acts, UNION X Acts) ; safety_prop X |]
      ==> Allowed F = X"
by (simp add: mk_total_program_def def_prg_Allowed)

lemma def_UNION_ok_iff:
     "[| F = mk_program(init,acts,UNION X Acts); safety_prop X |]
      ==> F ok G = (G \<in> X & acts \<subseteq> AllowedActs G)"
by (auto simp add: ok_def safety_prop_Acts_iff)

text{*The union of two total programs is total.*}
lemma totalize_Join: "totalize F\<squnion>totalize G = totalize (F\<squnion>G)"
by (simp add: program_equalityI totalize_def Join_def image_Un)

lemma all_total_Join: "[|all_total F; all_total G|] ==> all_total (F\<squnion>G)"
by (simp add: all_total_def, blast)

lemma totalize_JN: "(\<Squnion>i \<in> I. totalize (F i)) = totalize(\<Squnion>i \<in> I. F i)"
by (simp add: program_equalityI totalize_def JOIN_def image_UN)

lemma all_total_JN: "(!!i. i\<in>I ==> all_total (F i)) ==> all_total(\<Squnion>i\<in>I. F i)"
by (simp add: all_total_iff_totalize totalize_JN [symmetric])

end


(*
    Author: Asta Halkjær From, DTU Compute, 2019
    Contributors: Alexander Birch Jensen, Anders Schlichtkrull & Jørgen Villadsen
    See also the Natural Deduction Assistant: https://nadea.compute.dtu.dk/
*)

section \<open>Tableau Calculus\<close>

theory Tableau imports Common begin

inductive TC :: \<open>('a, 'b) form list \<Rightarrow> bool\<close> (\<open>\<stileturn> _\<close> 0) where
  Basic: \<open>\<stileturn> Pred i l # Neg (Pred i l) # G\<close>
| BasicFF: \<open>\<stileturn> \<bottom> # G\<close>
| BasicNegTT: \<open>\<stileturn> Neg \<top> # G\<close>
| AlphaNegNeg: \<open>\<stileturn> A # G \<Longrightarrow> \<stileturn> Neg (Neg A) # G\<close>
| AlphaAnd: \<open>\<stileturn> A # B # G \<Longrightarrow> \<stileturn> And A B # G\<close>
| AlphaNegOr: \<open>\<stileturn> Neg A # Neg B # G \<Longrightarrow> \<stileturn> Neg (Or A B) # G\<close>
| AlphaNegImpl: \<open>\<stileturn> A # Neg B # G \<Longrightarrow> \<stileturn> Neg (Impl A B) # G\<close>
| BetaNegAnd: \<open>\<stileturn> Neg A # G \<Longrightarrow> \<stileturn> Neg B # G \<Longrightarrow> \<stileturn> Neg (And A B) # G\<close>
| BetaOr: \<open>\<stileturn> A # G \<Longrightarrow> \<stileturn> B # G \<Longrightarrow> \<stileturn> Or A B # G\<close>
| BetaImpl: \<open>\<stileturn> Neg A # G \<Longrightarrow> \<stileturn> B # G \<Longrightarrow> \<stileturn> Impl A B # G\<close>
| GammaForall: \<open>\<stileturn> subst A t 0 # G \<Longrightarrow> \<stileturn> Forall A # G\<close>
| GammaNegExists: \<open>\<stileturn> Neg (subst A t 0) # G \<Longrightarrow> \<stileturn> Neg (Exists A) # G\<close>
| DeltaExists: \<open>\<stileturn> subst A (App n []) 0 # G \<Longrightarrow> news n (A # G) \<Longrightarrow> \<stileturn> Exists A # G\<close>
| DeltaNegForall: \<open>\<stileturn> Neg (subst A (App n []) 0) # G \<Longrightarrow> news n (A # G) \<Longrightarrow> \<stileturn> Neg (Forall A) # G\<close>
| Order: \<open>\<stileturn> G \<Longrightarrow> set G = set G' \<Longrightarrow> \<stileturn> G'\<close>

lemma Shift: \<open>\<stileturn> rotate1 G \<Longrightarrow> \<stileturn> G\<close>
  by (simp add: Order)

lemma Swap: \<open>\<stileturn> B # A # G \<Longrightarrow> \<stileturn> A # B # G\<close>
  by (simp add: Order insert_commute)

definition tableauproof :: \<open>('a, 'b) form list \<Rightarrow> ('a, 'b) form \<Rightarrow> bool\<close> where
  \<open>tableauproof ps p \<equiv> (\<stileturn> Neg p # ps)\<close>

theorem tableauNotAA: \<open>\<stileturn> [Neg (Pred ''A'' []), Pred ''A'' []]\<close>
  by (rule Shift, simp) (rule Basic)

theorem AndAnd:
  \<open>\<stileturn> [And (Pred ''A'' []) (Pred ''B'' []), Neg (And (Pred ''B'' []) (Pred ''A'' []))]\<close>
  apply (rule AlphaAnd)
  apply (rule Shift, rule Shift, simp)
  apply (rule BetaNegAnd)
   apply (rule Shift, rule Shift, simp)
   apply (rule Basic)
  apply (rule Swap)
  apply (rule Basic)
  done

subsection \<open>Soundness\<close>

lemma TC_soundness:
  \<open>\<stileturn> G \<Longrightarrow> \<exists>p \<in> set G. \<not> eval e f g p\<close>
proof (induct G arbitrary: f rule: TC.induct)
  case (DeltaExists A n G)
  show ?case
  proof (rule ccontr)
    assume \<open>\<not> (\<exists>p \<in> set (Exists A # G). \<not> eval e f g p)\<close>
    then have *: \<open>\<forall>p \<in> set (Exists A # G). eval e f g p\<close>
      by simp

    then obtain x where \<open>eval (shift e 0 x) (f(n := \<lambda>w. x)) g A\<close>
      using \<open>news n (A # G)\<close> by auto
    then have **: \<open>eval e (f(n := \<lambda>w. x)) g (subst A (App n []) 0)\<close>
      by simp

    have \<open>\<exists>p \<in> set (subst A (App n []) 0 # G). \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      using DeltaExists by fast
    then consider
      \<open>\<not> eval e (f(n := \<lambda>w. x)) g (subst A (App n []) 0)\<close> |
      \<open>\<exists>p \<in> set G. \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      by auto
    then show False
    proof cases
      case 1
      then show ?thesis
        using ** ..
    next
      case 2
      then obtain p where \<open>\<not> eval e (f(n := \<lambda>w. x)) g p\<close> \<open>p \<in> set G\<close>
        by blast
      then have \<open>\<not> eval e f g p\<close>
        using \<open>news n (A # G)\<close> by (metis Ball_set set_subset_Cons subsetCE upd_lemma)
      then show ?thesis
        using * \<open>p \<in> set G\<close> by simp
    qed
  qed
next
  case (DeltaNegForall A n G)
  show ?case
  proof (rule ccontr)
    assume \<open>\<not> (\<exists>p \<in> set (Neg (Forall A) # G). \<not> eval e f g p)\<close>
    then have *: \<open>\<forall>p \<in> set (Neg (Forall A) # G). eval e f g p\<close>
      by simp

    then obtain x where \<open>eval (shift e 0 x) (f(n := \<lambda>w. x)) g (Neg A)\<close>
      using \<open>news n (A # G)\<close> by auto
    then have **: \<open>eval e (f(n := \<lambda>w. x)) g (Neg (subst A (App n []) 0))\<close>
      by simp

    have \<open>\<exists>p \<in> set (Neg (subst A (App n []) 0) # G). \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      using DeltaNegForall by fast
    then consider
      \<open>\<not> eval e (f(n := \<lambda>w. x)) g (Neg (subst A (App n []) 0))\<close> |
      \<open>\<exists>p \<in> set G. \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      by auto
    then show False
    proof cases
      case 1
      then show ?thesis
        using ** ..
    next
      case 2
      then obtain p where \<open>\<not> eval e (f(n := \<lambda>w. x)) g p\<close> \<open>p \<in> set G\<close>
        by blast
      then have \<open>\<not> eval e f g p\<close>
        using \<open>news n (A # G)\<close> by (metis Ball_set set_subset_Cons subsetCE upd_lemma)
      then show ?thesis
        using * \<open>p \<in> set G\<close> by simp
    qed
  qed
qed auto

theorem tableau_soundness:
  \<open>tableauproof ps p \<Longrightarrow> list_all (eval e f g) ps \<Longrightarrow> eval e f g p\<close>
  using TC_soundness unfolding tableauproof_def list_all_def by fastforce

subsection \<open>Completeness for Closed Formulas\<close>

theorem infinite_nonempty: \<open>infinite A \<Longrightarrow> \<exists>x. x \<in> A\<close>
  by (simp add: ex_in_conv infinite_imp_nonempty)

theorem TCd_consistency:
  assumes inf_param: \<open>infinite (UNIV::'a set)\<close>
  shows \<open>consistency {S::('a, 'b) form set. \<exists>G. S = set G \<and> \<not> (\<stileturn> G)}\<close>
  unfolding consistency_def
proof (intro conjI allI impI notI)
  fix S :: \<open>('a, 'b) form set\<close>
  assume \<open>S \<in> {set G | G. \<not> (\<stileturn> G)}\<close> (is \<open>S \<in> ?C\<close>)
  then obtain G :: \<open>('a, 'b) form list\<close>
    where *: \<open>S = set G\<close> and \<open>\<not> (\<stileturn> G)\<close>
    by blast

  { fix p ts
    assume \<open>Pred p ts \<in> S \<and> Neg (Pred p ts) \<in> S\<close>
    then show False
      using * Basic Order \<open>\<not> (\<stileturn> G)\<close> by fastforce }

  { assume \<open>\<bottom> \<in> S\<close>
    then show False
      using * BasicFF Order \<open>\<not> (\<stileturn> G)\<close> by fastforce }

  { assume \<open>Neg \<top> \<in> S\<close>
    then show False
      using * BasicNegTT Order \<open>\<not> (\<stileturn> G)\<close> by fastforce }

  { fix Z
    assume \<open>Neg (Neg Z) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Z # G)\<close>
      using * AlphaNegNeg Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Z} = set (Z # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {Z} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>And A B \<in> S\<close>
    then have \<open>\<not> (\<stileturn> A # B # G)\<close>
      using * AlphaAnd Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {A, B} = set (A # B # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {A, B} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>Neg (Or A B) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg A # Neg B # G)\<close>
      using * AlphaNegOr Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Neg A, Neg B} = set (Neg A # Neg B # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {Neg A, Neg B} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>Neg (Impl A B) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> A # Neg B # G)\<close>
      using * AlphaNegImpl Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>{A, Neg B} \<union> S = set (A # Neg B # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {A, Neg B} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>Or A B \<in> S\<close>
    then have \<open>\<not> (\<stileturn> A # G) \<or> \<not> (\<stileturn> B # G)\<close>
      using * BetaOr Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    then show \<open>S \<union> {A} \<in> ?C \<or> S \<union> {B} \<in> ?C\<close>
      using * by auto }

  { fix A B
    assume \<open>Neg (And A B) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg A # G) \<or> \<not> (\<stileturn> Neg B # G)\<close>
      using * BetaNegAnd Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    then show \<open>S \<union> {Neg A} \<in> ?C \<or> S \<union> {Neg B} \<in> ?C\<close>
      using * by auto }

  { fix A B
    assume \<open>Impl A B \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg A # G) \<or> \<not> (\<stileturn> B # G)\<close>
      using * BetaImpl Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    then show \<open>S \<union> {Neg A} \<in> ?C \<or> S \<union> {B} \<in> ?C\<close>
      using * by auto }

  { fix P and t :: \<open>'a term\<close>
    assume \<open>Forall P \<in> S\<close>
    then have \<open>\<not> (\<stileturn> subst P t 0 # G)\<close>
      using * GammaForall Order\<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {subst P t 0} = set (subst P t 0 # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {subst P t 0} \<in> ?C\<close>
      by blast }

  { fix P and t :: \<open>'a term\<close>
    assume \<open>Neg (Exists P) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg (subst P t 0) # G)\<close>
      using * GammaNegExists Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Neg (subst P t 0)} = set (Neg (subst P t 0) # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {Neg (subst P t 0)} \<in> ?C\<close>
      by blast }

  { fix P
    assume \<open>Exists P \<in> S\<close>
    have \<open>finite ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      by simp
    then have \<open>infinite (- ((\<Union>p \<in> set G. params p) \<union> params P))\<close>
      using inf_param Diff_infinite_finite finite_compl infinite_UNIV_listI by blast
    then obtain x where **: \<open>x \<in> - ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      using infinite_imp_nonempty by blast
    then have \<open>news x (P # G)\<close>
      using Ball_set_list_all by auto
    then have \<open>\<not> (\<stileturn> subst P (App x []) 0 # G)\<close>
      using * \<open>Exists P \<in> S\<close> Order DeltaExists \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {subst P (App x []) 0} = set (subst P (App x []) 0 # G)\<close>
      using * by simp
    ultimately show \<open>\<exists>x. S \<union> {subst P (App x []) 0} \<in> ?C\<close>
      by blast }

  { fix P
    assume \<open>Neg (Forall P) \<in> S\<close>
    have \<open>finite ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      by simp
    then have \<open>infinite (- ((\<Union>p \<in> set G. params p) \<union> params P))\<close>
      using inf_param Diff_infinite_finite finite_compl infinite_UNIV_listI by blast
    then obtain x where **: \<open>x \<in> - ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      using infinite_imp_nonempty by blast
    then have \<open>news x (P # G)\<close>
      using Ball_set_list_all by auto
    then have \<open>\<not> (\<stileturn> Neg (subst P (App x []) 0) # G)\<close>
      using * \<open>Neg (Forall P) \<in> S\<close> Order DeltaNegForall \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Neg (subst P (App x []) 0)} = set (Neg (subst P (App x []) 0) # G)\<close>
      using * by simp
    ultimately show \<open>\<exists>x. S \<union> {Neg (subst P (App x []) 0)} \<in> ?C\<close>
      by blast }
qed

theorem tableau_completeness':
  fixes p :: \<open>(nat, nat) form\<close>
  assumes \<open>closed 0 p\<close>
    and \<open>list_all (closed 0) ps\<close>
    and mod: \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_all (eval e f g) ps \<longrightarrow> eval e f g p\<close>
  shows \<open>tableauproof ps p\<close>
proof (rule ccontr)
  fix e
  assume \<open>\<not> tableauproof ps p\<close>

  let ?S = \<open>set (Neg p # ps)\<close>
  let ?C = \<open>{set (G :: (nat, nat) form list) | G. \<not> (\<stileturn> G)}\<close>
  let ?f = HApp
  let ?g = \<open>(\<lambda>a ts. Pred a (terms_of_hterms ts) \<in> Extend ?S
              (mk_finite_char (mk_alt_consistency (close ?C))) from_nat)\<close>

  from \<open>list_all (closed 0) ps\<close>
  have \<open>\<forall>p \<in> set ps. closed 0 p\<close>
    by (simp add: list_all_iff)

  { fix x
    assume \<open>x \<in> ?S\<close>
    moreover have \<open>consistency ?C\<close>
      using TCd_consistency by blast
    moreover have \<open>?S \<in> ?C\<close>
      using \<open>\<not> tableauproof ps p\<close> unfolding tableauproof_def by blast
    moreover have \<open>infinite (- (\<Union>p \<in> ?S. params p))\<close>
      by (simp add: Compl_eq_Diff_UNIV infinite_UNIV_listI)
    moreover note \<open>closed 0 p\<close> \<open>\<forall>p \<in> set ps. closed 0 p\<close> \<open>x \<in> ?S\<close>
    then have \<open>closed 0 x\<close> by auto
    ultimately have \<open>eval e ?f ?g x\<close>
      using model_existence by blast }
  then have \<open>list_all (eval e ?f ?g) (Neg p # ps)\<close>
    by (simp add: list_all_iff)
  moreover have \<open>eval e ?f ?g (Neg p)\<close>
    using calculation by simp
  moreover have \<open>list_all (eval e ?f ?g) ps\<close>
    using calculation by simp
  then have \<open>eval e ?f ?g p\<close>
    using mod by blast
  ultimately show False by simp
qed

subsection \<open>Open Formulas\<close>

lemma TC_psubst:
  fixes f :: \<open>'a \<Rightarrow> 'a\<close>
  assumes inf_params: \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> map (psubst f) G\<close>
proof (induct G arbitrary: f rule: TC.induct)
  case (DeltaExists A n G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p)\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where *: \<open>fresh \<notin> ?params \<union> {n} \<union> image f ?params\<close>
    using ex_new_if_finite inf_params
    by (metis finite.emptyI finite.insertI finite_UnI finite_imageI)

  let ?f = \<open>f(n := fresh)\<close>

  have \<open>news n (A # G)\<close>
    using DeltaExists by blast
  then have \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close>
    using * new_psubst_image news_psubst by (fastforce simp add: image_Un)+
  then have G: \<open>map (psubst ?f) G = map (psubst f) G\<close>
    using DeltaExists
    by (metis (mono_tags, lifting) Ball_set insertCI list.set(2) map_eq_conv psubst_upd)

  have \<open>\<stileturn> psubst ?f (subst A (App n []) 0) # map (psubst ?f) G\<close>
    using DeltaExists by (metis list.simps(9))
  then have \<open>\<stileturn> subst (psubst ?f A) (App fresh []) 0 # map (psubst ?f) G\<close>
    by simp
  moreover have \<open>news fresh (map (psubst ?f) (A # G))\<close>
    using \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close> by simp
  then have \<open>news fresh (psubst ?f A # map (psubst ?f) G)\<close>
    by simp
  ultimately have \<open>\<stileturn> map (psubst ?f) (Exists A # G)\<close>
    using TC.DeltaExists by fastforce
  then show ?case
    using DeltaExists G by simp
next
  case (DeltaNegForall A n G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p)\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where *: \<open>fresh \<notin> ?params \<union> {n} \<union> image f ?params\<close>
    using ex_new_if_finite inf_params
    by (metis finite.emptyI finite.insertI finite_UnI finite_imageI)

  let ?f = \<open>f(n := fresh)\<close>

  have \<open>news n (A # G)\<close>
    using DeltaNegForall by blast
  then have \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close>
    using * new_psubst_image news_psubst by (fastforce simp add: image_Un)+
  then have G: \<open>map (psubst ?f) G = map (psubst f) G\<close>
    using DeltaNegForall
    by (metis (mono_tags, lifting) Ball_set insertCI list.set(2) map_eq_conv psubst_upd)

  have \<open>\<stileturn> psubst ?f (Neg (subst A (App n []) 0)) # map (psubst ?f) G\<close>
    using DeltaNegForall by (metis list.simps(9))
  then have \<open>\<stileturn> Neg (subst (psubst ?f A) (App fresh []) 0) # map (psubst ?f) G\<close>
    by simp
  moreover have \<open>news fresh (map (psubst ?f) (A # G))\<close>
    using \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close> by simp
  then have \<open>news fresh (psubst ?f A # map (psubst ?f) G)\<close>
    by simp
  ultimately have \<open>\<stileturn> map (psubst ?f) (Neg (Forall A) # G)\<close>
    using TC.DeltaNegForall by fastforce
  then show ?case
    using DeltaNegForall G by simp
next
  case (Order G G')
  then show ?case
    using Order TC.Order set_map by metis
qed (auto intro: TC.intros)

lemma subcs_map: \<open>subcs c s G = map (subc c s) G\<close>
  by (induct G) simp_all

lemma TC_subcs:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes inf_params: \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> subcs c s G\<close>
proof (induct G arbitrary: c s rule: TC.induct)
  case (GammaForall A t G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> paramst t \<union> {c}\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
    using ex_new_if_finite inf_params by metis

  let ?f = \<open>id(c := fresh)\<close>
  let ?g = \<open>id(fresh := c)\<close>
  let ?s = \<open>psubstt ?f s\<close>

  have s: \<open>psubstt ?g ?s = s\<close>
    using fresh psubst_new_away' by simp
  have \<open>subc (?g c) (psubstt ?g ?s) (psubst ?g (Forall A)) = subc c s (Forall A)\<close>
    using fresh by simp
  then have A: \<open>psubst ?g (subc c ?s (Forall A)) = subc c s (Forall A)\<close>
    using fun_upd_apply id_def subc_psubst UnCI fresh params.simps(8) by metis
  have \<open>\<forall>x \<in> (\<Union>p \<in> set (Forall A # G). params p). x \<noteq> c \<longrightarrow> ?g x \<noteq> ?g c\<close>
    using fresh by auto
  moreover have \<open>map (psubst ?g) (Forall A # G) = Forall A # G\<close>
    using fresh by (induct G) simp_all
  ultimately have G: \<open>map (psubst ?g) (subcs c ?s (Forall A # G)) = subcs c s (Forall A # G)\<close>
    using s A by (simp add: subcs_psubst)

  have \<open>new_term c ?s\<close>
    using fresh psubst_new_free' by fast
  then have \<open>\<stileturn> subc c ?s (subst A (subc_term c ?s t) 0) # subcs c ?s G\<close>
    using GammaForall by (metis new_subc_put subcs.simps(2))
  moreover have \<open>new_term c (subc_term c ?s t)\<close>
    using \<open>new_term c ?s\<close> new_subc_same' by simp
  ultimately have \<open>\<stileturn> subst (subc c (liftt ?s) A) (subc_term c ?s t) 0 # subcs c ?s G\<close>
    by simp
  moreover have \<open>Forall (subc c (liftt ?s) A) \<in> set (subcs c ?s (Forall A # G))\<close>
    by simp
  ultimately have \<open>\<stileturn> subcs c ?s (Forall A # G)\<close>
    using TC.GammaForall by simp
  then have \<open>\<stileturn> map (psubst ?g) (subcs c ?s (Forall A # G))\<close>
    using TC_psubst inf_params by blast
  then show \<open>\<stileturn> subcs c s (Forall A # G)\<close>
    using G by simp
next
  case (GammaNegExists A t G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> paramst t \<union> {c}\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
    using ex_new_if_finite inf_params by metis

  let ?f = \<open>id(c := fresh)\<close>
  let ?g = \<open>id(fresh := c)\<close>
  let ?s = \<open>psubstt ?f s\<close>

  have s: \<open>psubstt ?g ?s = s\<close>
    using fresh psubst_new_away' by simp
  have \<open>subc (?g c) (psubstt ?g ?s) (psubst ?g (Neg (Exists A))) = subc c s (Neg (Exists A))\<close>
    using fresh by simp
  then have A: \<open>psubst ?g (subc c ?s (Neg (Exists A))) = subc c s (Neg (Exists A))\<close>
    using fun_upd_apply id_def subc_psubst UnCI fresh params.simps(7,9) by metis

  have \<open>\<forall>x \<in> (\<Union>p \<in> set (Neg (Exists A) # G). params p). x \<noteq> c \<longrightarrow> ?g x \<noteq> ?g c\<close>
    using fresh by auto
  moreover have \<open>map (psubst ?g) (Neg (Exists A) # G) = Neg (Exists A) # G\<close>
    using fresh by (induct G) simp_all
  ultimately have G: \<open>map (psubst ?g) (subcs c ?s (Neg (Exists A) # G)) =
      subcs c s (Neg (Exists A) # G)\<close>
    using s A by (simp add: subcs_psubst)

  have \<open>new_term c ?s\<close>
    using fresh psubst_new_free' by fast
  then have \<open>\<stileturn> Neg (subc c ?s (subst A (subc_term c ?s t) 0)) # subcs c ?s G\<close>
    using GammaNegExists by (metis new_subc_put subc.simps(4) subcs.simps(2))
  moreover have \<open>new_term c (subc_term c ?s t)\<close>
    using \<open>new_term c ?s\<close> new_subc_same' by simp
  ultimately have \<open>\<stileturn> Neg (subst (subc c (liftt ?s) A) (subc_term c ?s t) 0) # subcs c ?s G\<close>
    by simp
  moreover have \<open>Neg (Exists (subc c (liftt ?s) A)) \<in> set (subcs c ?s (Neg (Exists A) # G))\<close>
    by simp
  ultimately have \<open>\<stileturn> subcs c ?s (Neg (Exists A) # G)\<close>
    using TC.GammaNegExists by simp
  then have \<open>\<stileturn> map (psubst ?g) (subcs c ?s (Neg (Exists A) # G))\<close>
    using TC_psubst inf_params by blast
  then show \<open>\<stileturn> subcs c s (Neg (Exists A) # G)\<close>
    using G by simp
next
  case (DeltaExists A n G)
  then show ?case
  proof (cases \<open>c = n\<close>)
    case True
    then have \<open>\<stileturn> Exists A # G\<close>
      using DeltaExists TC.DeltaExists by metis
    moreover have \<open>new c A\<close> and \<open>news c G\<close>
      using DeltaExists True by simp_all
    ultimately show ?thesis
      by (simp add: subcs_news)
  next
    case False
    let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> {c} \<union> {n}\<close>

    have \<open>finite ?params\<close>
      by simp
    then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
      using ex_new_if_finite inf_params by metis

    let ?s = \<open>psubstt (id(n := fresh)) s\<close>
    let ?f = \<open>id(n := fresh, fresh := n)\<close>

    have f: \<open>\<forall>x \<in> ?params. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      using fresh by simp

    have \<open>new_term n ?s\<close>
      using fresh psubst_new_free' by fast
    then have \<open>psubstt ?f ?s = psubstt (id(fresh := n)) ?s\<close>
      by (metis fun_upd_twist psubstt_upd(1))
    then have psubst_s: \<open>psubstt ?f ?s = s\<close>
      using fresh psubst_new_away' by simp

    have \<open>?f c = c\<close> and \<open>new_term c (App fresh [])\<close>
      using False fresh by auto

    have \<open>psubst ?f (subc c ?s (subst A (App n []) 0)) =
      subc (?f c) (psubstt ?f ?s) (psubst ?f (subst A (App n []) 0))\<close>
      by (simp add: subc_psubst)
    also have \<open>\<dots> = subc c s (subst (psubst ?f A) (App fresh []) 0)\<close>
      using \<open>?f c = c\<close> psubst_subst psubst_s by simp
    also have \<open>\<dots> = subc c s (subst A (App fresh []) 0)\<close>
      using DeltaExists fresh by simp
    finally have psubst_A: \<open>psubst ?f (subc c ?s (subst A (App n []) 0)) =
        subst (subc c (liftt s) A) (App fresh []) 0\<close>
      using \<open>new_term c (App fresh [])\<close> by simp

    have \<open>news n G\<close>
      using DeltaExists by simp
    moreover have \<open>news fresh G\<close>
      using fresh by (induct G) simp_all
    ultimately have \<open>map (psubst ?f) G = G\<close>
      by (induct G) simp_all
    moreover have \<open>\<forall>x \<in> \<Union>p \<in> set G. params p. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      by auto
    ultimately have psubst_G: \<open>map (psubst ?f) (subcs c ?s G) = subcs c s G\<close>
      using \<open>?f c = c\<close> psubst_s by (simp add: subcs_psubst)

    have \<open>\<stileturn> subc c ?s (subst A (App n []) 0) # subcs c ?s G\<close>
      using DeltaExists by simp
    then have \<open>\<stileturn> psubst ?f (subc c ?s (subst A (App n []) 0)) # map (psubst ?f) (subcs c ?s G)\<close>
      using TC_psubst inf_params DeltaExists.hyps(3) by fastforce
    then have \<open>\<stileturn> psubst ?f (subc c ?s (subst A (App n []) 0)) # subcs c s G\<close>
      using psubst_G by simp
    then have sub_A: \<open>\<stileturn> subst (subc c (liftt s) A) (App fresh []) 0 # subcs c s G\<close>
      using psubst_A by simp

    have \<open>new_term fresh s\<close>
      using fresh by simp
    then have \<open>new_term fresh (liftt s)\<close>
      by simp
    then have \<open>new fresh (subc c (liftt s) A)\<close>
      using fresh new_subc by simp
    moreover have \<open>news fresh (subcs c s G)\<close>
      using \<open>news fresh G\<close> \<open>new_term fresh s\<close> news_subcs by fast
    ultimately show \<open>\<stileturn> subcs c s (Exists A # G)\<close>
      using TC.DeltaExists sub_A by fastforce
  qed
next
  case (DeltaNegForall A n G)
  then show ?case
  proof (cases \<open>c = n\<close>)
    case True
    then have \<open>\<stileturn> Neg (Forall A) # G\<close>
      using DeltaNegForall TC.DeltaNegForall by metis
    moreover have \<open>new c A\<close> and \<open>news c G\<close>
      using DeltaNegForall True by simp_all
    ultimately show ?thesis
      by (simp add: subcs_news)
  next
    case False
    let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> {c} \<union> {n}\<close>

    have \<open>finite ?params\<close>
      by simp
    then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
      using ex_new_if_finite inf_params by metis

    let ?s = \<open>psubstt (id(n := fresh)) s\<close>
    let ?f = \<open>id(n := fresh, fresh := n)\<close>

    have f: \<open>\<forall>x \<in> ?params. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      using fresh by simp

    have \<open>new_term n ?s\<close>
      using fresh psubst_new_free' by fast
    then have \<open>psubstt ?f ?s = psubstt (id(fresh := n)) ?s\<close>
      using fun_upd_twist psubstt_upd(1) by metis
    then have psubst_s: \<open>psubstt ?f ?s = s\<close>
      using fresh psubst_new_away' by simp

    have \<open>?f c = c\<close> and \<open>new_term c (App fresh [])\<close>
      using False fresh by auto

    have \<open>psubst ?f (subc c ?s (Neg (subst A (App n []) 0))) =
      subc (?f c) (psubstt ?f ?s) (psubst ?f (Neg (subst A (App n []) 0)))\<close>
      by (simp add: subc_psubst)
    also have \<open>\<dots> = subc c s (Neg (subst (psubst ?f A)(App fresh []) 0))\<close>
      using \<open>?f c = c\<close> psubst_subst psubst_s by simp
    also have \<open>\<dots> = subc c s (Neg (subst A (App fresh []) 0))\<close>
      using DeltaNegForall fresh by simp
    finally have psubst_A: \<open>psubst ?f (subc c ?s (Neg (subst A (App n []) 0))) =
        Neg (subst (subc c (liftt s) A) (App fresh []) 0)\<close>
      using \<open>new_term c (App fresh [])\<close> by simp

    have \<open>news n G\<close>
      using DeltaNegForall by simp
    moreover have \<open>news fresh G\<close>
      using fresh by (induct G) simp_all
    ultimately have \<open>map (psubst ?f) G = G\<close>
      by (induct G) simp_all
    moreover have \<open>\<forall>x \<in> \<Union>p \<in> set G. params p. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      by auto
    ultimately have psubst_G: \<open>map (psubst ?f) (subcs c ?s G) = subcs c s G\<close>
      using \<open>?f c = c\<close> psubst_s by (simp add: subcs_psubst)

    have \<open>\<stileturn> subc c ?s (Neg (subst A (App n []) 0)) # subcs c ?s G\<close>
      using DeltaNegForall by simp
    then have \<open>\<stileturn> psubst ?f (subc c ?s (Neg (subst A (App n []) 0)))
                # map (psubst ?f) (subcs c ?s G)\<close>
      using TC_psubst inf_params DeltaNegForall.hyps(3) by fastforce
    then have \<open>\<stileturn> psubst ?f (subc c ?s (Neg (subst A (App n []) 0))) # subcs c s G\<close>
      using psubst_G by simp
    then have sub_A: \<open>\<stileturn> Neg (subst (subc c (liftt s) A) (App fresh []) 0) # subcs c s G\<close>
      using psubst_A by simp

    have \<open>new_term fresh s\<close>
      using fresh by simp
    then have \<open>new_term fresh (liftt s)\<close>
      by simp
    then have \<open>new fresh (subc c (liftt s) A)\<close>
      using fresh new_subc by simp
    moreover have \<open>news fresh (subcs c s G)\<close>
      using \<open>news fresh G\<close> \<open>new_term fresh s\<close> news_subcs by fast
    ultimately show \<open>\<stileturn> subcs c s (Neg (Forall A) # G)\<close>
      using TC.DeltaNegForall sub_A by fastforce
  qed
next
  case (Order G G')
  then show ?case
    using TC.Order set_map subcs_map by metis
qed (auto intro: TC.intros)

lemma TC_map_subc:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes inf_params: \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> map (subc c s) G\<close>
  using assms TC_subcs subcs_map by metis

lemma ex_all_closed: \<open>\<exists>m. list_all (closed m) G\<close>
proof (induct G)
  case Nil
  then show ?case
    by simp
next
  case (Cons a G)
  then show ?case
    unfolding list_all_def
    using ex_closed closed_mono
    by (metis Ball_set list_all_simps(1) nat_le_linear)
qed

primrec sub_consts :: \<open>'a list \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form\<close> where
  \<open>sub_consts [] p = p\<close>
| \<open>sub_consts (c # cs) p = sub_consts cs (subst p (App c []) (length cs))\<close>

lemma valid_sub_consts:
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. eval e f g p\<close>
  shows \<open>eval (e :: nat => 'a) f g (sub_consts cs p)\<close>
  using assms by (induct cs arbitrary: p) simp_all

lemma closed_sub' [simp]:
  assumes \<open>k \<le> m\<close> shows
    \<open>closedt (Suc m) t = closedt m (substt t (App c []) k)\<close>
    \<open>closedts (Suc m) l = closedts m (substts l (App c []) k)\<close>
  using assms by (induct t and l rule: closedt.induct closedts.induct) auto

lemma closed_sub: \<open>k \<le> m \<Longrightarrow> closed (Suc m) p = closed m (subst p (App c []) k)\<close>
  by (induct p arbitrary: m k) simp_all

lemma closed_sub_consts: \<open>length cs = k \<Longrightarrow> closed m (sub_consts cs p) = closed (m + k) p\<close>
proof (induct cs arbitrary: k p)
  case Nil
  then show ?case
    by simp
next
  case (Cons c cs)
  then show ?case
    using closed_sub by fastforce
qed

lemma map_sub_consts_Nil: \<open>map (sub_consts []) G = G\<close>
  by (induct G) simp_all

primrec conjoin :: \<open>('a, 'b) form list \<Rightarrow> ('a, 'b) form\<close> where
  \<open>conjoin [] = Neg \<bottom>\<close>
| \<open>conjoin (p # ps) = And p (conjoin ps)\<close>

lemma eval_conjoin: \<open>list_all (eval e f g) G = eval e f g (conjoin G)\<close>
  by (induct G) simp_all

lemma valid_sub:
  fixes e :: \<open>nat \<Rightarrow> 'a\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. eval e f g p \<longrightarrow> eval e f g q\<close>
  shows \<open>eval e f g (subst p t m) \<longrightarrow> eval e f g (subst q t m)\<close>
  using assms by simp

lemma eval_sub_consts:
  fixes e :: \<open>nat \<Rightarrow> 'a\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. eval e f g p \<longrightarrow> eval e f g q\<close>
    and \<open>eval e f g (sub_consts cs p)\<close>
  shows \<open>eval e f g (sub_consts cs q)\<close>
  using assms
proof (induct cs arbitrary: p q)
  case Nil
  then show ?case
    by simp
next
  case (Cons c cs)
  then show ?case
    by (metis sub_consts.simps(2) subst_lemma)
qed

lemma sub_consts_And [simp]: \<open>sub_consts cs (And p q) = And (sub_consts cs p) (sub_consts cs q)\<close>
  by (induct cs arbitrary: p q) simp_all

lemma sub_consts_conjoin:
  \<open>eval e f g (sub_consts cs (conjoin G)) = eval e f g (conjoin (map (sub_consts cs) G))\<close>
proof (induct G)
  case Nil
  then show ?case
    by (induct cs) simp_all
next
  case (Cons p G)
  then show ?case
    using sub_consts_And by simp
qed

lemma all_sub_consts_conjoin:
  \<open>list_all (eval e f g) (map (sub_consts cs) G) = eval e f g (sub_consts cs (conjoin G))\<close>
  by (induct G) (simp_all add: valid_sub_consts)

lemma valid_all_sub_consts:
  fixes e :: \<open>nat \<Rightarrow> 'a\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. list_all (eval e f g) G \<longrightarrow> eval e f g p\<close>
  shows \<open>list_all (eval e f g) (map (sub_consts cs) G) \<longrightarrow> eval e f g (sub_consts cs p)\<close>
  using assms eval_conjoin eval_sub_consts all_sub_consts_conjoin by metis

lemma TC_vars_for_consts:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> map (\<lambda>p. vars_for_consts p cs) G\<close>
proof (induct cs)
  case Nil
  then show ?case
    by simp
next
  case (Cons c cs)
  have \<open>(\<stileturn> map (\<lambda>p. vars_for_consts p (c # cs)) G) =
      (\<stileturn> map (\<lambda>p. subc c (Var (length cs)) (vars_for_consts p cs)) G)\<close>
    by simp
  also have \<open>\<dots> = (\<stileturn> map (subc c (Var (length cs)) o (\<lambda>p. vars_for_consts p cs)) G)\<close>
    unfolding comp_def by simp
  also have \<open>\<dots> = (\<stileturn> map (subc c (Var (length cs))) (map (\<lambda>p. vars_for_consts p cs) G))\<close>
    by simp
  finally show ?case
    using Cons TC_map_subc assms by metis
qed

lemma vars_for_consts_sub_consts:
  \<open>closed (length cs) p \<Longrightarrow> list_all (\<lambda>c. new c p) cs \<Longrightarrow> distinct cs \<Longrightarrow>
   vars_for_consts (sub_consts cs p) cs = p\<close>
proof (induct cs arbitrary: p)
  case (Cons c cs)
  then show ?case
    using subst_new_all closed_sub by force
qed simp

lemma all_vars_for_consts_sub_consts:
  \<open>list_all (closed (length cs)) G \<Longrightarrow> list_all (\<lambda>c. list_all (new c) G) cs \<Longrightarrow> distinct cs \<Longrightarrow>
   map (\<lambda>p. vars_for_consts p cs) (map (sub_consts cs) G) = G\<close>
  using vars_for_consts_sub_consts unfolding list_all_def
  by (induct G) fastforce+

lemma new_conjoin: \<open>new c (conjoin G) \<Longrightarrow> list_all (new c) G\<close>
  by (induct G) simp_all

lemma all_fresh_constants:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<exists>cs. length cs = m \<and> list_all (\<lambda>c. list_all (new c) G) cs \<and> distinct cs\<close>
proof -
  obtain cs where \<open>length cs = m\<close> \<open>list_all (\<lambda>c. new c (conjoin G)) cs\<close> \<open>distinct cs\<close>
    using assms fresh_constants by blast
  then show ?thesis
    using new_conjoin unfolding list_all_def by metis
qed

lemma sub_consts_Neg: \<open>sub_consts cs (Neg p) = Neg (sub_consts cs p)\<close>
  by (induct cs arbitrary: p) simp_all

subsection \<open>Completeness\<close>

  moreover have \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_all (eval e f g) (map (sub_consts cs) G) \<longrightarrow>
    eval e f g (sub_consts cs p)\<close>
    using assms valid_all_sub_consts by blast
  ultimately have \<open>\<stileturn> Neg (sub_consts cs p) # map (sub_consts cs) G\<close>
    using tableau_completeness' unfolding tableauproof_def by simp
  then have \<open>\<stileturn> map (sub_consts cs) (Neg p # G)\<close>
    by (simp add: sub_consts_Neg)
  then have \<open>\<stileturn> map (\<lambda>p. vars_for_consts p cs) (map (sub_consts cs) (Neg p # G))\<close>
    using TC_vars_for_consts by blast
  then show ?thesis
    unfolding tableauproof_def
    using all_vars_for_consts_sub_consts[where G=\<open>Neg p # G\<close>] * ** by simp
qed

corollary
  fixes p :: \<open>(nat, nat) form\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. eval e f g p\<close>
  shows \<open>\<stileturn> [Neg p]\<close>
  using assms tableau_completeness unfolding tableauproof_def by simp

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong_Semantics
  imports Tau_Chain
begin

definition weakCongTrans :: "ccs \<Rightarrow> act \<Rightarrow> ccs \<Rightarrow> bool" ("_ \<Longrightarrow>_ \<prec> _" [80, 80, 80] 80)
  where "P \<Longrightarrow>\<alpha> \<prec> P' \<equiv> \<exists>P'' P'''. P \<Longrightarrow>\<^sub>\<tau> P'' \<and> P'' \<longmapsto>\<alpha> \<prec> P''' \<and> P''' \<Longrightarrow>\<^sub>\<tau> P'"

lemma weakCongTransE:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs

  assumes "P \<Longrightarrow>\<alpha> \<prec> P'"

  obtains P'' P''' where "P \<Longrightarrow>\<^sub>\<tau> P''" and "P'' \<longmapsto>\<alpha> \<prec> P'''" and "P''' \<Longrightarrow>\<^sub>\<tau> P'"
using assms
by(auto simp add: weakCongTrans_def)

lemma weakCongTransI:
  fixes P    :: ccs
  and   P''  :: ccs
  and   \<alpha>    :: act
  and   P''' :: ccs
  and   P'   :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P''"
  and     "P'' \<longmapsto>\<alpha> \<prec> P'''"
  and     "P''' \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P \<Longrightarrow>\<alpha> \<prec> P'"
using assms
by(auto simp add: weakCongTrans_def)

lemma transitionWeakCongTransition:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs

  assumes "P \<longmapsto>\<alpha> \<prec> P'"

  shows "P \<Longrightarrow>\<alpha> \<prec> P'"
using assms
by(force simp add: weakCongTrans_def)

lemma weakCongAction:
  fixes a :: name
  and   P :: ccs

  shows "\<alpha>.(P) \<Longrightarrow>\<alpha> \<prec> P"
by(auto simp add: weakCongTrans_def)
  (blast intro: Action tauChainRefl)

lemma weakCongSum1:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<alpha> \<prec> P'"

  shows "P \<oplus> Q \<Longrightarrow>\<alpha> \<prec> P'"
using assms
apply(auto simp add: weakCongTrans_def)
apply(case_tac "P=P''")
apply(force simp add: tauChain_def dest: Sum1)
by(force intro: tauChainSum1)

lemma weakCongSum2:
  fixes Q  :: ccs
  and   \<alpha>  :: act
  and   Q' :: ccs
  and   P  :: ccs

  assumes "Q \<Longrightarrow>\<alpha> \<prec> Q'"

  shows "P \<oplus> Q \<Longrightarrow>\<alpha> \<prec> Q'"
using assms
apply(auto simp add: weakCongTrans_def)
apply(case_tac "Q=P''")
apply(force simp add: tauChain_def dest: Sum2)
by(force intro: tauChainSum2)

lemma weakCongPar1:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<alpha> \<prec> P'"

  shows "P \<parallel> Q \<Longrightarrow>\<alpha> \<prec> P' \<parallel> Q"
using assms
by(auto simp add: weakCongTrans_def)
  (blast dest: tauChainPar1 Par1)

lemma weakCongPar2:
  fixes Q  :: ccs
  and   \<alpha>  :: act
  and   Q' :: ccs
  and   P  :: ccs

  assumes "Q \<Longrightarrow>\<alpha> \<prec> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<alpha> \<prec> P \<parallel> Q'"
using assms
by(auto simp add: weakCongTrans_def)
  (blast dest: tauChainPar2 Par2)

lemma weakCongSync:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<alpha> \<prec> P'"
  and     "Q \<Longrightarrow>(coAction \<alpha>) \<prec> Q'"
  and     "\<alpha> \<noteq> \<tau>"

  shows "P \<parallel> Q \<Longrightarrow>\<tau> \<prec> P' \<parallel> Q'"
using assms
apply(auto simp add: weakCongTrans_def)
apply(rule_tac x= "P'' \<parallel> P''a" in exI)
apply auto
apply(blast dest: tauChainPar1 tauChainPar2)
apply(rule_tac x="P''' \<parallel> P'''a" in exI)
apply auto
apply(rule Comm)
apply auto
apply(rule_tac P'="P' \<parallel> P'''a" in tauChainAppend)
by(blast dest: tauChainPar1 tauChainPar2)+

lemma weakCongRes:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs
  and   x  :: name

  assumes "P \<Longrightarrow>\<alpha> \<prec> P'"
  and     "x \<sharp> \<alpha>"

  shows "\<lparr>\<nu>x\<rparr>P \<Longrightarrow>\<alpha> \<prec> \<lparr>\<nu>x\<rparr>P'"
using assms
by(auto simp add: weakCongTrans_def)
  (blast dest: tauChainRes Res)

lemma weakCongRepl:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs

  assumes "P \<parallel> !P \<Longrightarrow>\<alpha> \<prec> P'"

  shows "!P \<Longrightarrow>\<alpha> \<prec> P'"
using assms
apply(auto simp add: weakCongTrans_def)
apply(case_tac "P'' = P \<parallel> !P")
apply auto
apply(force intro: Bang simp add: tauChain_def)
by(force intro: tauChainRepl)

end