theory TheoremD2
imports LocalLexingLemmas Validity Derivations
begin

context LocalLexing begin

definition splits_at :: "sentence \<Rightarrow> nat \<Rightarrow> sentence \<Rightarrow> symbol \<Rightarrow> sentence \<Rightarrow> bool"
where
  "splits_at \<delta> i \<alpha> N \<beta> = (i < length \<delta> \<and> \<alpha> = take i \<delta> \<and> N = \<delta> ! i \<and> \<beta> = drop (Suc i) \<delta>)"

lemma splits_at_combine: "splits_at \<delta> i \<alpha> N \<beta> \<Longrightarrow> \<delta> = \<alpha> @ [N] @ \<beta>"
  by (simp add: id_take_nth_drop splits_at_def)

lemma splits_at_combine_dest: "Derives1 a i r b \<Longrightarrow> splits_at a i \<alpha> N \<beta> \<Longrightarrow> b = \<alpha> @ (snd r) @ \<beta>"
  by (metis (no_types, lifting) Derives1_drop Derives1_split append_assoc append_eq_conv_conj
      length_append splits_at_def)

lemma Derives1_nonterminal:
  assumes "Derives1 a i r b"
  assumes "splits_at a i \<alpha> N \<beta>"
  shows "fst r = N \<and> is_nonterminal N"
proof -
  from assms have fst: "fst r = N"
    by (metis Derives1_split append_Cons nth_append_length splits_at_def)
  then have "is_nonterminal N"
    by (metis Derives1_def assms(1) prod.collapse rule_nonterminal_type)
  with fst show ?thesis by auto
qed

lemma splits_at_ex: "Derives1 \<delta> i r s \<Longrightarrow> \<exists> \<alpha> N \<beta>. splits_at \<delta> i \<alpha> N \<beta>"
by (simp add: Derives1_bound splits_at_def)

lemma splits_at_\<alpha>: "Derives1 \<delta> i r s \<Longrightarrow> splits_at \<delta> i \<alpha> N \<beta> \<Longrightarrow>
  \<alpha> = take i \<delta> \<and> \<alpha> = take i s \<and> length \<alpha> = i"
by (metis Derives1_split append_eq_conv_conj splits_at_def)

lemma LeftDerives1_splits_at_is_word: "LeftDerives1 \<delta> i r s \<Longrightarrow> splits_at \<delta> i \<alpha> N \<beta> \<Longrightarrow> is_word \<alpha>"
by (metis LeftDerives1_def leftmost_def splits_at_def)

lemma splits_at_\<beta>: "Derives1 \<delta> i r s \<Longrightarrow> splits_at \<delta> i \<alpha> N \<beta> \<Longrightarrow>
  \<beta> = drop (Suc i) \<delta> \<and> \<beta> = drop (i + length (snd r)) s \<and> length \<beta> = length \<delta> - i - 1"
by (metis Derives1_drop Suc_eq_plus1 diff_diff_left length_drop splits_at_def)

lemma Derives1_suffix:
  assumes ab: "Derives1 \<delta> i r (a@b)"
  assumes split: "splits_at \<delta> i \<alpha> N \<beta>"
  shows "is_suffix \<beta> b \<or> is_suffix b \<beta>"
proof -
  have drop1: "\<beta> = drop (i + length (snd r)) (a@b)" using ab split splits_at_\<beta> by blast
  have drop2: "b = drop (length a) (a@b)" by simp
  show ?thesis
  proof (cases "(i + length (snd r)) \<le> length a")
    case True
    with drop1 drop2 have "is_suffix b \<beta>" by (simp add: is_suffix_def)
    then show ?thesis by auto
  next
    case False
    then have "length a \<le> (i + length (snd r))" by arith
    with drop1 drop2 have "is_suffix \<beta> b"
      by (metis append_Nil append_take_drop_id drop_append drop_eq_Nil is_suffix_def)
    then show ?thesis by auto
  qed
qed

lemma Derives1_skip_prefix:
  "length a \<le> i \<Longrightarrow> Derives1 (a@b) i r (a@c) \<Longrightarrow> Derives1 b (i - length a) r c"
apply (auto simp add: Derives1_def)
by (metis append_eq_append_conv_if is_sentence_concat is_sentence_cons is_symbol_def
    length_drop rule_nonterminal_type)

lemma cancel_suffix:
  assumes "a @ c = b @ d"
  assumes "length c \<le> length d"
  shows "a = b @ (take (length d - length c) d)"
proof -
  have "a @ c = (b @ take (length d - length c) d) @ drop (length d - length c) d"
    by (metis append_assoc append_take_drop_id assms(1))
  then show ?thesis
    by (metis append_eq_append_conv assms(2) diff_diff_cancel length_drop)
qed

lemma is_sentence_take:
  "is_sentence y \<Longrightarrow> is_sentence (take n y)"
by (metis append_take_drop_id is_sentence_concat)

lemma Derives1_skip_suffix:
  assumes i: "i < length a"
  assumes D: "Derives1 (a@c) i r (b@c)"
  shows "Derives1 a i r b"
proof -
  note Derives1_def[where u="a@c" and v="b@c" and i=i and r=r]
  then have "\<exists>x y N \<alpha>.
    a @ c = x @ [N] @ y \<and>
    b @ c = x @ \<alpha> @ y \<and> is_sentence x \<and> is_sentence y \<and> (N, \<alpha>) \<in> \<RR> \<and> r = (N, \<alpha>) \<and> i = length x"
    using D by blast
  then obtain x y N \<alpha> where split:
    "a @ c = x @ [N] @ y \<and>
     b @ c = x @ \<alpha> @ y \<and> is_sentence x \<and> is_sentence y \<and> (N, \<alpha>) \<in> \<RR> \<and> r = (N, \<alpha>) \<and> i = length x"
     by blast
  from split have "length (a@c) = length (x @ [N] @ y)" by auto
  then have "length a + length c = length x + length y + 1" by simp
  with split have "length a + length c = i + length y + 1" by simp
  with i have len_c_y: "length c \<le> length y" by arith
  let ?y = "take (length y - length c) y"
  from split have ac: "a @ c = (x @ [N]) @ y" by auto
  note cancel_suffix[where a=a and c = c and b = "x@[N]" and d = "y", OF ac len_c_y]
  then have a: "a = x @ [N] @ ?y" by auto
  from split have bc: "b @ c = (x @ \<alpha>) @ y" by auto
  note cancel_suffix[where a=b and c = c and b = "x@\<alpha>" and d = "y", OF bc len_c_y]
  then have b: "b = x @ \<alpha> @ ?y" by auto
  from split len_c_y a b show ?thesis
    apply (simp only: Derives1_def)
    apply (rule_tac x=x in exI)
    apply (rule_tac x="?y" in exI)
    apply (rule_tac x="N" in exI)
    apply (rule_tac x="\<alpha>" in exI)
    apply auto
    by (rule is_sentence_take)
qed

