section \<open>Deciding RPO-constraints is NP-hard\<close>

text \<open>We show that for a given an RPO it is NP-hard to decide whether two terms are in relation,
  following a proof in \<^cite>\<open>"RPO_NPC"\<close>.\<close>

theory RPO_NP_Hard
  imports
    Multiset_Ordering_NP_Hard
    Weighted_Path_Order.RPO
begin

subsection \<open>Definition of the Encoding\<close>

datatype FSyms = A | F | G | H | U (* unsigned *) | P (* positive sign *) | N (* negative sign *)

text \<open>We slightly deviate from the paper encoding, since we add the three constants
  @{const U}, @{const P}, @{const N} in order to be able to easily convert an encoded term
  back to the multiset-element.\<close>

fun ms_elem_to_term :: "'a cnf \<Rightarrow> 'a ms_elem \<Rightarrow> (FSyms, 'a + nat)term" where
  (* y_i in the paper *)
  "ms_elem_to_term cnf (Inr i) = Var (Inr i)"
| (* t_x in the paper *)
  "ms_elem_to_term cnf (Inl (x, Unsigned)) = Fun F (Var (Inl x) # Fun U [] #
        map (\<lambda> _. Fun A []) cnf)"
  (* t+_x in the paper *)
| "ms_elem_to_term cnf (Inl (x, Positive)) = Fun F (Var (Inl x) # Fun P [] #
        map (\<lambda> i. if (x,True) \<in> set (cnf ! i) then Var (Inr i) else Fun A []) [0 ..< length cnf])"
  (* t-_x in the paper *)
| "ms_elem_to_term cnf (Inl (x, Negative)) = Fun F (Var (Inl x) # Fun N [] #
        map (\<lambda> i. if (x,False) \<in> set (cnf ! i) then Var (Inr i) else Fun A []) [0 ..< length cnf])"

definition term_lists_of_cnf :: "'a cnf \<Rightarrow> (FSyms, 'a + nat)term list \<times> (FSyms, 'a + nat)term list" where
  "term_lists_of_cnf cnf = (case multiset_problem_of_cnf cnf of
       (as, bs, S, NS) \<Rightarrow>
       (map (ms_elem_to_term cnf) as, map (ms_elem_to_term cnf) bs))"

definition rpo_constraint_of_cnf :: "'a cnf \<Rightarrow> (_,_)term \<times> (_,_)term" where
  "rpo_constraint_of_cnf cnf = (case term_lists_of_cnf cnf of
       (as, bs) \<Rightarrow> (Fun G as, Fun H bs))"

text \<open>An RPO instance where all symbols are equivalent in precedence and all symbols have
  multiset-status.\<close>
interpretation trivial_rpo: rpo_with_assms "\<lambda> f g. (False, True)" "\<lambda> f. True" "\<lambda> _. Mul" 0
  by (unfold_locales, auto)

subsection \<open>Soundness of the Encoding\<close>

fun term_to_ms_elem :: "(FSyms, 'a + nat)term \<Rightarrow> 'a ms_elem" where
  "term_to_ms_elem (Var (Inr i)) = Inr i"
| "term_to_ms_elem (Fun F (Var (Inl x) # Fun U _ # ts)) = Inl (x, Unsigned)"
| "term_to_ms_elem (Fun F (Var (Inl x) # Fun P _ # ts)) = Inl (x, Positive)"
| "term_to_ms_elem (Fun F (Var (Inl x) # Fun N _ # ts)) = Inl (x, Negative)"
| "term_to_ms_elem _ = undefined"

lemma term_to_ms_elem_ms_elem_to_term[simp]: "term_to_ms_elem (ms_elem_to_term cnf x) = x"
  apply (cases x)
  subgoal for a by (cases a, cases "snd a", auto)
  by auto

lemma (in rpo_with_assms) rpo_vars_term: "rpo_s s t \<or> rpo_ns s t \<Longrightarrow> vars_term s \<supseteq> vars_term t"
proof (induct s t rule: rpo.induct[of _ prc prl c n], force, force)
  case (3 f ss y)
  thus ?case
    by (smt (verit, best) fst_conv rpo.simps(3) snd_conv subset_eq term.set_intros(4))
next
  case (4 f ss g ts)
  show ?case
  proof (cases "\<exists>s\<in>set ss. rpo_ns s (Fun g ts)")
    case True
    from 4(1) True show ?thesis by auto
  next
    case False
    obtain ps pns where prc: "prc (f, length ss) (g, length ts) = (ps, pns)" by force
    from False have "(if (\<exists>s\<in>set ss. rpo_ns s (Fun g ts)) then b else e) = e" for b e :: "bool \<times> bool" by simp
    note res = 4(5)[unfolded rpo.simps this prc Let_def split]
    from res have rel: "\<forall>t\<in>set ts. rpo_s (Fun f ss) t" by (auto split: if_splits)
    note IH = 4(2)[OF False prc[symmetric] refl]
    from rel IH show ?thesis by auto
  qed
qed

lemma term_lists_of_cnf: assumes "term_lists_of_cnf cnf = (as, bs)"
  and non_triv: "cnf \<noteq> []"
  shows "(\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> (mset as, mset bs) \<in> s_mul_ext (trivial_rpo.RPO_NS) (trivial_rpo.RPO_S)"
  "length (vars_of_cnf cnf) \<ge> 2 \<Longrightarrow>
     (\<exists> \<beta>. eval_cnf \<beta> cnf) \<longleftrightarrow> (Fun G as, Fun H bs) \<in> trivial_rpo.RPO_S"
