(*  Title:       Reasoning about Lists via List Interleaving
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "List interleaving"

theory ListInterleaving
imports Main
begin

text \<open>
\null

Among the various mathematical tools introduced in his outstanding work on Communicating Sequential
Processes \cite{R2}, Hoare has defined \emph{interleaves} as the predicate satisfied by any three
lists \emph{s}, \emph{t}, emph{u} such that \emph{s} may be split into sublists alternately
extracted from \emph{t} and \emph{u}, whatever is the criterion for extracting an item from either
\emph{t} or \emph{u} in each step.

This paper enriches Hoare's definition by identifying such criterion with the truth value of a
predicate taking as inputs the head and the tail of \emph{s}. This enhanced \emph{interleaves}
predicate turns out to permit the proof of equalities between lists without the need of an
induction. Some rules that allow to infer \emph{interleaves} statements without induction,
particularly applying to the addition of a prefix to the input lists, are also proven. Finally, a
stronger version of the predicate, named \emph{Interleaves}, is shown to fulfil further rules
applying to the addition of a suffix to the input lists.

Throughout this paper, the salient points of definitions and proofs are commented; for additional
information, cf. Isabelle documentation, particularly \cite{R3}, \cite{R4}, \cite{R5}, and
\cite{R6}. For a sample nontrivial application of the mathematical machinery developed in this
paper, cf. \cite{R1}.
\<close>

subsection "A first version of interleaving"

text \<open>
Here below is the definition of predicate \<open>interleaves\<close>, as well as of a convenient symbolic
notation for it. As in the definition of predicate \emph{interleaves} formulated in \cite{R2}, the
recursive decomposition of the input lists is performed by item prepending. In the case of a list
\<open>ws\<close> constructed recursively by item appending rather than prepending, the statement that it
satisfies predicate \<open>interleaves\<close> with two further lists can nevertheless be proven by
induction using as input @{term "rev ws"}, rather than \<open>ws\<close> itself.

With respect to Hoare's homonymous predicate, \<open>interleaves\<close> takes as an additional input a
predicate \<open>P\<close>, which is a function of a single item and a list. Then, for statement
@{term "interleaves P (x # xs) (y # ys) (z # zs)"} to hold, the item picked for being \<open>x\<close> must
be \<open>y\<close> if \<open>P x xs\<close>, \<open>z\<close> otherwise. On the contrary, in case either the second or
the third list is empty, the truth value of \<open>P x xs\<close> does not matter and list
@{term "x # xs"} just has to match the other nonempty one, if any.

\null
\<close>

fun interleaves ::
 "('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"interleaves P (x # xs) (y # ys) (z # zs) = (if P x xs
  then x = y \<and> interleaves P xs ys (z # zs)
  else x = z \<and> interleaves P xs (y # ys) zs)" |
"interleaves P (x # xs) (y # ys) [] =
  (x = y \<and> interleaves P xs ys [])" |
"interleaves P (x # xs) [] (z # zs) =
  (x = z \<and> interleaves P xs [] zs)" |
"interleaves _ (_ # _) [] [] = False" |
"interleaves _ [] (_ # _) _ = False" |
"interleaves _ [] _ (_ # _) = False" |
"interleaves _ [] [] [] = True"

abbreviation interleaves_syntax ::
    "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> bool"
    ("(_ \<simeq> {_, _, _})" [60, 60, 60] 51)
  where "xs \<simeq> {ys, zs, P} \<equiv> interleaves P xs ys zs"

text \<open>
\null

The advantage provided by this enhanced \emph{interleaves} predicate is that in case
@{term "xs \<simeq> {ys, zs, P}"}, fixing the values of \<open>xs\<close> and either \<open>ys\<close> or \<open>zs\<close> has
the effect of fixing the value of the remaining list, too. Namely, if @{term "xs \<simeq> {ys', zs, P}"}
also holds, then @{term "ys = ys'"}, and likewise, if @{term "xs \<simeq> {ys, zs', P}"} also holds, then
@{term "zs = zs'"}. Therefore, once two \emph{interleaves} statements @{term "xs \<simeq> {ys, zs, P}"},
@{term "xs' \<simeq> {ys', zs', P'}"} have been proven along with equalities @{term "xs = xs'"},
@{term "P = P'"}, and either @{term "zs = zs'"} or @{term "ys = ys'"}, possibly by induction, the
remaining equality, i.e. respectively @{term "ys = ys'"} and @{term "zs = zs'"}, can be inferred
without the need of a further induction.

Here below is the proof of this property as well as of other ones. Particularly, it is also proven
that in case @{term "xs \<simeq> {ys, zs, P}"}, lists \<open>ys\<close> and \<open>zs\<close> can be swapped by
replacing predicate \<open>P\<close> with its negation.

It is worth noting that fixing the values of \<open>ys\<close> and \<open>zs\<close> does not fix the value of
\<open>xs\<close> instead. A counterexample is @{term "ys = [y]"}, @{term "zs = [z]"} with @{term "y \<noteq> z"},
@{term "P y [z] = True"}, @{term "P z [y] = False"}, in which case both of the \emph{interleaves}
statements @{term "[y, z] \<simeq> {ys, zs, P}"} and @{term "[z, y] \<simeq> {ys, zs, P}"} hold.

\null
\<close>

lemma interleaves_length [rule_format]:
 "xs \<simeq> {ys, zs, P} \<longrightarrow> length xs = length ys + length zs"
proof (induction P xs ys zs rule: interleaves.induct, simp_all)
qed (rule conjI, (rule_tac [!] impI)+, simp_all)

lemma interleaves_nil:
 "[] \<simeq> {ys, zs, P} \<Longrightarrow> ys = [] \<and> zs = []"
by (rule interleaves.cases [of "(P, [], ys, zs)"], simp_all)

lemma interleaves_swap:
 "xs \<simeq> {ys, zs, P} = xs \<simeq> {zs, ys, \<lambda>w ws. \<not> P w ws}"
proof (induction P xs ys zs rule: interleaves.induct, simp_all)
  fix y' :: 'a and ys' zs' P'
  show "\<not> [] \<simeq> {zs', y' # ys', \<lambda>w ws. \<not> P' w ws}" by (cases zs', simp_all)
qed

lemma interleaves_equal_fst [rule_format]:
 "xs \<simeq> {ys, zs, P} \<longrightarrow> xs \<simeq> {ys', zs, P} \<longrightarrow> ys = ys'"
proof (induction xs arbitrary: ys ys' zs, (rule_tac [!] impI)+)
  fix ys ys' zs
  assume "[] \<simeq> {ys, zs, P}"
  hence "ys = [] \<and> zs = []" by (rule interleaves_nil)
  moreover assume "[] \<simeq> {ys', zs, P}"
  hence "ys' = [] \<and> zs = []" by (rule interleaves_nil)
  ultimately show "ys = ys'" by simp
next
  fix x xs ys ys' zs
  assume
    A: "\<And>ys ys' zs. xs \<simeq> {ys, zs, P} \<longrightarrow> xs \<simeq> {ys', zs, P} \<longrightarrow> ys = ys'" and
    B: "x # xs \<simeq> {ys, zs, P}" and
    B': "x # xs \<simeq> {ys', zs, P}"
  show "ys = ys'"
  proof (cases zs, case_tac [2] ys, case_tac [2-3] ys', simp_all)
    assume C: "zs = []"
    hence "\<exists>w ws. ys = w # ws" using B by (cases ys, simp_all)
    then obtain w ws where Y: "ys = w # ws" by blast
    hence D: "w = x" using B and C by simp
    have "xs \<simeq> {ws, [], P}" using B and C and Y by simp
    moreover have "\<exists>w' ws'. ys' = w' # ws'"
     using B' and C by (cases ys', simp_all)
    then obtain w' ws' where Y': "ys' = w' # ws'" by blast
    hence D': "w' = x" using B' and C by simp
    have "xs \<simeq> {ws', [], P}" using B' and C and Y' by simp
    moreover have "xs \<simeq> {ws, [], P} \<longrightarrow> xs \<simeq> {ws', [], P} \<longrightarrow> ws = ws'"
     using A .
    ultimately have "ws = ws'" by simp
    with Y and Y' and D and D' show ?thesis by simp
  next
    fix v vs w' ws'
    assume C: "zs = v # vs" and "ys = []"
    hence D: "xs \<simeq> {[], vs, P}" using B by simp
    assume E: "ys' = w' # ws'"
    have "P x xs \<or> \<not> P x xs" by simp
    moreover {
      assume "P x xs"
      hence "xs \<simeq> {ws', v # vs, P}" using B' and C and E by simp
      hence "length xs = Suc (length vs) + length ws'"
       by (simp add: interleaves_length)
      moreover have "length xs = length vs"
       using D by (simp add: interleaves_length)
      ultimately have False by simp
    }
    moreover {
      assume "\<not> P x xs"
      hence "xs \<simeq> {w' # ws', vs, P}" using B' and C and E by simp
      moreover have "xs \<simeq> {[], vs, P} \<longrightarrow> xs \<simeq> {w' # ws', vs, P} \<longrightarrow>
        [] = w' # ws'"
       using A .
      ultimately have "[] = w' # ws'" using D by simp
      hence False by simp
    }
    ultimately show False ..
  next
    fix v vs w ws
    assume C: "zs = v # vs" and "ys' = []"
    hence D: "xs \<simeq> {[], vs, P}" using B' by simp
    assume E: "ys = w # ws"
    have "P x xs \<or> \<not> P x xs" by simp
    moreover {
      assume "P x xs"
      hence "xs \<simeq> {ws, v # vs, P}" using B and C and E by simp
      hence "length xs = Suc (length vs) + length ws"
       by (simp add: interleaves_length)
      moreover have "length xs = length vs"
       using D by (simp add: interleaves_length)
      ultimately have False by simp
    }
    moreover {
      assume "\<not> P x xs"
      hence "xs \<simeq> {w # ws, vs, P}" using B and C and E by simp
      moreover have "xs \<simeq> {[], vs, P} \<longrightarrow> xs \<simeq> {w # ws, vs, P} \<longrightarrow> [] = w # ws"
       using A .
      ultimately have "[] = w # ws" using D by simp
      hence False by simp
    }
    ultimately show False ..
  next
    fix v vs w ws w' ws'
    assume C: "zs = v # vs" and D: "ys = w # ws" and D': "ys' = w' # ws'"
    have "P x xs \<or> \<not> P x xs" by simp
    moreover {
      assume E: "P x xs"
      hence F: "w = x" using B and C and D by simp
      have "xs \<simeq> {ws, v # vs, P}" using B and C and D and E by simp
      moreover have F': "w' = x" using B' and C and D' and E by simp
      have "xs \<simeq> {ws', v # vs, P}" using B' and C and D' and E by simp
      moreover have "xs \<simeq> {ws, v # vs, P} \<longrightarrow> xs \<simeq> {ws', v # vs, P} \<longrightarrow>
        ws = ws'"
       using A .
      ultimately have "ws = ws'" by simp
      hence "w = w' \<and> ws = ws'" using F and F' by simp
    }
    moreover {
      assume E: "\<not> P x xs"
      hence "xs \<simeq> {w # ws, vs, P}" using B and C and D by simp
      moreover have "xs \<simeq> {w' # ws', vs, P}"
       using B' and C and D' and E by simp
      moreover have "xs \<simeq> {w # ws, vs, P} \<longrightarrow> xs \<simeq> {w' # ws', vs, P} \<longrightarrow>
        w # ws = w' # ws'"
       using A .
      ultimately have "w # ws = w' # ws'" by simp
      hence "w = w' \<and> ws = ws'" by simp
    }
    ultimately show "w = w' \<and> ws = ws'" ..
  qed
qed

lemma interleaves_equal_snd:
 "xs \<simeq> {ys, zs, P} \<Longrightarrow> xs \<simeq> {ys, zs', P} \<Longrightarrow> zs = zs'"
by (subst (asm) (1 2) interleaves_swap, rule interleaves_equal_fst)

text \<open>
\null

Since \emph{interleaves} statements permit to prove equalities between lists without the need of an
induction, it is useful to search for rules that allow to infer such statements themselves without
induction, which is precisely what is done here below. Particularly, it is proven that under proper
assumptions, predicate @{term interleaves} keeps being satisfied by applying a filter, a mapping, or
the addition or removal of a prefix to the input lists.

\null
\<close>

lemma interleaves_all_nil:
 "xs \<simeq> {xs, [], P}"
by (induction xs, simp_all)

lemma interleaves_nil_all:
 "xs \<simeq> {[], xs, P}"
by (induction xs, simp_all)

lemma interleaves_equal_all_nil:
 "xs \<simeq> {ys, [], P} \<Longrightarrow> xs = ys"
by (insert interleaves_all_nil, rule interleaves_equal_fst)

lemma interleaves_equal_nil_all:
 "xs \<simeq> {[], zs, P} \<Longrightarrow> xs = zs"
by (insert interleaves_nil_all, rule interleaves_equal_snd)

lemma interleaves_filter [rule_format]:
  assumes A: "\<forall>x xs. P x (filter Q xs) = P x xs"
  shows "xs \<simeq> {ys, zs, P} \<longrightarrow> filter Q xs \<simeq> {filter Q ys, filter Q zs, P}"
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp)
  fix ys zs
  assume "[] \<simeq> {ys, zs, P}"
  hence "ys = [] \<and> zs = []" by (rule interleaves_nil)
  thus "[] \<simeq> {filter Q ys, filter Q zs, P}" by simp
next
  fix x xs ys zs
  assume
    B: "\<And>ys' zs'. xs \<simeq> {ys', zs', P} \<longrightarrow>
      filter Q xs \<simeq> {filter Q ys', filter Q zs', P}" and
    C: "x # xs \<simeq> {ys, zs, P}"
  show "filter Q (x # xs) \<simeq> {filter Q ys, filter Q zs, P}"
  proof (cases ys, case_tac [!] zs, simp_all del: filter.simps, rule ccontr)
    assume "ys = []" and "zs = []"
    thus False using C by simp
  next
    fix z zs'
    assume "ys = []" and "zs = z # zs'"
    hence D: "x = z \<and> xs \<simeq> {[], zs', P}" using C by simp
    moreover have "xs \<simeq> {[], zs', P} \<longrightarrow>
      filter Q xs \<simeq> {filter Q [], filter Q zs', P}"
     using B .
    ultimately have "filter Q xs \<simeq> {[], filter Q zs', P}" by simp
    thus "filter Q (x # xs) \<simeq> {[], filter Q (z # zs'), P}" using D by simp
  next
    fix y ys'
    assume "ys = y # ys'" and "zs = []"
    hence D: "x = y \<and> xs \<simeq> {ys', [], P}" using C by simp
    moreover have "xs \<simeq> {ys', [], P} \<longrightarrow>
      filter Q xs \<simeq> {filter Q ys', filter Q [], P}"
     using B .
    ultimately have "filter Q xs \<simeq> {filter Q ys', [], P}" by simp
    thus "filter Q (x # xs) \<simeq> {filter Q (y # ys'), [], P}" using D by simp
  next
    fix y ys' z zs'
    assume "ys = y # ys'" and "zs = z # zs'"
    hence D: "x # xs \<simeq> {y # ys', z # zs', P}" using C by simp
    show "filter Q (x # xs) \<simeq> {filter Q (y # ys'), filter Q (z # zs'), P}"
    proof (cases "P x xs")
      case True
      hence E: "P x (filter Q xs)" using A by simp
      have F: "x = y \<and> xs \<simeq> {ys', z # zs', P}" using D and True by simp
      moreover have "xs \<simeq> {ys', z # zs', P} \<longrightarrow>
        filter Q xs \<simeq> {filter Q ys', filter Q (z # zs'), P}"
       using B .
      ultimately have G: "filter Q xs \<simeq> {filter Q ys', filter Q (z # zs'), P}"
       by simp
      show ?thesis
      proof (cases "Q x")
        assume "Q x"
        hence "filter Q (x # xs) = x # filter Q xs" by simp
        moreover have "filter Q (y # ys') = x # filter Q ys'"
         using \<open>Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (z # zs')", simp_all)
      next
        assume "\<not> Q x"
        hence "filter Q (x # xs) = filter Q xs" by simp
        moreover have "filter Q (y # ys') = filter Q ys'"
         using \<open>\<not> Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (z # zs')", simp_all)
      qed
    next
      case False
      hence E: "\<not> P x (filter Q xs)" using A by simp
      have F: "x = z \<and> xs \<simeq> {y # ys', zs', P}" using D and False by simp
      moreover have "xs \<simeq> {y # ys', zs', P} \<longrightarrow>
        filter Q xs \<simeq> {filter Q (y # ys'), filter Q zs', P}"
       using B .
      ultimately have G: "filter Q xs \<simeq> {filter Q (y # ys'), filter Q zs', P}"
       by simp
      show ?thesis
      proof (cases "Q x")
        assume "Q x"
        hence "filter Q (x # xs) = x # filter Q xs" by simp
        moreover have "filter Q (z # zs') = x # filter Q zs'"
         using \<open>Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (y # ys')", simp_all)
      next
        assume "\<not> Q x"
        hence "filter Q (x # xs) = filter Q xs" by simp
        moreover have "filter Q (z # zs') = filter Q zs'"
         using \<open>\<not> Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (z # zs')", simp_all)
      qed
    qed
  qed
qed

lemma interleaves_map [rule_format]:
  assumes A: "inj f"
  shows "xs \<simeq> {ys, zs, P} \<longrightarrow>
    map f xs \<simeq> {map f ys, map f zs, \<lambda>w ws. P (inv f w) (map (inv f) ws)}"
    (is "_ \<longrightarrow> _ \<simeq> {_, _, ?P'}")
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp_all)
  fix ys zs
  assume "[] \<simeq> {ys, zs, P}"
  hence "ys = [] \<and> zs = []" by (rule interleaves_nil)
  thus "[] \<simeq> {map f ys, map f zs, ?P'}" by simp
next
  fix x xs ys zs
  assume
    B: "\<And>ys zs. xs \<simeq> {ys, zs, P} \<longrightarrow> map f xs \<simeq> {map f ys, map f zs, ?P'}" and
    C: "x # xs \<simeq> {ys, zs, P}"
  show "f x # map f xs \<simeq> {map f ys, map f zs, ?P'}"
  proof (cases ys, case_tac [!] zs, simp_all del: interleaves.simps(1))
    assume "ys = []" and "zs = []"
    thus False using C by simp
  next
    fix z zs'
    assume "ys = []" and "zs = z # zs'"
    hence "x = z \<and> xs \<simeq> {[], zs', P}" using C by simp
    moreover have "xs \<simeq> {[], zs', P} \<longrightarrow> map f xs \<simeq> {map f [], map f zs', ?P'}"
     using B .
    ultimately show "f x = f z \<and> map f xs \<simeq> {[], map f zs', ?P'}" by simp
  next
    fix y ys'
    assume "ys = y # ys'" and "zs = []"
    hence "x = y \<and> xs \<simeq> {ys', [], P}" using C by simp
    moreover have "xs \<simeq> {ys', [], P} \<longrightarrow> map f xs \<simeq> {map f ys', map f [], ?P'}"
     using B .
    ultimately show "f x = f y \<and> map f xs \<simeq> {map f ys', [], ?P'}" by simp
  next
    fix y ys' z zs'
    assume "ys = y # ys'" and "zs = z # zs'"
    hence D: "x # xs \<simeq> {y # ys', z # zs', P}" using C by simp
    show "f x # map f xs \<simeq> {f y # map f ys', f z # map f zs', ?P'}"
    proof (cases "P x xs")
      case True
      hence E: "?P' (f x) (map f xs)" using A by simp
      have "x = y \<and> xs \<simeq> {ys', z # zs', P}" using D and True by simp
      moreover have "xs \<simeq> {ys', z # zs', P} \<longrightarrow>
        map f xs \<simeq> {map f ys', map f (z # zs'), ?P'}"
       using B .
      ultimately have "f x = f y \<and> map f xs \<simeq> {map f ys', map f (z # zs'), ?P'}"
       by simp
      thus ?thesis using E by simp
    next
      case False
      hence E: "\<not> ?P' (f x) (map f xs)" using A by simp
      have "x = z \<and> xs \<simeq> {y # ys', zs', P}" using D and False by simp
      moreover have "xs \<simeq> {y # ys', zs', P} \<longrightarrow>
        map f xs \<simeq> {map f (y # ys'), map f zs', ?P'}"
       using B .
      ultimately have "f x = f z \<and> map f xs \<simeq> {map f (y # ys'), map f zs', ?P'}"
       by simp
      thus ?thesis using E by simp
    qed
  qed
qed

lemma interleaves_prefix_fst_1 [rule_format]:
  assumes A: "xs \<simeq> {ys, zs, P}"
  shows "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    ws @ xs \<simeq> {ws @ ys, zs, P}"
proof (induction ws, simp_all add: A, rule impI)
  fix w ws
  assume B: "\<forall>n < Suc (length ws). P ((w # ws) ! n) (drop n ws @ xs)"
  assume "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    ws @ xs \<simeq> {ws @ ys, zs, P}"
  moreover have "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)"
  proof (rule allI, rule impI)
    fix n
    assume "n < length ws"
    moreover have "Suc n < Suc (length ws) \<longrightarrow>
      P ((w # ws) ! (Suc n)) (drop (Suc n) ws @ xs)"
     using B ..
    ultimately show "P (ws ! n) (drop (Suc n) ws @ xs)" by simp
  qed
  ultimately have "ws @ xs \<simeq> {ws @ ys, zs, P}" ..
  moreover have "0 < Suc (length ws) \<longrightarrow> P ((w # ws) ! 0) (drop 0 ws @ xs)"
   using B ..
  hence "P w (ws @ xs)" by simp
  ultimately show "w # ws @ xs \<simeq> {w # ws @ ys, zs, P}" by (cases zs, simp_all)
qed

lemma interleaves_prefix_fst_2 [rule_format]:
 "ws @ xs \<simeq> {ws @ ys, zs, P} \<longrightarrow>
  (\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
  xs \<simeq> {ys, zs, P}"
proof (induction ws, simp_all, (rule impI)+)
  fix w ws
  assume A: "\<forall>n < Suc (length ws). P ((w # ws) ! n) (drop n ws @ xs)"
  hence "0 < Suc (length ws) \<longrightarrow> P ((w # ws) ! 0) (drop 0 ws @ xs)" ..
  hence "P w (ws @ xs)" by simp
  moreover assume "w # ws @ xs \<simeq> {w # ws @ ys, zs, P}"
  ultimately have "ws @ xs \<simeq> {ws @ ys, zs, P}" by (cases zs, simp_all)
  moreover assume "ws @ xs \<simeq> {ws @ ys, zs, P} \<longrightarrow>
    (\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    xs \<simeq> {ys, zs, P}"
  ultimately have "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    xs \<simeq> {ys, zs, P}"
   by simp
  moreover have "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)"
  proof (rule allI, rule impI)
    fix n
    assume "n < length ws"
    moreover have "Suc n < Suc (length ws) \<longrightarrow>
      P ((w # ws) ! (Suc n)) (drop (Suc n) ws @ xs)"
     using A ..
    ultimately show "P (ws ! n) (drop (Suc n) ws @ xs)" by simp
  qed
  ultimately show "xs \<simeq> {ys, zs, P}" ..
qed

lemma interleaves_prefix_fst [rule_format]:
 "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs) \<Longrightarrow>
  xs \<simeq> {ys, zs, P} = ws @ xs \<simeq> {ws @ ys, zs, P}"
proof (rule iffI, erule interleaves_prefix_fst_1, simp)
qed (erule interleaves_prefix_fst_2, simp)

lemma interleaves_prefix_snd [rule_format]:
 "\<forall>n < length ws. \<not> P (ws ! n) (drop (Suc n) ws @ xs) \<Longrightarrow>
  xs \<simeq> {ys, zs, P} = ws @ xs \<simeq> {ys, ws @ zs, P}"
proof (subst (1 2) interleaves_swap)
qed (rule interleaves_prefix_fst, simp)

subsection "A second, stronger version of interleaving"

text \<open>
Simple counterexamples show that unlike prefixes, the addition or removal of suffixes to the input
lists does not generally preserve the validity of predicate @{term interleaves}. In fact, if
@{term "P y [x] = True"} with @{term "x \<noteq> y"}, then @{term "[y, x] \<simeq> {[x], [y], P}"} does not hold
although @{term "[y] \<simeq> {[], [y], \<lambda>w ws. P w (ws @ [x])}"} does, by virtue of lemma
@{thm interleaves_nil_all}. Similarly, @{term "[x, y] \<simeq> {[], [y, x], \<lambda>w ws. P w (ws @ [x])}"} does
not hold for @{term "x \<noteq> y"} even though @{term "[x, y, x] \<simeq> {[x], [y, x], P}"} does.

Both counterexamples would not work any longer if the truth value of the input predicate were
significant even if either the second or the third list is empty. In fact, in the former case,
condition @{term "P y [x] = True"} would entail the falseness of statement
@{term "[y] \<simeq> {[], [y], \<lambda>w ws. P w (ws @ [x])}"}, so that the validity of rule
@{term "[y] \<simeq> {[], [y], \<lambda>w ws. P w (ws @ [x])} \<Longrightarrow> [y, x] \<simeq> {[x], [y], P}"} would be preserved. In
the latter case, statement @{term "[x, y, x] \<simeq> {[x], [y, x], P}"} may only hold provided the last
item \<open>x\<close> of the first list is extracted from the third one, which would require that
@{term "\<not> P x []"}; thus, subordinating rule
@{term "[x, y, x] \<simeq> {[x], [y, x], P} \<Longrightarrow> [x, y] \<simeq> {[], [y, x], \<lambda>w ws. P w (ws @ [x])}"} to
condition @{term "P x []"} would preserve its validity.

This argument suggests that in order to obtain an \emph{interleaves} predicate whose validity is
also preserved upon the addition or removal of a suffix to the input lists, the truth value of the
input predicate must matter until both the second and the third list are empty. In what follows,
such a stronger version of the predicate, named \<open>Interleaves\<close>, is defined along with a
convenient symbolic notation for it.

\null
\<close>

fun Interleaves ::
 "('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"Interleaves P (x # xs) (y # ys) (z # zs) = (if P x xs
  then x = y \<and> Interleaves P xs ys (z # zs)
  else x = z \<and> Interleaves P xs (y # ys) zs)" |
"Interleaves P (x # xs) (y # ys) [] =
  (P x xs \<and> x = y \<and> Interleaves P xs ys [])" |
"Interleaves P (x # xs) [] (z # zs) =
  (\<not> P x xs \<and> x = z \<and> Interleaves P xs [] zs)" |
"Interleaves _ (_ # _) [] [] = False" |
"Interleaves _ [] (_ # _) _ = False" |
"Interleaves _ [] _ (_ # _) = False" |
"Interleaves _ [] [] [] = True"

abbreviation Interleaves_syntax ::
    "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> bool"
    ("(_ \<cong> {_, _, _})" [60, 60, 60] 51)
  where "xs \<cong> {ys, zs, P} \<equiv> Interleaves P xs ys zs"

text \<open>
\null

In what follows, it is proven that predicate @{term Interleaves} is actually not weaker than, viz.
is a sufficient condition for, predicate @{term interleaves}. Moreover, the former predicate is
shown to fulfil the same rules as the latter, although sometimes under more stringent assumptions
(cf. lemmas \<open>Interleaves_all_nil\<close>, \<open>Interleaves_nil_all\<close> with lemmas
@{thm interleaves_all_nil}, @{thm interleaves_nil_all}), and to have the further property that under
proper assumptions, its validity is preserved upon the addition or removal of a suffix to the input
lists.

\null
\<close>

lemma Interleaves_interleaves [rule_format]:
 "xs \<cong> {ys, zs, P} \<longrightarrow> xs \<simeq> {ys, zs, P}"
proof (induction P xs ys zs rule: interleaves.induct, simp_all)
qed (rule conjI, (rule_tac [!] impI)+, simp_all)

lemma Interleaves_nil:
 "[] \<cong> {ys, zs, P} \<Longrightarrow> ys = [] \<and> zs = []"
by (drule Interleaves_interleaves, rule interleaves_nil)

lemma Interleaves_swap:
 "xs \<cong> {ys, zs, P} = xs \<cong> {zs, ys, \<lambda>w ws. \<not> P w ws}"
proof (induction P xs ys zs rule: Interleaves.induct, simp_all)
  fix y' :: 'a and ys' zs' P'
  show "\<not> [] \<cong> {zs', y' # ys', \<lambda>w ws. \<not> P' w ws}" by (cases zs', simp_all)
qed

lemma Interleaves_equal_fst:
 "xs \<cong> {ys, zs, P} \<Longrightarrow> xs \<cong> {ys', zs, P} \<Longrightarrow> ys = ys'"
by ((drule Interleaves_interleaves)+, rule interleaves_equal_fst)

lemma Interleaves_equal_snd:
 "xs \<cong> {ys, zs, P} \<Longrightarrow> xs \<cong> {ys, zs', P} \<Longrightarrow> zs = zs'"
by ((drule Interleaves_interleaves)+, rule interleaves_equal_snd)

lemma Interleaves_equal_all_nil:
 "xs \<cong> {ys, [], P} \<Longrightarrow> xs = ys"
by (drule Interleaves_interleaves, rule interleaves_equal_all_nil)

lemma Interleaves_equal_nil_all:
 "xs \<cong> {[], zs, P} \<Longrightarrow> xs = zs"
by (drule Interleaves_interleaves, rule interleaves_equal_nil_all)

lemma Interleaves_filter [rule_format]:
  assumes A: "\<forall>x xs. P x (filter Q xs) = P x xs"
  shows "xs \<cong> {ys, zs, P} \<longrightarrow> filter Q xs \<cong> {filter Q ys, filter Q zs, P}"
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp)
  fix ys zs
  assume "[] \<cong> {ys, zs, P}"
  hence "ys = [] \<and> zs = []" by (rule Interleaves_nil)
  thus "[] \<cong> {filter Q ys, filter Q zs, P}" by simp
next
  fix x xs ys zs
  assume
    B: "\<And>ys' zs'. xs \<cong> {ys', zs', P} \<longrightarrow>
      filter Q xs \<cong> {filter Q ys', filter Q zs', P}" and
    C: "x # xs \<cong> {ys, zs, P}"
  show "filter Q (x # xs) \<cong> {filter Q ys, filter Q zs, P}"
  proof (cases ys, case_tac [!] zs, simp_all del: filter.simps, rule ccontr)
    assume "ys = []" and "zs = []"
    thus False using C by simp
  next
    fix z zs'
    assume "ys = []" and "zs = z # zs'"
    hence D: "\<not> P x xs \<and> x = z \<and> xs \<cong> {[], zs', P}" using C by simp+
    moreover have "xs \<cong> {[], zs', P} \<longrightarrow>
      filter Q xs \<cong> {filter Q [], filter Q zs', P}"
     using B .
    ultimately have "filter Q xs \<cong> {[], filter Q zs', P}" by simp
    moreover have "\<not> P x (filter Q xs)" using A and D by simp+
    ultimately show "filter Q (x # xs) \<cong> {[], filter Q (z # zs'), P}"
     using D by simp
  next
    fix y ys'
    assume "ys = y # ys'" and "zs = []"
    hence D: "P x xs \<and> x = y \<and> xs \<cong> {ys', [], P}" using C by simp+
    moreover have "xs \<cong> {ys', [], P} \<longrightarrow>
      filter Q xs \<cong> {filter Q ys', filter Q [], P}"
     using B .
    ultimately have "filter Q xs \<cong> {filter Q ys', [], P}" by simp
    moreover have "P x (filter Q xs)" using A and D by simp+
    ultimately show "filter Q (x # xs) \<cong> {filter Q (y # ys'), [], P}"
     using D by simp
  next
    fix y ys' z zs'
    assume "ys = y # ys'" and "zs = z # zs'"
    hence D: "x # xs \<cong> {y # ys', z # zs', P}" using C by simp
    show "filter Q (x # xs) \<cong> {filter Q (y # ys'), filter Q (z # zs'), P}"
    proof (cases "P x xs")
      case True
      hence E: "P x (filter Q xs)" using A by simp
      have F: "x = y \<and> xs \<cong> {ys', z # zs', P}" using D and True by simp
      moreover have "xs \<cong> {ys', z # zs', P} \<longrightarrow>
        filter Q xs \<cong> {filter Q ys', filter Q (z # zs'), P}"
       using B .
      ultimately have G: "filter Q xs \<cong> {filter Q ys', filter Q (z # zs'), P}"
       by simp
      show ?thesis
      proof (cases "Q x")
        assume "Q x"
        hence "filter Q (x # xs) = x # filter Q xs" by simp
        moreover have "filter Q (y # ys') = x # filter Q ys'"
         using \<open>Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (z # zs')", simp_all)
      next
        assume "\<not> Q x"
        hence "filter Q (x # xs) = filter Q xs" by simp
        moreover have "filter Q (y # ys') = filter Q ys'"
         using \<open>\<not> Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (z # zs')", simp_all)
      qed
    next
      case False
      hence E: "\<not> P x (filter Q xs)" using A by simp
      have F: "x = z \<and> xs \<cong> {y # ys', zs', P}" using D and False by simp
      moreover have "xs \<cong> {y # ys', zs', P} \<longrightarrow>
        filter Q xs \<cong> {filter Q (y # ys'), filter Q zs', P}"
       using B .
      ultimately have G: "filter Q xs \<cong> {filter Q (y # ys'), filter Q zs', P}"
       by simp
      show ?thesis
      proof (cases "Q x")
        assume "Q x"
        hence "filter Q (x # xs) = x # filter Q xs" by simp
        moreover have "filter Q (z # zs') = x # filter Q zs'"
         using \<open>Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (y # ys')", simp_all)
      next
        assume "\<not> Q x"
        hence "filter Q (x # xs) = filter Q xs" by simp
        moreover have "filter Q (z # zs') = filter Q zs'"
         using \<open>\<not> Q x\<close> and F by simp
        ultimately show ?thesis using E and G
         by (cases "filter Q (z # zs')", simp_all)
      qed
    qed
  qed
qed

lemma Interleaves_map [rule_format]:
  assumes A: "inj f"
  shows "xs \<cong> {ys, zs, P} \<longrightarrow>
    map f xs \<cong> {map f ys, map f zs, \<lambda>w ws. P (inv f w) (map (inv f) ws)}"
    (is "_ \<longrightarrow> _ \<cong> {_, _, ?P'}")
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp_all)
  fix ys zs
  assume "[] \<cong> {ys, zs, P}"
  hence "ys = [] \<and> zs = []" by (rule Interleaves_nil)
  thus "[] \<cong> {map f ys, map f zs, ?P'}" by simp
next
  fix x xs ys zs
  assume
    B: "\<And>ys zs. xs \<cong> {ys, zs, P} \<longrightarrow> map f xs \<cong> {map f ys, map f zs, ?P'}" and
    C: "x # xs \<cong> {ys, zs, P}"
  show "f x # map f xs \<cong> {map f ys, map f zs, ?P'}"
  proof (cases ys, case_tac [!] zs, simp_all del: Interleaves.simps(1-3))
    assume "ys = []" and "zs = []"
    thus False using C by simp
  next
    fix z zs'
    assume "ys = []" and "zs = z # zs'"
    hence D: "\<not> P x xs \<and> x = z \<and> xs \<cong> {[], zs', P}" using C by simp+
    moreover have "xs \<cong> {[], zs', P} \<longrightarrow> map f xs \<cong> {map f [], map f zs', ?P'}"
     using B .
    ultimately have "map f xs \<cong> {[], map f zs', ?P'}" by simp
    moreover have "\<not> ?P' (f x) (map f xs)" using A and D by simp+
    ultimately show "f x # map f xs \<cong> {[], f z # map f zs', ?P'}"
     using D by simp
  next
    fix y ys'
    assume "ys = y # ys'" and "zs = []"
    hence D: "P x xs \<and> x = y \<and> xs \<cong> {ys', [], P}" using C by simp+
    moreover have "xs \<cong> {ys', [], P} \<longrightarrow> map f xs \<cong> {map f ys', map f [], ?P'}"
     using B .
    ultimately have "map f xs \<cong> {map f ys', [], ?P'}" by simp
    moreover have "?P' (f x) (map f xs)" using A and D by simp+
    ultimately show "f x # map f xs \<cong> {f y # map f ys', [], ?P'}"
     using D by simp
  next
    fix y ys' z zs'
    assume "ys = y # ys'" and "zs = z # zs'"
    hence D: "x # xs \<cong> {y # ys', z # zs', P}" using C by simp
    show "f x # map f xs \<cong> {f y # map f ys', f z # map f zs', ?P'}"
    proof (cases "P x xs")
      case True
      hence E: "?P' (f x) (map f xs)" using A by simp
      have "x = y \<and> xs \<cong> {ys', z # zs', P}" using D and True by simp
      moreover have "xs \<cong> {ys', z # zs', P} \<longrightarrow>
        map f xs \<cong> {map f ys', map f (z # zs'), ?P'}"
       using B .
      ultimately have "f x = f y \<and> map f xs \<cong> {map f ys', map f (z # zs'), ?P'}"
       by simp
      thus ?thesis using E by simp
    next
      case False
      hence E: "\<not> ?P' (f x) (map f xs)" using A by simp
      have "x = z \<and> xs \<cong> {y # ys', zs', P}" using D and False by simp
      moreover have "xs \<cong> {y # ys', zs', P} \<longrightarrow>
        map f xs \<cong> {map f (y # ys'), map f zs', ?P'}"
       using B .
      ultimately have "f x = f z \<and> map f xs \<cong> {map f (y # ys'), map f zs', ?P'}"
       by simp
      thus ?thesis using E by simp
    qed
  qed
qed

lemma Interleaves_prefix_fst_1 [rule_format]:
  assumes A: "xs \<cong> {ys, zs, P}"
  shows "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    ws @ xs \<cong> {ws @ ys, zs, P}"
proof (induction ws, simp_all add: A, rule impI)
  fix w ws
  assume B: "\<forall>n < Suc (length ws). P ((w # ws) ! n) (drop n ws @ xs)"
  assume "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    ws @ xs \<cong> {ws @ ys, zs, P}"
  moreover have "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)"
  proof (rule allI, rule impI)
    fix n
    assume "n < length ws"
    moreover have "Suc n < Suc (length ws) \<longrightarrow>
      P ((w # ws) ! (Suc n)) (drop (Suc n) ws @ xs)"
     using B ..
    ultimately show "P (ws ! n) (drop (Suc n) ws @ xs)" by simp
  qed
  ultimately have "ws @ xs \<cong> {ws @ ys, zs, P}" ..
  moreover have "0 < Suc (length ws) \<longrightarrow> P ((w # ws) ! 0) (drop 0 ws @ xs)"
   using B ..
  hence "P w (ws @ xs)" by simp
  ultimately show "w # ws @ xs \<cong> {w # ws @ ys, zs, P}" by (cases zs, simp_all)
qed

lemma Interleaves_prefix_fst_2 [rule_format]:
 "ws @ xs \<cong> {ws @ ys, zs, P} \<longrightarrow>
  (\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
  xs \<cong> {ys, zs, P}"
proof (induction ws, simp_all, (rule impI)+)
  fix w ws
  assume A: "\<forall>n < Suc (length ws). P ((w # ws) ! n) (drop n ws @ xs)"
  hence "0 < Suc (length ws) \<longrightarrow> P ((w # ws) ! 0) (drop 0 ws @ xs)" ..
  hence "P w (ws @ xs)" by simp
  moreover assume "w # ws @ xs \<cong> {w # ws @ ys, zs, P}"
  ultimately have "ws @ xs \<cong> {ws @ ys, zs, P}" by (cases zs, simp_all)
  moreover assume "ws @ xs \<cong> {ws @ ys, zs, P} \<longrightarrow>
    (\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    xs \<cong> {ys, zs, P}"
  ultimately have "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)) \<longrightarrow>
    xs \<cong> {ys, zs, P}"
   by simp
  moreover have "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs)"
  proof (rule allI, rule impI)
    fix n
    assume "n < length ws"
    moreover have "Suc n < Suc (length ws) \<longrightarrow>
      P ((w # ws) ! (Suc n)) (drop (Suc n) ws @ xs)"
     using A ..
    ultimately show "P (ws ! n) (drop (Suc n) ws @ xs)" by simp
  qed
  ultimately show "xs \<cong> {ys, zs, P}" ..
qed

lemma Interleaves_prefix_fst [rule_format]:
 "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws @ xs) \<Longrightarrow>
  xs \<cong> {ys, zs, P} = ws @ xs \<cong> {ws @ ys, zs, P}"
proof (rule iffI, erule Interleaves_prefix_fst_1, simp)
qed (erule Interleaves_prefix_fst_2, simp)

lemma Interleaves_prefix_snd [rule_format]:
 "\<forall>n < length ws. \<not> P (ws ! n) (drop (Suc n) ws @ xs) \<Longrightarrow>
  xs \<cong> {ys, zs, P} = ws @ xs \<cong> {ys, ws @ zs, P}"
proof (subst (1 2) Interleaves_swap)
qed (rule Interleaves_prefix_fst, simp)

lemma Interleaves_all_nil_1 [rule_format]:
 "xs \<cong> {xs, [], P} \<longrightarrow> (\<forall>n < length xs. P (xs ! n) (drop (Suc n) xs))"
proof (induction xs, simp_all, rule impI, erule conjE, rule allI, rule impI)
  fix x xs n
  assume
    "xs \<cong> {xs, [], P} \<longrightarrow> (\<forall>n < length xs. P (xs ! n) (drop (Suc n) xs))" and
    "xs \<cong> {xs, [], P}"
  hence A: "\<forall>n < length xs. P (xs ! n) (drop (Suc n) xs)" ..
  assume
    B: "P x xs" and
    C: "n < Suc (length xs)"
  show "P ((x # xs) ! n) (drop n xs)"
  proof (cases n, simp_all add: B)
    case (Suc m)
    have "m < length xs \<longrightarrow> P (xs ! m) (drop (Suc m) xs)" using A ..
    moreover have "m < length xs" using C and Suc by simp
    ultimately show "P (xs ! m) (drop (Suc m) xs)" ..
  qed
qed

lemma Interleaves_all_nil_2 [rule_format]:
 "\<forall>n < length xs. P (xs ! n) (drop (Suc n) xs) \<Longrightarrow> xs \<cong> {xs, [], P}"
by (insert Interleaves_prefix_fst [of xs P "[]" "[]" "[]"], simp)

lemma Interleaves_all_nil:
 "xs \<cong> {xs, [], P} = (\<forall>n < length xs. P (xs ! n) (drop (Suc n) xs))"
proof (rule iffI, rule allI, rule impI, rule Interleaves_all_nil_1, assumption+)
qed (rule Interleaves_all_nil_2, simp)

lemma Interleaves_nil_all:
 "xs \<cong> {[], xs, P} = (\<forall>n < length xs. \<not> P (xs ! n) (drop (Suc n) xs))"
by (subst Interleaves_swap, simp add: Interleaves_all_nil)

lemma Interleaves_suffix_one_aux:
  assumes A: "P x []"
  shows "\<not> xs @ [x] \<cong> {[], zs, P}"
proof (induction xs arbitrary: zs, simp_all, rule_tac [!] notI)
  fix zs
  assume "[x] \<cong> {[], zs, P}"
  thus False by (cases zs, simp_all add: A)
next
  fix w xs zs
  assume B: "\<And>zs. \<not> xs @ [x] \<cong> {[], zs, P}"
  assume "w # xs @ [x] \<cong> {[], zs, P}"
  thus False proof (cases zs, simp_all, (erule_tac conjE)+)
    fix zs'
    assume "xs @ [x] \<cong> {[], zs', P}"
    moreover have "\<not> xs @ [x] \<cong> {[], zs', P}" using B .
    ultimately show False by contradiction
  qed
qed

lemma Interleaves_suffix_one_fst_2 [rule_format]:
  assumes A: "P x []"
  shows "xs @ [x] \<cong> {ys @ [x], zs, P} \<longrightarrow> xs \<cong> {ys, zs, \<lambda>w ws. P w (ws @ [x])}"
    (is "_ \<longrightarrow> _ \<cong> {_, _, ?P'}")
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp_all)
  fix ys zs
  assume "[x] \<cong> {ys @ [x], zs, P}"
  hence B: "length [x] = length (ys @ [x]) + length zs"
   by (rule Interleaves_length)
  have ys: "ys = []" by (cases ys, simp, insert B, simp)
  then have "zs = []" by (cases zs, simp, insert B, simp)
  with ys show "[] \<cong> {ys, zs, ?P'}" by simp
next
  fix w xs ys zs
  assume B: "\<And>ys zs. xs @ [x] \<cong> {ys @ [x], zs, P} \<longrightarrow> xs \<cong> {ys, zs, ?P'}"
  assume "w # xs @ [x] \<cong> {ys @ [x], zs, P}"
  thus "w # xs \<cong> {ys, zs, ?P'}"
  proof (cases zs, case_tac [!] ys, simp_all del: Interleaves.simps(1,3),
   (erule_tac [1-2] conjE)+)
    assume "xs @ [x] \<cong> {[], [], P}"
    thus False by (cases xs, simp_all)
  next
    fix ys'
    have "xs @ [x] \<cong> {ys' @ [x], [], P} \<longrightarrow> xs \<cong> {ys', [], ?P'}" using B .
    moreover assume "xs @ [x] \<cong> {ys' @ [x], [], P}"
    ultimately show "xs \<cong> {ys', [], ?P'}" ..
  next
    fix z' zs'
    assume "w # xs @ [x] \<cong> {[x], z' # zs', P}"
    thus "w # xs \<cong> {[], z' # zs', ?P'}"
    proof (cases "P w (xs @ [x])", simp_all, erule_tac [!] conjE)
      assume "xs @ [x] \<cong> {[], z' # zs', P}"
      moreover have "\<not> xs @ [x] \<cong> {[], z' # zs', P}"
       using A by (rule Interleaves_suffix_one_aux)
      ultimately show False by contradiction
    next
      have "xs @ [x] \<cong> {[x], zs', P} \<longrightarrow> xs \<cong> {[], zs', ?P'}" using B by simp
      moreover assume "xs @ [x] \<cong> {[x], zs', P}"
      ultimately show "xs \<cong> {[], zs', ?P'}" ..
    qed
  next
    fix y' ys' z' zs'
    assume "w # xs @ [x] \<cong> {y' # ys' @ [x], z' # zs', P}"
    thus "w # xs \<cong> {y' # ys', z' # zs', ?P'}"
    proof (cases "P w (xs @ [x])", simp_all, erule_tac [!] conjE)
      have "xs @ [x] \<cong> {ys' @ [x], z' # zs', P} \<longrightarrow> xs \<cong> {ys', z' # zs', ?P'}"
       using B .
      moreover assume "xs @ [x] \<cong> {ys' @ [x], z' # zs', P}"
      ultimately show "xs \<cong> {ys', z' # zs', ?P'}" ..
    next
      have "xs @ [x] \<cong> {y' # ys' @ [x], zs', P} \<longrightarrow> xs \<cong> {y' # ys', zs', ?P'}"
       using B by simp
      moreover assume "xs @ [x] \<cong> {y' # ys' @ [x], zs', P}"
      ultimately show "xs \<cong> {y' # ys', zs', ?P'}" ..
    qed
  qed
qed

lemma Interleaves_suffix_fst_1 [rule_format]:
  assumes A: "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws)"
  shows "xs \<cong> {ys, zs, \<lambda>v vs. P v (vs @ ws)} \<longrightarrow> xs @ ws \<cong> {ys @ ws, zs, P}"
    (is "_ \<cong> {_, _, ?P'} \<longrightarrow> _")
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp_all)
  fix ys zs
  assume "[] \<cong> {ys, zs, ?P'}"
  hence "ys = [] \<and> zs = []" by (rule Interleaves_nil)
  thus "ws \<cong> {ys @ ws, zs, P}" using A by (simp add: Interleaves_all_nil)
next
  fix x xs ys zs
  assume A: "\<And>ys zs. xs \<cong> {ys, zs, ?P'} \<longrightarrow> xs @ ws \<cong> {ys @ ws, zs, P}"
  assume "x # xs \<cong> {ys, zs, ?P'}"
  thus "x # xs @ ws \<cong> {ys @ ws, zs, P}"
  proof (rule_tac Interleaves.cases [of "(?P', x # xs, ys, zs)"],
   simp_all del: Interleaves.simps(1),
   (erule_tac conjE)+, (erule_tac [2] conjE)+, (erule_tac [3] conjE)+)
    fix P' x' xs' y' ys' z' zs'
    assume
      B: "x' # xs' \<cong> {y' # ys', z' # zs', P'}" and
      C: "?P' = P'" and
      D: "xs = xs'"
    show "x' # xs' @ ws \<cong> {y' # ys' @ ws, z' # zs', P}"
    proof (cases "P' x' xs'")
      have "xs \<cong> {ys', z' # zs', ?P'} \<longrightarrow> xs @ ws \<cong> {ys' @ ws, z' # zs', P}"
       using A .
      moreover case True
      hence "xs \<cong> {ys', z' # zs', ?P'}" using B and C and D by simp
      ultimately have "xs @ ws \<cong> {ys' @ ws, z' # zs', P}" ..
      moreover have "P x' (xs' @ ws)" using C [symmetric] and True by simp
      moreover have "x' = y'" using B and True by simp
      ultimately show ?thesis using D by simp
    next
      have "xs \<cong> {y' # ys', zs', ?P'} \<longrightarrow> xs @ ws \<cong> {(y' # ys') @ ws, zs', P}"
       using A .
      moreover case False
      hence "xs \<cong> {y' # ys', zs', ?P'}" using B and C and D by simp
      ultimately have "xs @ ws \<cong> {(y' # ys') @ ws, zs', P}" ..
      moreover have "\<not> P x' (xs' @ ws)" using C [symmetric] and False by simp
      moreover have "x' = z'" using B and False by simp
      ultimately show ?thesis using D by simp
    qed
  next
    fix P' x' xs' y' ys'
    have "xs \<cong> {ys', [], ?P'} \<longrightarrow> xs @ ws \<cong> {ys' @ ws, [], P}" using A .
    moreover assume
      "xs' \<cong> {ys', [], P'}" and
      B: "?P' = P'" and
      C: "xs = xs'"
    hence "xs \<cong> {ys', [], ?P'}" by simp
    ultimately have "xs' @ ws \<cong> {ys' @ ws, [], P}" using C by simp
    moreover assume
      "P' x' xs'" and
      "x' = y'"
    hence "P y' (xs' @ ws)" using B [symmetric] by simp
    ultimately show "P y' (xs' @ ws) \<and> xs' @ ws \<cong> {ys' @ ws, [], P}" by simp
  next
    fix P' x' xs' z' zs'
    have "xs \<cong> {[], zs', ?P'} \<longrightarrow> xs @ ws \<cong> {[] @ ws, zs', P}" using A .
    moreover assume
      "xs' \<cong> {[], zs', P'}" and
      B: "?P' = P'" and
      C: "xs = xs'"
    hence "xs \<cong> {[], zs', ?P'}" by simp
    ultimately have "xs' @ ws \<cong> {ws, zs', P}" using C by simp
    moreover assume
      "\<not> P' x' xs'" and
      "x' = z'"
    hence "\<not> P z' (xs' @ ws)" using B [symmetric] by simp
    ultimately show "z' # xs' @ ws \<cong> {ws, z' # zs', P}" by (cases ws, simp_all)
  qed
qed

lemma Interleaves_suffix_one_fst_1 [rule_format]:
 "P x [] \<Longrightarrow>
  xs \<cong> {ys, zs, \<lambda>w ws. P w (ws @ [x])} \<Longrightarrow> xs @ [x] \<cong> {ys @ [x], zs, P}"
by (rule Interleaves_suffix_fst_1, simp)

lemma Interleaves_suffix_one_fst:
 "P x [] \<Longrightarrow>
  xs \<cong> {ys, zs, \<lambda>w ws. P w (ws @ [x])} = xs @ [x] \<cong> {ys @ [x], zs, P}"
proof (rule iffI, rule Interleaves_suffix_one_fst_1, assumption+)
qed (rule Interleaves_suffix_one_fst_2)

lemma Interleaves_suffix_one_snd:
 "\<not> P x [] \<Longrightarrow>
  xs \<cong> {ys, zs, \<lambda>w ws. P w (ws @ [x])} = xs @ [x] \<cong> {ys, zs @ [x], P}"
by (subst (1 2) Interleaves_swap, rule Interleaves_suffix_one_fst)

lemma Interleaves_suffix_aux [rule_format]:
 "(\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws)) \<longrightarrow>
  x # xs @ ws \<cong> {ws, zs, P} \<longrightarrow>
  \<not> P x (xs @ ws)"
proof (induction ws arbitrary: P rule: rev_induct, simp_all,
 rule impI, (rule_tac [2] impI)+)
  fix P
  assume "x # xs \<cong> {[], zs, P}"
  thus "\<not> P x xs" by (cases zs, simp_all)
next
  fix w ws P
  assume
    A: "\<And>P'. (\<forall>n < length ws. P' (ws ! n) (drop (Suc n) ws)) \<longrightarrow>
      x # xs @ ws \<cong> {ws, zs, P'} \<longrightarrow> \<not> P' x (xs @ ws)" and
    B: "\<forall>n < Suc (length ws). P ((ws @ [w]) ! n)
      (drop (Suc n) ws @ drop (Suc n - length ws) [w])"
  assume "x # xs @ ws @ [w] \<cong> {ws @ [w], zs, P}"
  hence C: "(x # xs @ ws) @ [w] \<cong> {ws @ [w], zs, P}" by simp
  let ?P' = "\<lambda>v vs. P v (vs @ [w])"
  have "(\<forall>n < length ws. ?P' (ws ! n) (drop (Suc n) ws)) \<longrightarrow>
    x # xs @ ws \<cong> {ws, zs, ?P'} \<longrightarrow> \<not> ?P' x (xs @ ws)"
   using A .
  moreover have "\<forall>n < length ws. ?P' (ws ! n) (drop (Suc n) ws)"
  proof (rule allI, rule impI)
    fix n
    assume D: "n < length ws"
    moreover have "n < Suc (length ws) \<longrightarrow> P ((ws @ [w]) ! n)
      (drop (Suc n) ws @ drop (Suc n - length ws) [w])"
     using B ..
    ultimately have "P ((ws @ [w]) ! n) (drop (Suc n) ws @ [w])" by simp
    moreover have "n < length (butlast (ws @ [w]))" using D by simp
    hence "butlast (ws @ [w]) ! n = (ws @ [w]) ! n" by (rule nth_butlast)
    ultimately show "P (ws ! n) (drop (Suc n) ws @ [w])" by simp
  qed
  ultimately have "x # xs @ ws \<cong> {ws, zs, ?P'} \<longrightarrow> \<not> ?P' x (xs @ ws)" ..
  moreover have "length ws < Suc (length ws) \<longrightarrow> P ((ws @ [w]) ! length ws)
    (drop (Suc (length ws)) ws @ drop (Suc (length ws) - length ws) [w])"
   using B ..
  hence "P w []" by simp
  hence "x # xs @ ws \<cong> {ws, zs, ?P'}"
   using C by (rule Interleaves_suffix_one_fst_2)
  ultimately have "\<not> ?P' x (xs @ ws)" ..
  thus "\<not> P x (xs @ ws @ [w])" by simp
qed

lemma Interleaves_suffix_fst_2 [rule_format]:
  assumes A: "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws)"
  shows "xs @ ws \<cong> {ys @ ws, zs, P} \<longrightarrow> xs \<cong> {ys, zs, \<lambda>v vs. P v (vs @ ws)}"
    (is "_ \<longrightarrow> _ \<cong> {_, _, ?P'}")
proof (induction xs arbitrary: ys zs, rule_tac [!] impI, simp_all)
  fix ys zs
  assume "ws \<cong> {ys @ ws, zs, P}"
  hence B: "length ws = length (ys @ ws) + length zs"
   by (rule Interleaves_length)
  have ys: "ys = []" by (cases ys, simp, insert B, simp)
  then have "zs = []" by (cases zs, simp, insert B, simp)
  with ys show "[] \<cong> {ys, zs, ?P'}" by simp
next
  fix x xs ys zs
  assume B: "\<And>ys zs. xs @ ws \<cong> {ys @ ws, zs, P} \<longrightarrow> xs \<cong> {ys, zs, ?P'}"
  assume "x # xs @ ws \<cong> {ys @ ws, zs, P}"
  thus "x # xs \<cong> {ys, zs, ?P'}"
  proof (cases zs, case_tac [!] ys, simp_all del: Interleaves.simps(1,3),
   (erule_tac [2] conjE)+)
    assume C: "x # xs @ ws \<cong> {ws, [], P}"
    have "length (x # xs @ ws) = length ws + length []"
     by (insert Interleaves_length [OF C], simp)
    thus False by simp
  next
    fix ys'
    have "xs @ ws \<cong> {ys' @ ws, [], P} \<longrightarrow> xs \<cong> {ys', [], ?P'}" using B .
    moreover assume "xs @ ws \<cong> {ys' @ ws, [], P}"
    ultimately show "xs \<cong> {ys', [], ?P'}" ..
  next
    fix z' zs'
    assume "x # xs @ ws \<cong> {ws, z' # zs', P}"
    thus "x # xs \<cong> {[], z' # zs', ?P'}"
    proof (cases "P x (xs @ ws)", simp_all)
      case True
      moreover assume "x # xs @ ws \<cong> {ws, z' # zs', P}"
      with A [rule_format] have "\<not> P x (xs @ ws)"
       by (rule Interleaves_suffix_aux)
      ultimately show False by contradiction
    next
      case False
      moreover assume "x # xs @ ws \<cong> {ws, z' # zs', P}"
      ultimately have "x = z' \<and> xs @ ws \<cong> {ws, zs', P}" by (cases ws, simp_all)
      moreover have "xs @ ws \<cong> {[] @ ws, zs', P} \<longrightarrow> xs \<cong> {[], zs', ?P'}"
       using B .
      ultimately show "x = z' \<and> xs \<cong> {[], zs', ?P'}" by simp
    qed
  next
    fix y' ys' z' zs'
    assume "x # xs @ ws \<cong> {y' # ys' @ ws, z' # zs', P}"
    thus "x # xs \<cong> {y' # ys', z' # zs', ?P'}"
    proof (cases "P x (xs @ ws)", simp_all, erule_tac [!] conjE)
      have "xs @ ws \<cong> {ys' @ ws, z' # zs', P} \<longrightarrow> xs \<cong> {ys', z' # zs', ?P'}"
       using B .
      moreover assume "xs @ ws \<cong> {ys' @ ws, z' # zs', P}"
      ultimately show "xs \<cong> {ys', z' # zs', ?P'}" ..
    next
      have "xs @ ws \<cong> {y' # ys' @ ws, zs', P} \<longrightarrow> xs \<cong> {y' # ys', zs', ?P'}"
       using B by simp
      moreover assume "xs @ ws \<cong> {y' # ys' @ ws, zs', P}"
      ultimately show "xs \<cong> {y' # ys', zs', ?P'}" ..
    qed
  qed
qed

lemma Interleaves_suffix_fst [rule_format]:
 "\<forall>n < length ws. P (ws ! n) (drop (Suc n) ws) \<Longrightarrow>
  xs \<cong> {ys, zs, \<lambda>v vs. P v (vs @ ws)} = xs @ ws \<cong> {ys @ ws, zs, P}"
proof (rule iffI, rule Interleaves_suffix_fst_1, simp_all)
qed (rule Interleaves_suffix_fst_2, simp)

lemma Interleaves_suffix_snd [rule_format]:
 "\<forall>n < length ws. \<not> P (ws ! n) (drop (Suc n) ws) \<Longrightarrow>
  xs \<cong> {ys, zs, \<lambda>v vs. P v (vs @ ws)} = xs @ ws \<cong> {ys, zs @ ws, P}"
by (subst (1 2) Interleaves_swap, rule Interleaves_suffix_fst, simp)

end


chapter\<open>De Bruijn Syntax, Quotations, Codes, V-Codes\<close>

theory Coding
imports SyntaxN
begin

declare fresh_Nil [iff]

section \<open>de Bruijn Indices (locally-nameless version)\<close>

nominal_datatype dbtm = DBZero | DBVar name | DBInd nat | DBEats dbtm dbtm

nominal_datatype dbfm =
    DBMem dbtm dbtm
  | DBEq dbtm dbtm
  | DBDisj dbfm dbfm
  | DBNeg dbfm
  | DBEx dbfm

declare dbtm.supp [simp]
declare dbfm.supp [simp]

fun lookup :: "name list \<Rightarrow> nat \<Rightarrow> name \<Rightarrow> dbtm"
  where
    "lookup [] n x = DBVar x"
  | "lookup (y # ys) n x = (if x = y then DBInd n else (lookup ys (Suc n) x))"

lemma fresh_imp_notin_env: "atom name \<sharp> e \<Longrightarrow> name \<notin> set e"
  by (metis List.finite_set fresh_finite_set_at_base fresh_set)

lemma lookup_notin: "x \<notin> set e \<Longrightarrow> lookup e n x = DBVar x"
  by (induct e arbitrary: n) auto

lemma lookup_in:
  "x \<in> set e \<Longrightarrow> \<exists>k. lookup e n x = DBInd k \<and> n \<le> k \<and> k < n + length e"
  by (induction e arbitrary: n) force+

lemma lookup_fresh: "x \<sharp> lookup e n y \<longleftrightarrow> y \<in> set e \<or> x \<noteq> atom y"
  by (induct arbitrary: n rule: lookup.induct) (auto simp: pure_fresh fresh_at_base)

lemma lookup_eqvt[eqvt]: "(p \<bullet> lookup xs n x) = lookup (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
  by (induct xs arbitrary: n) (simp_all add: permute_pure)

lemma lookup_inject [iff]: "(lookup e n x = lookup e n y) \<longleftrightarrow> x = y"
proof (induction e n x arbitrary: y rule: lookup.induct)
  case (2 y ys n x z)
  then show ?case
    by (metis dbtm.distinct(7) dbtm.eq_iff(3) lookup.simps(2) lookup_in lookup_notin not_less_eq_eq)
qed auto

nominal_function trans_tm :: "name list \<Rightarrow> tm \<Rightarrow> dbtm"
  where
   "trans_tm e Zero = DBZero"
 | "trans_tm e (Var k) = lookup e 0 k"
 | "trans_tm e (Eats t u) = DBEats (trans_tm e t) (trans_tm e u)"
by (auto simp: eqvt_def trans_tm_graph_aux_def) (metis tm.strong_exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_trans_tm_iff [simp]: "i \<sharp> trans_tm e t \<longleftrightarrow> i \<sharp> t \<or> i \<in> atom ` set e"
  by (induct t rule: tm.induct, auto simp: lookup_fresh fresh_at_base)

lemma trans_tm_forget: "atom i \<sharp> t \<Longrightarrow> trans_tm [i] t = trans_tm [] t"
  by (induct t rule: tm.induct, auto simp: fresh_Pair)

nominal_function (invariant "\<lambda>(xs, _) y. atom ` set xs \<sharp>* y")
  trans_fm :: "name list \<Rightarrow> fm \<Rightarrow> dbfm"
  where
   "trans_fm e (Mem t u) = DBMem (trans_tm e t) (trans_tm e u)"
 | "trans_fm e (Eq t u)  = DBEq (trans_tm e t) (trans_tm e u)"
 | "trans_fm e (Disj A B) = DBDisj (trans_fm e A) (trans_fm e B)"
 | "trans_fm e (Neg A)   = DBNeg (trans_fm e A)"
 | "atom k \<sharp> e \<Longrightarrow> trans_fm e (Ex k A) = DBEx (trans_fm (k#e) A)"
                   supply [[simproc del: defined_all]]
                   apply(simp add: eqvt_def trans_fm_graph_aux_def)
                  apply(erule trans_fm_graph.induct)
  using [[simproc del: alpha_lst]]
                      apply(auto simp: fresh_star_def)
   apply (metis fm.strong_exhaust fresh_star_insert)
  apply(erule Abs_lst1_fcb2')
     apply (simp_all add: eqvt_at_def)
    apply (simp_all add: fresh_star_Pair perm_supp_eq)
  apply (simp add: fresh_star_def)
  done

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_trans_fm [simp]: "i \<sharp> trans_fm e A \<longleftrightarrow> i \<sharp> A \<or> i \<in> atom ` set e"
  by (nominal_induct A avoiding: e rule: fm.strong_induct, auto simp: fresh_at_base)

abbreviation DBConj :: "dbfm \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where "DBConj t u \<equiv> DBNeg (DBDisj (DBNeg t) (DBNeg u))"

lemma trans_fm_Conj [simp]: "trans_fm e (Conj A B) = DBConj (trans_fm e A) (trans_fm e B)"
  by (simp add: Conj_def)

lemma trans_tm_inject [iff]: "(trans_tm e t = trans_tm e u) \<longleftrightarrow> t = u"
proof (induct t arbitrary: u rule: tm.induct)
  case Zero show ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(1) dbtm.distinct(3) lookup_in lookup_notin)
    done
next
  case (Var i) show ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(1) dbtm.distinct(3) lookup_in lookup_notin)
    apply (metis dbtm.distinct(10) dbtm.distinct(11) lookup_in lookup_notin)
    done
next
  case (Eats tm1 tm2) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(12) dbtm.distinct(9) lookup_in lookup_notin)
    done
qed

lemma trans_fm_inject [iff]: "(trans_fm e A = trans_fm e B) \<longleftrightarrow> A = B"
proof (nominal_induct A avoiding: e B rule: fm.strong_induct)
  case (Mem tm1 tm2) thus ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: fresh_star_def)
next
  case (Eq tm1 tm2) thus ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: fresh_star_def)
next
  case (Disj fm1 fm2) show ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: Disj fresh_star_def)
next
  case (Neg fm) show ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: Neg fresh_star_def)
next
  case (Ex name fm)
  thus ?case  using [[simproc del: alpha_lst]]
  proof (cases rule: fm.strong_exhaust [where y=B and c="(e, name)"], simp_all add: fresh_star_def)
    fix name'::name and fm'::fm
    assume name': "atom name' \<sharp> (e, name)"
    assume "atom name \<sharp> fm' \<or> name = name'"
    thus "(trans_fm (name # e) fm = trans_fm (name' # e) fm') = ([[atom name]]lst. fm = [[atom name']]lst. fm')"
         (is "?lhs = ?rhs")
    proof (rule disjE)
      assume "name = name'"
      thus "?lhs = ?rhs"
        by (metis fresh_Pair fresh_at_base(2) name')
    next
      assume name: "atom name \<sharp> fm'"
      have eq1: "(name \<leftrightarrow> name') \<bullet> trans_fm (name' # e) fm' = trans_fm (name' # e) fm'"
        by (simp add: flip_fresh_fresh name)
      have eq2: "(name \<leftrightarrow> name') \<bullet> ([[atom name']]lst. fm') = [[atom name']]lst. fm'"
        by (rule flip_fresh_fresh) (auto simp: Abs_fresh_iff name)
      show "?lhs = ?rhs" using name' eq1 eq2 Ex(1) Ex(3) [of "name#e" "(name \<leftrightarrow> name') \<bullet> fm'"]
        by (simp add: flip_fresh_fresh) (metis Abs1_eq(3))
    qed
  qed
qed

lemma trans_fm_perm:
  assumes c: "atom c \<sharp> (i,j,A,B)"
  and     t: "trans_fm [i] A = trans_fm [j] B"
  shows "(i \<leftrightarrow> c) \<bullet> A = (j \<leftrightarrow> c) \<bullet> B"
proof -
  have c_fresh1: "atom c \<sharp> trans_fm [i] A"
    using c by (auto simp: supp_Pair)
  moreover
  have i_fresh: "atom i \<sharp> trans_fm [i] A"
    by auto
  moreover
  have c_fresh2: "atom c \<sharp> trans_fm [j] B"
    using c by (auto simp: supp_Pair)
  moreover
  have j_fresh: "atom j \<sharp> trans_fm [j] B"
    by auto
  ultimately have "((i \<leftrightarrow> c) \<bullet> (trans_fm [i] A)) = ((j \<leftrightarrow> c) \<bullet> trans_fm [j] B)"
    by (simp only: flip_fresh_fresh t)
  then have "trans_fm [c] ((i \<leftrightarrow> c) \<bullet> A) = trans_fm [c] ((j \<leftrightarrow> c) \<bullet> B)"
    by simp
  then show "(i \<leftrightarrow> c) \<bullet> A = (j \<leftrightarrow> c) \<bullet> B" by simp
qed

section\<open>Abstraction and Substitution on de Bruijn Formulas\<close>

nominal_function abst_dbtm :: "name \<Rightarrow> nat \<Rightarrow> dbtm \<Rightarrow> dbtm"
  where
   "abst_dbtm name i DBZero = DBZero"
 | "abst_dbtm name i (DBVar name') = (if name = name' then DBInd i else DBVar name')"
 | "abst_dbtm name i (DBInd j) = DBInd j"
 | "abst_dbtm name i (DBEats t1 t2) = DBEats (abst_dbtm name i t1) (abst_dbtm name i t2)"
apply (simp add: eqvt_def abst_dbtm_graph_aux_def, auto)
apply (metis dbtm.exhaust)
done

nominal_termination (eqvt)
  by lexicographic_order

nominal_function subst_dbtm :: "dbtm \<Rightarrow> name \<Rightarrow> dbtm \<Rightarrow> dbtm"
  where
   "subst_dbtm u x DBZero = DBZero"
 | "subst_dbtm u x (DBVar name) = (if x = name then u else DBVar name)"
 | "subst_dbtm u x (DBInd j) = DBInd j"
 | "subst_dbtm u x (DBEats t1 t2) = DBEats (subst_dbtm u x t1) (subst_dbtm u x t2)"
by (auto simp: eqvt_def subst_dbtm_graph_aux_def) (metis dbtm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_iff_non_subst_dbtm: "subst_dbtm DBZero i t = t \<longleftrightarrow> atom i \<sharp> t"
  by (induct t rule: dbtm.induct) (auto simp: pure_fresh fresh_at_base(2))

lemma lookup_append: "lookup (e @ [i]) n j = abst_dbtm i (length e + n) (lookup e n j)"
  by (induct e arbitrary: n) (auto simp: fresh_Cons)

lemma trans_tm_abs: "trans_tm (e@[name]) t = abst_dbtm name (length e) (trans_tm e t)"
  by (induct t rule: tm.induct) (auto simp: lookup_notin lookup_append)

subsection\<open>Well-Formed Formulas\<close>

nominal_function abst_dbfm :: "name \<Rightarrow> nat \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where
   "abst_dbfm name i (DBMem t1 t2) = DBMem (abst_dbtm name i t1) (abst_dbtm name i t2)"
 | "abst_dbfm name i (DBEq t1 t2) =  DBEq (abst_dbtm name i t1) (abst_dbtm name i t2)"
 | "abst_dbfm name i (DBDisj A1 A2) = DBDisj (abst_dbfm name i A1) (abst_dbfm name i A2)"
 | "abst_dbfm name i (DBNeg A) = DBNeg (abst_dbfm name i A)"
 | "abst_dbfm name i (DBEx A) = DBEx (abst_dbfm name (i+1) A)"
apply (simp add: eqvt_def abst_dbfm_graph_aux_def, auto)
apply (metis dbfm.exhaust)
done

nominal_termination (eqvt)
  by lexicographic_order

nominal_function subst_dbfm :: "dbtm \<Rightarrow> name \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where
   "subst_dbfm u x (DBMem t1 t2) = DBMem (subst_dbtm u x t1) (subst_dbtm u x t2)"
 | "subst_dbfm u x (DBEq t1 t2) =  DBEq (subst_dbtm u x t1) (subst_dbtm u x t2)"
 | "subst_dbfm u x (DBDisj A1 A2) = DBDisj (subst_dbfm u x A1) (subst_dbfm u x A2)"
 | "subst_dbfm u x (DBNeg A) = DBNeg (subst_dbfm u x A)"
 | "subst_dbfm u x (DBEx A) = DBEx (subst_dbfm u x A)"
by (auto simp: eqvt_def subst_dbfm_graph_aux_def) (metis dbfm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_iff_non_subst_dbfm: "subst_dbfm DBZero i t = t \<longleftrightarrow> atom i \<sharp> t"
  by (induct t rule: dbfm.induct) (auto simp: fresh_iff_non_subst_dbtm)

section\<open>Well formed terms and formulas (de Bruijn representation)\<close>

subsection\<open>Well-Formed Terms\<close>

inductive wf_dbtm :: "dbtm \<Rightarrow> bool"
  where
    Zero:  "wf_dbtm DBZero"
  | Var:   "wf_dbtm (DBVar name)"
  | Eats:  "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbtm (DBEats t1 t2)"

equivariance wf_dbtm

inductive_cases Zero_wf_dbtm [elim!]: "wf_dbtm DBZero"
inductive_cases Var_wf_dbtm [elim!]:  "wf_dbtm (DBVar name)"
inductive_cases Ind_wf_dbtm [elim!]:  "wf_dbtm (DBInd i)"
inductive_cases Eats_wf_dbtm [elim!]: "wf_dbtm (DBEats t1 t2)"

declare wf_dbtm.intros [intro]

lemma wf_dbtm_imp_is_tm:
  assumes "wf_dbtm x"
  shows "\<exists>t::tm. x = trans_tm [] t"
using assms
proof (induct rule: wf_dbtm.induct)
  case Zero thus ?case
    by (metis trans_tm.simps(1))
next
  case (Var i) thus ?case
    by (metis lookup.simps(1) trans_tm.simps(2))
next
  case (Eats dt1 dt2) thus ?case
    by (metis trans_tm.simps(3))
qed

lemma wf_dbtm_trans_tm: "wf_dbtm (trans_tm [] t)"
  by (induct t rule: tm.induct) auto

theorem wf_dbtm_iff_is_tm: "wf_dbtm x \<longleftrightarrow> (\<exists>t::tm. x = trans_tm [] t)"
  by (metis wf_dbtm_imp_is_tm wf_dbtm_trans_tm)

subsection\<open>Well-Formed Formulas\<close>

inductive wf_dbfm :: "dbfm \<Rightarrow> bool"
  where
    Mem:   "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbfm (DBMem t1 t2)"
  | Eq:    "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbfm (DBEq t1 t2)"
  | Disj:  "wf_dbfm A1 \<Longrightarrow> wf_dbfm A2 \<Longrightarrow> wf_dbfm (DBDisj A1 A2)"
  | Neg:   "wf_dbfm A \<Longrightarrow> wf_dbfm (DBNeg A)"
  | Ex:    "wf_dbfm A \<Longrightarrow> wf_dbfm (DBEx (abst_dbfm name 0 A))"

equivariance wf_dbfm

lemma atom_fresh_abst_dbtm [simp]: "atom i \<sharp> abst_dbtm i n t"
  by (induct t rule: dbtm.induct) (auto simp: pure_fresh)

text\<open>Setting up strong induction: "avoiding" for name. Necessary to allow some proofs to go through\<close>
nominal_inductive wf_dbfm
  avoids Ex: name
  by (auto simp: fresh_star_def)

inductive_cases Mem_wf_dbfm [elim!]:  "wf_dbfm (DBMem t1 t2)"
inductive_cases Eq_wf_dbfm [elim!]:   "wf_dbfm (DBEq t1 t2)"
inductive_cases Disj_wf_dbfm [elim!]: "wf_dbfm (DBDisj A1 A2)"
inductive_cases Neg_wf_dbfm [elim!]:  "wf_dbfm (DBNeg A)"
inductive_cases Ex_wf_dbfm [elim!]:   "wf_dbfm (DBEx z)"

declare wf_dbfm.intros [intro]

lemma trans_fm_abs: "trans_fm (e@[name]) A = abst_dbfm name (length e) (trans_fm e A)"
  apply (nominal_induct A avoiding: name e rule: fm.strong_induct)
  apply (auto simp: trans_tm_abs fresh_Cons fresh_append)
  by (metis append_Cons length_Cons)

lemma abst_trans_fm: "abst_dbfm name 0 (trans_fm [] A) = trans_fm [name] A"
  by (metis append_Nil list.size(3) trans_fm_abs)

lemma abst_trans_fm2: "i \<noteq> j \<Longrightarrow> abst_dbfm i (Suc 0) (trans_fm [j] A) = trans_fm [j,i] A"
  using trans_fm_abs [where e="[j]" and name=i]
  by auto

lemma wf_dbfm_imp_is_fm:
  assumes "wf_dbfm x" shows "\<exists>A::fm. x = trans_fm [] A"
using assms
proof (induct rule: wf_dbfm.induct)
  case (Mem t1 t2) thus ?case
    by (metis trans_fm.simps(1) wf_dbtm_imp_is_tm)
next
  case (Eq t1 t2) thus ?case
    by (metis trans_fm.simps(2) wf_dbtm_imp_is_tm)
next
  case (Disj fm1 fm2) thus ?case
    by (metis trans_fm.simps(3))
next
  case (Neg fm) thus ?case
    by (metis trans_fm.simps(4))
next
  case (Ex fm name) thus ?case
    apply auto
    apply (rule_tac x="Ex name A" in exI)
    apply (auto simp: abst_trans_fm)
    done
qed

lemma wf_dbfm_trans_fm: "wf_dbfm (trans_fm [] A)"
  apply (nominal_induct A rule: fm.strong_induct)
  apply (auto simp: wf_dbtm_trans_tm abst_trans_fm)
  apply (metis abst_trans_fm wf_dbfm.Ex)
  done

lemma wf_dbfm_iff_is_fm: "wf_dbfm x \<longleftrightarrow> (\<exists>A::fm. x = trans_fm [] A)"
  by (metis wf_dbfm_imp_is_fm wf_dbfm_trans_fm)

lemma dbtm_abst_ignore [simp]:
  "abst_dbtm name i (abst_dbtm name j t) = abst_dbtm name j t"
  by (induct t rule: dbtm.induct) auto

lemma abst_dbtm_fresh_ignore [simp]: "atom name \<sharp> u \<Longrightarrow> abst_dbtm name j u = u"
  by (induct u rule: dbtm.induct) auto

lemma dbtm_subst_ignore [simp]:
  "subst_dbtm u name (abst_dbtm name j t) = abst_dbtm name j t"
  by (induct t rule: dbtm.induct) auto

lemma dbtm_abst_swap_subst:
  "name \<noteq> name' \<Longrightarrow> atom name' \<sharp> u \<Longrightarrow>
   subst_dbtm u name (abst_dbtm name' j t) = abst_dbtm name' j (subst_dbtm u name t)"
  by (induct t rule: dbtm.induct) auto

lemma dbfm_abst_swap_subst:
  "name \<noteq> name' \<Longrightarrow> atom name' \<sharp> u \<Longrightarrow>
   subst_dbfm u name (abst_dbfm name' j A) = abst_dbfm name' j (subst_dbfm u name A)"
  by (induct A arbitrary: j rule: dbfm.induct) (auto simp: dbtm_abst_swap_subst)

lemma subst_trans_commute [simp]:
  "atom i \<sharp> e \<Longrightarrow> subst_dbtm (trans_tm e u) i (trans_tm e t) = trans_tm e (subst i u t)"
  apply (induct t rule: tm.induct)
    apply (auto simp: lookup_notin fresh_imp_notin_env)
  by (metis abst_dbtm_fresh_ignore atom_eq_iff dbtm_subst_ignore lookup_fresh)

lemma subst_fm_trans_commute [simp]:
  "subst_dbfm (trans_tm [] u) name (trans_fm [] A) = trans_fm [] (A (name::= u))"
  apply (nominal_induct A avoiding: name u rule: fm.strong_induct)
  apply (auto simp: lookup_notin dbfm_abst_swap_subst simp flip: abst_trans_fm)
  done

lemma subst_fm_trans_commute_eq:
  "du = trans_tm [] u \<Longrightarrow> subst_dbfm du i (trans_fm [] A) = trans_fm [] (A(i::=u))"
  by (metis subst_fm_trans_commute)

section\<open>Quotations\<close>

fun htuple :: "nat \<Rightarrow> hf"  where
   "htuple 0 = \<langle>0,0\<rangle>"
 | "htuple (Suc k) = \<langle>0, htuple k\<rangle>"

fun HTuple :: "nat \<Rightarrow> tm"  where
   "HTuple 0 = HPair Zero Zero"
 | "HTuple (Suc k) = HPair Zero (HTuple k)"

lemma eval_tm_HTuple [simp]:  "\<lbrakk>HTuple n\<rbrakk>e = htuple n"
  by (induct n) auto

lemma fresh_HTuple [simp]: "x \<sharp> HTuple n"
  by (induct n) auto

lemma HTuple_eqvt[eqvt]: "(p \<bullet> HTuple n) = HTuple (p \<bullet> n)"
  by (induct n, auto simp: HPair_eqvt permute_pure)

lemma htuple_nonzero [simp]: "htuple k \<noteq> 0"
  by (induct k) auto

lemma htuple_inject [iff]: "htuple i = htuple j \<longleftrightarrow> i=j"
proof (induct i arbitrary: j)
  case 0 show ?case
    by (cases j) auto
next
  case (Suc i) show ?case
    by (cases j) (auto simp: Suc)
qed

subsection \<open>Quotations of de Bruijn terms\<close>

definition nat_of_name :: "name \<Rightarrow> nat"
  where "nat_of_name x = nat_of (atom x)"

lemma nat_of_name_inject [simp]: "nat_of_name n1 = nat_of_name n2 \<longleftrightarrow> n1 = n2"
  by (metis nat_of_name_def atom_components_eq_iff atom_eq_iff sort_of_atom_eq)

definition name_of_nat :: "nat \<Rightarrow> name"
  where "name_of_nat n \<equiv> Abs_name (Atom (Sort ''SyntaxN.name'' []) n)"

lemma nat_of_name_Abs_eq [simp]: "nat_of_name (Abs_name (Atom (Sort ''SyntaxN.name'' []) n)) = n"
  by (auto simp: nat_of_name_def atom_name_def Abs_name_inverse)

lemma nat_of_name_name_eq [simp]: "nat_of_name (name_of_nat n) = n"
  by (simp add: name_of_nat_def)

lemma name_of_nat_nat_of_name [simp]: "name_of_nat (nat_of_name i) = i"
  by (metis nat_of_name_inject nat_of_name_name_eq)

lemma HPair_neq_ORD_OF [simp]: "HPair x y \<noteq> ORD_OF i"
  by (metis Not_Ord_hpair Ord_ord_of eval_tm_HPair eval_tm_ORD_OF)

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function quot_dbtm :: "dbtm \<Rightarrow> tm"
  where
   "quot_dbtm DBZero = Zero"
 | "quot_dbtm (DBVar name) = ORD_OF (Suc (nat_of_name name))"
 | "quot_dbtm (DBInd k) = HPair (HTuple 6) (ORD_OF k)"
 | "quot_dbtm (DBEats t u) = HPair (HTuple 1) (HPair (quot_dbtm t) (quot_dbtm u))"
by (rule dbtm.exhaust) auto

termination
  by lexicographic_order

lemma quot_dbtm_inject_

lemma quot_dbtm_inject [iff]: "quot_dbtm t = quot_dbtm u \<longleftrightarrow> t=u"
  by (metis quot_dbtm_inject_lemma)

subsection \<open>Quotations of de Bruijn formulas\<close>

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function quot_dbfm :: "dbfm \<Rightarrow> tm"
  where
   "quot_dbfm (DBMem t u) = HPair (HTuple 0) (HPair (quot_dbtm t) (quot_dbtm u))"
 | "quot_dbfm (DBEq t u) = HPair (HTuple 2) (HPair (quot_dbtm t) (quot_dbtm u))"
 | "quot_dbfm (DBDisj A B) = HPair (HTuple 3) (HPair (quot_dbfm A) (quot_dbfm B))"
 | "quot_dbfm (DBNeg A) = HPair (HTuple 4) (quot_dbfm A)"
 | "quot_dbfm (DBEx A) = HPair (HTuple 5) (quot_dbfm A)"
by (rule_tac y=x in dbfm.exhaust, auto)

termination
  by lexicographic_order

lemma htuple_minus_1: "n > 0 \<Longrightarrow> htuple n = \<langle>0, htuple (n - 1)\<rangle>"
  by (metis Suc_diff_1 htuple.simps(2))

lemma HTuple_minus_1: "n > 0 \<Longrightarrow> HTuple n = HPair Zero (HTuple (n - 1))"
  by (metis Suc_diff_1 HTuple.simps(2))

lemmas HTS = HTuple_minus_1 HTuple.simps \<comment> \<open>for freeness reasoning on codes\<close>

lemma quot_dbfm_inject_lemma [simp]: "\<lbrakk>quot_dbfm A\<rbrakk>e = \<lbrakk>quot_dbfm B\<rbrakk>e \<longleftrightarrow> A=B"
proof (induct A arbitrary: B rule: dbfm.induct)
  case (DBMem t u) show ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
next
  case (DBEq t u) show ?case
    by (induct B rule: dbfm.induct) (auto simp: htuple_minus_1)
next
  case (DBDisj A B') thus ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
next
  case (DBNeg A) thus ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
next
  case (DBEx A) thus ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
qed

class quot =
  fixes quot :: "'a \<Rightarrow> tm"  ("\<guillemotleft>_\<guillemotright>")

instantiation tm :: quot
begin
  definition quot_tm :: "tm \<Rightarrow> tm"
    where "quot_tm t = quot_dbtm (trans_tm [] t)"

  instance ..
end

lemma quot_dbtm_fresh [simp]: "s \<sharp> (quot_dbtm t)"
  by (induct t rule: dbtm.induct) auto

lemma quot_tm_fresh [simp]: fixes t::tm shows "s \<sharp> \<guillemotleft>t\<guillemotright>"
  by (simp add: quot_tm_def)

lemma quot_Zero [simp]: "\<guillemotleft>Zero\<guillemotright> = Zero"
  by (simp add: quot_tm_def)

lemma quot_Var: "\<guillemotleft>Var x\<guillemotright> = SUCC (ORD_OF (nat_of_name x))"
  by (simp add: quot_tm_def)

lemma quot_Eats: "\<guillemotleft>Eats x y\<guillemotright> = HPair (HTuple 1) (HPair \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright>)"
  by (simp add: quot_tm_def)

text\<open>irrelevance of the environment for quotations, because they are ground terms\<close>
lemma eval_quot_dbtm_ignore:
    "\<lbrakk>quot_dbtm t\<rbrakk>e = \<lbrakk>quot_dbtm t\<rbrakk>e'"
  by (induct t rule: dbtm.induct) auto

lemma eval_quot_dbfm_ignore:
    "\<lbrakk>quot_dbfm A\<rbrakk>e = \<lbrakk>quot_dbfm A\<rbrakk>e'"
  by (induct A rule: dbfm.induct) (auto intro: eval_quot_dbtm_ignore)

instantiation fm :: quot
begin
  definition quot_fm :: "fm \<Rightarrow> tm"
    where "quot_fm A = quot_dbfm (trans_fm [] A)"

  instance ..
end

lemma quot_dbfm_fresh [simp]: "s \<sharp> (quot_dbfm A)"
  by (induct A rule: dbfm.induct) auto

lemma quot_fm_fresh [simp]: fixes A::fm shows "s \<sharp> \<guillemotleft>A\<guillemotright>"
  by (simp add: quot_fm_def)

lemma quot_fm_permute [simp]: fixes A:: fm shows "p \<bullet> \<guillemotleft>A\<guillemotright> = \<guillemotleft>A\<guillemotright>"
  by (metis fresh_star_def perm_supp_eq quot_fm_fresh)

lemma quot_Mem: "\<guillemotleft>x IN y\<guillemotright> = HPair (HTuple 0) (HPair (\<guillemotleft>x\<guillemotright>) (\<guillemotleft>y\<guillemotright>))"
  by (simp add: quot_fm_def quot_tm_def)

lemma quot_Eq: "\<guillemotleft>x EQ y\<guillemotright> = HPair (HTuple 2) (HPair (\<guillemotleft>x\<guillemotright>) (\<guillemotleft>y\<guillemotright>))"
  by (simp add: quot_fm_def quot_tm_def)

lemma quot_Disj: "\<guillemotleft>A OR B\<guillemotright> = HPair (HTuple 3) (HPair (\<guillemotleft>A\<guillemotright>) (\<guillemotleft>B\<guillemotright>))"
  by (simp add: quot_fm_def)

lemma quot_Neg: "\<guillemotleft>Neg A\<guillemotright> = HPair (HTuple 4) (\<guillemotleft>A\<guillemotright>)"
  by (simp add: quot_fm_def)

lemma quot_Ex: "\<guillemotleft>Ex i A\<guillemotright> = HPair (HTuple 5) (quot_dbfm (trans_fm [i] A))"
  by (simp add: quot_fm_def)

lemma eval_quot_fm_ignore: fixes A:: fm shows "\<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e'"
  by (metis eval_quot_dbfm_ignore quot_fm_def)

lemmas quot_simps = quot_Var quot_Eats quot_Eq quot_Mem quot_Disj quot_Neg quot_Ex

section\<open>Definitions Involving Coding\<close>

definition q_Var :: "name \<Rightarrow> hf"
  where "q_Var i \<equiv> succ (ord_of (nat_of_name i))"

definition q_Ind :: "hf \<Rightarrow> hf"
  where "q_Ind k \<equiv>  \<langle>htuple 6, k\<rangle>"

abbreviation Q_Eats :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Eats t u \<equiv> HPair (HTuple (Suc 0)) (HPair t u)"

definition q_Eats :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Eats x y \<equiv> \<langle>htuple 1, x, y\<rangle>"

abbreviation Q_Succ :: "tm \<Rightarrow> tm"
  where "Q_Succ t \<equiv> Q_Eats t t"

definition q_Succ :: "hf \<Rightarrow> hf"
  where "q_Succ x \<equiv> q_Eats x x"

lemma quot_Succ: "\<guillemotleft>SUCC x\<guillemotright> = Q_Succ \<guillemotleft>x\<guillemotright>"
  by (auto simp: SUCC_def quot_Eats)

abbreviation Q_HPair :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_HPair t u \<equiv>
           Q_Eats (Q_Eats Zero (Q_Eats (Q_Eats Zero u) t))
                  (Q_Eats (Q_Eats Zero t) t)"

definition q_HPair :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_HPair x y \<equiv>
           q_Eats (q_Eats 0 (q_Eats (q_Eats 0 y) x))
                  (q_Eats (q_Eats 0 x) x)"

abbreviation Q_Mem :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Mem t u \<equiv> HPair (HTuple 0) (HPair t u)"

definition q_Mem :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Mem x y \<equiv> \<langle>htuple 0, x, y\<rangle>"

abbreviation Q_Eq :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Eq t u \<equiv> HPair (HTuple 2) (HPair t u)"

definition q_Eq :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Eq x y \<equiv> \<langle>htuple 2, x, y\<rangle>"

abbreviation Q_Disj :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Disj t u \<equiv> HPair (HTuple 3) (HPair t u)"

definition q_Disj :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Disj x y \<equiv> \<langle>htuple 3, x, y\<rangle>"

abbreviation Q_Neg :: "tm \<Rightarrow> tm"
  where "Q_Neg t \<equiv> HPair (HTuple 4) t"

definition q_Neg :: "hf \<Rightarrow> hf"
  where "q_Neg x \<equiv> \<langle>htuple 4, x\<rangle>"

abbreviation Q_Conj :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Conj t u \<equiv> Q_Neg (Q_Disj (Q_Neg t) (Q_Neg u))"

definition q_Conj :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Conj t u \<equiv> q_Neg (q_Disj (q_Neg t) (q_Neg u))"

abbreviation Q_Imp :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Imp t u \<equiv> Q_Disj (Q_Neg t) u"

definition q_Imp :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Imp t u \<equiv> q_Disj (q_Neg t) u"

abbreviation Q_Ex :: "tm \<Rightarrow> tm"
  where "Q_Ex t \<equiv> HPair (HTuple 5) t"

definition q_Ex :: "hf \<Rightarrow> hf"
  where "q_Ex x \<equiv> \<langle>htuple 5, x\<rangle>"

abbreviation Q_All :: "tm \<Rightarrow> tm"
  where "Q_All t \<equiv> Q_Neg (Q_Ex (Q_Neg t))"

definition q_All :: "hf \<Rightarrow> hf"
  where "q_All x \<equiv> q_Neg (q_Ex (q_Neg x))"

lemmas q_defs = q_Var_def q_Ind_def q_Eats_def q_HPair_def q_Eq_def q_Mem_def
                q_Disj_def q_Neg_def q_Conj_def q_Imp_def q_Ex_def q_All_def

lemma q_Eats_iff [iff]: "q_Eats x y = q_Eats x' y' \<longleftrightarrow> x=x' \<and> y=y'"
  by (metis hpair_iff q_Eats_def)

lemma quot_subst_eq: "\<guillemotleft>A(i::=t)\<guillemotright> = quot_dbfm (subst_dbfm (trans_tm [] t) i (trans_fm [] A))"
  by (metis quot_fm_def subst_fm_trans_commute)

lemma Q_Succ_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> Q_Succ x EQ Q_Succ x'"
  by (metis HPair_cong Refl)

section\<open>Quotations are Injective\<close>

subsection\<open>Terms\<close>

lemma eval_tm_inject [simp]: fixes t::tm shows "\<lbrakk>\<guillemotleft>t\<guillemotright>\<rbrakk> e = \<lbrakk>\<guillemotleft>u\<guillemotright>\<rbrakk> e \<longleftrightarrow> t=u"
proof (induct t arbitrary: u rule: tm.induct)
  case Zero thus ?case
    by (cases u rule: tm.exhaust) (auto simp: quot_Var quot_Eats)
next
  case (Var i) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (auto simp: quot_Var quot_Eats)
    done
next
  case (Eats t1 t2) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (auto simp: quot_Eats quot_Var)
    done
qed

subsection\<open>Formulas\<close>

lemma eval_fm_inject [simp]: fixes A::fm shows "\<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk> e = \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk> e \<longleftrightarrow> A=B"
proof (nominal_induct B arbitrary: A rule: fm.strong_induct)
  case (Mem tm1 tm2) thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Eq tm1 tm2) thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Neg \<alpha>) thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Disj fm1 fm2)
  thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Ex i \<alpha>)
  thus ?case
    apply (induct A arbitrary: i rule: fm.induct)
    apply (auto simp: trans_fm_perm quot_simps htuple_minus_1 Abs1_eq_iff_all)
    by (metis (no_types) Abs1_eq_iff_all(3) dbfm.eq_iff(5) fm.eq_iff(5) fresh_Nil trans_fm.simps(5))
qed

subsection\<open>The set \<open>\<Gamma>\<close> of Definition 1.1, constant terms used for coding\<close>

inductive coding_tm :: "tm \<Rightarrow> bool"
  where
    Ord:    "\<exists>i. x = ORD_OF i \<Longrightarrow> coding_tm x"
  | HPair:  "coding_tm x \<Longrightarrow> coding_tm y \<Longrightarrow> coding_tm (HPair x y)"

declare coding_tm.intros [intro]

lemma coding_tm_Zero [intro]: "coding_tm Zero"
  by (metis ORD_OF.simps(1) Ord)

lemma coding_tm_HTuple [intro]: "coding_tm (HTuple k)"
  by (induct k, auto)

inductive_simps coding_tm_HPair [simp]: "coding_tm (HPair x y)"

lemma quot_dbtm_coding [simp]: "coding_tm (quot_dbtm t)"
  apply (induct t rule: dbtm.induct, auto)
  apply (metis ORD_OF.simps(2) Ord)
  done

lemma quot_dbfm_coding [simp]: "coding_tm (quot_dbfm fm)"
  by (induct fm rule: dbfm.induct, auto)

lemma quot_fm_coding: fixes A::fm shows "coding_tm \<guillemotleft>A\<guillemotright>"
  by (metis quot_dbfm_coding quot_fm_def)

inductive coding_hf :: "hf \<Rightarrow> bool"
  where
    Ord:    "\<exists>i. x = ord_of i \<Longrightarrow> coding_hf x"
  | HPair:  "coding_hf x \<Longrightarrow> coding_hf y \<Longrightarrow> coding_hf (\<langle>x,y\<rangle>)"

declare coding_hf.intros [intro]

lemma coding_hf_0 [intro]: "coding_hf 0"
  by (metis coding_hf.Ord ord_of.simps(1))

inductive_simps coding_hf_hpair [simp]: "coding_hf (\<langle>x,y\<rangle>)"

lemma coding_tm_hf [simp]: "coding_tm t \<Longrightarrow> coding_hf \<lbrakk>t\<rbrakk>e"
  by (induct t rule: coding_tm.induct) auto

section \<open>V-Coding for terms and formulas, for the Second Theorem\<close>

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function vquot_dbtm :: "name set \<Rightarrow> dbtm \<Rightarrow> tm"
  where
   "vquot_dbtm V DBZero = Zero"
 | "vquot_dbtm V (DBVar name) = (if name \<in> V then Var name
                                 else ORD_OF (Suc (nat_of_name name)))"
 | "vquot_dbtm V (DBInd k) = HPair (HTuple 6) (ORD_OF k)"
 | "vquot_dbtm V (DBEats t u) = HPair (HTuple 1) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
by (auto, rule_tac y=b in dbtm.exhaust, auto)

termination
  by lexicographic_order

lemma fresh_vquot_dbtm [simp]: "i \<sharp> vquot_dbtm V tm \<longleftrightarrow> i \<sharp> tm \<or> i \<notin> atom ` V"
  by (induct tm rule: dbtm.induct) (auto simp: fresh_at_base pure_fresh)

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function vquot_dbfm :: "name set \<Rightarrow> dbfm \<Rightarrow> tm"
  where
   "vquot_dbfm V (DBMem t u) = HPair (HTuple 0) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
 | "vquot_dbfm V (DBEq t u) = HPair (HTuple 2) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
 | "vquot_dbfm V (DBDisj A B) = HPair (HTuple 3) (HPair (vquot_dbfm V A) (vquot_dbfm V B))"
 | "vquot_dbfm V (DBNeg A) = HPair (HTuple 4) (vquot_dbfm V A)"
 | "vquot_dbfm V (DBEx A) = HPair (HTuple 5) (vquot_dbfm V A)"
by (auto, rule_tac y=b in dbfm.exhaust, auto)

termination
  by lexicographic_order

lemma fresh_vquot_dbfm [simp]: "i \<sharp> vquot_dbfm V fm \<longleftrightarrow> i \<sharp> fm \<or> i \<notin> atom ` V"
  by (induct fm rule: dbfm.induct) (auto simp: HPair_def HTuple_minus_1)

class vquot =
  fixes vquot :: "'a \<Rightarrow> name set \<Rightarrow> tm"  ("\<lfloor>_\<rfloor>_"  [0,1000]1000)

instantiation tm :: vquot
begin
  definition vquot_tm :: "tm \<Rightarrow> name set \<Rightarrow> tm"
    where "vquot_tm t V = vquot_dbtm V (trans_tm [] t)"
  instance ..
end

lemma vquot_dbtm_empty [simp]: "vquot_dbtm {} t = quot_dbtm t"
  by (induct t rule: dbtm.induct) auto

lemma vquot_tm_empty [simp]: fixes t::tm shows "\<lfloor>t\<rfloor>{} = \<guillemotleft>t\<guillemotright>"
  by (simp add: vquot_tm_def quot_tm_def)

lemma vquot_dbtm_eq: "atom ` V \<inter> supp t = atom ` W \<inter> supp t \<Longrightarrow> vquot_dbtm V t = vquot_dbtm W t"
  by (induct t rule: dbtm.induct) (auto simp: image_iff, blast+)

instantiation fm :: vquot
begin
  definition vquot_fm :: "fm \<Rightarrow> name set \<Rightarrow> tm"
    where "vquot_fm A V = vquot_dbfm V (trans_fm [] A)"
  instance ..
end

lemma vquot_fm_fresh [simp]: fixes A::fm shows "i \<sharp> \<lfloor>A\<rfloor>V \<longleftrightarrow> i \<sharp> A \<or> i \<notin> atom ` V"
  by (simp add: vquot_fm_def)

lemma vquot_dbfm_empty [simp]: "vquot_dbfm {} A = quot_dbfm A"
  by (induct A rule: dbfm.induct) auto

lemma vquot_fm_empty [simp]: fixes A::fm shows "\<lfloor>A\<rfloor>{} = \<guillemotleft>A\<guillemotright>"
  by (simp add: vquot_fm_def quot_fm_def)

lemma vquot_dbfm_eq: "atom ` V \<inter> supp A = atom ` W \<inter> supp A \<Longrightarrow> vquot_dbfm V A = vquot_dbfm W A"
  by (induct A rule: dbfm.induct) (auto simp: intro!: vquot_dbtm_eq, blast+)

lemma vquot_fm_insert:
  fixes A::fm shows "atom i \<notin> supp A \<Longrightarrow> \<lfloor>A\<rfloor>(insert i V) = \<lfloor>A\<rfloor>V"
  by (auto simp: vquot_fm_def supp_conv_fresh intro: vquot_dbfm_eq)

declare HTuple.simps [simp del]

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
section \<open>First-Order Terms\<close>

theory Term
  imports Main
begin

datatype (funs_term : 'f, vars_term : 'v) "term" =
  is_Var: Var (the_Var: 'v) |
  Fun 'f (args : "('f, 'v) term list")
where
  "args (Var _) = []"

abbreviation "is_Fun t \<equiv> \<not> is_Var t"

lemma is_VarE [elim]:
  "is_Var t \<Longrightarrow> (\<And>x. t = Var x \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases t) auto

lemma is_FunE [elim]:
  "is_Fun t \<Longrightarrow> (\<And>f ts. t = Fun f ts \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases t) auto

text \<open>Reorient equations of the form @{term "Var x = t"} and @{term "Fun f ss = t"} to facilitate
  simplification.\<close>
setup \<open>
  Reorient_Proc.add
    (fn Const (@{const_name Var}, _) $ _ => true | _ => false)
  #> Reorient_Proc.add
    (fn Const (@{const_name Fun}, _) $ _ $ _ => true | _ => false)
\<close>

simproc_setup reorient_Var ("Var x = t") = Reorient_Proc.proc
simproc_setup reorient_Fun ("Fun f ss = t") = Reorient_Proc.proc

text \<open>The \emph{root symbol} of a term is defined by:\<close>
fun root :: "('f, 'v) term \<Rightarrow> ('f \<times> nat) option"
where
  "root (Var x) = None" |
  "root (Fun f ts) = Some (f, length ts)"

lemma finite_vars_term [simp]:
  "finite (vars_term t)"
  by (induct t) simp_all

lemma finite_Union_vars_term:
  "finite (\<Union>t \<in> set ts. vars_term t)"
  by auto

text \<open>A substitution is a mapping \<open>\<sigma>\<close> from variables to terms. We call a substitution that
  alters the type of variables a generalized substitution, since it does not have all properties
  that are expected of (standard) substitutions (e.g., there is no empty substitution).\<close>
type_synonym ('f, 'v, 'w) gsubst = "'v \<Rightarrow> ('f, 'w) term"
type_synonym ('f, 'v) subst  = "('f, 'v, 'v) gsubst"

fun subst_apply_term :: "('f, 'v) term \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term" (infixl "\<cdot>" 67)
  where
    "Var x \<cdot> \<sigma> = \<sigma> x"
  | "Fun f ss \<cdot> \<sigma> = Fun f (map (\<lambda>t. t \<cdot> \<sigma>) ss)"

definition
  subst_compose :: "('f, 'u, 'v) gsubst \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'u, 'w) gsubst"
  (infixl "\<circ>\<^sub>s" 75)
  where
    "\<sigma> \<circ>\<^sub>s \<tau> = (\<lambda>x. (\<sigma> x) \<cdot> \<tau>)"

lemma subst_subst_compose [simp]:
  "t \<cdot> (\<sigma> \<circ>\<^sub>s \<tau>) = t \<cdot> \<sigma> \<cdot> \<tau>"
  by (induct t \<sigma> rule: subst_apply_term.induct) (simp_all add: subst_compose_def)

lemma subst_compose_assoc:
  "\<sigma> \<circ>\<^sub>s \<tau> \<circ>\<^sub>s \<mu> = \<sigma> \<circ>\<^sub>s (\<tau> \<circ>\<^sub>s \<mu>)"
proof (rule ext)
  fix x show "(\<sigma> \<circ>\<^sub>s \<tau> \<circ>\<^sub>s \<mu>) x = (\<sigma> \<circ>\<^sub>s (\<tau> \<circ>\<^sub>s \<mu>)) x"
  proof -
    have "(\<sigma> \<circ>\<^sub>s \<tau> \<circ>\<^sub>s \<mu>) x = \<sigma>(x) \<cdot> \<tau> \<cdot> \<mu>" by (simp add: subst_compose_def)
    also have "\<dots> = \<sigma>(x) \<cdot> (\<tau> \<circ>\<^sub>s \<mu>)" by simp
    finally show ?thesis by (simp add: subst_compose_def)
  qed
qed

lemma subst_apply_term_empty [simp]:
  "t \<cdot> Var = t"
proof (induct t)
  case (Fun f ts)
  from map_ext [rule_format, of ts _ id, OF Fun] show ?case by simp
qed simp

interpretation subst_monoid_mult: monoid_mult "Var" "(\<circ>\<^sub>s)"
  by (unfold_locales) (simp add: subst_compose_assoc, simp_all add: subst_compose_def)

lemma term_subst_eq:
  assumes "\<And>x. x \<in> vars_term t \<Longrightarrow> \<sigma> x = \<tau> x"
  shows "t \<cdot> \<sigma> = t \<cdot> \<tau>"
  using assms by (induct t) (auto)

lemma term_subst_eq_rev:
  "t \<cdot> \<sigma> = t \<cdot> \<tau> \<Longrightarrow> \<forall>x \<in> vars_term t. \<sigma> x = \<tau> x"
  by (induct t) simp_all

lemma term_subst_eq_conv:
  "t \<cdot> \<sigma> = t \<cdot> \<tau> \<longleftrightarrow> (\<forall>x \<in> vars_term t. \<sigma> x = \<tau> x)"
  using term_subst_eq [of t \<sigma> \<tau>] and term_subst_eq_rev [of t \<sigma> \<tau>] by auto

lemma subst_term_eqI:
  assumes "(\<And>t. t \<cdot> \<sigma> = t \<cdot> \<tau>)"
  shows "\<sigma> = \<tau>"
  using assms [of "Var x" for x] by (intro ext) simp

definition subst_domain :: "('f, 'v) subst \<Rightarrow> 'v set"
  where
    "subst_domain \<sigma> = {x. \<sigma> x \<noteq> Var x}"

fun subst_range :: "('f, 'v) subst \<Rightarrow> ('f, 'v) term set"
  where
    "subst_range \<sigma> = \<sigma> ` subst_domain \<sigma>"

text \<open>The variables introduced by a substitution.\<close>
definition range_vars :: "('f, 'v) subst \<Rightarrow> 'v set"
where
  "range_vars \<sigma> = \<Union>(vars_term ` subst_range \<sigma>)"

definition is_renaming :: "('f, 'v) subst \<Rightarrow> bool"
  where
    "is_renaming \<sigma> \<longleftrightarrow> (\<forall>x. is_Var (\<sigma> x)) \<and> inj_on \<sigma> (subst_domain \<sigma>)"

lemma vars_term_subst:
  "vars_term (t \<cdot> \<sigma>) = \<Union>(vars_term ` \<sigma> ` vars_term t)"
  by (induct t) simp_all

lemma range_varsE [elim]:
  assumes "x \<in> range_vars \<sigma>"
    and "\<And>t. x \<in> vars_term t \<Longrightarrow> t \<in> subst_range \<sigma> \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp: range_vars_def)

lemma range_vars_subst_compose_subset:
  "range_vars (\<sigma> \<circ>\<^sub>s \<tau>) \<subseteq> (range_vars \<sigma> - subst_domain \<tau>) \<union> range_vars \<tau>" (is "?L \<subseteq> ?R")
proof
  fix x
  assume "x \<in> ?L"
  then obtain y where "y \<in> subst_domain (\<sigma> \<circ>\<^sub>s \<tau>)"
    and "x \<in> vars_term ((\<sigma> \<circ>\<^sub>s \<tau>) y)" by (auto simp: range_vars_def)
  then show "x \<in> ?R"
  proof (cases)
    assume "y \<in> subst_domain \<sigma>" and "x \<in> vars_term ((\<sigma> \<circ>\<^sub>s \<tau>) y)"
    moreover then obtain v where "v \<in> vars_term (\<sigma> y)"
      and "x \<in> vars_term (\<tau> v)" by (auto simp: subst_compose_def vars_term_subst)
    ultimately show ?thesis
      by (cases "v \<in> subst_domain \<tau>") (auto simp: range_vars_def subst_domain_def)
  qed (auto simp: range_vars_def subst_compose_def subst_domain_def)
qed

definition "subst x t = Var (x := t)"

lemma subst_simps [simp]:
  "subst x t x = t"
  "subst x (Var x) = Var"
  by (auto simp: subst_def)

lemma subst_subst_domain [simp]:
  "subst_domain (subst x t) = (if t = Var x then {} else {x})"
proof -
  { fix y
    have "y \<in> {y. subst x t y \<noteq> Var y} \<longleftrightarrow> y \<in> (if t = Var x then {} else {x})"
      by (cases "x = y", auto simp: subst_def) }
  then show ?thesis by (simp add: subst_domain_def)
qed

lemma subst_subst_range [simp]:
  "subst_range (subst x t) = (if t = Var x then {} else {t})"
  by (cases "t = Var x") (auto simp: subst_domain_def subst_def)

lemma subst_apply_left_idemp [simp]:
  assumes "\<sigma> x = t \<cdot> \<sigma>"
  shows "s \<cdot> subst x t \<cdot> \<sigma> = s \<cdot> \<sigma>"
  using assms by (induct s) (auto simp: subst_def)

lemma subst_compose_left_idemp [simp]:
  assumes "\<sigma> x = t \<cdot> \<sigma>"
  shows "subst x t \<circ>\<^sub>s \<sigma> = \<sigma>"
  by (rule subst_term_eqI) (simp add: assms)

lemma subst_ident [simp]:
  assumes "x \<notin> vars_term t"
  shows "t \<cdot> subst x u = t"
proof -
  have "t \<cdot> subst x u = t \<cdot> Var"
    by (rule term_subst_eq) (auto simp: assms subst_def)
  then show ?thesis by simp
qed

lemma subst_self_idemp [simp]:
  "x \<notin> vars_term t \<Longrightarrow> subst x t \<circ>\<^sub>s subst x t = subst x t"
  by (metis subst_simps(1) subst_compose_left_idemp subst_ident)

type_synonym ('f, 'v) terms = "('f, 'v) term set"

text \<open>Applying a substitution to every term of a given set.\<close>
abbreviation
  subst_apply_set :: "('f, 'v) terms \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) terms" (infixl "\<cdot>\<^sub>s\<^sub>e\<^sub>t" 60)
  where
    "T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma> \<equiv> (\<lambda>t. t \<cdot> \<sigma>) ` T"

text \<open>Composition of substitutions\<close>
lemma subst_compose: "(\<sigma> \<circ>\<^sub>s \<tau>) x = \<sigma> x \<cdot> \<tau>" by (auto simp: subst_compose_def)

lemmas subst_subst = subst_subst_compose [symmetric]

lemma subst_domain_Var [simp]:
  "subst_domain Var = {}"
  by (simp add: subst_domain_def)

lemma subst_apply_eq_Var:
  assumes "s \<cdot> \<sigma> = Var x"
  obtains y where "s = Var y" and "\<sigma> y = Var x"
  using assms by (induct s) auto

lemma subst_domain_subst_compose:
  "subst_domain (\<sigma> \<circ>\<^sub>s \<tau>) =
    (subst_domain \<sigma> - {x. \<exists>y. \<sigma> x = Var y \<and> \<tau> y = Var x}) \<union>
    (subst_domain \<tau> - subst_domain \<sigma>)"
  by (auto simp: subst_domain_def subst_compose_def elim: subst_apply_eq_Var)

text \<open>A substitution is idempotent iff the variables in its range are disjoint from its domain.
  (See also "Term Rewriting and All That" \cite[Lemma 4.5.7]{AllThat}.)\<close>
lemma subst_idemp_iff:
  "\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma> \<longleftrightarrow> subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
proof
  assume "\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma>"
  then have "\<And>x. \<sigma> x \<cdot> \<sigma> = \<sigma> x \<cdot> Var" by simp (metis subst_compose_def)
  then have *: "\<And>x. \<forall>y\<in>vars_term (\<sigma> x). \<sigma> y = Var y"
    unfolding term_subst_eq_conv by simp
  { fix x y
    assume "\<sigma> x \<noteq> Var x" and "x \<in> vars_term (\<sigma> y)"
    with * [of y] have False by simp }
  then show "subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
    by (auto simp: subst_domain_def range_vars_def)
next
  assume "subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
  then have *: "\<And>x y. \<sigma> x = Var x \<or> \<sigma> y = Var y \<or> x \<notin> vars_term (\<sigma> y)"
    by (auto simp: subst_domain_def range_vars_def)
  have "\<And>x. \<forall>y\<in>vars_term (\<sigma> x). \<sigma> y = Var y"
  proof
    fix x y
    assume "y \<in> vars_term (\<sigma> x)"
    with * [of y x] show "\<sigma> y = Var y" by auto
  qed
  then show "\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma>"
    by (simp add: subst_compose_def term_subst_eq_conv [symmetric])
qed

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

lemma num_funs_0:
  assumes "num_funs t = 0"
  obtains x where "t = Var x"
  using assms by (induct t) auto

lemma num_funs_subst:
  "num_funs (t \<cdot> \<sigma>) \<ge> num_funs t"
  by (induct t) (simp_all, metis comp_apply sum_list_mono)

lemma sum_list_map_num_funs_subst:
  assumes "sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts) = sum_list (map num_funs ts)"
  shows "\<forall>i < length ts. num_funs (ts ! i \<cdot> \<sigma>) = num_funs (ts ! i)"
  using assms
proof (induct ts)
  case (Cons t ts)
  then have "num_funs (t \<cdot> \<sigma>) + sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts)
    = num_funs t + sum_list (map num_funs ts)" by (simp add: o_def)
  moreover have "num_funs (t \<cdot> \<sigma>) \<ge> num_funs t" by (metis num_funs_subst)
  moreover have "sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts) \<ge> sum_list (map num_funs ts)"
    using num_funs_subst [of _ \<sigma>] by (induct ts) (auto intro: add_mono)
  ultimately show ?case using Cons by (auto) (case_tac i, auto)
qed simp

lemma is_Fun_num_funs_less:
  assumes "x \<in> vars_term t" and "is_Fun t"
  shows "num_funs (\<sigma> x) < num_funs (t \<cdot> \<sigma>)"
  using assms
proof (induct t)
  case (Fun f ts)
  then obtain u where u: "u \<in> set ts" "x \<in> vars_term u" by auto
  then have "num_funs (u \<cdot> \<sigma>) \<le> sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts)"
    by (intro member_le_sum_list) simp
  moreover have "num_funs (\<sigma> x) \<le> num_funs (u \<cdot> \<sigma>)"
    using Fun.hyps [OF u] and u  by (cases u; simp)
  ultimately show ?case by simp
qed simp

lemma finite_subst_domain_subst:
  "finite (subst_domain (subst x y))"
  by simp

lemma subst_domain_compose:
  "subst_domain (\<sigma> \<circ>\<^sub>s \<tau>) \<subseteq> subst_domain \<sigma> \<union> subst_domain \<tau>"
  by (auto simp: subst_domain_def subst_compose_def)

lemma vars_term_disjoint_imp_unifier:
  fixes \<sigma> :: "('f, 'v, 'w) gsubst"
  assumes "vars_term s \<inter> vars_term t = {}"
    and "s \<cdot> \<sigma> = t \<cdot> \<tau>"
  shows "\<exists>\<mu> :: ('f, 'v, 'w) gsubst. s \<cdot> \<mu> = t \<cdot> \<mu>"
proof -
  let ?\<mu> = "\<lambda>x. if x \<in> vars_term s then \<sigma> x else \<tau> x"
  have "s \<cdot> \<sigma> = s \<cdot> ?\<mu>"
    unfolding term_subst_eq_conv
    by (induct s) (simp_all)
  moreover have "t \<cdot> \<tau> = t \<cdot> ?\<mu>"
    using assms(1)
    unfolding term_subst_eq_conv
    by (induct s arbitrary: t) (auto)
  ultimately have "s \<cdot> ?\<mu> = t \<cdot> ?\<mu>" using assms(2) by simp
  then show ?thesis by blast
qed

lemma vars_term_subset_subst_eq:
  assumes "vars_term t \<subseteq> vars_term s"
    and "s \<cdot> \<sigma> = s \<cdot> \<tau>"
  shows "t \<cdot> \<sigma> = t \<cdot> \<tau>"
  using assms by (induct t) (induct s, auto)

end


theory ArityStack
imports "Arity" SestoftConf
begin

fun Astack :: "stack \<Rightarrow> Arity"
  where "Astack [] = 0"
      | "Astack (Arg x # S) = inc\<cdot>(Astack S)"
      | "Astack (Alts e1 e2 # S) = 0"
      | "Astack (Upd x # S) = 0"
      | "Astack (Dummy x # S) = 0"

lemma Astack_restr_stack_below:
  "Astack (restr_stack V S) \<sqsubseteq> Astack S"
  by (induction V S rule: restr_stack.induct) auto

lemma Astack_map_Dummy[simp]:
  "Astack (map Dummy l) = 0"
by (induction l) auto

lemma Astack_append_map_Dummy[simp]:
  "Astack S' = 0 \<Longrightarrow> Astack (S @ S') = Astack S"
by (induction S rule: Astack.induct) auto

end


theory Reverse
imports MainRLT
begin

fun T_append :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
"T_append [] ys = 1" |
"T_append (x#xs) ys = T_append xs ys + 1"

fun T_rev :: "'a list \<Rightarrow> nat" where
"T_rev [] = 1" |
"T_rev (x#xs) = T_rev xs + T_append (rev xs) [x] + 1"

lemma T_append: "T_append xs ys = length xs + 1"
by(induction xs) auto

lemma T_rev: "T_rev xs \<le> (length xs + 1)^2"
by(induction xs) (auto simp: T_append power2_eq_square)

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (x#xs) ys = itrev xs (x # ys)"

lemma itrev: "itrev xs ys = rev xs @ ys"
by(induction xs arbitrary: ys) auto

lemma itrev_Nil: "itrev xs [] = rev xs"
by(simp add: itrev)

fun T_itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
"T_itrev [] ys = 1" |
"T_itrev (x#xs) ys = T_itrev xs (x # ys) + 1"

lemma T_itrev: "T_itrev xs ys = length xs + 1"
by(induction xs arbitrary: ys) auto

end