lemma drop_cancel_suffix: "a@c = drop n (b@c) \<Longrightarrow> a = drop n b"
proof -
  assume a1: "a @ c = drop n (b @ c)"
  have "length (drop n b) = length b + length c - n - length c"
    by (metis add_diff_cancel_right' diff_commute length_drop)
  then show ?thesis
    using a1 by (metis add_diff_cancel_right' append_eq_append_conv drop_append
      length_append length_drop)
qed

lemma drop_keep_last: "u \<noteq> [] \<Longrightarrow> u = drop n (a@[X]) \<Longrightarrow> u = drop n a @ [X]"
by (metis append_take_drop_id drop_butlast last_appendR snoc_eq_iff_butlast)

lemma Derives1_X_is_part_of_rule[consumes 2, case_names Suffix Prefix]:
  assumes aXb: "Derives1 \<delta> i r (a@[X]@b)"
  assumes split: "splits_at \<delta> i \<alpha> N \<beta>"
  assumes prefix: "\<And> \<beta>. \<delta> = a @ [X] @ \<beta> \<Longrightarrow> length a < i \<Longrightarrow>
                     Derives1 \<beta> (i - length a - 1) r b \<Longrightarrow> False"
  assumes suffix: "\<And> \<alpha>. \<delta> = \<alpha> @ [X] @ b \<Longrightarrow> Derives1 \<alpha> i r a \<Longrightarrow> False"
  shows "\<exists> u v. a = \<alpha> @ u \<and> b = v @ \<beta> \<and> (snd r) = u@[X]@v"
proof -
  have prefix_or: "is_prefix \<alpha> a \<or> is_proper_prefix a \<alpha>"
    by (metis Derives1_prefix split aXb is_prefix_eq_proper_prefix)
  have "is_proper_prefix a \<alpha> \<Longrightarrow> False"
  proof -
    assume proper:"is_proper_prefix a \<alpha>"
    then have "\<exists> u. u \<noteq> [] \<and> \<alpha> = a@u" by (metis is_proper_prefix_def)
    then obtain u where u: "u \<noteq> [] \<and> \<alpha> = a@u" by blast
    note splits_at = splits_at_\<alpha>[OF aXb split] splits_at_combine[OF split]
    from splits_at have \<alpha>1: "\<alpha> = take i \<delta>" by blast
    from splits_at have \<alpha>2: "\<alpha> = take i (a@[X]@b)" by blast
    from splits_at have len\<alpha>: "length \<alpha> = i" by blast
    with proper have lena: "length a < i"
      using append_eq_conv_conj drop_eq_Nil leI u by auto
    from u \<alpha>2 have "a@u = take i (a@[X]@b)" by auto
    with lena have "u = take (i - length a) ([X]@b)" by (simp add: less_or_eq_imp_le)
    with lena have uX: "u = [X]@(take (i - length a - 1) b)" by (simp add: not_less take_Cons')
    let ?\<beta> = "(take (i - length a - 1) b) @ [N] @ \<beta>"
    from splits_at have f1: "\<delta> = \<alpha> @ [N] @ \<beta>" by blast
    with u uX have f2: "\<delta> = a @ [X] @ ?\<beta>" by simp
    note skip = Derives1_skip_prefix[where a = "a @ [X]" and b = "?\<beta>" and
      r = r and i = i and c = b]
    then have D: "Derives1 ?\<beta> (i - length a - 1) r b"
      using One_nat_def Suc_leI aXb append_assoc diff_diff_left f2 lena length_Cons
        length_append length_append_singleton list.size(3) by fastforce
    note prefix[OF f2 lena D]
    then show "False" .
  qed
  with prefix_or have is_prefix: "is_prefix \<alpha> a" by blast

  from aXb have aXb': "Derives1 \<delta> i r ((a@[X])@b)" by auto
  note  Derives1_suffix[OF aXb' split]
  then have suffix_or: "is_suffix \<beta> b \<or> is_proper_suffix b \<beta>"
    by (metis is_suffix_eq_proper_suffix)
  have "is_proper_suffix b \<beta> \<Longrightarrow> False"
  proof -
    assume proper: "is_proper_suffix b \<beta>"
    then have "\<exists> u. u \<noteq> [] \<and> \<beta> = u@b" by (metis is_proper_suffix_def)
    then obtain u where u: "u \<noteq> [] \<and> \<beta> = u@b" by blast
    note splits_at = splits_at_\<beta>[OF aXb split] splits_at_combine[OF split]
    from splits_at have \<beta>1: "\<beta> = drop (Suc i) \<delta>" by blast
    from splits_at have \<beta>2: "\<beta> = drop (i + length (snd r)) (a @ [X] @ b)" by blast
    from splits_at have len\<beta>: "length \<beta> = length \<delta> - i - 1" by blast
    with proper have lenb: "length b < length \<beta>" by (metis is_proper_suffix_length_cmp)
    from u \<beta>2 have "u@b = drop (i + length (snd r)) ((a @ [X]) @ b)" by auto
    hence "u = drop (i + length (snd r)) (a @ [X])"
      by (metis drop_cancel_suffix)
    hence uX: "u = drop (i + length (snd r)) a @ [X]" by (metis drop_keep_last u)
    let ?\<alpha> = "\<alpha> @ [N] @ (drop (i + length (snd r)) a)"
    from splits_at have f1: "\<delta> = \<alpha> @ [N] @ \<beta>" by blast
    with u uX have f2: "\<delta> = ?\<alpha> @ [X] @ b" by simp
    note skip = Derives1_skip_suffix[where a = "?\<alpha>" and c = "[X]@b" and b="a" and
      r = r and i = i]
    have f3: "i < length (\<alpha> @ [N] @ drop (i + length (snd r)) a)"
    proof -
      have f1: "1 + i + length b = length [X] + length b + i"
        by (metis Groups.add_ac(2) Suc_eq_plus1_left length_Cons list.size(3) list.size(4) semiring_normalization_rules(22))
      have f2: "length \<delta> - i - 1 = length ((\<alpha> @ [N] @ drop (i + length (snd r)) a) @ [X] @ b) - Suc i"
        by (metis f2 length_drop splits_at(1))
      have "length ([]::symbol list) \<noteq> length \<delta> - i - 1 - length b"
        by (metis add_diff_cancel_right' append_Nil2 append_eq_append_conv len\<beta> length_append u)
      then have "length ([]::symbol list) \<noteq> length \<alpha> + length ([N] @ drop (i + length (snd r)) a) - i"
        using f2 f1 by (metis Suc_eq_plus1_left add_diff_cancel_right' diff_diff_left length_append)
      then show ?thesis
        by auto
    qed
    from aXb f2 have D: "Derives1 (?\<alpha> @ [X] @ b) i r (a@[X]@b)" by auto
    note skip[OF f3 D]
    note suffix[OF f2  skip[OF f3 D]]
    then show "False" .
  qed
  with suffix_or have is_suffix: "is_suffix \<beta> b" by blast

  from is_prefix have "\<exists> u. a = \<alpha> @ u" by (auto simp add: is_prefix_def)
  then obtain u where u: "a = \<alpha> @ u" by blast
  from is_suffix have "\<exists> v. b = v @ \<beta>" by (auto simp add: is_suffix_def)
  then obtain v where v: "b = v @ \<beta>" by blast

  from u v splits_at_combine[OF split] aXb have D:"Derives1 (\<alpha>@[N]@\<beta>) i r (\<alpha>@(u@[X]@v)@\<beta>)"
    by simp
  from splits_at_\<alpha>[OF aXb split] have i: "length \<alpha> = i" by blast
  from i have i1: "length \<alpha> \<le> i" and i2: "i \<le> length \<alpha>" by auto
  note Derives1_skip_suffix[OF _ Derives1_skip_prefix[OF i1 D], simplified, OF i2]
  then have "Derives1 [N] 0 r (u @ [X] @ v)" by auto
  then have r: "snd r = u @ [X] @ v"
    by (metis Derives1_split append_Cons append_Nil length_0_conv list.inject self_append_conv)

  show ?thesis using u v r by auto
qed

lemma \<L>\<^sub>P_derives: "a \<in> \<L>\<^sub>P \<Longrightarrow> \<exists> b. derives [\<SS>] (a@b)"
by (simp add: \<L>\<^sub>P_def is_derivation_def)

lemma \<L>\<^sub>P_leftderives: "a \<in> \<L>\<^sub>P \<Longrightarrow> \<exists> b. leftderives [\<SS>] (a@b)"
by (metis \<L>\<^sub>P_derives \<L>\<^sub>P_is_word derives_implies_leftderives_gen)

lemma Derives1_rule: "Derives1 a i r b \<Longrightarrow> r \<in> \<RR>"
  by (auto simp add: Derives1_def)

lemma is_prefix_empty[simp]: "is_prefix [] a"
  by (simp add: is_prefix_def)

lemma is_prefix_cons: "is_prefix (x # a) b = (\<exists> c. b = x # c \<and> is_prefix a c)"
  by (metis append_Cons is_prefix_def)

lemma is_prefix_cancel[simp]: "is_prefix (a@b) (a@c) = is_prefix b c"
  by (metis append_assoc is_prefix_def same_append_eq)

lemma is_prefix_chars: "is_prefix a b \<Longrightarrow> is_prefix (chars a) (chars b)"
proof (induct a arbitrary: b)
  case Nil thus ?case by simp
next
  case (Cons x a)
  from Cons(2) have "\<exists> c. b = x # c \<and> is_prefix a c"
    by (simp add: is_prefix_cons)
  then obtain c where c: "b = x # c \<and> is_prefix a c" by blast
  from c Cons(1) show ?case by simp
qed

lemma is_prefix_length: "is_prefix a b \<Longrightarrow> length a \<le> length b"
by (auto simp add: is_prefix_def)

lemma is_prefix_take[simp]: "is_prefix (take n a) a"
apply (auto simp add: is_prefix_def)
apply (rule_tac x="drop n a" in exI)
by simp

lemma doc_tokens_length: "doc_tokens p \<Longrightarrow> length (chars p) \<le> length Doc"
by (metis doc_tokens_def is_prefix_length)

fun count_terminals :: "sentence \<Rightarrow> nat" where
  "count_terminals [] = 0"
| "count_terminals (x#xs) = (if (is_terminal x) then Suc (count_terminals xs) else (count_terminals xs))"

lemma count_terminals_upper_bound: "count_terminals p \<le> length p"
  by (induct p, auto)

lemma count_terminals_append[simp]: "count_terminals (a@b) = count_terminals a + count_terminals b"
  by (induct a arbitrary: b, auto)

lemma Derives1_count_terminals:
  assumes D: "Derives1 a i r b"
  shows "count_terminals b = count_terminals a + count_terminals (snd r)"
proof -
  have "\<exists> \<alpha> N \<beta>. splits_at a i \<alpha> N \<beta>" using D splits_at_ex by simp
  then obtain \<alpha> N \<beta> where split: "splits_at a i \<alpha> N \<beta>" by blast
  from D split have N: "is_nonterminal N" by (simp add: Derives1_nonterminal)
  have a: "a = \<alpha> @ [N] @ \<beta>" by (metis split splits_at_combine)
  from D split have b: "b = \<alpha> @ (snd r) @ \<beta>" using splits_at_combine_dest by simp
  show ?thesis
    apply (simp add: a b)
    using N by (metis is_terminal_nonterminal)
qed

lemma Derives1_count_terminals_leq:
  assumes D: "Derives1 a i r b"
  shows "count_terminals a \<le> count_terminals b"
by (metis Derives1_count_terminals assms le_less_linear not_add_less1)

lemma Derivation_count_terminals_leq:
  "Derivation a E b \<Longrightarrow> count_terminals a \<le> count_terminals b"
proof (induct E arbitrary: a)
  case Nil thus ?case by auto
next
  case (Cons e E)
  then have "\<exists> x i r. Derives1 a i r x \<and> Derivation x E b" using Derivation.simps(2) by blast
  then obtain x i r where axb: "Derives1 a i r x \<and> Derivation x E b" by blast
  from axb have ax: "count_terminals a \<le> count_terminals x"
    using Derives1_count_terminals_leq by blast
  from axb have xb: "count_terminals x \<le> count_terminals b" using Cons by simp
  show ?case using ax xb by arith
qed

lemma derives_count_terminals_leq: "derives a b \<Longrightarrow> count_terminals a \<le> count_terminals b"
using Derivation_count_terminals_leq derives_implies_Derivation by force

lemma is_word_cons[simp]: "is_word (x#xs) = (is_terminal x \<and> is_word xs)"
  by (simp add: is_word_def)

lemma count_terminals_of_word: "is_word w \<Longrightarrow> count_terminals w = length w"
  by (induct w, auto)

lemma length_terminals[simp]: "length (terminals p) = length p"
  by (auto simp add: terminals_def)

lemma path_length_is_upper_bound:
  assumes p: "wellformed_tokens p"
  assumes \<alpha>: "is_word \<alpha>"
  assumes derives: "derives (\<alpha>@u) (terminals p)"
  shows "length \<alpha> \<le> length p"
proof -
  have counts: "count_terminals \<alpha> \<le> count_terminals (terminals p)"
    using derives derives_count_terminals_leq by fastforce
  have len1: "length \<alpha> = count_terminals \<alpha>" by (simp add: \<alpha> count_terminals_of_word)
  have len2: "length (terminals p) = count_terminals (terminals p)"
    by (simp add: count_terminals_of_word is_word_terminals p)
  show ?thesis using counts len1 len2 by auto
qed

lemma is_word_Derives1_index:
  assumes w: "is_word w"
  assumes derives1: "Derives1 (w@a) i r b"
  shows "i \<ge> length w"
proof -
  from derives1 have n: "is_nonterminal ((w@a) ! i)"
    using Derives1_nonterminal splits_at_def splits_at_ex by auto
  from w have t: "i < length w \<Longrightarrow> is_terminal ((w@a) ! i)"
    by (simp add: is_word_is_terminal nth_append)
  show ?thesis
    by (metis t n is_terminal_nonterminal less_le_not_le nat_le_linear)
qed

lemma is_word_Derivation_derivation_ge:
  assumes w: "is_word w"
  assumes D: "Derivation (w@a) D b"
  shows "derivation_ge D (length w)"
by (metis D Derivation_leftmost derivation_ge_empty leftmost_Derivation leftmost_append w)

lemma derives_word_is_prefix:
  assumes w: "is_word w"
  assumes derives: "derives (w@a) b"
  shows "is_prefix w b"
by (metis Derivation_take append_eq_conv_conj derives derives_implies_Derivation
    is_prefix_take is_word_Derivation_derivation_ge w)

lemma terminals_take[simp]: "terminals (take n p) = take n (terminals p)"
by (simp add: take_map terminals_def)

lemma terminals_drop[simp]: "terminals (drop n p) = drop n (terminals p)"
by (simp add: drop_map terminals_def)

lemma take_prefix[simp]: "is_prefix a b \<Longrightarrow> take (length a) b = a"
by (metis append_eq_conv_conj is_prefix_unsplit)

lemma Derives1_drop_prefixword:
  assumes w: "is_word w"
  assumes wa_b: "Derives1 (w@a) i r b"
  shows "Derives1 a (i - length w) r (drop (length w) b)"
proof -
  have i: "length w \<le> i" using wa_b is_word_Derives1_index w by blast
  have "is_prefix w b" by (metis append_eq_conv_conj i is_prefix_take le_Derives1_take wa_b)
  then have b: "b = w @ (drop (length w) b)" by (simp add: is_prefix_unsplit)
  show ?thesis
    apply (rule_tac Derives1_skip_prefix[OF i])
    by (simp add: b[symmetric] wa_b)
qed

lemma derives1_drop_prefixword:
  assumes w: "is_word w"
  assumes wa_b: "derives1 (w@a) b"
  shows "derives1 a (drop (length w) b)"
by (metis Derives1_drop_prefixword Derives1_implies_derives1 derives1_implies_Derives1 w wa_b)

lemma derives1_is_word_is_prefix_drop:
  assumes w: "is_word w"
  assumes w_a: "is_prefix w a"
  assumes ab: "derives1 a b"
  shows "derives1 (drop (length w) a) (drop (length w) b)"
by (metis ab append_take_drop_id derives1_drop_prefixword take_prefix w w_a)

lemma derives_drop_prefixword_helper:
  "derives a b \<Longrightarrow> is_word w \<Longrightarrow> is_prefix w a \<Longrightarrow> derives (drop (length w) a) (drop (length w) b)"
proof (induct rule: derives_induct)
  case Base thus ?case by auto
next
  case (Step y z)
  have is_prefix_w_y: "is_prefix w y"
    by (metis Step.hyps(1) Step.prems(1) Step.prems(2) derives_word_is_prefix is_prefix_def)
  thus ?case
    by (metis Step.hyps(2) Step.hyps(3) Step.prems(1) Step.prems(2) derives1_implies_derives
        derives1_is_word_is_prefix_drop derives_trans)
qed

lemma derive_drop_prefixword:
  "is_word w \<Longrightarrow> derives (w@a) b \<Longrightarrow> derives a (drop (length w) b)"
by (metis append_eq_conv_conj derives_drop_prefixword_helper is_prefix_take)

lemma thmD2':
  assumes X: "is_terminal X"
  assumes p: "doc_tokens p"
  assumes pX: "(terminals p)@[X] \<in> \<L>\<^sub>P"
  shows "\<exists> x. pvalid p x \<and> next_symbol x = Some X"
proof -
  from p have wellformed_p: "wellformed_tokens p" by (simp add: doc_tokens_def)
  have "\<exists> \<omega>. leftderives [\<SS>] (((terminals p)@[X]) @ \<omega>)" using \<L>\<^sub>P_leftderives pX by blast
  then obtain \<omega> where "leftderives [\<SS>] (((terminals p)@[X]) @ \<omega>)" by blast
  then have "\<exists> D. LeftDerivation [\<SS>] D (((terminals p)@[X]) @ \<omega>)"
    using leftderives_implies_LeftDerivation by blast
  then obtain D where D: "LeftDerivation [\<SS>] D (((terminals p)@[X]) @ \<omega>)" by blast
  let ?P = "\<lambda> k. (\<exists> a b. LeftDerivation [\<SS>] (take k D) (a@[X]@b) \<and> derives a (terminals p))"
  have "?P (length D)"
    apply (rule_tac x="terminals p" in exI)
    apply (rule_tac x="\<omega>" in exI)
    using D by simp
  then show ?thesis
  proof (induct rule: minimal_witness[where P="?P"])
    case (Minimal K)
    from Minimal(2) obtain a b where
       aXb: "LeftDerivation [\<SS>] (take K D) (a @ [X] @ b)" and
       a: "derives a (terminals p)" by blast
    have KD: "K > 0 \<and> length D > 0"
    proof (cases "K = 0 \<or> length D = 0")
      case True
        hence "take K D = []" by auto
        with True aXb have "[\<SS>] = a @ [X] @ b" by simp
        hence "\<SS> = X"
          by (metis Nil_is_append_conv append_self_conv2 butlast.simps(2)
              butlast_append hd_append2 list.sel(1) not_Cons_self2)
        then have "False"
          using X is_nonterminal_startsymbol is_terminal_nonterminal by auto
        then show ?thesis by blast
    next
      case False thus ?thesis by arith
    qed
    then have "take K D = take (K - 1) D @ [D ! (K - 1)]"
      by (metis Minimal.hyps(1) One_nat_def Suc_less_eq Suc_pred hd_drop_conv_nth
          le_imp_less_Suc take_hd_drop)
    then have "\<exists> \<delta>. LeftDerivation [\<SS>] (take (K - 1) D) \<delta> \<and> LeftDerivation \<delta> [D ! (K - 1)] (a@[X]@b)"
      by (metis LeftDerivation_append aXb)
    then obtain \<delta> where
      \<delta>1: "LeftDerivation [\<SS>] (take (K - 1) D) \<delta>"
      and \<delta>2: "LeftDerivation \<delta> [D ! (K - 1)] (a@[X]@b)"
      by blast
    from \<delta>2 have "\<exists> i r. LeftDerives1 \<delta> i r (a@[X]@b)" by fastforce
    then obtain i r where LeftDerives1_\<delta>: "LeftDerives1 \<delta> i r (a@[X]@b)" by blast
    then have Derives1_\<delta>: "Derives1 \<delta> i r (a@[X]@b)"
      by (metis LeftDerives1_implies_Derives1)
    then have "\<exists> \<alpha> N \<beta> . splits_at \<delta> i \<alpha> N \<beta>" by (simp add: splits_at_ex)
    then obtain \<alpha> N \<beta> where split_\<delta>: "splits_at \<delta> i \<alpha> N \<beta>" by blast
    have is_word_\<alpha>: "is_word \<alpha>" by (metis LeftDerives1_\<delta> LeftDerives1_splits_at_is_word split_\<delta>)
    have "\<not> (?P (K - 1))" using KD Minimal(3) by auto
    with \<delta>1 have min_\<delta>: "\<not> (\<exists> a b. \<delta> = a@[X]@b \<and> derives a (terminals p))" by blast
    from Derives1_\<delta> split_\<delta> have "\<exists> u v. a = \<alpha> @ u \<and> b = v @ \<beta> \<and> (snd r) = u@[X]@v"
    proof (induction rule: Derives1_X_is_part_of_rule)
      case (Suffix \<gamma>)
        from min_\<delta> Suffix(1) a show ?case by auto
    next
      case (Prefix \<gamma>)
        have "derives \<gamma> (terminals p)"
          by (metis Derives1_implies_derives1 Prefix(2) a
              derives1_implies_derives derives_trans)
        with min_\<delta> Prefix(1) show ?case by auto
    qed
    then obtain u v where uXv: "a = \<alpha> @ u \<and> b = v @ \<beta> \<and> (snd r) = u@[X]@v" by blast
    let ?l = "length \<alpha>"
    let ?q = "take ?l p"
    let ?x = "Item r (length u) (charslength ?q) (charslength p)"
    have "item_rhs ?x = snd r" by (simp add: item_rhs_def)
    then have item_rhs_x: "item_rhs ?x = u@[X]@v" using uXv by simp
    have wellformed_x: "wellformed_item ?x"
      apply (auto simp add: wellformed_item_def)
      apply (metis Derives1_\<delta> Derives1_rule)
      apply (rule is_prefix_length)
      apply (rule is_prefix_chars)
      apply simp
      apply (simp add: doc_tokens_length[OF p])
      using item_rhs_x by simp
    from item_rhs_x have next_symbol_x: "next_symbol ?x = Some X"
      by (auto simp add: next_symbol_def is_complete_def)
    have len_\<alpha>_p: "length \<alpha> \<le> length p"
      apply (rule_tac path_length_is_upper_bound[where u=u])
      apply (simp add: wellformed_p)
      apply (simp add: is_word_\<alpha>)
      using a uXv by blast
    have item_nonterminal_x: "item_nonterminal ?x = N"
      apply (simp add: item_nonterminal_def)
      using Derives1_\<delta> Derives1_nonterminal split_\<delta> by blast
    have take_terminals: "take (length \<alpha>) (terminals p) = \<alpha>"
      apply (rule_tac take_prefix)
      using a derives_word_is_prefix is_word_\<alpha> uXv by blast
    have item_\<alpha>_x: "item_\<alpha> ?x = u" using item_\<alpha>_def item_rhs_x by auto
    from wellformed_x next_symbol_x len_\<alpha>_p show ?thesis
      apply (rule_tac x="?x" in exI)
      apply (auto simp add: pvalid_def wellformed_p)
      apply (rule_tac x="length \<alpha>" in exI)
      apply (auto)
      using item_nonterminal_x apply (simp)
      apply (simp add: take_terminals)
      apply (rule_tac x="\<beta>" in exI)
      using LeftDerivation_implies_leftderives \<delta>1 is_leftderivation_def split_\<delta> splits_at_combine
      apply auto[1]
      using item_\<alpha>_x apply simp
      by (metis a derive_drop_prefixword is_word_\<alpha> uXv)
  qed
qed

lemma admissible_wellformed_tokens: "admissible p \<Longrightarrow> wellformed_tokens p"
  by (auto simp add: admissible_def \<L>\<^sub>P_wellformed_tokens)

lemma chars_append[simp]: "chars (a@b) = (chars a)@(chars b)"
  by (induct a arbitrary: b, auto)

lemma chars_of_token_simp[simp]: "chars_of_token (a, b) = b"
  by (simp add: chars_of_token_def)

lemma is_prefix_append: "is_prefix (a@b) D = (is_prefix a D \<and> is_prefix b (drop (length a) D))"
  by (metis append_assoc is_prefix_cancel is_prefix_def is_prefix_unsplit)

lemma \<PP>_are_doc_tokens: "p \<in> \<PP> \<Longrightarrow> doc_tokens p"
proof (induct rule: \<PP>_induct)
  case Base thus ?case
    by (simp add: doc_tokens_def wellformed_tokens_def)
next
  case (Induct p k u)
  from Induct(2)[simplified] show ?case
  proof (induct rule: limit_induct)
    case (Init p) from Induct(1)[OF Init] show ?case .
  next
    case (Iterate p Y)
    have Y_is_prefix: "\<And> p. p \<in> Y \<Longrightarrow> is_prefix (chars p) Doc"
      apply (drule Iterate(1))
      by (simp add: doc_tokens_def)
    have "\<Y> (\<Z> k u) (\<P> k u) k \<subseteq> \<X> k" by (metis \<Z>.simps(2) \<Z>_subset_\<X>)
    then have 1: "Append (\<Y> (\<Z> k u) (\<P> k u) k) k Y \<subseteq> Append (\<X> k) k Y"
      by (rule Append_mono, simp)
    have 2: "p \<in> Append (\<X> k) k Y \<Longrightarrow> doc_tokens p"
      apply (auto simp add: Append_def)
      apply (simp add: Iterate)
      apply (auto simp add: doc_tokens_def admissible_wellformed_tokens
             is_prefix_append Y_is_prefix)
      by (metis \<X>_is_prefix snd_conv)
    show ?case
      apply (rule 2)
      by (metis (mono_tags, lifting) "1" Iterate(2) subsetCE)
  qed
qed

theorem thmD2:
  assumes X: "is_terminal X"
  assumes p: "p \<in> \<PP>"
  assumes pX: "(terminals p)@[X] \<in> \<L>\<^sub>P"
  shows "\<exists> x. pvalid p x \<and> next_symbol x = Some X"
by (metis X \<PP>_are_doc_tokens p pX thmD2')

end

end


section {* Substitution *}

theory utp_subst
imports
  utp_expr
  utp_unrest
begin

subsection {* Substitution definitions *}

text {* Variable substitution, like unrestriction, will be characterised semantically using lenses
  and state-spaces. Effectively a substitution $\sigma$ is simply a function on the state-space which
  can be applied to an expression $e$ using the syntax $\sigma \mathop{\dagger} e$.  We introduce
  a polymorphic constant that will be used to represent application of a substitution, and also a
  set of theorems to represent laws. *}

consts
  usubst :: "'s \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "\<dagger>" 80)

named_theorems usubst

text {* A substitution is simply a transformation on the alphabet; it shows how variables
  should be mapped to different values. Most of the time these will be homogeneous functions
  but for flexibility we also allow some operations to be heterogeneous. *}

type_synonym ('\<alpha>,'\<beta>) psubst = "'\<alpha> \<Rightarrow> '\<beta>"
type_synonym '\<alpha> usubst = "'\<alpha> \<Rightarrow> '\<alpha>"

text {* Application of a substitution simply applies the function $\sigma$ to the state binding
  $b$ before it is handed to $e$ as an input. This effectively ensures all variables are updated
  in $e$. *}

lift_definition subst :: "('\<alpha>, '\<beta>) psubst \<Rightarrow> ('a, '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" is
"\<lambda> \<sigma> e b. e (\<sigma> b)" .

adhoc_overloading
  usubst subst

text {* Substitutions can be updated by associating variables with expressions. We thus create an
  additional polymorphic constant to represent updating the value of a variable to an expression
  in a substitution, where the variable is modelled by type @{typ "'v"}. This again allows us
  to support different notions of variables, such as deep variables, later. *}

consts subst_upd :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> 'v \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst"

text {* The following function takes a substitution form state-space @{typ "'\<alpha>"} to @{typ "'\<beta>"}, a
  lens with source @{typ "'\<beta>"} and view "'a", and an expression over @{typ "'\<alpha>"} and returning
  a value of type "@{typ "'a"}, and produces an updated substitution. It does this by constructing
  a substitution function that takes state binding $b$, and updates the state first by applying
  the original substitution $\sigma$, and then updating the part of the state associated with lens
  $x$ with expression evaluated in the context of $b$. This effectively means that $x$ is now
  associated with expression $v$. We add this definition to our overloaded constant. *}

definition subst_upd_uvar :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst" where
"subst_upd_uvar \<sigma> x v = (\<lambda> b. put\<^bsub>x\<^esub> (\<sigma> b) (\<lbrakk>v\<rbrakk>\<^sub>eb))"

adhoc_overloading
  subst_upd subst_upd_uvar

text {* The next function looks up the expression associated with a variable in a substitution
  by use of the \emph{get} lens function. *}

lift_definition usubst_lookup :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<langle>_\<rangle>\<^sub>s")
is "\<lambda> \<sigma> x b. (get\<^bsub>x\<^esub> (\<sigma> b))" .

text {* Substitutions also exhibit a natural notion of unrestriction which states that $\sigma$
  does not restrict $x$ if application of $\sigma$ to an arbitrary state $\rho$ will not effect
  the valuation of $x$. Put another way, it requires that \emph{put} and the substitution commute. *}

definition unrest_usubst :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> usubst \<Rightarrow> bool"
where "unrest_usubst x \<sigma> = (\<forall> \<rho> v. \<sigma> (put\<^bsub>x\<^esub> \<rho> v) = put\<^bsub>x\<^esub> (\<sigma> \<rho>) v)"

adhoc_overloading
  unrest unrest_usubst

text {* Parallel substitutions allow us to divide the state space into three segments using two
  lens, A and B. They correspond to the part of the state that should be updated by the
  respective substitution. The two lenses should be independent. If any part of the state
  is not covered by either lenses then this area is left unchanged (framed). *}

definition par_subst :: "'\<alpha> usubst \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> usubst" where
"par_subst \<sigma>\<^sub>1 A B \<sigma>\<^sub>2 = (\<lambda> s. (s \<oplus>\<^sub>L (\<sigma>\<^sub>1 s) on A) \<oplus>\<^sub>L (\<sigma>\<^sub>2 s) on B)"

subsection {* Syntax translations *}

text {* We support two kinds of syntax for substitutions, one where we construct a substitution
  using a maplet-style syntax, with variables mapping to expressions. Such a constructed substitution
  can be applied to an expression. Alternatively, we support the more traditional notation,
  $P \llbracket v / x \rrbracket$, which also support multiple simultaneous substitutions. We
  have to use double square brackets as the single ones are already well used.

  We set up non-terminals to represent a single substitution maplet, a sequence of maplets, a
  list of expressions, and a list of alphabets. The parser effectively uses @{term subst_upd}
  to construct substitutions from multiple variables.
*}

nonterminal smaplet and smaplets and uexprs and salphas

syntax
  "_smaplet"  :: "[salpha, 'a] => smaplet"             ("_ /\<mapsto>\<^sub>s/ _")
  ""          :: "smaplet => smaplets"            ("_")
  "_SMaplets" :: "[smaplet, smaplets] => smaplets" ("_,/ _")
  "_SubstUpd" :: "['m usubst, smaplets] => 'm usubst" ("_/'(_')" [900,0] 900)
  "_Subst"    :: "smaplets => 'a \<rightharpoonup> 'b"            ("(1[_])")
  "_psubst"  :: "[logic, svars, uexprs] \<Rightarrow> logic"
  "_subst"   :: "logic \<Rightarrow> uexprs \<Rightarrow> salphas \<Rightarrow> logic" ("(_\<lbrakk>_'/_\<rbrakk>)" [990,0,0] 991)
  "_uexprs"  :: "[logic, uexprs] => uexprs" ("_,/ _")
  ""         :: "logic => uexprs" ("_")
  "_salphas" :: "[salpha, salphas] => salphas" ("_,/ _")
  ""         :: "salpha => salphas" ("_")
  "_par_subst" :: "logic \<Rightarrow> salpha \<Rightarrow> salpha \<Rightarrow> logic \<Rightarrow> logic" ("_ [_|_]\<^sub>s _" [100,0,0,101] 101)

translations
  "_SubstUpd m (_SMaplets xy ms)"     == "_SubstUpd (_SubstUpd m xy) ms"
  "_SubstUpd m (_smaplet x y)"        == "CONST subst_upd m x y"
  "_Subst ms"                         == "_SubstUpd (CONST id) ms"
  "_Subst (_SMaplets ms1 ms2)"        <= "_SubstUpd (_Subst ms1) ms2"
  "_SMaplets ms1 (_SMaplets ms2 ms3)" <= "_SMaplets (_SMaplets ms1 ms2) ms3"
  "_subst P es vs" => "CONST subst (_psubst (CONST id) vs es) P"
  "_psubst m (_salphas x xs) (_uexprs v vs)" => "_psubst (_psubst m x v) xs vs"
  "_psubst m x v"  => "CONST subst_upd m x v"
  "P\<lbrakk>v/$x\<rbrakk>" <= "CONST usubst (CONST subst_upd (CONST id) (CONST ivar x) v) P"
  "P\<lbrakk>v/$x\<acute>\<rbrakk>" <= "CONST usubst (CONST subst_upd (CONST id) (CONST ovar x) v) P"
  "P\<lbrakk>v/x\<rbrakk>" <= "CONST usubst (CONST subst_upd (CONST id) x v) P"
  "_par_subst \<sigma>\<^sub>1 A B \<sigma>\<^sub>2" == "CONST par_subst \<sigma>\<^sub>1 A B \<sigma>\<^sub>2"

text {* Thus we can write things like @{term "\<sigma>(x \<mapsto>\<^sub>s v)"} to update a variable $x$ in $\sigma$ with
  expression $v$, @{term "[x \<mapsto>\<^sub>s e, y \<mapsto>\<^sub>s f]"} to construct a substitution with two variables,
  and finally @{term "P\<lbrakk>v/x\<rbrakk>"}, the traditional syntax.

  We can now express deletion of a substitution maplet. *}

definition subst_del :: "'\<alpha> usubst \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> usubst" (infix "-\<^sub>s" 85) where
"subst_del \<sigma> x = \<sigma>(x \<mapsto>\<^sub>s &x)"

subsection {* Substitution application laws *}

text {* We set up a simple substitution tactic that applies substitution and unrestriction laws *}

method subst_tac = (simp add: usubst unrest)?

text {* Evaluation of a substitution expression involves application of the substitution to different
  variables. Thus we first prove laws for these cases. The simplest substitution, $id$, when applied
  to any variable $x$ simply returns the variable expression, since $id$ has no effect. *}

lemma usubst_lookup_id [usubst]: "\<langle>id\<rangle>\<^sub>s x = var x"
  by (transfer, simp)

lemma subst_upd_id_lam [usubst]: "subst_upd (\<lambda> x. x) x v = subst_upd id x v"
  by (simp add: id_def)

text {* A substitution update naturally yields the given expression. *}

lemma usubst_lookup_upd [usubst]:
  assumes "mwb_lens x"
  shows "\<langle>\<sigma>(x \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x = v"
  using assms
  by (simp add: subst_upd_uvar_def, transfer) (simp)

lemma usubst_lookup_upd_pr_var [usubst]:
  assumes "mwb_lens x"
  shows "\<langle>\<sigma>(x \<mapsto>\<^sub>s v)\<rangle>\<^sub>s (pr_var x) = v"
  using assms
  by (simp add: subst_upd_uvar_def pr_var_def, transfer) (simp)

text {* Substitution update is idempotent. *}

lemma usubst_upd_idem [usubst]:
  assumes "mwb_lens x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, x \<mapsto>\<^sub>s v) = \<sigma>(x \<mapsto>\<^sub>s v)"
  by (simp add: subst_upd_uvar_def assms comp_def)

text {* Substitution updates commute when the lenses are independent. *}

lemma usubst_upd_comm:
  assumes "x \<bowtie> y"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v) = \<sigma>(y \<mapsto>\<^sub>s v, x \<mapsto>\<^sub>s u)"
  using assms
  by (rule_tac ext, auto simp add: subst_upd_uvar_def assms comp_def lens_indep_comm)

lemma usubst_upd_comm2:
  assumes "z \<bowtie> y" and "mwb_lens x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v, z \<mapsto>\<^sub>s s) = \<sigma>(x \<mapsto>\<^sub>s u, z \<mapsto>\<^sub>s s, y \<mapsto>\<^sub>s v)"
  using assms
  by (rule_tac ext, auto simp add: subst_upd_uvar_def assms comp_def lens_indep_comm)

lemma subst_upd_pr_var [usubst]:  "s(&x \<mapsto>\<^sub>s v) = s(x \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def)

text {* A substitution which swaps two independent variables is an injective function. *}

lemma swap_usubst_inj:
  fixes x y :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "inj [x \<mapsto>\<^sub>s &y, y \<mapsto>\<^sub>s &x]"
proof (rule injI)
  fix b\<^sub>1 :: '\<alpha> and b\<^sub>2 :: '\<alpha>
  assume "[x \<mapsto>\<^sub>s &y, y \<mapsto>\<^sub>s &x] b\<^sub>1 = [x \<mapsto>\<^sub>s &y, y \<mapsto>\<^sub>s &x] b\<^sub>2"
  hence a: "put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b\<^sub>1 (\<lbrakk>&y\<rbrakk>\<^sub>e b\<^sub>1)) (\<lbrakk>&x\<rbrakk>\<^sub>e b\<^sub>1) = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b\<^sub>2 (\<lbrakk>&y\<rbrakk>\<^sub>e b\<^sub>2)) (\<lbrakk>&x\<rbrakk>\<^sub>e b\<^sub>2)"
    by (auto simp add: subst_upd_uvar_def)
  then have "(\<forall>a b c. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> a b) c = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> a c) b) \<and>
             (\<forall>a b. get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> a b) = get\<^bsub>x\<^esub> a) \<and> (\<forall>a b. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> a b) = get\<^bsub>y\<^esub> a)"
    by (simp add: assms(3) lens_indep.lens_put_irr2 lens_indep_comm)
  then show "b\<^sub>1 = b\<^sub>2"
    by (metis  a assms(1) assms(2) pr_var_def var.rep_eq vwb_lens.source_determination vwb_lens_def wb_lens_def weak_lens.put_get)
qed

lemma usubst_upd_var_id [usubst]:
  "vwb_lens x \<Longrightarrow> [x \<mapsto>\<^sub>s var x] = id"
  apply (simp add: subst_upd_uvar_def)
  apply (transfer)
  apply (rule ext)
  apply (auto)
done

lemma usubst_upd_pr_var_id [usubst]:
  "vwb_lens x \<Longrightarrow> [x \<mapsto>\<^sub>s var (pr_var x)] = id"
  apply (simp add: subst_upd_uvar_def pr_var_def)
  apply (transfer)
  apply (rule ext)
  apply (auto)
done

lemma usubst_upd_comm_dash [usubst]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<sigma>($x\<acute> \<mapsto>\<^sub>s v, $x \<mapsto>\<^sub>s u) = \<sigma>($x \<mapsto>\<^sub>s u, $x\<acute> \<mapsto>\<^sub>s v)"
  using out_in_indep usubst_upd_comm by blast

lemma subst_upd_lens_plus [usubst]:
  "subst_upd \<sigma> (x +\<^sub>L y) \<guillemotleft>(u,v)\<guillemotright> = \<sigma>(y \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>, x \<mapsto>\<^sub>s \<guillemotleft>u\<guillemotright>)"
  by (simp add: lens_defs uexpr_defs subst_upd_uvar_def, transfer, auto)

lemma subst_upd_in_lens_plus [usubst]:
  "subst_upd \<sigma> (ivar (x +\<^sub>L y)) \<guillemotleft>(u,v)\<guillemotright> = \<sigma>($y \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>, $x \<mapsto>\<^sub>s \<guillemotleft>u\<guillemotright>)"
  by (simp add: lens_defs uexpr_defs subst_upd_uvar_def, transfer, auto simp add: prod.case_eq_if)

lemma subst_upd_out_lens_plus [usubst]:
  "subst_upd \<sigma> (ovar (x +\<^sub>L y)) \<guillemotleft>(u,v)\<guillemotright> = \<sigma>($y\<acute> \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>, $x\<acute> \<mapsto>\<^sub>s \<guillemotleft>u\<guillemotright>)"
  by (simp add: lens_defs uexpr_defs subst_upd_uvar_def, transfer, auto simp add: prod.case_eq_if)

lemma usubst_lookup_upd_indep [usubst]:
  assumes "mwb_lens x" "x \<bowtie> y"
  shows "\<langle>\<sigma>(y \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x = \<langle>\<sigma>\<rangle>\<^sub>s x"
  using assms
  by (simp add: subst_upd_uvar_def, transfer, simp)

text {* If a variable is unrestricted in a substitution then it's application has no effect. *}

lemma usubst_apply_unrest [usubst]:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s x = var x"
  by (simp add: unrest_usubst_def, transfer, auto simp add: fun_eq_iff, metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)

text {* There follows various laws about deleting variables from a substitution. *}

lemma subst_del_id [usubst]:
  "vwb_lens x \<Longrightarrow> id -\<^sub>s x = id"
  by (simp add: subst_del_def subst_upd_uvar_def pr_var_def, transfer, auto)

lemma subst_del_upd_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) -\<^sub>s x = \<sigma> -\<^sub>s x"
  by (simp add: subst_del_def subst_upd_uvar_def)

lemma subst_del_upd_diff [usubst]:
  "x \<bowtie> y \<Longrightarrow> \<sigma>(y \<mapsto>\<^sub>s v) -\<^sub>s x = (\<sigma> -\<^sub>s x)(y \<mapsto>\<^sub>s v)"
  by (simp add: subst_del_def subst_upd_uvar_def lens_indep_comm)

text {* If a variable is unrestricted in an expression, then any substitution of that variable
  has no effect on the expression .*}

lemma subst_unrest [usubst]: "x \<sharp> P \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> P = \<sigma> \<dagger> P"
  by (simp add: subst_upd_uvar_def, transfer, auto)

lemma subst_compose_upd [usubst]: "x \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<circ> \<rho>(x \<mapsto>\<^sub>s v) = (\<sigma> \<circ> \<rho>)(x \<mapsto>\<^sub>s v) "
  by (simp add: subst_upd_uvar_def, transfer, auto simp add: unrest_usubst_def)

text {* Any substitution is a monotonic function. *}

lemma subst_mono: "mono (subst \<sigma>)"
  by (simp add: less_eq_uexpr.rep_eq mono_def subst.rep_eq)

subsection {* Substitution laws *}

text {* We now prove the key laws that show how a substitution should be performed for every
  expression operator, including the core function operators, literals, variables, and the
  arithmetic operators. They are all added to the \emph{usubst} theorem attribute so that
  we can apply them using the substitution tactic. *}

lemma id_subst [usubst]: "id \<dagger> v = v"
  by (transfer, simp)

lemma subst_lit [usubst]: "\<sigma> \<dagger> \<guillemotleft>v\<guillemotright> = \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

lemma subst_var [usubst]: "\<sigma> \<dagger> var x = \<langle>\<sigma>\<rangle>\<^sub>s x"
  by (transfer, simp)

lemma usubst_ulambda [usubst]: "\<sigma> \<dagger> (\<lambda> x \<bullet> P(x)) = (\<lambda> x \<bullet> \<sigma> \<dagger> P(x))"
  by (transfer, simp)

lemma unrest_usubst_del [unrest]: "\<lbrakk> vwb_lens x; x \<sharp> (\<langle>\<sigma>\<rangle>\<^sub>s x); x \<sharp> \<sigma> -\<^sub>s x \<rbrakk> \<Longrightarrow>  x \<sharp> (\<sigma> \<dagger> P)"
  by (simp add: subst_del_def subst_upd_uvar_def unrest_uexpr_def unrest_usubst_def subst.rep_eq usubst_lookup.rep_eq)
     (metis vwb_lens.put_eq)

text {* We add the symmetric definition of input and output variables to substitution laws
        so that the variables are correctly normalised after substitution. *}

lemma subst_uop [usubst]: "\<sigma> \<dagger> uop f v = uop f (\<sigma> \<dagger> v)"
  by (transfer, simp)

lemma subst_bop [usubst]: "\<sigma> \<dagger> bop f u v = bop f (\<sigma> \<dagger> u) (\<sigma> \<dagger> v)"
  by (transfer, simp)

lemma subst_trop [usubst]: "\<sigma> \<dagger> trop f u v w = trop f (\<sigma> \<dagger> u) (\<sigma> \<dagger> v) (\<sigma> \<dagger> w)"
  by (transfer, simp)

lemma subst_qtop [usubst]: "\<sigma> \<dagger> qtop f u v w x = qtop f (\<sigma> \<dagger> u) (\<sigma> \<dagger> v) (\<sigma> \<dagger> w) (\<sigma> \<dagger> x)"
  by (transfer, simp)

lemma subst_plus [usubst]: "\<sigma> \<dagger> (x + y) = \<sigma> \<dagger> x + \<sigma> \<dagger> y"
  by (simp add: plus_uexpr_def subst_bop)

lemma subst_times [usubst]: "\<sigma> \<dagger> (x * y) = \<sigma> \<dagger> x * \<sigma> \<dagger> y"
  by (simp add: times_uexpr_def subst_bop)

lemma subst_mod [usubst]: "\<sigma> \<dagger> (x mod y) = \<sigma> \<dagger> x mod \<sigma> \<dagger> y"
  by (simp add: mod_uexpr_def usubst)

lemma subst_div [usubst]: "\<sigma> \<dagger> (x div y) = \<sigma> \<dagger> x div \<sigma> \<dagger> y"
  by (simp add: divide_uexpr_def usubst)

lemma subst_minus [usubst]: "\<sigma> \<dagger> (x - y) = \<sigma> \<dagger> x - \<sigma> \<dagger> y"
  by (simp add: minus_uexpr_def subst_bop)

lemma subst_uminus [usubst]: "\<sigma> \<dagger> (- x) = - (\<sigma> \<dagger> x)"
  by (simp add: uminus_uexpr_def subst_uop)

lemma usubst_sgn [usubst]: "\<sigma> \<dagger> sgn x = sgn (\<sigma> \<dagger> x)"
  by (simp add: sgn_uexpr_def subst_uop)

lemma usubst_abs [usubst]: "\<sigma> \<dagger> abs x = abs (\<sigma> \<dagger> x)"
  by (simp add: abs_uexpr_def subst_uop)

lemma subst_zero [usubst]: "\<sigma> \<dagger> 0 = 0"
  by (simp add: zero_uexpr_def subst_lit)

lemma subst_one [usubst]: "\<sigma> \<dagger> 1 = 1"
  by (simp add: one_uexpr_def subst_lit)

lemma subst_eq_upred [usubst]: "\<sigma> \<dagger> (x =\<^sub>u y) = (\<sigma> \<dagger> x =\<^sub>u \<sigma> \<dagger> y)"
  by (simp add: eq_upred_def usubst)

text {* This laws shows the effect of applying one substitution after another -- we simply
  use function composition to compose them. *}

lemma subst_subst [usubst]: "\<sigma> \<dagger> \<rho> \<dagger> e = (\<rho> \<circ> \<sigma>) \<dagger> e"
  by (transfer, simp)

text {* The next law is similar, but shows how such a substitution is to be applied to every
  updated variable additionally. *}

lemma subst_upd_comp [usubst]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<rho>(x \<mapsto>\<^sub>s v) \<circ> \<sigma> = (\<rho> \<circ> \<sigma>)(x \<mapsto>\<^sub>s \<sigma> \<dagger> v)"
  by (rule ext, simp add:uexpr_defs subst_upd_uvar_def, transfer, simp)
term "(subst_upd \<rho> x v)\<circ> \<sigma> = subst_upd (\<rho> \<circ> \<sigma>) x (subst \<sigma> v)"
term "subst \<sigma> "
term "Domain "
term "dom"
find_consts  "('a \<Rightarrow> 'b) \<Rightarrow> 'a set"
term "f(x:= v)"
term "(inv \<sigma>) x"
 term "\<lambda>s. v (\<sigma> s)"
lemma "f(x:= v)o \<sigma> = (f o \<sigma>)(x := v) "

oops
lemma subst_singleton:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "x \<sharp> \<sigma>"
  shows "\<sigma>(x \<mapsto>\<^sub>s v) \<dagger> P = (\<sigma> \<dagger> P)\<lbrakk>v/x\<rbrakk>"
  using assms
  by (simp add: usubst)

lemmas subst_to_singleton = subst_singleton id_subst

subsection {* Ordering substitutions *}

text {* We set up a purely syntactic order on variable lenses which is useful for the substitution
        normal form. *}

definition var_name_ord :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> '\<alpha>) \<Rightarrow> bool" where
[no_atp]: "var_name_ord x y = True"

syntax
  "_var_name_ord" :: "salpha \<Rightarrow> salpha \<Rightarrow> bool" (infix "\<prec>\<^sub>v" 65)

translations
  "_var_name_ord x y" == "CONST var_name_ord x y"

text {* A fact of the form @{term "x \<prec>\<^sub>v y"} has no logical information; it simply exists to define
  a total order on named lenses that is useful for normalisation. The following theorem is simply
  an instance of the commutativity law for substitutions. However, that law could not be a simplification
  law as it would cause the simplifier to loop. Assuming that the variable order is a total order then
  this theorem will not loop. *}

lemma usubst_upd_comm_ord [usubst]:
  assumes "x \<bowtie> y" "y \<prec>\<^sub>v x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v) = \<sigma>(y \<mapsto>\<^sub>s v, x \<mapsto>\<^sub>s u)"
  by (simp add: assms(1) usubst_upd_comm)

subsection {* Unrestriction laws *}

text {* These are the key unrestriction theorems for substitutions and expressions involving substitutions. *}

lemma unrest_usubst_single [unrest]:
  "\<lbrakk> mwb_lens x; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> P\<lbrakk>v/x\<rbrakk>"
  by (transfer, auto simp add: subst_upd_uvar_def unrest_uexpr_def)

lemma unrest_usubst_id [unrest]:
  "mwb_lens x \<Longrightarrow> x \<sharp> id"
  by (simp add: unrest_usubst_def)

lemma unrest_usubst_upd [unrest]:
  "\<lbrakk> x \<bowtie> y; x \<sharp> \<sigma>; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> \<sigma>(y \<mapsto>\<^sub>s v)"
  by (simp add: subst_upd_uvar_def unrest_usubst_def unrest_uexpr.rep_eq lens_indep_comm)

lemma unrest_subst [unrest]:
  "\<lbrakk> x \<sharp> P; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> x \<sharp> (\<sigma> \<dagger> P)"
  by (transfer, simp add: unrest_usubst_def)

subsection {* Parallel Substitution Laws *}

lemma par_subst_id [usubst]:
  "\<lbrakk> vwb_lens A; vwb_lens B \<rbrakk> \<Longrightarrow> id [A|B]\<^sub>s id = id"
  by (simp add: par_subst_def lens_override_idem id_def)

lemma par_subst_left_empty [usubst]:
  "\<lbrakk> vwb_lens A \<rbrakk> \<Longrightarrow> \<sigma> [&\<emptyset>|A]\<^sub>s \<rho> = id [&\<emptyset>|A]\<^sub>s \<rho>"
  by (simp add: par_subst_def pr_var_def)

lemma par_subst_right_empty [usubst]:
  "\<lbrakk> vwb_lens A \<rbrakk> \<Longrightarrow> \<sigma> [A|&\<emptyset>]\<^sub>s \<rho> = \<sigma> [A|&\<emptyset>]\<^sub>s id"
  by (simp add: par_subst_def pr_var_def)

lemma par_subst_comm:
  "\<lbrakk> A \<bowtie> B \<rbrakk> \<Longrightarrow> \<sigma> [A|B]\<^sub>s \<rho> = \<rho> [B|A]\<^sub>s \<sigma>"
  by (simp add: par_subst_def lens_override_def lens_indep_comm)

lemma par_subst_upd_left_in [usubst]:
  "\<lbrakk> vwb_lens A; A \<bowtie> B; x \<subseteq>\<^sub>L A \<rbrakk> \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) [A|B]\<^sub>s \<rho> = (\<sigma> [A|B]\<^sub>s \<rho>)(x \<mapsto>\<^sub>s v)"
  by (simp add: par_subst_def subst_upd_uvar_def lens_override_put_right_in)
     (simp add: lens_indep_comm lens_override_def sublens_pres_indep)

lemma par_subst_upd_left_out [usubst]:
  "\<lbrakk> vwb_lens A; x \<bowtie> A \<rbrakk> \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) [A|B]\<^sub>s \<rho> = (\<sigma> [A|B]\<^sub>s \<rho>)"
  by (simp add: par_subst_def subst_upd_uvar_def lens_override_put_right_out)

lemma par_subst_upd_right_in [usubst]:
  "\<lbrakk> vwb_lens B; A \<bowtie> B; x \<subseteq>\<^sub>L B \<rbrakk> \<Longrightarrow> \<sigma> [A|B]\<^sub>s \<rho>(x \<mapsto>\<^sub>s v) = (\<sigma> [A|B]\<^sub>s \<rho>)(x \<mapsto>\<^sub>s v)"
  using lens_indep_sym par_subst_comm par_subst_upd_left_in by fastforce

lemma par_subst_upd_right_out [usubst]:
  "\<lbrakk> vwb_lens B; A \<bowtie> B; x \<bowtie> B \<rbrakk> \<Longrightarrow> \<sigma> [A|B]\<^sub>s \<rho>(x \<mapsto>\<^sub>s v) = (\<sigma> [A|B]\<^sub>s \<rho>)"
  by (simp add: par_subst_comm par_subst_upd_left_out)

end


(*
 * Copyright 2016, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * Author: Zhe Hou, David Sanan.
 *)

theory Separata
imports Main "Sep_Algebra.Separation_Algebra" "HOL-Eisbach.Eisbach_Tools"
begin

text {* The tactics in this file are a simple proof search procedure based on
the labelled sequent calculus LS\_PASL for Propositional Abstract Separation Logic
in Zhe Hou's PhD thesis.

We extend the tactics with a treatment for quantifiers over heaps a la Zhe Hou \&
Alwen Tiu's APLAS2016 paper. *}

text {* We define a class which is an extension to cancellative\_sep\_algebra
with other useful properties in separation algebra, including:
indivisible unit, disjointness, and cross-split.
We also add a property about the (reverse) distributivity of the disjointness. *}

class heap_sep_algebra = cancellative_sep_algebra +
  assumes sep_add_ind_unit: "\<lbrakk>x + y = 0; x ## y\<rbrakk> \<Longrightarrow> x = 0"
  assumes sep_add_disj: "x##x \<Longrightarrow>x= 0 "
  assumes sep_add_cross_split:
      "\<lbrakk>a + b = w; c + d = w; a ## b; c ## d\<rbrakk> \<Longrightarrow>
       \<exists> e f g h. e + f = a \<and> g + h = b \<and> e + g = c \<and> f + h = d \<and>
                  e ## f \<and> g ## h \<and> e ## g \<and> f ## h"
  assumes disj_dstri: "\<lbrakk>x ## y; y ## z; x ## z\<rbrakk> \<Longrightarrow> x ## (y + z)"
begin

section {* Lemmas about the labelled sequent calculus. *}

text {* An abbreviation of the + and \#\# operators in Separation\_Algebra.thy.
This notion is closer to the ternary relational atoms used in the literature.
This will be the main data structure which our labelled sequent calculus works on. *}

definition tern_rel:: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(_,_\<triangleright>_)" 25) where
"(a,b\<triangleright>c) \<equiv> a ## b \<and> a + b = c"

lemma exist_comb: "x ## y \<Longrightarrow> \<exists>z. (x,y\<triangleright>z)"
by (simp add: tern_rel_def)

lemma disj_comb:
assumes a1: "(x,y\<triangleright>z)"
assumes a2: "x ## w"
assumes a3: "y ## w"
shows "z ## w"
proof -
  from a1 have f1: "x ## y \<and> x + y = z"
    by (simp add: tern_rel_def)
  then show ?thesis using a2 a3
    using local.disj_dstri local.sep_disj_commuteI by blast
qed

text {* The following lemmas corresponds to inference rules in LS\_PASL.
Thus these lemmas prove the soundness of LS\_PASL.
We also show the invertibility of those rules. *}

lemma lspasl_id:
"Gamma \<and> (A h) \<Longrightarrow> (A h) \<or> Delta"
by simp

lemma lspasl_botl:
"Gamma \<and> (sep_false h) \<Longrightarrow> Delta"
by simp

lemma lspasl_topr:
"Gamma \<Longrightarrow> (sep_true h) \<or> Delta"
by simp

lemma lspasl_empl:
"Gamma \<and> (h = 0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (sep_empty h) \<longrightarrow> Delta"
by (simp add: local.sep_empty_def)

lemma lspasl_empl_inv:
"Gamma \<and> (sep_empty h) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h = 0) \<longrightarrow> Delta"
by simp

text {* The following two lemmas are the same as applying
simp add: sep\_empty\_def. *}

lemma lspasl_empl_der: "sep_empty h \<Longrightarrow> h = 0"
by (simp add: local.sep_empty_def)

lemma lspasl_empr:
"Gamma \<longrightarrow> (sep_empty 0) \<or> Delta"
by simp

lemma lspasl_notl:
"Gamma \<longrightarrow> (A h) \<or> Delta \<Longrightarrow>
 Gamma \<and> ((not A) h) \<longrightarrow> Delta"
by auto

lemma lspasl_notl_inv:
"Gamma \<and> ((not A) h) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<longrightarrow> (A h) \<or> Delta"
by auto

lemma lspasl_notr:
"Gamma \<and> (A h) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<longrightarrow> ((not A) h) \<or> Delta"
by simp

lemma lspasl_notr_inv:
"Gamma \<longrightarrow> ((not A) h) \<or> Delta \<Longrightarrow>
 Gamma \<and> (A h) \<longrightarrow> Delta"
by simp

lemma lspasl_andl_inv:
"Gamma \<and> ((A and B) h) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (A h) \<and> (B h) \<longrightarrow> Delta"
by simp

lemma lspasl_andr:
"\<lbrakk>Gamma \<longrightarrow> (A h) \<or> Delta; Gamma \<longrightarrow> (B h) \<or> Delta\<rbrakk> \<Longrightarrow>
 Gamma \<longrightarrow> ((A and B) h) \<or> Delta"
by auto

lemma lspasl_andr_inv:
"Gamma \<longrightarrow> ((A and B) h) \<or> Delta \<Longrightarrow>
 (Gamma \<longrightarrow> (A h) \<or> Delta) \<and> (Gamma \<longrightarrow> (B h) \<or> Delta)"
by auto

lemma lspasl_orl:
"\<lbrakk>Gamma \<and> (A h) \<longrightarrow> Delta; Gamma \<and> (B h) \<longrightarrow> Delta\<rbrakk> \<Longrightarrow>
 Gamma \<and> (A or B) h \<longrightarrow> Delta"
by auto

lemma lspasl_orl_inv:
"Gamma \<and> (A or B) h \<longrightarrow> Delta \<Longrightarrow>
 (Gamma \<and> (A h) \<longrightarrow> Delta) \<and> (Gamma \<and> (B h) \<longrightarrow> Delta)"
by simp

lemma lspasl_orr:
"Gamma \<longrightarrow> (A h) \<or> (B h) \<or> Delta \<Longrightarrow>
 Gamma \<longrightarrow> ((A or B) h) \<or> Delta"
by simp

lemma lspasl_orr_inv:
"Gamma \<longrightarrow> ((A or B) h) \<or> Delta \<Longrightarrow>
 Gamma \<longrightarrow> (A h) \<or> (B h) \<or> Delta"
by simp

lemma lspasl_impl:
"\<lbrakk>Gamma \<longrightarrow> (A h) \<or> Delta; Gamma \<and> (B h) \<longrightarrow> Delta\<rbrakk> \<Longrightarrow>
 Gamma \<and> ((A imp B) h) \<longrightarrow> Delta"
by auto

lemma lspasl_impl_inv:
"Gamma \<and> ((A imp B) h) \<longrightarrow> Delta \<Longrightarrow>
 (Gamma \<longrightarrow> (A h) \<or> Delta) \<and> (Gamma \<and> (B h) \<longrightarrow> Delta)"
by auto

lemma lspasl_impr:
"Gamma \<and> (A h) \<longrightarrow> (B h) \<or> Delta \<Longrightarrow>
 Gamma \<longrightarrow> ((A imp B) h) \<or> Delta"
by simp

lemma lspasl_impr_inv:
"Gamma \<longrightarrow> ((A imp B) h) \<or> Delta \<Longrightarrow>
 Gamma \<and> (A h) \<longrightarrow> (B h) \<or> Delta"
by simp

text {* We don't provide lemmas for derivations for the classical connectives,
as Isabelle proof methods can easily deal with them. *}

lemma lspasl_starl:
"(\<exists>h1 h2. (Gamma \<and> (h1,h2\<triangleright>h0) \<and> (A h1) \<and> (B h2))) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> ((A ** B) h0) \<longrightarrow> Delta"
using local.sep_conj_def by (auto simp add: tern_rel_def)

lemma lspasl_starl_inv:
"Gamma \<and> ((A ** B) h0) \<longrightarrow> Delta \<Longrightarrow>
 (\<exists>h1 h2. (Gamma \<and> (h1,h2\<triangleright>h0) \<and> (A h1) \<and> (B h2))) \<longrightarrow> Delta"
using local.sep_conjI by (auto simp add: tern_rel_def)

lemma lspasl_starl_eq:
"((A ** B) h0) = (\<exists>h1 h2. (h1,h2\<triangleright>h0) \<and> (A h1) \<and> (B h2))"
by (metis lspasl_starl lspasl_starl_inv)

lemma lspasl_starr:
"\<lbrakk>Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> (A h1) \<or> ((A ** B) h0) \<or> Delta;
  Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> (B h2) \<or> ((A ** B) h0) \<or> Delta\<rbrakk> \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> ((A ** B) h0) \<or> Delta"
using local.sep_conjI by (auto simp add: tern_rel_def)

lemma lspasl_starr_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> ((A ** B) h0) \<or> Delta \<Longrightarrow>
 (Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> (A h1) \<or> ((A ** B) h0) \<or> Delta) \<and>
 (Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> (B h2) \<or> ((A ** B) h0) \<or> Delta)"
by simp

text {* For efficiency we only apply *R on a pair of a ternary relational atom
and a formula ONCE. To achieve this, we create a special predicate to indicate that
a pair of a ternary relational atom and a formula has already been used in
a *R application.
Note that the predicate is true even if the *R rule hasn't been applied.
We will not infer the truth of this predicate in proof search, but only
check its syntactical appearance, which is only generated by the lemma lspasl\_starr\_der.
We need to ensure that this predicate is not generated elsewhere
in the proof search. *}

definition starr_applied:: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"starr_applied h1 h2 h0 F \<equiv> (h1,h2\<triangleright>h0) \<and> \<not>(F h0)"

lemma lspasl_starr_der:
"(h1,h2\<triangleright>h0) \<Longrightarrow> \<not> ((A ** B) h0) \<Longrightarrow>
  ((h1,h2\<triangleright>h0) \<and> \<not> ((A h1) \<or> ((A ** B) h0)) \<and> (starr_applied h1 h2 h0 (A ** B))) \<or>
  ((h1,h2\<triangleright>h0) \<and> \<not> ((B h2) \<or> ((A ** B) h0)) \<and> (starr_applied h1 h2 h0 (A ** B)))"
by (simp add: lspasl_starl_eq starr_applied_def)

lemma lspasl_starr_der2:
"(h1,h2\<triangleright>h0) \<Longrightarrow> \<not> ((A ** B) h0) \<Longrightarrow>
  ((h1,h2\<triangleright>h0) \<and> \<not> ((A h2) \<or> ((A ** B) h0)) \<and> (starr_applied h2 h1 h0 (A ** B))) \<or>
  ((h1,h2\<triangleright>h0) \<and> \<not> ((B h1) \<or> ((A ** B) h0)) \<and> (starr_applied h2 h1 h0 (A ** B)))"
using local.sep_add_commute local.sep_disj_commute lspasl_starr_der tern_rel_def by auto

lemma lspasl_starr_eq:
"((h1,h2\<triangleright>h0) \<and> \<not> ((A ** B) h0)) =
  (((h1,h2\<triangleright>h0) \<and> \<not> ((A h1) \<or> ((A ** B) h0))) \<or> ((h1,h2\<triangleright>h0) \<and> \<not> ((B h2) \<or> ((A ** B) h0))))"
using lspasl_starr_der by blast

lemma lspasl_magicl:
"\<lbrakk>Gamma \<and> (h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2) \<longrightarrow> (A h1) \<or> Delta;
  Gamma \<and> (h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2) \<and> (B h0) \<longrightarrow> Delta\<rbrakk> \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2) \<longrightarrow> Delta"
using local.sep_add_commute local.sep_disj_commuteI local.sep_implD tern_rel_def
by fastforce

lemma lspasl_magicl_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2) \<longrightarrow> Delta \<Longrightarrow>
 (Gamma \<and> (h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2) \<longrightarrow> (A h1) \<or> Delta) \<and>
 (Gamma \<and> (h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2) \<and> (B h0) \<longrightarrow> Delta)"
by simp

text {* For efficiency we only apply -*L on a pair of a ternary relational atom
and a formula ONCE. To achieve this, we create a special predicate to indicate that
a pair of a ternary relational atom and a formula has already been used in
a *R application.
Note that the predicate is true even if the *R rule hasn't been applied.
We will not infer the truth of this predicate in proof search, but only
check its syntactical appearance, which is only generated by the lemma lspasl\_magicl\_der.
We need to ensure that in the proof search of Separata, this predicate is
not generated elsewhere.*}

definition magicl_applied:: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"magicl_applied h1 h2 h0 F \<equiv> (h1,h2\<triangleright>h0) \<and> (F h2)"

lemma lspasl_magicl_der:
"(h1,h2\<triangleright>h0) \<Longrightarrow> ((A \<longrightarrow>* B) h2) \<Longrightarrow>
  ((h1,h2\<triangleright>h0) \<and> \<not>(A h1) \<and> ((A \<longrightarrow>* B) h2) \<and> (magicl_applied h1 h2 h0 (A \<longrightarrow>* B))) \<or>
  ((h1,h2\<triangleright>h0) \<and> (B h0) \<and> ((A \<longrightarrow>* B) h2) \<and> (magicl_applied h1 h2 h0 (A \<longrightarrow>* B)))"
by (metis lspasl_magicl magicl_applied_def)

lemma lspasl_magicl_der2:
"(h2,h1\<triangleright>h0) \<Longrightarrow> ((A \<longrightarrow>* B) h2) \<Longrightarrow>
  ((h2,h1\<triangleright>h0) \<and> \<not>(A h1) \<and> ((A \<longrightarrow>* B) h2) \<and> (magicl_applied h1 h2 h0 (A \<longrightarrow>* B))) \<or>
  ((h2,h1\<triangleright>h0) \<and> (B h0) \<and> ((A \<longrightarrow>* B) h2) \<and> (magicl_applied h1 h2 h0 (A \<longrightarrow>* B)))"
by (metis local.sep_add_commute local.sep_disj_commuteI local.sep_implD magicl_applied_def tern_rel_def)

lemma lspasl_magicl_eq:
"((h1,h2\<triangleright>h0) \<and> ((A \<longrightarrow>* B) h2)) =
  (((h1,h2\<triangleright>h0) \<and> \<not>(A h1) \<and> ((A \<longrightarrow>* B) h2)) \<or> ((h1,h2\<triangleright>h0) \<and> (B h0) \<and> ((A \<longrightarrow>* B) h2)))"
using lspasl_magicl_der by blast

lemma lspasl_magicr:
"(\<exists>h1 h0. Gamma \<and> (h1,h2\<triangleright>h0) \<and> (A h1) \<and> ((not B) h0)) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<longrightarrow> ((A \<longrightarrow>* B) h2) \<or> Delta"
using local.sep_add_commute local.sep_disj_commute local.sep_impl_def tern_rel_def
by auto

lemma lspasl_magicr_inv:
"Gamma \<longrightarrow> ((A \<longrightarrow>* B) h2) \<or> Delta \<Longrightarrow>
 (\<exists>h1 h0. Gamma \<and> (h1,h2\<triangleright>h0) \<and> (A h1) \<and> ((not B) h0)) \<longrightarrow> Delta"
by (metis lspasl_magicl)

lemma lspasl_magicr_der:
"\<not> ((A \<longrightarrow>* B) h2) \<Longrightarrow>
 (\<exists>h1 h0. (h1,h2\<triangleright>h0) \<and> (A h1) \<and> ((not B) h0))"
by (metis lspasl_magicr)

lemma lspasl_magicr_eq:
"(\<not> ((A \<longrightarrow>* B) h2)) =
 ((\<exists>h1 h0. (h1,h2\<triangleright>h0) \<and> (A h1) \<and> ((not B) h0)))"
by (metis lspasl_magicl lspasl_magicr)

lemma lspasl_eq:
"Gamma \<and> (0,h2\<triangleright>h2) \<and> h1 = h2 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (0,h1\<triangleright>h2) \<longrightarrow> Delta"
by (simp add: tern_rel_def)

lemma lspasl_eq_inv:
"Gamma \<and> (0,h1\<triangleright>h2) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (0,h2\<triangleright>h2) \<and> h1 = h2 \<longrightarrow> Delta"
by simp

lemma lspasl_eq_der: "(0,h1\<triangleright>h2) \<Longrightarrow> ((0,h1\<triangleright>h1) \<and> h1 = h2)"
using lspasl_eq by auto

lemma lspasl_eq_eq: "(0,h1\<triangleright>h2) = ((0,h1\<triangleright>h1) \<and> (h1 = h2))"
by (simp add: tern_rel_def)

lemma lspasl_eq2:
"Gamma \<and> (h2,0\<triangleright>h2) \<and> h1 = h2 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,0\<triangleright>h2) \<longrightarrow> Delta"
by (simp add: tern_rel_def)

lemma lspasl_eq_inv2:
"Gamma \<and> (h1,0\<triangleright>h2) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h2,0\<triangleright>h2) \<and> h1 = h2 \<longrightarrow> Delta"
by simp

lemma lspasl_eq_der2: "(h1,0\<triangleright>h2) \<Longrightarrow> ((h1,0\<triangleright>h1) \<and> h1 = h2)"
using lspasl_eq2 by auto

lemma lspasl_eq_eq2: "(h1,0\<triangleright>h2) = ((h1,0\<triangleright>h1) \<and> (h1 = h2))"
by (simp add: tern_rel_def)

lemma lspasl_u:
"Gamma \<and> (h,0\<triangleright>h) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<longrightarrow> Delta"
by (simp add: tern_rel_def)

lemma lspasl_u_inv:
"Gamma \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h,0\<triangleright>h) \<longrightarrow> Delta"
by simp

lemma lspasl_u_der: "(h,0\<triangleright>h)"
using lspasl_u by auto

lemma lspasl_e:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> Delta"
by (simp add: local.sep_add_commute local.sep_disj_commute tern_rel_def)

lemma lspasl_e_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<longrightarrow> Delta"
by simp

lemma lspasl_e_eq: "(h1,h2\<triangleright>h0) = ((h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0))"
using lspasl_e by blast

lemma lspasl_a_der:
assumes a1: "(h1,h2\<triangleright>h0)"
    and a2: "(h3,h4\<triangleright>h1)"
shows "(\<exists>h5. (h3,h5\<triangleright>h0) \<and> (h2,h4\<triangleright>h5) \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1))"
proof -
  have f1: "h1 ## h2"
    using a1 by (simp add: tern_rel_def)
  have f2: "h3 ## h4"
    using a2 by (simp add: tern_rel_def)
  have f3: "h3 + h4 = h1"
    using a2 by (simp add: tern_rel_def)
  then have "h3 ## h2"
    using f2 f1 by (metis local.sep_disj_addD1 local.sep_disj_commute)
  then have f4: "h2 ## h3"
    by (metis local.sep_disj_commute)
  then have f5: "h2 + h4 ## h3"
    using f3 f2 f1 by (metis (no_types) local.sep_add_commute local.sep_add_disjI1)
  have "h4 ## h2"
    using f3 f2 f1 by (metis local.sep_add_commute local.sep_disj_addD1 local.sep_disj_commute)
  then show ?thesis
    using f5 f4 by (metis (no_types) assms tern_rel_def local.sep_add_assoc local.sep_add_commute local.sep_disj_commute)
qed

lemma lspasl_a:
"(\<exists>h5. Gamma \<and> (h3,h5\<triangleright>h0) \<and> (h2,h4\<triangleright>h5) \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1)) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1) \<longrightarrow> Delta"
using lspasl_a_der by blast

lemma lspasl_a_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1) \<longrightarrow> Delta \<Longrightarrow>
 (\<exists>h5. Gamma \<and> (h3,h5\<triangleright>h0) \<and> (h2,h4\<triangleright>h5) \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1)) \<longrightarrow> Delta"