proof -
  obtain xs ys S NS where mp: "multiset_problem_of_cnf cnf = (xs,ys,S,NS)"
    by (cases "multiset_problem_of_cnf cnf", auto)
  from assms(1)[unfolded term_lists_of_cnf_def mp split]
  have abs: "as = map (ms_elem_to_term cnf) xs" "bs = map (ms_elem_to_term cnf) ys" by auto
  from mp[unfolded multiset_problem_of_cnf_def Let_def List.maps_def, simplified]
  have S: "S = concat (map (\<lambda>i. map (\<lambda>l. (ms_elem_of_lit l, Inr i)) (cnf ! i)) [0..<length cnf])"
    and NS: "NS = concat (map (\<lambda>x. [(Inl (x, Positive), Inl (x, Unsigned)), (Inl (x, Negative), Inl (x, Unsigned))]) (vars_of_cnf cnf)) @ S"
    and ys: "ys = map (\<lambda>x. Inl (x, Unsigned)) (vars_of_cnf cnf) @ map Inr [0..<length cnf]"
    and xs: "xs = concat (map (\<lambda>x. [Inl (x, Positive), Inl (x, Negative)]) (vars_of_cnf cnf))" by auto
  show one: "(\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> (mset as, mset bs) \<in> s_mul_ext (trivial_rpo.RPO_NS) (trivial_rpo.RPO_S)"
    unfolding multiset_problem_of_cnf(2)[OF mp non_triv]
  proof
    assume "(mset xs, mset ys) \<in> s_mul_ext (set NS) (set S)"
    hence mem: "(xs, ys) \<in> {(as, bs). (mset as, mset bs) \<in> s_mul_ext (set NS) (set S)}" by simp
    have "(as, bs) \<in> {(as, bs). (mset as, mset bs) \<in> s_mul_ext trivial_rpo.RPO_NS trivial_rpo.RPO_S}"
      unfolding abs
    proof (rule s_mul_ext_map[OF _ _ mem, of "ms_elem_to_term cnf"])
      {
        fix a b
        assume "(a,b) \<in> set S"
        from this[unfolded S, simplified]
        obtain i x s where i: "i < length cnf" and a: "a = ms_elem_of_lit (x,s)"
          and mem: "(x,s) \<in> set (cnf ! i)" and b: "b = Inr i" by auto
        from mem i obtain t ts where a: "ms_elem_to_term cnf a = Fun F (Var (Inl x) # t # ts)" and len: "length ts = length cnf" and tsi: "ts ! i = Var (Inr i)"
          unfolding a by (cases s, auto)
        from len i tsi have mem: "Var (Inr i) \<in> set ts" unfolding set_conv_nth by auto
        show "(ms_elem_to_term cnf a, ms_elem_to_term cnf b) \<in> trivial_rpo.RPO_S"
          unfolding a b by (simp add: Let_def, intro disjI2 bexI[OF _ mem], simp)
      } note S = this
      fix a b
      assume mem: "(a,b) \<in> set NS"
      show "(ms_elem_to_term cnf a, ms_elem_to_term cnf b) \<in> trivial_rpo.RPO_NS"
      proof (cases "(a,b) \<in> set S")
        case True
        from S[OF this] show ?thesis using trivial_rpo.RPO_S_subset_RPO_NS by fastforce
      next
        case False
        with mem[unfolded NS] obtain x s where "x \<in> set (vars_of_cnf cnf)" and
          a: "a = Inl (x, s)" and b: "b = Inl (x, Unsigned)" and s: "s = Positive \<or> s = Negative"
          by auto
        show ?thesis unfolding a b using s
          apply (auto intro!: all_nstri_imp_mul_nstri)
          subgoal for i by (cases i; cases "i - 1", auto intro!: all_nstri_imp_mul_nstri)
          subgoal for i by (cases i; cases "i - 1", auto intro!: all_nstri_imp_mul_nstri)
          done
      qed
    qed
    thus "(mset as, mset bs) \<in> s_mul_ext trivial_rpo.RPO_NS trivial_rpo.RPO_S"
      unfolding abs by simp
  next
    assume "(mset as, mset bs) \<in> s_mul_ext trivial_rpo.RPO_NS trivial_rpo.RPO_S"
    hence mem: "(as, bs) \<in> {(as, bs). (mset as, mset bs) \<in> s_mul_ext trivial_rpo.RPO_NS trivial_rpo.RPO_S}" by simp
    have xsys: "xs = map term_to_ms_elem as" "ys = map term_to_ms_elem bs" unfolding abs map_map o_def
      by (rule nth_equalityI, auto)
    have "(xs, ys) \<in> {(as, bs). (mset as, mset bs) \<in> s_mul_ext (set NS) (set S)}"
      unfolding xsys
    proof (rule s_mul_ext_map[OF _ _ mem])
      fix a b
      assume ab: "a \<in> set as" "b \<in> set bs"
      from ab(2)[unfolded abs] obtain y where y: "y \<in> set ys" and b: "b = ms_elem_to_term cnf y" by auto
      from ab(1)[unfolded abs] obtain x where x: "x \<in> set xs" and a: "a = ms_elem_to_term cnf x" by auto
      from y[unfolded ys] obtain v i where y: "y = Inl (v, Unsigned) \<and> v \<in> set (vars_of_cnf cnf)
          \<or> y = Inr i \<and> i < length cnf" by auto
      from x[unfolded xs] obtain w s where s: "s = Positive \<or> s = Negative" and w: "w \<in> set (vars_of_cnf cnf)"
        and x: "x = Inl (w, s)" by auto
      {
        assume y: "y = Inl (v, Unsigned)" and v: "v \<in> set (vars_of_cnf cnf)"
        {
          assume "(a,b) \<in> trivial_rpo.RPO_NS"
          from s this v have "(term_to_ms_elem a, term_to_ms_elem b) \<in> set NS" unfolding a b x y
            by (cases s, auto split: if_splits simp: Let_def NS)
        } note case11 = this
        {
          assume "(a,b) \<in> trivial_rpo.RPO_S"
          hence "trivial_rpo.rpo_s a b" by simp
          from s this v have False unfolding a b x y
            by (cases, auto split: if_splits simp: Let_def, auto dest!: fst_mul_ext_imp_fst)
        } note case12 = this
        note case11 case12
      } note case1 = this
      {
        assume y: "y = Inr i" and i: "i < length cnf"
        assume "(a,b) \<in> trivial_rpo.RPO_NS \<union> trivial_rpo.RPO_S"
        hence "(a,b) \<in> trivial_rpo.RPO_NS"
          using trivial_rpo.RPO_S_subset_RPO_NS by blast
        from s this have "(term_to_ms_elem a, term_to_ms_elem b) \<in> set S" unfolding a b x y
          by (cases, auto split: if_splits simp: Let_def NS S, force+)
      } note case2 = this
      from case1 case2 y
      show "(a, b) \<in> trivial_rpo.RPO_S \<Longrightarrow> (term_to_ms_elem a, term_to_ms_elem b) \<in> set S" by auto
      from case1 case2 y
      show "(a, b) \<in> trivial_rpo.RPO_NS \<Longrightarrow> (term_to_ms_elem a, term_to_ms_elem b) \<in> set NS" unfolding NS by auto
    qed
    thus "(mset xs, mset ys) \<in> s_mul_ext (set NS) (set S)" by simp
  qed

  text \<open>Here the encoding for single RPO-terms is handled. We do this here and not in a separate
    lemma, since some of the properties of xs, ys, as, bs, etc. are required.\<close>
  assume len2: "length (vars_of_cnf cnf) \<ge> 2"
  show "(\<exists> \<beta>. eval_cnf \<beta> cnf) \<longleftrightarrow> (Fun G as, Fun H bs) \<in> trivial_rpo.RPO_S"
    unfolding one
  proof
    assume mul: "(mset as, mset bs) \<in> s_mul_ext trivial_rpo.RPO_NS trivial_rpo.RPO_S"
    {
      fix b
      assume "b \<in> set bs"
      hence "b \<in># mset bs" by auto
      from s_mul_ext_point[OF mul this] have "\<exists> a \<in> set as. (a,b) \<in> trivial_rpo.RPO_NS"
        using trivial_rpo.RPO_S_subset_RPO_NS by fastforce
      hence "(Fun G as, b) \<in> trivial_rpo.RPO_S" by (cases b, auto)
    }
    with mul show "(Fun G as, Fun H bs) \<in> trivial_rpo.RPO_S"
      by (auto simp: mul_ext_def)
  next
    assume rpo: "(Fun G as, Fun H bs) \<in> trivial_rpo.RPO_S"
    have "\<not> (\<exists>s\<in>set as. trivial_rpo.rpo_ns s (Fun H bs))"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      then obtain a where a: "a \<in> set as" and "trivial_rpo.rpo_ns a (Fun H bs)" by auto
      with trivial_rpo.rpo_vars_term[of a "Fun H bs"]
      have vars: "vars_term (Fun H bs) \<subseteq> vars_term a" by auto
      from a[unfolded abs xs, simplified] obtain x where "vars_term a \<inter> range Inl = {Inl x}"
        by force
      with vars have sub: "vars_term (Fun G bs) \<inter> range Inl \<subseteq> {Inl x}" by auto
      from len2 obtain y z vs where vars: "vars_of_cnf cnf = y # z # vs"
        by (cases "vars_of_cnf cnf"; cases "tl (vars_of_cnf cnf)", auto)
      have "distinct (vars_of_cnf cnf)" unfolding vars_of_cnf_def by auto
      with vars have yz: "y \<noteq> z" by auto
      have "{Inl y, Inl z} \<subseteq> vars_term (Fun G bs)"
        unfolding abs ys vars by auto
      with sub yz
      show False by auto
    qed
    with rpo have "fst (mul_ext trivial_rpo.rpo_pr as bs)" by (auto split: if_splits)
    thus "(mset as, mset bs) \<in> s_mul_ext trivial_rpo.RPO_NS trivial_rpo.RPO_S"
      by (auto simp: mul_ext_def Let_def)
  qed