by auto

lemma lspasl_a_eq:
"((h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1)) =
 (\<exists>h5. (h3,h5\<triangleright>h0) \<and> (h2,h4\<triangleright>h5) \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h1))"
using lspasl_a_der by blast

lemma lspasl_p:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> h0 = h3 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h1,h2\<triangleright>h3) \<longrightarrow> Delta"
by (auto simp add: tern_rel_def)

lemma lspasl_p_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h1,h2\<triangleright>h3) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> h0 = h3 \<longrightarrow> Delta"
by auto

lemma lspasl_p_der:
"(h1,h2\<triangleright>h0) \<Longrightarrow> (h1,h2\<triangleright>h3) \<Longrightarrow> (h1,h2\<triangleright>h0) \<and> h0 = h3"
by (simp add: tern_rel_def)

lemma lspasl_p_eq:
"((h1,h2\<triangleright>h0) \<and> (h1,h2\<triangleright>h3)) = ((h1,h2\<triangleright>h0) \<and> h0 = h3)"
using lspasl_p_der by auto

lemma lspasl_p2:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h0 = h3 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h3) \<longrightarrow> Delta"
using lspasl_e_der lspasl_p_eq by blast

lemma lspasl_p_inv2:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h3) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h0 = h3 \<longrightarrow> Delta"
by auto