qed

lemma rpo_constraint_of_cnf: assumes non_triv: "length (vars_of_cnf cnf) \<ge> 2"
shows "(\<exists> \<beta>. eval_cnf \<beta> cnf) \<longleftrightarrow> rpo_constraint_of_cnf cnf \<in> trivial_rpo.RPO_S"
proof -
  obtain as bs where res: "term_lists_of_cnf cnf = (as,bs)" by force
  from non_triv have cnf: "cnf \<noteq> []" unfolding vars_of_cnf_def by auto
  show ?thesis unfolding rpo_constraint_of_cnf_def res split
    by (subst term_lists_of_cnf(2)[OF res cnf non_triv], auto)
qed

subsection \<open>Size of Encoding is Quadratic\<close>

fun term_size :: "('f,'v)term \<Rightarrow> nat" where
  "term_size (Var x) = 1"
| "term_size (Fun f ts) = 1 + sum_list (map term_size ts)"

lemma size_of_rpo_constraint_of_cnf:
  assumes "rpo_constraint_of_cnf cnf = (s,t)"
  and "size_cnf cnf = n"
  shows "term_size s + term_size t \<le> 4 * n\<^sup>2 + 12 * n + 2"
proof -
  obtain as bs S NS where mp: "multiset_problem_of_cnf cnf = (as, bs, S, NS)"
    by (cases "multiset_problem_of_cnf cnf", auto)
  from size_of_multiset_problem_of_cnf[OF mp assms(2)]
  have las: "length as \<le> 2 * n" "length bs \<le> 2 * n" by auto
  have tl: "term_lists_of_cnf cnf = (map (ms_elem_to_term cnf) as, map (ms_elem_to_term cnf) bs)"
    unfolding term_lists_of_cnf_def mp split by simp
  from assms(1)[unfolded rpo_constraint_of_cnf_def tl split]
  have st: "s = Fun G (map (ms_elem_to_term cnf) as)" "t = Fun H (map (ms_elem_to_term cnf) bs)" by auto
  have [simp]: "term_size (if b then Var (Inr x) :: (FSyms, 'a + nat) Term.term else Fun A []) = 1" for b x
    by (cases b, auto)
  have len_n: "length cnf \<le> n" using assms(2) unfolding size_cnf_def by auto
  have "term_size (ms_elem_to_term cnf a) \<le> 3 + length cnf" for a
    by (cases "(cnf,a)" rule: ms_elem_to_term.cases, auto simp: o_def sum_list_triv)
  also have "\<dots> \<le> 3 + n" using len_n by auto
  finally have size_ms: "term_size (ms_elem_to_term cnf a) \<le> 3 + n" for a .
  {
    fix u
    assume "u \<in> {s,t}"
    then obtain G cs where "cs \<in> {as, bs}" and u: "u = Fun G (map (ms_elem_to_term cnf) cs)"
      unfolding st by auto
    hence lcs: "length cs \<le> 2 * n" using las by auto
    have "term_size u = 1 + (\<Sum>x\<leftarrow>cs. term_size (ms_elem_to_term cnf x))" unfolding u by (simp add: o_def size_list_conv_sum_list)
    also have "\<dots> \<le> 1 + (\<Sum>x\<leftarrow>cs. 3 + n)"
      by (intro add_mono lcs le_refl sum_list_mono size_ms)
    also have "\<dots> \<le> 1 + (2 * n) * (3 + n)" unfolding sum_list_triv
      by (intro add_mono le_refl mult_mono, insert lcs, auto)
    also have "\<dots> = 2 * n^2 + 6 * n + 1" by (simp add: field_simps power2_eq_square)
    finally have "term_size u \<le> 2 * n\<^sup>2 + 6 * n + 1" .
  }
  from this[of s] this[of t]
  show "term_size s + term_size t \<le> 4 * n\<^sup>2 + 12 * n + 2" by simp
qed

subsection \<open>Check Executability\<close>

value (code) "case rpo_constraint_of_cnf [
  [(''x'',True),(''y'',False)],              \<comment> \<open>clause 0\<close>
  [(''x'',False)],                           \<comment> \<open>clause 1\<close>
  [(''y'',True),(''z'',True)],               \<comment> \<open>clause 2\<close>
  [(''x'',True),(''y'',True),(''z'',False)]] \<comment> \<open>clause 3\<close>
   of (s,t) \<Rightarrow> (''SAT: '', trivial_rpo.rpo_s s t, ''Encoding: '', s, '' >RPO '', t)"

hide_const (open) A F G H U P N

end


(*  Author:     Stefan Berghofer, TU Muenchen, 2005
*)

theory Basis
imports Main
begin

section {* General Utilities *}

text {*
This section introduces some general utilities that will be useful later on in
the formalization of System \fsub{}.

The following rewrite rules are useful for simplifying mutual induction rules.
*}

lemma True_simps:
  "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
  "(PROP P \<Longrightarrow> True) \<equiv> PROP Trueprop True"
  "(\<And>x. True) \<equiv> PROP Trueprop True"
  apply -
  apply rule
  apply (erule meta_mp)
  apply (rule TrueI)
  apply assumption
  apply rule
  apply (rule TrueI)
  apply assumption
  apply rule
  apply (rule TrueI)+
  done

text {*
Unfortunately, the standard introduction and elimination rules for bounded
universal and existential quantifier do not work properly for sets of pairs.
*}

lemma ballpI: "(\<And>x y. (x, y) \<in> A \<Longrightarrow> P x y) \<Longrightarrow> \<forall>(x, y) \<in> A. P x y"
  by blast

lemma bpspec: "\<forall>(x, y) \<in> A. P x y \<Longrightarrow> (x, y) \<in> A \<Longrightarrow> P x y"
  by blast

lemma ballpE: "\<forall>(x, y) \<in> A. P x y \<Longrightarrow> (P x y \<Longrightarrow> Q) \<Longrightarrow>
  ((x, y) \<notin> A \<Longrightarrow> Q) \<Longrightarrow> Q"
  by blast

lemma bexpI: "P x y \<Longrightarrow> (x, y) \<in> A \<Longrightarrow> \<exists>(x, y) \<in> A. P x y"
  by blast

lemma bexpE: "\<exists>(x, y) \<in> A. P x y \<Longrightarrow>
  (\<And>x y. (x, y) \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q) \<Longrightarrow> Q"
  by blast

lemma ball_eq_sym: "\<forall>(x, y) \<in> S. f x y = g x y \<Longrightarrow> \<forall>(x, y) \<in> S. g x y = f x y"
  by auto

lemma wf_measure_size: "wf (measure size)" by simp

notation
  Some ("\<lfloor>_\<rfloor>")

notation
  None ("\<bottom>")

notation
  length ("\<parallel>_\<parallel>")

notation
  Cons ("_ \<Colon>/ _" [66, 65] 65)

text {*
The following variant of the standard @{text nth} function returns
@{text "\<bottom>"} if the index is out of range.
*}

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = \<bottom>"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> \<lfloor>x\<rfloor> | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

lemma [simp]: "\<parallel>xs\<parallel> \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle> = ys\<langle>i - \<parallel>xs\<parallel>\<rangle>"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
  done

text {* Association lists *}