lemma lspasl_p_der2:
"(h1,h2\<triangleright>h0) \<Longrightarrow> (h2,h1\<triangleright>h3) \<Longrightarrow> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h0 = h3"
using lspasl_e_der lspasl_p_eq by blast

lemma lspasl_p_eq2:
"((h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h3)) = ((h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h0 = h3)"
using lspasl_p_der lspasl_e_der by blast

lemma lspasl_c:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h1,h3\<triangleright>h0) \<longrightarrow> Delta"
by (metis local.sep_add_cancelD local.sep_add_commute tern_rel_def
local.sep_disj_commuteI)

lemma lspasl_c_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h1,h3\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta"
by auto

lemma lspasl_c_eq:
"((h1,h2\<triangleright>h0) \<and> (h1,h3\<triangleright>h0)) = ((h1,h2\<triangleright>h0) \<and> h2 = h3)"
using lspasl_c_der by auto

lemma lspasl_c2:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h3,h1\<triangleright>h0) \<longrightarrow> Delta"
by (metis local.sep_add_cancelD local.sep_add_commute tern_rel_def
local.sep_disj_commuteI)

lemma lspasl_c_inv2:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h3,h1\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta"
by auto

lemma lspasl_c_der2:
"(h1,h2\<triangleright>h0) \<Longrightarrow> (h3,h1\<triangleright>h0) \<Longrightarrow> (h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h2 = h3"
using lspasl_c2 by blast