primrec assoc :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" ("_\<langle>_\<rangle>\<^sub>?" [90, 0] 91)
where
  "[]\<langle>a\<rangle>\<^sub>? = \<bottom>"
| "(x # xs)\<langle>a\<rangle>\<^sub>? = (if fst x = a then \<lfloor>snd x\<rfloor> else xs\<langle>a\<rangle>\<^sub>?)"

primrec unique :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "unique [] = True"
| "unique (x # xs) = (xs\<langle>fst x\<rangle>\<^sub>? = \<bottom> \<and> unique xs)"

lemma assoc_set: "ps\<langle>x\<rangle>\<^sub>? = \<lfloor>y\<rfloor> \<Longrightarrow> (x, y) \<in> set ps"
  by (induct ps) (auto split add: split_if_asm)

lemma map_assoc_None [simp]:
  "ps\<langle>x\<rangle>\<^sub>? = \<bottom> \<Longrightarrow> map (\<lambda>(x, y). (x, f x y)) ps\<langle>x\<rangle>\<^sub>? = \<bottom>"
  by (induct ps) auto

no_syntax
  "_ofsort" :: "[tid, sort] => type"  ("_\<Colon>_" [1000, 0] 1000)
  "_constrain" :: "[logic, type] => 'a"  ("_\<Colon>_" [4, 0] 3)
  "_idtyp" :: "[id, type] => idt"  ("_\<Colon>_" [] 0)
  "_idtypdummy" :: "type => idt"  ("'_()\<Colon>_" [] 0)
  "_Map" :: "maplets => 'a ~=> 'b"  ("(1[_])")

end


theory TickTock_Renaming
  imports TickTock_Core
begin

fun lift_renaming_func :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a ttevent \<Rightarrow> 'b ttevent)" where
  "lift_renaming_func f (Event e) = Event (f e)" |
  "lift_renaming_func f Tock = Tock" |
  "lift_renaming_func f Tick = Tick"

lemma lift_renaming_func_mono: "X \<subseteq> Y \<Longrightarrow> {lift_renaming_func f e |e. e \<in> X} \<subseteq> {lift_renaming_func f e |e. e \<in> Y}"
  by auto

lemma lift_renaming_func_subset: "Xa \<subseteq> {lift_renaming_func f e |e. e \<in> X} \<Longrightarrow> \<exists>Y. Xa = {lift_renaming_func f e |e. e \<in> Y} \<and> Y \<subseteq> X"
  by (rule_tac x="{e. lift_renaming_func f e \<in> Xa \<and> e \<in> X}" in exI, auto)

lemma lift_renaming_func_vimage_insert_Tick: "lift_renaming_func f -` (insert Tick Y) = insert Tick (lift_renaming_func f -` Y)"
  using lift_renaming_func.elims by blast

fun rename_trace :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ttobs list \<Rightarrow> 'b ttobs list set" where
  "rename_trace f [] = {[]}" |
  "rename_trace f ([e]\<^sub>E # t) = {s. \<exists>s'. s = [lift_renaming_func f e]\<^sub>E # s' \<and> s' \<in> rename_trace f t}" |
  "rename_trace f ([X]\<^sub>R # t) = {s. \<exists>s' Y. s = [Y]\<^sub>R # s' \<and> X = (lift_renaming_func f) -` Y \<and> s' \<in> rename_trace f t}"

lemma rename_trace_ttWF: "ttWF t \<Longrightarrow> \<forall>s\<in>(rename_trace f t). ttWF s"
  by (induct t rule:ttWF.induct, auto)

definition RenamingTT :: "'a ttobs list set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b ttobs list set" where
  "RenamingTT P f = {t. \<exists>x\<in>P. t \<in> rename_trace f x}"

lemma RenamingTT_wf:
  assumes "\<forall>x\<in>P. ttWF x"
  shows "\<forall>x\<in>RenamingTT P f. ttWF x"
  unfolding RenamingTT_def using assms rename_trace_ttWF by auto

lemma TT0_Renaming:
  assumes "TT1 P" "TT0 P"
  shows "TT0 (RenamingTT P f)"
  unfolding RenamingTT_def TT0_def using TT0_TT1_empty assms by force

lemma TT1_Renaming:
  assumes "TT1 P"
  shows "TT1 (RenamingTT P f)"
  unfolding RenamingTT_def TT1_def
proof auto
  fix \<rho> \<sigma> x
  have "\<And>P \<rho> \<sigma>. TT1 P \<Longrightarrow> \<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> x \<in> P \<Longrightarrow> \<sigma> \<in> rename_trace f x \<Longrightarrow> \<exists>x\<in>P. \<rho> \<in> rename_trace f x"
  proof (induct f x rule:rename_trace.induct, auto)
    fix f P \<rho>
    show "\<rho> \<lesssim>\<^sub>C [] \<Longrightarrow> [] \<in> P \<Longrightarrow> \<exists>x\<in>P. \<rho> \<in> rename_trace f x"
      using tt_prefix_subset_antisym by force
  next
    fix f e t P \<rho> s'
    assume ind_hyp: "\<And>P \<rho> \<sigma>. TT1 P \<Longrightarrow> \<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> t \<in> P \<Longrightarrow> \<sigma> \<in> rename_trace f t \<Longrightarrow> \<exists>x\<in>P. \<rho> \<in> rename_trace f x"
    assume case_assms: "TT1 P" "\<rho> \<lesssim>\<^sub>C [lift_renaming_func f e]\<^sub>E # s'" "[e]\<^sub>E # t \<in> P" "s' \<in> rename_trace f t"
    have "\<rho> = [] \<or> (\<exists> s. \<rho> = [lift_renaming_func f e]\<^sub>E # s)"
      using case_assms(2) by (cases \<rho> rule:ttWF.cases, auto)
    then show "\<exists>x\<in>P. \<rho> \<in> rename_trace f x"
    proof auto
      show "\<rho> = [] \<Longrightarrow> \<exists>x\<in>P. [] \<in> rename_trace f x"
        using TT0_TT1_empty TT0_def case_assms(1) case_assms(3) by (rule_tac x="[]" in bexI, auto)
    next
      fix s
      assume case_assm2: "\<rho> = [lift_renaming_func f e]\<^sub>E # s"
      have 1: "TT1 {x. [e]\<^sub>E # x \<in> P}"
        using case_assms(1) tt_prefix_subset.simps(3) unfolding TT1_def by blast
      have 2: "s \<lesssim>\<^sub>C s'"
        using case_assm2 case_assms(2) by auto
      have "\<exists>x\<in>{x. [e]\<^sub>E # x \<in> P}. s \<in> rename_trace f x"
        using 1 2 case_assms ind_hyp[where P="{x. [e]\<^sub>E # x \<in> P}", where \<rho>=s] by auto
      then show "\<exists>x\<in>P. [lift_renaming_func f e]\<^sub>E # s \<in> rename_trace f x"
        by (auto, rule_tac x="[e]\<^sub>E # x" in bexI, auto)
    qed
  next
    fix f t P \<rho> s' Y
    assume ind_hyp: "\<And>P \<rho> \<sigma>. TT1 P \<Longrightarrow> \<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> t \<in> P \<Longrightarrow> \<sigma> \<in> rename_trace f t \<Longrightarrow> \<exists>x\<in>P. \<rho> \<in> rename_trace f x"
    assume case_assms: "TT1 P" "\<rho> \<lesssim>\<^sub>C [Y]\<^sub>R # s'" "[lift_renaming_func f -` Y]\<^sub>R # t \<in> P" "s' \<in> rename_trace f t"
    have "\<rho> = [] \<or> (\<exists> s Z. \<rho> = [Z]\<^sub>R # s \<and> Z \<subseteq> Y)"
      using case_assms(2) by (cases \<rho> rule:ttWF.cases, auto)
    then show "\<exists>x\<in>P. \<rho> \<in> rename_trace f x"
    proof auto
      show "\<rho> = [] \<Longrightarrow> \<exists>x\<in>P. [] \<in> rename_trace f x"
        using TT0_TT1_empty TT0_def case_assms by (rule_tac x="[]" in bexI, auto)
    next
      fix s Z
      assume case_assms2: "Z \<subseteq> Y" "\<rho> = [Z]\<^sub>R # s"
      thm ind_hyp[where P="{x. [lift_renaming_func f -` Z]\<^sub>R # x \<in> P}", where \<rho>=s, where \<sigma>=s']
      have 1: "TT1 {x. [lift_renaming_func f -` Z]\<^sub>R # x \<in> P}"
        using case_assms(1) tt_prefix_subset.simps(2) unfolding TT1_def by blast
      have 2: "s \<lesssim>\<^sub>C s'"
        using case_assms2 case_assms(2) by auto
      have "[lift_renaming_func f -` Z]\<^sub>R # t \<lesssim>\<^sub>C [lift_renaming_func f -` Y]\<^sub>R # t"
        by (simp add: case_assms2(1) tt_prefix_subset_refl vimage_mono)
      then have 3: "t \<in> {x. [lift_renaming_func f -` Z]\<^sub>R # x \<in> P}"
        using case_assms(1) case_assms(3) unfolding TT1_def by fastforce
     have "\<exists>x\<in>{x. [lift_renaming_func f -` Z]\<^sub>R # x \<in> P}. s \<in> rename_trace f x"
        using 1 2 3 case_assms ind_hyp[where P="{x. [lift_renaming_func f -` Z]\<^sub>R # x \<in> P}", where \<rho>=s] by auto
      then show "\<exists>x\<in>P. [Z]\<^sub>R # s \<in> rename_trace f x"
        using case_assms(4) case_assms2(1) by (auto, rule_tac x="[lift_renaming_func f -` Z]\<^sub>R # x" in bexI, auto)
    qed
  qed
  then show "\<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> x \<in> P \<Longrightarrow> \<sigma> \<in> rename_trace f x \<Longrightarrow> \<exists>x\<in>P. \<rho> \<in> rename_trace f x"
    using assms by auto
qed

lemma TT2_Renaming:
  assumes "TT2 P"
  shows "TT2 (RenamingTT P f)"
  unfolding TT2_def RenamingTT_def
proof (auto)
  fix \<rho> \<sigma> X Y x
  have "\<And>P \<rho>. Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {} \<Longrightarrow>
       TT2 P \<Longrightarrow> x \<in> P \<Longrightarrow> \<rho> @ [X]\<^sub>R # \<sigma> \<in> rename_trace f x \<Longrightarrow> \<exists>x\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
  proof (induct f x rule:rename_trace.induct, simp_all)
    fix f e t P \<rho>
    assume ind_hyp: "\<And>P \<rho>. Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {} \<Longrightarrow>
               TT2 P \<Longrightarrow> t \<in> P \<Longrightarrow> \<rho> @ [X]\<^sub>R # \<sigma> \<in> rename_trace f t \<Longrightarrow> \<exists>x\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
    assume case_assms: "Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {}"
       "TT2 P" "[e]\<^sub>E # t \<in> P" "\<exists>s'. \<rho> @ [X]\<^sub>R # \<sigma> = [lift_renaming_func f e]\<^sub>E # s' \<and> s' \<in> rename_trace f t"
    obtain \<rho>' where \<rho>_def: "\<rho> = [lift_renaming_func f e]\<^sub>E # \<rho>'"
      using case_assms(4) by (cases \<rho> rule:ttWF.cases, auto)
    have 1: "TT2 {x. [e]\<^sub>E # x \<in> P}"
      using case_assms(2) unfolding TT2_def by (auto, erule_tac x="[e]\<^sub>E # \<rho>" in allE, auto)
    have "{ea. ea \<noteq> Tock \<and> (\<exists>x\<in>{x. [e]\<^sub>E # x \<in> P}. \<rho>' @ [[ea]\<^sub>E] \<in> rename_trace f x) \<or> ea = Tock \<and> (\<exists>x\<in>{x. [e]\<^sub>E # x \<in> P}. \<rho>' @ [[X]\<^sub>R, [ea]\<^sub>E] \<in> rename_trace f x)}
      \<subseteq> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)}"
      using \<rho>_def by force
    then have 2: "Y \<inter> {ea. ea \<noteq> Tock \<and> (\<exists>x\<in>{x. [e]\<^sub>E # x \<in> P}. \<rho>' @ [[ea]\<^sub>E] \<in> rename_trace f x) \<or> ea = Tock \<and> (\<exists>x\<in>{x. [e]\<^sub>E # x \<in> P}. \<rho>' @ [[X]\<^sub>R, [ea]\<^sub>E] \<in> rename_trace f x)} = {}"
      using case_assms(1) by auto
    have 3: "\<rho>' @ [X]\<^sub>R # \<sigma> \<in> rename_trace f t"
      using \<rho>_def case_assms(4) by auto
    have "\<exists>x\<in>{x. [e]\<^sub>E # x \<in> P}. \<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
      using case_assms \<rho>_def 1 2 3 ind_hyp[where P="{x. [e]\<^sub>E # x \<in> P}", where \<rho>=\<rho>'] by auto
    then show "\<exists>x\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
      using \<rho>_def by force
  next
    fix f Xa t P \<rho>
    assume ind_hyp: "\<And>P \<rho>. Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {} \<Longrightarrow>
               TT2 P \<Longrightarrow> t \<in> P \<Longrightarrow> \<rho> @ [X]\<^sub>R # \<sigma> \<in> rename_trace f t \<Longrightarrow> \<exists>x\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
    assume case_assms: "Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {}"
      "TT2 P" "[Xa]\<^sub>R # t \<in> P" "\<exists>s' Y. \<rho> @ [X]\<^sub>R # \<sigma> = [Y]\<^sub>R # s' \<and> Xa = lift_renaming_func f -` Y \<and> s' \<in> rename_trace f t"
    have 1: "TT2 {x. [Xa]\<^sub>R # x \<in> P}"
      using case_assms(2) unfolding TT2_def by (auto, erule_tac x="[Xa]\<^sub>R # \<rho>" in allE, auto)
    obtain Z s' where Z_assms: "\<rho> @ [X]\<^sub>R # \<sigma> = [Z]\<^sub>R # s' \<and> Xa = lift_renaming_func f -` Z \<and> s' \<in> rename_trace f t"
      using case_assms(4) by auto
    then have "(\<exists>\<rho>'. \<rho> = [Z]\<^sub>R # \<rho>') \<or> (X = Z \<and> \<rho> = [])"
      by (cases \<rho> rule:ttWF.cases, auto)
    then show "\<exists>x\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
    proof auto
      fix \<rho>''
      assume case_assm2: "\<rho> = [Z]\<^sub>R # \<rho>''"
      have 1: "TT2 {x. [Xa]\<^sub>R # x \<in> P}"
        using case_assms(2) unfolding TT2_def by (auto, erule_tac x="[Xa]\<^sub>R # \<rho>" in allE, auto)
      have "{e. e \<noteq> Tock \<and> (\<exists>x\<in>{x. [Xa]\<^sub>R # x \<in> P}. \<rho>'' @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>{x. [Xa]\<^sub>R # x \<in> P}. \<rho>'' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)}
        \<subseteq> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)}"
        using case_assm2 Z_assms by (auto, (smt CollectI Z_assms case_assms(4) list.inject rename_trace.simps(3))+)
      then have 2: "Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>{x. [Xa]\<^sub>R # x \<in> P}. \<rho>'' @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>{x. [Xa]\<^sub>R # x \<in> P}. \<rho>'' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {}"
        using case_assms(1) by auto
      have 3: "\<rho>'' @ [X]\<^sub>R # \<sigma> \<in> rename_trace f t"
        using case_assm2 case_assms(4) by auto
      have "\<exists>x\<in>{x. [Xa]\<^sub>R # x \<in> P}. \<rho>'' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
        using case_assms case_assm2 1 2 3 ind_hyp[where P="{x. [Xa]\<^sub>R # x \<in> P}", where \<rho>=\<rho>''] by auto
      then show "\<exists>x\<in>P. [Z]\<^sub>R # \<rho>'' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
        using case_assm2 Z_assms apply (auto)
        by (smt CollectI Z_assms case_assms(4) list.inject rename_trace.simps(3))
    next
      assume case_assms2: "\<rho> = []" "X = Z"
      obtain Y' where Y'_def: "Y' = lift_renaming_func f -` Y"
        by auto
      have "Y' \<inter> {e. e \<noteq> Tock \<and> [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> [[Xa]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
      proof auto
        fix x
        assume case_assms3: "x \<in> Y'" "x \<noteq> Tock" "[[x]\<^sub>E] \<in> P"
        have "lift_renaming_func f x \<in> Y"
          using case_assms3 Y'_def by auto
        then have "lift_renaming_func f x \<notin> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)}"
          using case_assms(1) by blast
        then show "False"
          using case_assms2(1) case_assms3 lift_renaming_func.elims by auto
      next
        assume case_assms3: "Tock \<in> Y'" "[[Xa]\<^sub>R, [Tock]\<^sub>E] \<in> P"
        have "lift_renaming_func f Tock \<in> Y"
          using case_assms3 Y'_def by auto
        then have "lift_renaming_func f Tock \<notin> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)}"
          using case_assms(1) by blast
        then show "False"
          using Z_assms case_assms3(2) case_assms2 by auto
      qed
      then have "[Xa \<union> Y']\<^sub>R # t \<in> P"
        using case_assms(2) case_assms(3) unfolding TT2_def by (erule_tac x="[]" in allE, auto)
      then show "\<exists>x\<in>P. [Z \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
        using Z_assms Y'_def case_assms2(1) by (rule_tac x="[Xa \<union> Y']\<^sub>R # t" in bexI, auto)
    qed
  qed
  then show "Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x\<in>P. \<rho> @ [[e]\<^sub>E] \<in> rename_trace f x) \<or> e = Tock \<and> (\<exists>x\<in>P. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> rename_trace f x)} = {} \<Longrightarrow>
       x \<in> P \<Longrightarrow> \<rho> @ [X]\<^sub>R # \<sigma> \<in> rename_trace f x \<Longrightarrow> \<exists>x\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> rename_trace f x"
    using assms by auto