lemma lspasl_c_eq2:
"((h1,h2\<triangleright>h0) \<and> (h3,h1\<triangleright>h0)) = ((h1,h2\<triangleright>h0) \<and> (h2,h1\<triangleright>h0) \<and> h2 = h3)"
using lspasl_c_der lspasl_e_der by blast

lemma lspasl_c3:
"Gamma \<and> (h2,h1\<triangleright>h0) \<and> (h1,h2\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h2,h1\<triangleright>h0) \<and> (h1,h3\<triangleright>h0) \<longrightarrow> Delta"
by (metis local.sep_add_cancelD local.sep_add_commute tern_rel_def
local.sep_disj_commuteI)

lemma lspasl_c_inv3:
"Gamma \<and> (h2,h1\<triangleright>h0) \<and> (h1,h3\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h2,h1\<triangleright>h0) \<and> (h1,h2\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta"
by auto

lemma lspasl_c_der3:
"(h2,h1\<triangleright>h0) \<Longrightarrow> (h1,h3\<triangleright>h0) \<Longrightarrow> (h2,h1\<triangleright>h0) \<and> (h1,h2\<triangleright>h0) \<and> h2 = h3"
using lspasl_c3 by blast

lemma lspasl_c_eq3:
"((h2,h1\<triangleright>h0) \<and> (h1,h3\<triangleright>h0)) = ((h2,h1\<triangleright>h0) \<and> (h1,h2\<triangleright>h0) \<and> h2 = h3)"
using lspasl_c_der3 by blast

lemma lspasl_c4:
"Gamma \<and> (h2,h1\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h2,h1\<triangleright>h0) \<and> (h3,h1\<triangleright>h0) \<longrightarrow> Delta"
by (metis local.sep_add_cancelD  tern_rel_def)

lemma lspasl_c_inv4:
"Gamma \<and> (h2,h1\<triangleright>h0) \<and> (h3,h1\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h2,h1\<triangleright>h0) \<and> h2 = h3 \<longrightarrow> Delta"
by auto

lemma lspasl_c_der4:
"(h2,h1\<triangleright>h0) \<Longrightarrow> (h3,h1\<triangleright>h0) \<Longrightarrow> (h2,h1\<triangleright>h0) \<and> h2 = h3"
using lspasl_c4 by blast

lemma lspasl_c_eq4:
"((h2,h1\<triangleright>h0) \<and> (h3,h1\<triangleright>h0)) = ((h2,h1\<triangleright>h0) \<and> h2 = h3)"
using lspasl_c_der4 by blast

lemma lspasl_iu:
"Gamma \<and> (0,h2\<triangleright>0) \<and> h1 = 0 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>0) \<longrightarrow> Delta"
using local.sep_add_ind_unit tern_rel_def by blast

lemma lspasl_iu_inv:
"Gamma \<and> (h1,h2\<triangleright>0) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (0,h2\<triangleright>0) \<and> h1 = 0 \<longrightarrow> Delta"
by simp