qed

lemma ttWFx_Renaming: "ttWFx P \<Longrightarrow> ttWFx (RenamingTT P f)"
  unfolding ttWFx_def RenamingTT_def
proof (simp, safe)
  fix x xa
  have "\<And>P x. \<forall>x\<in>P. ttWFx_trace x \<Longrightarrow> xa \<in> P \<Longrightarrow> x \<in> rename_trace f xa \<Longrightarrow> ttWFx_trace x"
  proof (induct xa rule:ttWFx_trace.induct)
    fix P x
    show "Ball P ttWFx_trace \<Longrightarrow> [] \<in> P \<Longrightarrow> x \<in> rename_trace f [] \<Longrightarrow> ttWFx_trace x"
      by simp
  next
    fix x P xa
    show "Ball P ttWFx_trace \<Longrightarrow> [x] \<in> P \<Longrightarrow> xa \<in> rename_trace f [x] \<Longrightarrow> ttWFx_trace xa"
      by (cases x, auto)
  next
    fix X \<rho> P x
    assume ind_hyp: "\<And>P x. Ball P ttWFx_trace \<Longrightarrow> \<rho> \<in> P \<Longrightarrow> x \<in> rename_trace f \<rho> \<Longrightarrow> ttWFx_trace x"
    assume case_assms: "Ball P ttWFx_trace" "[X]\<^sub>R # [Tock]\<^sub>E # \<rho> \<in> P" "x \<in> rename_trace f ([X]\<^sub>R # [Tock]\<^sub>E # \<rho>)"
    obtain x' Y where x_def: "x = [Y]\<^sub>R # [Tock]\<^sub>E # x' \<and> X = lift_renaming_func f -` Y"
      using case_assms(3) by (cases x rule:ttWF.cases, auto)
    have 1: "Ball {x. [X]\<^sub>R # [Tock]\<^sub>E # x \<in> P} ttWFx_trace"
      using case_assms(1) by auto
    have 2: "\<rho> \<in> {x. [X]\<^sub>R # [Tock]\<^sub>E # x \<in> P}"
      using case_assms(2) by auto
    have 3: "x' \<in> rename_trace f \<rho>"
      using x_def case_assms(3) by auto
    have "ttWFx_trace x'"
      using 1 2 3 ind_hyp[where x=x', where P="{x. [X]\<^sub>R # [Tock]\<^sub>E # x \<in> P}"] by fastforce
    then show "ttWFx_trace x"
      by (metis ttWFx_trace.simps(3) case_assms(1) case_assms(2) lift_renaming_func.simps(2) vimageI x_def)
  next
    fix va vb vc P x
    assume ind_hyp: "\<And>P x. Ball P ttWFx_trace \<Longrightarrow> vb # vc \<in> P \<Longrightarrow> x \<in> rename_trace f (vb # vc) \<Longrightarrow> ttWFx_trace x"
    assume case_assms: "Ball P ttWFx_trace" "[va]\<^sub>E # vb # vc \<in> P" "x \<in> rename_trace f ([va]\<^sub>E # vb # vc)"
    obtain va' vb' x' where x_def: "x = [va']\<^sub>E # vb' # x'"
      using case_assms(3) by (cases x rule:ttWFx_trace.cases, auto, cases vb, auto)
    have 1: "Ball {x. [va]\<^sub>E # x \<in> P} ttWFx_trace"
      using case_assms(1) ttWFx_trace_cons_imp_cons by blast
    have "ttWFx_trace (vb' # x')"
      using 1 case_assms(2) case_assms(3) x_def ind_hyp[where x="vb' # x'", where P="{x. [va]\<^sub>E # x \<in> P}"] by fastforce
    then show "ttWFx_trace x"
      using x_def case_assms(3) by simp
  next
    fix va vd vc P x
    assume ind_hyp: "\<And>P x. Ball P ttWFx_trace \<Longrightarrow> [Event vd]\<^sub>E # vc \<in> P \<Longrightarrow> x \<in> rename_trace f ([Event vd]\<^sub>E # vc) \<Longrightarrow> ttWFx_trace x"
    assume case_assms: "Ball P ttWFx_trace" "[va]\<^sub>R # [Event vd]\<^sub>E # vc \<in> P" "x \<in> rename_trace f ([va]\<^sub>R # [Event vd]\<^sub>E # vc)"
    obtain va' vd' x' where x_def: "x = [va']\<^sub>R # [Event vd']\<^sub>E # x'"
      using case_assms(3) by (cases x rule:ttWF.cases, auto)
    have 1: "Ball {x. [va]\<^sub>R # x \<in> P} ttWFx_trace"
      using case_assms(1) ttWFx_trace_cons_imp_cons by auto
    have "ttWFx_trace ([Event vd']\<^sub>E # x')"
      using 1 case_assms(2) case_assms(3) x_def ind_hyp[where x="[Event vd']\<^sub>E # x'", where P="{x. [va]\<^sub>R # x \<in> P}"] by fastforce
    then show "ttWFx_trace x"
      using x_def case_assms(3) by simp
  next
    fix va vc P x
    assume ind_hyp: "\<And>P x. Ball P ttWFx_trace \<Longrightarrow> [Tick]\<^sub>E # vc \<in> P \<Longrightarrow> x \<in> rename_trace f ([Tick]\<^sub>E # vc) \<Longrightarrow> ttWFx_trace x"
    assume case_assms: "Ball P ttWFx_trace" "[va]\<^sub>R # [Tick]\<^sub>E # vc \<in> P" "x \<in> rename_trace f ([va]\<^sub>R # [Tick]\<^sub>E # vc)"
    obtain va' x' where x_def: "x = [va']\<^sub>R # [Tick]\<^sub>E # x'"
      using case_assms(3) by (cases x rule:ttWF.cases, auto)
    have 1: "Ball {x. [va]\<^sub>R # x \<in> P} ttWFx_trace"
      using case_assms(1) ttWFx_trace_cons_imp_cons by auto
    have "ttWFx_trace ([Tick]\<^sub>E # x')"
      using 1 case_assms(2) case_assms(3) x_def ind_hyp[where x="[Tick]\<^sub>E # x'", where P="{x. [va]\<^sub>R # x \<in> P}"] by fastforce
    then show "ttWFx_trace x"
      using x_def case_assms(3) by simp
  next
    fix vb va vc P x
    assume ind_hyp: "\<And>P x. Ball P ttWFx_trace \<Longrightarrow> [va]\<^sub>R # vc \<in> P \<Longrightarrow> x \<in> rename_trace f ([va]\<^sub>R # vc) \<Longrightarrow> ttWFx_trace x"
    assume case_assms: "Ball P ttWFx_trace" "[vb]\<^sub>R # [va]\<^sub>R # vc \<in> P" "x \<in> rename_trace f ([vb]\<^sub>R # [va]\<^sub>R # vc)"
    obtain va' vb' x' where x_def: "x = [vb']\<^sub>R # [va']\<^sub>R # x'"
      using case_assms(3) by (cases x rule:ttWF.cases, auto)
    have 1: "Ball {x. [vb]\<^sub>R # x \<in> P} ttWFx_trace"
      using case_assms(1) ttWFx_trace_cons_imp_cons by auto
    have "ttWFx_trace ([va']\<^sub>R # x')"
      using 1 case_assms(2) case_assms(3) x_def ind_hyp[where x="[va']\<^sub>R # x'", where P="{x. [vb]\<^sub>R # x \<in> P}"] by fastforce
    then show "ttWFx_trace x"
      using x_def case_assms(3) by simp
  qed
  then show "\<forall>x\<in>P. ttWFx_trace x \<Longrightarrow> xa \<in> P \<Longrightarrow> x \<in> rename_trace f xa \<Longrightarrow> ttWFx_trace x"
    by blast
qed

lemma TT3w_Renaming:
  assumes "TT3w P"
  shows "TT3w (RenamingTT P f)"
  unfolding RenamingTT_def TT3w_def
proof auto
  fix \<rho> x
  have "\<And>P \<rho>. x \<in> P \<Longrightarrow> \<rho> \<in> rename_trace f x \<Longrightarrow> add_Tick_refusal_trace \<rho> \<in> rename_trace f (add_Tick_refusal_trace x)"
    using UNIV_I lift_renaming_func.elims by (induct f x rule:rename_trace.induct, auto, blast+)
  then show "x \<in> P \<Longrightarrow> \<rho> \<in> rename_trace f x \<Longrightarrow> \<exists>x\<in>P. add_Tick_refusal_trace \<rho> \<in> rename_trace f x"
    using assms unfolding TT3w_def by (rule_tac x="add_Tick_refusal_trace x" in bexI, auto)
qed

lemma TT3_Renaming:
  assumes "TT1 P" "TT3 P"
  shows "TT3 (RenamingTT P f)"
  by (meson TT1_Renaming TT1_TT3w_equiv_TT3 TT3w_Renaming assms)

lemma TT_Renaming:
  shows "TT P \<Longrightarrow> TT2 P \<Longrightarrow> TT (RenamingTT P f)"
  unfolding TT_def by (auto simp add: RenamingTT_wf TT0_Renaming TT1_Renaming TT2_Renaming TT2_imp_TT2w ttWFx_Renaming)

lemma Renaming_Union_dist:
  "S \<noteq> {} \<Longrightarrow> (RenamingTT (\<Union>S) f) = \<Union>{R. \<exists>Q. Q \<in> S \<and> R = RenamingTT Q f}"
    unfolding RenamingTT_def by (safe, simp_all, blast+)

end


theory Setsum_Infinite
imports Main Topological_Spaces Extended_Sorry
begin

typedef 'a finite_set = "{S::'a set. finite S}" by auto
definition fset :: "'a finite_set \<Rightarrow> 'a set" where
  "fset S = Rep_finite_set S";

instantiation finite_set :: (type) order
begin
definition less_eq_finite_set where "A \<le> B \<longleftrightarrow> fset A \<le> fset B"
definition less_finite_set where "A < B \<longleftrightarrow> fset A < fset B"
instance
apply intro_classes
apply (metis less_eq_finite_set_def less_finite_set_def less_le_not_le)
apply (metis less_eq_finite_set_def order_refl)
apply (metis le_iff_inf le_infI2 less_eq_finite_set_def)
by (metis fset_def Rep_finite_set_inject eq_iff less_eq_finite_set_def)
end

instantiation finite_set :: (type) semilattice_inf begin
definition inf_finite_set where "inf A B = Abs_finite_set (inf (fset A) (fset B))"
instance
  apply intro_classes
  apply (unfold inf_finite_set_def less_eq_finite_set_def fset_def)
  apply (metis Abs_finite_set_inverse Int_lower1 Rep_finite_set finite_Int mem_Collect_eq)
  apply (metis Abs_finite_set_inverse Int_lower1 Rep_finite_set finite_Int inf_commute mem_Collect_eq)
  by (metis Abs_finite_set_inverse Rep_finite_set finite_Int le_inf_iff mem_Collect_eq)
end

instantiation finite_set :: (type) semilattice_sup begin
definition sup_finite_set where "sup A B = Abs_finite_set (sup (fset A) (fset B))"
instance
  apply intro_classes
  apply (unfold sup_finite_set_def less_eq_finite_set_def fset_def)
  apply (metis Abs_finite_set_inverse Rep_finite_set finite_Un mem_Collect_eq sup_ge1)
  apply (metis Abs_finite_set_inverse Rep_finite_set finite_Un mem_Collect_eq sup.commute sup_ge1)
  by (metis Abs_finite_set_inverse Rep_finite_set mem_Collect_eq rev_finite_subset sup.boundedI)
end

instantiation finite_set :: (type) distrib_lattice begin
instance apply intro_classes
  apply (unfold sup_finite_set_def inf_finite_set_def fset_def)
  apply (subst Abs_finite_set_inverse)
  apply (metis Rep_finite_set finite_Int mem_Collect_eq)
  by (metis Abs_finite_set_inverse Rep_finite_set finite_Un mem_Collect_eq sup_inf_distrib1)
end

instantiation finite_set :: (type) bounded_lattice_bot
begin
definition bot_finite_set where "bot = Abs_finite_set bot"
instance
by (intro_classes, metis (mono_tags, hide_lams) Abs_finite_set_inverse fset_def bot_finite_set_def equals0D finite.emptyI less_eq_finite_set_def mem_Collect_eq subsetI)
end;

instantiation finite_set :: (type) minus
begin
definition minus_finite_set where "A - B = Abs_finite_set (fset A - fset B)"
instance ..
end;

definition SetSums_to :: "('a \<Rightarrow> 'b::{t2_space,comm_monoid_add}) \<Rightarrow> ('a set) \<Rightarrow> 'b \<Rightarrow> bool" where
  "SetSums_to f A b = ((\<lambda>S. setsum f (A \<inter> fset S)) ---> b) (at_top) ";

definition SetSums :: "('a \<Rightarrow> 'b::{t2_space,comm_monoid_add}) \<Rightarrow> ('a set) \<Rightarrow> bool" where
  "SetSums f A = (\<exists>b. SetSums_to f A b)";

definition SetSum :: "('a \<Rightarrow> 'b::{t2_space,comm_monoid_add}) \<Rightarrow> ('a set) \<Rightarrow> 'b" where
  "SetSum f A = (THE b. SetSums_to f A b)";

lemma at_top_neq_bot_finite_set: "(at_top::'a finite_set filter) \<noteq> bot"
unfolding at_top_def
unfolding filter_eq_iff
apply (subst eventually_INF_base)
apply auto
apply (metis sup.cobounded2 sup_ge1)
by (metis not_empty_eq_Ici_eq_empty principal_eq_bot_iff trivial_limit_def)

lemma setsum_def_alt: "SetSums_to f A b \<longleftrightarrow> (\<forall>U. open U \<longrightarrow> b \<in> U \<longrightarrow> (\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U)))"
proof -
  have setsums_unfold: "SetSums_to f A b \<longleftrightarrow>
        (\<forall>U. open U \<longrightarrow> b \<in> U \<longrightarrow> (\<exists>B0. \<forall>B\<in>{B0..}. setsum f (A \<inter> fset B) \<in> U))"
    unfolding SetSums_to_def trivial_limit_def tendsto_def at_top_def
    apply (subst eventually_INF_base)
    apply (metis empty_not_UNIV)
    apply (metis UNIV_I atLeast_subset_iff le_inf_iff principal_le_iff sup.cobounded2 sup_ge1)
    unfolding eventually_principal
    by simp;
  have dir1: "\<And>U. (\<exists>B0. \<forall>B\<in>{B0..}. setsum f (A \<inter> fset B) \<in> U) \<Longrightarrow>
             (\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U))"
  proof -
    fix U
    assume "\<exists>B0. \<forall>B\<in>{B0..}. setsum f (A \<inter> fset B) \<in> U"
    then obtain B0' where B0': "\<forall>B'\<in>{B0'..}. setsum f (A \<inter> fset B') \<in> U" by auto
    def B0 == "fset B0'"
    have "finite B0" by (metis B0_def fset_def Rep_finite_set mem_Collect_eq)
    have "\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U"
    proof (rule,rule)
      fix B::"'a set" assume finB: "finite B" and B_B0: "B\<in>{B0..}"
      def B' == "Abs_finite_set B"
      from B0' have "setsum f (A \<inter> fset B') \<in> U"
        by (metis Abs_finite_set_inverse B'_def B0_def B_B0 fset_def atLeast_iff finB less_eq_finite_set_def mem_Collect_eq)
      with fset_def finB B'_def show "setsum f (A \<inter> B) \<in> U"
        by (metis Abs_finite_set_inverse mem_Collect_eq)
    qed
  with `finite B0` show "\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U)" by auto
  qed
  have dir2: "\<And>U. (\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U)) \<Longrightarrow>
             (\<exists>B0'. \<forall>B'\<in>{B0'..}. setsum f (A \<inter> fset B') \<in> U)"
  proof -
    fix U assume "\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U)"
    then obtain B0 where finB0: "finite B0" and B_B0: "\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U" by auto
    def B0' == "Abs_finite_set B0"
    have "\<forall>B'\<in>{B0'..}. setsum f (A \<inter> fset B') \<in> U"
      by (metis Abs_finite_set_cases Abs_finite_set_inverse B0'_def B_B0 fset_def atLeast_def finB0 less_eq_finite_set_def mem_Collect_eq)
    thus "\<exists>B0'. \<forall>B'\<in>{B0'..}. setsum f (A \<inter> fset B') \<in> U" ..
  qed
  from dir1 dir2 have dir12: "\<And>U. (\<exists>B0. \<forall>B\<in>{B0..}. setsum f (A \<inter> fset B) \<in> U) \<longleftrightarrow>
             (\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U))" ..
  from setsums_unfold show "SetSums_to f A b \<longleftrightarrow> (\<forall>U. open U \<longrightarrow> b \<in> U \<longrightarrow> (\<exists>B0. finite B0 \<and> (\<forall>B\<in>{B0..}. finite B \<longrightarrow> setsum f (A \<inter> B) \<in> U)))"
    unfolding dir12 .
qed

lemma setsum_0: "SetSums_to (\<lambda>x. 0) UNIV 0"
  by (auto simp: setsum_def_alt)

end


theory Chisholm_DDL_Monadic imports DDL           (*Christoph Benzmüller & Xavier Parent, 2019*)

begin (* Chisholm Example *)
consts go::\<sigma> tell::\<sigma> kill::\<sigma>

 nitpick_params [user_axioms,show_all,format=2] (*Settings for model finder.*)

(*It ought to be that Jones goes to assist his neighbors.*)
  abbreviation  "D1 \<equiv> \<^bold>\<circle><go>"
(*It ought to be that if Jones goes, then he tells them he is coming.*)
  abbreviation  "D2w \<equiv> \<^bold>\<circle><go \<^bold>\<rightarrow> tell>"
  abbreviation  "D2n \<equiv> go \<^bold>\<rightarrow> \<^bold>\<circle><tell>"
(*If Jones doesn't go, then he ought not tell them he is coming.*)
  abbreviation  "D3w \<equiv> \<^bold>\<circle><\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell>"
  abbreviation  "D3n \<equiv> \<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<circle><\<^bold>\<not>tell>"
(*Jones doesn't go. (This is encoded as a locally valid statement.)*)
  abbreviation  "D4 \<equiv> \<^bold>\<not>go"

(*** Chisholm_A ***)
 (* All-wide scoping is not leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  sledgehammer nitpick oops (*timeout, no confirmation yet*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_A is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  nitpick oops (*Should James tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(*** Chisholm_B ***)
 (* All-narrow scoping is leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D4) \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1 \<^bold>\<and> D3n \<^bold>\<and> D4) \<^bold>\<rightarrow> D2n\<rfloor>"  by simp (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3n \<^bold>\<and> D4) \<^bold>\<rightarrow> D1\<rfloor>"  nitpick oops (*countermodel*)
 (* Chisholm_B is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by auto (*Should James not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms ax_5a ax_5b by metis (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(*** Chisholm_C ***)
 (* Wide-narrow scoping is leading to independence of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4) \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4) \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3n \<^bold>\<and> D4) \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_C is thus fine from this perspective. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by auto (*Should James not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  nitpick oops (*Should James tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)
 (* Chisholm_C is thus fine and as expected. *)

(*** Chisholm_D ***)
 (* Narrow-wide scoping is leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  sledgehammer nitpick oops (*timeout, no confirmation yet*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by auto  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_D is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms ax_5a ax_5b by force (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)
end


theory T92
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end