lemma lspasl_iu_der:
"(h1,h2\<triangleright>0) \<Longrightarrow> ((0,0\<triangleright>0) \<and> h1 = 0 \<and> h2 = 0)"
using lspasl_eq_der lspasl_iu by (auto simp add: tern_rel_def)

lemma lspasl_iu_eq:
"(h1,h2\<triangleright>0) = ((0,0\<triangleright>0) \<and> h1 = 0 \<and> h2 = 0)"
using lspasl_iu_der by blast

lemma lspasl_d:
"Gamma \<and> (0,0\<triangleright>h2) \<and> h1 = 0 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h1\<triangleright>h2) \<longrightarrow> Delta"
using local.sep_add_disj tern_rel_def by blast

lemma lspasl_d_inv:
"Gamma \<and> (h1,h1\<triangleright>h2) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (0,0\<triangleright>h2) \<and> h1 = 0 \<longrightarrow> Delta"
by blast

lemma lspasl_d_der:
"(h1,h1\<triangleright>h2) \<Longrightarrow> (0,0\<triangleright>0) \<and> h1 = 0 \<and> h2 = 0"
using lspasl_d lspasl_eq_der by blast

lemma lspasl_d_eq:
"(h1,h1\<triangleright>h2) = ((0,0\<triangleright>0) \<and> h1 = 0 \<and> h2 = 0)"
using lspasl_d_der by blast

lemma lspasl_cs_der:
assumes a1: "(h1,h2\<triangleright>h0)"
    and a2: "(h3,h4\<triangleright>h0)"
shows "(\<exists>h5 h6 h7 h8. (h5,h6\<triangleright>h1) \<and> (h7,h8\<triangleright>h2) \<and>(h5,h7\<triangleright>h3) \<and> (h6,h8\<triangleright>h4)
        \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0))"
proof -
  from a1 a2 have "h1 + h2 = h0 \<and> h3 + h4 = h0 \<and> h1 ## h2 \<and> h3 ## h4"
   by (simp add: tern_rel_def)
  then have "\<exists>h5 h6 h7 h8. h5 + h6 = h1 \<and> h7 + h8 = h2 \<and>
    h5 + h7 = h3 \<and> h6 + h8 = h4 \<and> h5 ## h6 \<and> h7 ## h8 \<and>
    h5 ## h7 \<and> h6 ## h8"
   using local.sep_add_cross_split by auto
  then have "\<exists>h5 h6 h7 h8. (h5,h6\<triangleright>h1) \<and> h7 + h8 = h2 \<and>
    h5 + h7 = h3 \<and> h6 + h8 = h4 \<and> h7 ## h8 \<and>
    h5 ## h7 \<and> h6 ## h8"
   by (auto simp add: tern_rel_def)
  then have "\<exists>h5 h6 h7 h8. (h5,h6\<triangleright>h1) \<and> (h7,h8\<triangleright>h2) \<and>
    h5 + h7 = h3 \<and> h6 + h8 = h4 \<and> h5 ## h7 \<and> h6 ## h8"
   by (auto simp add: tern_rel_def)
  then have "\<exists>h5 h6 h7 h8. (h5,h6\<triangleright>h1) \<and> (h7,h8\<triangleright>h2) \<and>
    (h5,h7\<triangleright>h3) \<and> h6 + h8 = h4 \<and> h6 ## h8"
   by (auto simp add: tern_rel_def)
  then show ?thesis using a1 a2 tern_rel_def by blast
qed

lemma lspasl_cs:
"(\<exists>h5 h6 h7 h8. Gamma \<and> (h5,h6\<triangleright>h1) \<and> (h7,h8\<triangleright>h2) \<and>(h5,h7\<triangleright>h3) \<and> (h6,h8\<triangleright>h4) \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0)) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0) \<longrightarrow> Delta"
using lspasl_cs_der by auto

lemma lspasl_cs_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0) \<longrightarrow> Delta \<Longrightarrow>
 (\<exists>h5 h6 h7 h8. Gamma \<and> (h5,h6\<triangleright>h1) \<and> (h7,h8\<triangleright>h2) \<and>(h5,h7\<triangleright>h3) \<and> (h6,h8\<triangleright>h4) \<and> (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0)) \<longrightarrow> Delta"
by auto

lemma lspasl_cs_eq:
"((h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0)) =
 (\<exists>h5 h6 h7 h8. (h5,h6\<triangleright>h1) \<and> (h7,h8\<triangleright>h2) \<and>(h5,h7\<triangleright>h3) \<and> (h6,h8\<triangleright>h4) \<and>
  (h1,h2\<triangleright>h0) \<and> (h3,h4\<triangleright>h0))"
using lspasl_cs_der by auto

text {* This section extends separata with treatments for quantifiers over
heaps. This is similar to the modalities [] and <> we used in our APLAS2016
paper. Here we use /\ h. A h be mean that h is universally quantified, which
is h: []A in the APLAS2016 paper. Similarly, Formulae like this are frequently used in seL4's proofs. *}

lemma lsfasl_boxl_der:
"(\<And>h. A h) \<Longrightarrow> \<forall>h. A h"
by simp

end

text {* The above proves the soundness and invertibility of LS\_PASL. *}

section {* Lemmas David proved for separation algebra. *}

lemma sep_substate_tran:
  "x \<preceq> y \<and> y \<preceq> z \<Longrightarrow> x \<preceq> z"
  unfolding sep_substate_def
proof -
  assume "(\<exists>z. x ## z \<and> x + z = y) \<and> (\<exists>za. y ## za \<and> y + za = z)"
  then obtain x' y' where  fixed:"(x ## x' \<and> x + x' = y) \<and> (y ## y' \<and> y + y' = z)"
   by auto
  then have disj_x:"x ## y' \<and> x' ## y'"
    using sep_disj_addD sep_disj_commute by blast
  then have p1:"x ## (x' + y')" using fixed sep_disj_commute sep_disj_addI3
    by blast
  then have "x + (x' + y') = z" using disj_x by (metis (no_types) fixed sep_add_assoc)
  thus "\<exists>za. x ## za \<and> x + za = z" using p1 by auto
qed

lemma precise_sep_conj:
 assumes a1:"precise I" and
        a2:"precise I'"
 shows "precise (I \<and>* I')"
proof  (clarsimp simp: precise_def)
  fix hp hp' h
  assume hp:"hp \<preceq> h" and hp': "hp' \<preceq> h" and ihp: "(I \<and>* I') hp" and ihp': "(I \<and>* I') hp'"
  obtain hp1 hp2 where ihpex: "hp1 ## hp2 \<and> hp = hp1 + hp2 \<and> I hp1 \<and> I' hp2" using ihp sep_conjD by blast
  obtain hp1' hp2' where ihpex': "hp1' ## hp2' \<and> hp' = hp1' + hp2' \<and> I hp1' \<and> I' hp2'" using ihp' sep_conjD by blast
  have f3: "hp2' ## hp1'"
    by (simp add: ihpex' sep_disj_commute)
  have f4: "hp2 ## hp1"
    using ihpex sep_disj_commute by blast
  have f5:"\<And>a. \<not> a \<preceq> hp \<or> a \<preceq> h"
    using hp sep_substate_tran by blast
  have f6:"\<And>a. \<not> a \<preceq> hp' \<or> a \<preceq> h"
    using hp' sep_substate_tran by blast
  thus "hp = hp'"
    using f4 f3 f5 a2 a1 a1 a2 ihpex ihpex'
    unfolding precise_def by (metis sep_add_commute sep_substate_disj_add')
qed

lemma unique_subheap:
"(\<sigma>1,\<sigma>2\<triangleright>\<sigma>) \<Longrightarrow> \<exists>!\<sigma>2'.(\<sigma>1,\<sigma>2'\<triangleright>\<sigma>)"
using lspasl_c_der by blast

lemma sep_split_substate:
  "(\<sigma>1, \<sigma>2\<triangleright> \<sigma>) \<Longrightarrow>
   (\<sigma>1  \<preceq> \<sigma>) \<and> (\<sigma>2  \<preceq> \<sigma>)"
proof-
assume a1:"(\<sigma>1, \<sigma>2\<triangleright> \<sigma>)"
  thus "(\<sigma>1  \<preceq> \<sigma>) \<and> (\<sigma>2  \<preceq> \<sigma>)"
   by (auto simp add: sep_disj_commute
       tern_rel_def
      sep_substate_disj_add
      sep_substate_disj_add')
qed

abbreviation sep_septraction :: "(('a::sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<longrightarrow>\<oplus>" 25)
where
  "P \<longrightarrow>\<oplus> Q \<equiv>  not (P \<longrightarrow>* not Q)"

section {* Below we integrate the inference rules in proof search. *}

method try_lspasl_empl = (
match premises in P[thin]:"sep_empty ?h" \<Rightarrow>
  \<open>insert lspasl_empl_der[OF P]\<close>,
simp?
)

method try_lspasl_starl = (
match premises in P[thin]:"(?A ** ?B) ?h" \<Rightarrow>
  \<open>insert lspasl_starl_der[OF P], auto\<close>,
simp?
)

method try_lspasl_magicr = (
match premises in P[thin]:"\<not>(?A \<longrightarrow>* ?B) ?h" \<Rightarrow>
  \<open>insert lspasl_magicr_der[OF P], auto\<close>,
simp?
)

text {* Only apply the rule Eq on (0,h1,h2) where h1 and h2
are not syntactically the same.
Note that we build commutativity in this rule application. *}

method try_lspasl_eq = (
match premises in P[thin]:"(0,?h1\<triangleright>?h2)" \<Rightarrow>
  \<open>match P in
    "(0,h\<triangleright>h)" for h \<Rightarrow> \<open>fail\<close>
    \<bar>_ \<Rightarrow> \<open>insert lspasl_eq_der[OF P], auto\<close>\<close>
\<bar> P'[thin]: "(?h1,0\<triangleright>?h2)" \<Rightarrow>
  \<open>match P' in
    "(h,0\<triangleright>h)" for h \<Rightarrow> \<open>fail\<close>
    \<bar>_ \<Rightarrow> \<open>insert lspasl_eq_der2[OF P'], auto\<close>\<close>,
simp?
)

text {* We restrict that the rule IU can't be applied
on (0,0,0). *}

method try_lspasl_iu = (
match premises in P[thin]:"(?h1,?h2\<triangleright>0)" \<Rightarrow>
  \<open>match P in
    "(0,0\<triangleright>0)" \<Rightarrow> \<open>fail\<close>
    \<bar>_ \<Rightarrow> \<open>insert lspasl_iu_der[OF P], auto\<close>\<close>,
simp?
)

text {* We restrict that the rule D can't be applied
on (0,0,0). *}

method try_lspasl_d = (
match premises in P[thin]:"(h1,h1\<triangleright>h2)" for h1 h2 \<Rightarrow>
  \<open>match P in
    "(0,0\<triangleright>0)" \<Rightarrow> \<open>fail\<close>
    \<bar>_ \<Rightarrow> \<open>insert lspasl_d_der[OF P], auto\<close>\<close>,
simp?
)

text {* We restrict that the rule P can't be applied to
two syntactically identical ternary relational atoms.
Note that we build communtativity in this rule application. *}

method try_lspasl_p = (
match premises in P[thin]:"(h1,h2\<triangleright>h0)" for h0 h1 h2 \<Rightarrow>
  \<open>match premises in "(h1,h2\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
  \<bar>"(h2,h1\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
  \<bar>P'[thin]:"(h1,h2\<triangleright>?h3)" \<Rightarrow> \<open>insert lspasl_p_der[OF P P'], auto\<close>
  \<bar>P''[thin]:"(h2,h1\<triangleright>?h3)" \<Rightarrow> \<open>insert lspasl_p_der2[OF P P''], auto\<close>\<close>,
simp?
)

text {* We restrict that the rule C can't be applied to
two syntactically identical ternary relational atoms.
Note that we build communtativity in this rule application. *}

method try_lspasl_c = (
match premises in P[thin]:"(h1,h2\<triangleright>h0)" for h0 h1 h2 \<Rightarrow>
  \<open>match premises in "(h1,h2\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
  \<bar>"(h2,h1\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
  \<bar>P'[thin]:"(h1,?h3\<triangleright>h0)" \<Rightarrow> \<open>insert lspasl_c_der[OF P P'], auto\<close>
  \<bar>P''[thin]:"(?h3,h1\<triangleright>h0)" \<Rightarrow> \<open>insert lspasl_c_der2[OF P P''], auto\<close>
  \<bar>P'''[thin]:"(h2,?h3\<triangleright>h0)" \<Rightarrow> \<open>insert lspasl_c_der3[OF P P'''], auto\<close>
  \<bar>P''''[thin]:"(?h3,h2\<triangleright>h0)" \<Rightarrow> \<open>insert lspasl_c_der4[OF P P''''], auto\<close>\<close>,
simp?
)

text {* We restrict that *R only applies to a pair of
a ternary relational and a formula once.
Here, we need to first try simp to simplify situations such as
(h1,h2,h0) and not((A ** B) h3) and (h3 = h0).
In the end, we try simp\_all to simplify all branches.
A similar strategy is used in -*L. *}

method try_lspasl_starr = (
simp?,
match premises in P:"(h1,h2\<triangleright>h)" and P':"\<not>(A ** B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "starr_applied h1 h2 h (A ** B)" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_starr_der[OF P P'], auto\<close>\<close>,
simp_all?
)

method try_lspasl_starr2 = (
simp?,
match premises in P:"(h1,h2\<triangleright>h)" and P':"\<not>(A ** B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "starr_applied h1 h2 h (A ** B)" \<Rightarrow>
    \<open>match premises in "starr_applied h2 h1 h (A ** B)" \<Rightarrow> \<open>fail\<close>
     \<bar>_ \<Rightarrow> \<open>insert lspasl_starr_der2[OF P P'], auto\<close>\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_starr_der[OF P P'], auto\<close>\<close>,
simp_all?
)

text {* We restrict that -*L only applies to a pair of
a ternary relational and a formula once. *}

method try_lspasl_magicl = (
simp?,
match premises in P: "(h1,h\<triangleright>h2)" and P':"(A \<longrightarrow>* B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "magicl_applied h1 h h2 (A \<longrightarrow>* B)" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_magicl_der[OF P P'], auto\<close>\<close>,
simp_all?
)

text {* We build commutativity in the following rule applicaiton. *}

method try_lspasl_magicl2 = (
simp?,
((match premises in P: "(h1,h\<triangleright>h2)" and P':"(A \<longrightarrow>* B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "magicl_applied h1 h h2 (A \<longrightarrow>* B)" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_magicl_der[OF P P'], auto\<close>\<close>)
|(match premises in P'': "(h,h1\<triangleright>h2)" and P''':"(A \<longrightarrow>* B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "magicl_applied h1 h h2 (A \<longrightarrow>* B)" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_magicl_der2[OF P'' P'''], auto\<close>\<close>)),
simp_all?
)

text {* We restrict that the U rule is only applicable to a world h
when (h,0,h) is not in the premises. There are two cases:
(1) We pick a ternary relational atom (h1,h2,h0),
and check if (h1,0,h1) occurs in the premises, if not,
apply U on h1. Otherwise, check other ternary relational atoms.
(2) We pick a labelled formula (A h),
and check if (h,0,h) occurs in the premises, if not,
apply U on h. Otherwise, check other labelled formulae. *}

method try_lspasl_u_tern = (
match premises in
  P:"(h1,h2\<triangleright>(h0::'a::heap_sep_algebra))" for h1 h2 h0 \<Rightarrow>
  \<open>match premises in
    "(h1,0\<triangleright>h1)" \<Rightarrow> \<open>match premises in
      "(h2,0\<triangleright>h2)" \<Rightarrow> \<open>match premises in
        I1:"(h0,0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
        \<bar>_ \<Rightarrow> \<open>insert lspasl_u_der[of h0]\<close>\<close>
      \<bar>_ \<Rightarrow> \<open>insert lspasl_u_der[of h2]\<close>\<close>
    \<bar>_ \<Rightarrow> \<open>insert lspasl_u_der[of h1]\<close>\<close>,
simp?
)

method try_lspasl_u_form = (
match premises in
  P':"_ (h::'a::heap_sep_algebra)" for h \<Rightarrow>
  \<open>match premises in "(h,0\<triangleright>h)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(0,0\<triangleright>0)" and "h = 0" \<Rightarrow> \<open>fail\<close>
   \<bar>"(0,0\<triangleright>0)" and "0 = h" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_u_der[of h]\<close>\<close>,
simp?
)

text {* We restrict that the E rule is only applicable to
(h1,h2,h0) when (h2,h1,h0) is not in the premises. *}

method try_lspasl_e = (
match premises in P:"(h1,h2\<triangleright>h0)" for h1 h2 h0 \<Rightarrow>
  \<open>match premises in "(h2,h1\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>insert lspasl_e_der[OF P], auto\<close>\<close>,
simp?
)

text {* We restrict that the A rule is only applicable to
(h1,h2,h0) and (h3,h4,h1) when (h3,h,h0) and (h2,h4,h)
or any commutative variants of the two
do not occur in the premises, for some h.
Additionally, we do not allow A to be applied to two identical
ternary relational atoms.
We further restrict that the leaves must not be 0,
because otherwise this application does not gain anything. *}

method try_lspasl_a = (
match premises in "(h1,h2\<triangleright>h0)" for h0 h1 h2 \<Rightarrow>
  \<open>match premises in
    "(0,h2\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h1,0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h1,h2\<triangleright>0)" \<Rightarrow> \<open>fail\<close>
   \<bar>P[thin]:"(h1,h2\<triangleright>h0)" \<Rightarrow>
    \<open>match premises in
      P':"(h3,h4\<triangleright>h1)" for h3 h4 \<Rightarrow> \<open>match premises in
        "(0,h4\<triangleright>h1)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(h3,0\<triangleright>h1)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(_,h3\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(h3,_\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(h2,h4\<triangleright>_)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(h4,h2\<triangleright>_)" \<Rightarrow> \<open>fail\<close>
       \<bar>_ \<Rightarrow> \<open>insert P P', drule lspasl_a_der, auto\<close>\<close>\<close>\<close>,
simp?
)

method try_lspasl_a_full = (
match premises in "(h1,h2\<triangleright>h0)" for h0 h1 h2 \<Rightarrow>
  \<open>match premises in
    "(0,h2\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h1,0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h1,h2\<triangleright>0)" \<Rightarrow> \<open>fail\<close>
   \<bar>P[thin]:"(h1,h2\<triangleright>h0)" \<Rightarrow>
    \<open>match premises in
      P':"(h3,h4\<triangleright>h1)" for h3 h4 \<Rightarrow> \<open>match premises in
        "(0,h4\<triangleright>h1)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(h3,0\<triangleright>h1)" \<Rightarrow> \<open>fail\<close>
       \<bar>"(h5,h3\<triangleright>h0)" for h5 \<Rightarrow> \<open>match premises in
         "(h2,h4\<triangleright>h5)" \<Rightarrow> \<open>fail\<close>
        \<bar>"(h4,h2\<triangleright>h5)" \<Rightarrow> \<open>fail\<close>
        \<bar>_ \<Rightarrow> \<open>insert P P', drule lspasl_a_der, auto\<close>\<close>
       \<bar>"(h3,h5\<triangleright>h0)" for h5 \<Rightarrow> \<open>match premises in
         "(h2,h4\<triangleright>h5)" \<Rightarrow> \<open>fail\<close>
        \<bar>"(h4,h2\<triangleright>h5)" \<Rightarrow> \<open>fail\<close>
        \<bar>_ \<Rightarrow> \<open>insert P P', drule lspasl_a_der, auto\<close>\<close>
       \<bar>"(h2,h4\<triangleright>h5)" for h5 \<Rightarrow> \<open>match premises in
         "(h3,h5\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
        \<bar>"(h5,h3\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
        \<bar>_ \<Rightarrow> \<open>insert P P', drule lspasl_a_der, auto\<close>\<close>
       \<bar>"(h4,h2\<triangleright>h5)" for h5 \<Rightarrow> \<open>match premises in
         "(h3,h5\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
        \<bar>"(h5,h3\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
        \<bar>_ \<Rightarrow> \<open>insert P P', drule lspasl_a_der, auto\<close>\<close>
       \<bar>_ \<Rightarrow> \<open>insert P P', drule lspasl_a_der, auto\<close>\<close>\<close>\<close>,
simp?
)

text {* I don't have a good heuristics for CS right now.
I simply forbid CS to be applied on the same pair twice. *}

(*
method try_lspasl_cs = (
match premises in P[thin]:"(h1,h2\<triangleright>h0)" for h0 h1 h2 \<Rightarrow>
  \<open>match premises in "(h1,h2\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h2,h1\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(0,h0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h0,0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>P':"(h3,h4\<triangleright>h0)" for h3 h4 \<Rightarrow> \<open>match premises in
      "(h5,h6\<triangleright>h1)" and "(h7,h8\<triangleright>h2)" and "(h5,h7\<triangleright>h3)" and "(h6,h8\<triangleright>h4)" for h5 h6 h7 h8 \<Rightarrow> \<open>fail\<close>
     \<bar>"(i5,i6\<triangleright>h2)" and "(i7,i8\<triangleright>h1)" and "(i5,i7\<triangleright>h3)" and "(i6,i8\<triangleright>h4)" for i5 i6 i7 i8 \<Rightarrow> \<open>fail\<close>
     \<bar>"(j5,j6\<triangleright>h1)" and "(j7,j8\<triangleright>h2)" and "(j5,j7\<triangleright>h4)" and "(j6,j8\<triangleright>h3)" for j5 j6 j7 j8 \<Rightarrow> \<open>fail\<close>
     \<bar>"(k5,k6\<triangleright>h2)" and "(k7,k8\<triangleright>h1)" and "(k5,k7\<triangleright>h4)" and "(k6,k8\<triangleright>h3)" for k5 k6 k7 k8 \<Rightarrow> \<open>fail\<close>
     \<bar>_ \<Rightarrow> \<open>insert lspasl_cs_der[OF P P'], auto\<close>\<close>\<close>,
simp?
)
*)

method try_lspasl_cs = (
match premises in P[thin]:"(h1,h2\<triangleright>h0)" for h0 h1 h2 \<Rightarrow>
  \<open>match P in "(0,h0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>"(h0,0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
   \<bar>_ \<Rightarrow> \<open>match premises in P':"(h3,h4\<triangleright>h0)" for h3 h4 \<Rightarrow>
    \<open>match P' in "(h2,h1\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
     \<bar>"(0,h0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
     \<bar>"(h0,0\<triangleright>h0)" \<Rightarrow> \<open>fail\<close>
     \<bar>_ \<Rightarrow> \<open>insert lspasl_cs_der[OF P P'], auto\<close>\<close>\<close>\<close>,
simp?
)

text {* Note that we build commutativity in the following rule applicaiton. *}

method try_lspasl_starr_guided = (
simp?,
((match premises in P:"(h1,h2\<triangleright>h)" and P':"\<not>(A ** B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "starr_applied h1 h2 h (A ** B)" \<Rightarrow> \<open>fail\<close>
   \<bar>"A h1" \<Rightarrow> \<open>insert lspasl_starr_der[OF P P'], auto\<close>
   \<bar>"B h2" \<Rightarrow> \<open>insert lspasl_starr_der[OF P P'], auto\<close>\<close>)
|(match premises in P:"(h1,h2\<triangleright>h)" and P':"\<not>(A ** B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "starr_applied h2 h1 h (A ** B)" \<Rightarrow> \<open>fail\<close>
   \<bar>"A h2" \<Rightarrow> \<open>insert lspasl_starr_der2[OF P P'], auto\<close>
   \<bar>"B h1" \<Rightarrow> \<open>insert lspasl_starr_der2[OF P P'], auto\<close>\<close>)),
simp_all?
)

text {* Note that we build commutativity in the following rule applicaiton. *}

method try_lspasl_magicl_guided = (
simp?,
match premises in P: "(h1,h\<triangleright>h2)" and P':"(A \<longrightarrow>* B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "magicl_applied h1 h h2 (A \<longrightarrow>* B)" \<Rightarrow> \<open>fail\<close>
   \<bar>"A h1" \<Rightarrow> \<open>insert lspasl_magicl_der[OF P P'], auto\<close>
   \<bar>"\<not>(B h2)" \<Rightarrow> \<open>insert lspasl_magicl_der[OF P P'], auto\<close>\<close>
\<bar>P'': "(h,h1\<triangleright>h2)" and P''':"(A \<longrightarrow>* B) (h::'a::heap_sep_algebra)" for h1 h2 h A B \<Rightarrow>
  \<open>match premises in "magicl_applied h1 h h2 (A \<longrightarrow>* B)" \<Rightarrow> \<open>fail\<close>
   \<bar>"A h1" \<Rightarrow> \<open>insert lspasl_magicl_der2[OF P'' P'''], auto\<close>
   \<bar>"\<not>(B h2)" \<Rightarrow> \<open>insert lspasl_magicl_der2[OF P'' P'''], auto\<close>\<close>,
simp_all?
)

text {* The following rule deals with the meta-language universal quantifier. *}

method try_lsfasl_boxl = (
simp?,
match premises in P[thin]: "\<And>h. ?A (h::'a::heap_sep_algebra)" \<Rightarrow>
  \<open>insert P, drule meta_spec, auto\<close>,
auto? (* Change this line to simp? will raise type errors... *)
)

text {* In case the conclusion is not False, we normalise the goal as below. *}

method norm_goal = (
match conclusion in "False" \<Rightarrow> \<open>fail\<close>
\<bar>_ \<Rightarrow> \<open>rule ccontr\<close>,
simp?
)

text {* The tactic for separata. We first try to simplify the problem
with auto simp add: sep\_conj\_ac, which ought to solve many problems.
Then we apply the "true" invertible rules and structural rules
which unify worlds as much as possible, followed by auto to simplify the goals.
Then we apply *R and -*L and other structural rules.
The rule CS is only applied when nothing else is applicable. We try not
to use it. *}

text {* Preparation for the solver. *}

lemma sep_implE2: "(P ** (P \<longrightarrow>* Q)) h \<Longrightarrow> Q h"
using sep_conj_commuteI sep_conj_sep_impl2 by blast

lemma sep_implE3: "(A ** (P ** (P \<longrightarrow>* Q))) h \<Longrightarrow> (A ** Q) h"
using sep_conj_impl sep_implE2 by blast

lemma sep_implE4: "((P ** (P \<longrightarrow>* Q)) ** A) h \<Longrightarrow> (Q ** A) h"
using sep_conj_commuteI sep_implE3 by blast

method prep = ((auto simp add: sep_conj_ac)|norm_goal)+

text {* This part contains invertible rules.
Apply as often as possible. *}

method invert = (
(try_lspasl_empl
|try_lspasl_iu
|try_lspasl_d
|try_lspasl_eq
|try_lspasl_p
|try_lspasl_c
|try_lspasl_starl
|try_lspasl_magicr
|try_lspasl_starr_guided
|try_lspasl_magicl_guided)+,
auto?)

text {* This part contains structural rules. *}

method struct = (
try_lspasl_u_tern
|try_lspasl_e
|try_lspasl_a)+

text {* This part contains *R and -*L rules. *}

method noninvert = (
try_lspasl_starr2
|try_lspasl_magicl2)

text {* This part contains rules that are rarely used. *}

method rare = (
try_lspasl_u_form+ (* This rule is rarely used. *)
|try_lspasl_a_full (* Just in case we need more ternary relational atoms from associativity. *)
|try_lspasl_cs (* Cross-split adds too much complication. Try not to use it. *)
)

method separata =
(prep
 |(invert
  |try_lsfasl_boxl
  |struct
  |noninvert
 )+
 |rare
)+

end