(*  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>\<open>"R2"\<close>, 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>\<open>"R3"\<close>, \<^cite>\<open>"R4"\<close>, \<^cite>\<open>"R5"\<close>, and
\<^cite>\<open>"R6"\<close>. For a sample nontrivial application of the mathematical machinery developed in this
paper, cf. \<^cite>\<open>"R1"\<close>.
\<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>\<open>"R2"\<close>, 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}"
using [[simproc del: defined_all]]
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'}")
using [[simproc del: defined_all]]
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> _")
using [[simproc del: defined_all]]
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'}")
using [[simproc del: defined_all]]
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


(*
 * Copyright Thomas Sewell, NICTA and Sascha Boehme, TU Muenchen
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Bitwise
  imports
    "HOL-Library.Word"
    More_Arithmetic
    Reversed_Bit_Lists
    Bit_Shifts_Infix_Syntax
begin

text \<open>Helper constants used in defining addition\<close>

definition xor3 :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
  where "xor3 a b c = (a = (b = c))"

definition carry :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
  where "carry a b c = ((a \<and> (b \<or> c)) \<or> (b \<and> c))"

lemma carry_simps:
  "carry True a b = (a \<or> b)"
  "carry a True b = (a \<or> b)"
  "carry a b True = (a \<or> b)"
  "carry False a b = (a \<and> b)"
  "carry a False b = (a \<and> b)"
  "carry a b False = (a \<and> b)"
  by (auto simp add: carry_def)

lemma xor3_simps:
  "xor3 True a b = (a = b)"
  "xor3 a True b = (a = b)"
  "xor3 a b True = (a = b)"
  "xor3 False a b = (a \<noteq> b)"
  "xor3 a False b = (a \<noteq> b)"
  "xor3 a b False = (a \<noteq> b)"
  by (simp_all add: xor3_def)

text \<open>Breaking up word equalities into equalities on their
  bit lists. Equalities are generated and manipulated in the
  reverse order to \<^const>\<open>to_bl\<close>.\<close>

lemma bl_word_sub: "to_bl (x - y) = to_bl (x + (- y))"
  by simp

lemma rbl_word_1: "rev (to_bl (1 :: 'a::len word)) = takefill False (LENGTH('a)) [True]"
  apply (rule_tac s="rev (to_bl (word_succ (0 :: 'a word)))" in trans)
   apply simp
  apply (simp only: rtb_rbl_ariths(1)[OF refl])
  apply simp
  apply (case_tac "LENGTH('a)")
   apply simp
  apply (simp add: takefill_alt)
  done

lemma rbl_word_if: "rev (to_bl (if P then x else y)) = map2 (If P) (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: split_def)

lemma rbl_add_carry_Cons:
  "(if car then rbl_succ else id) (rbl_add (x # xs) (y # ys)) =
    xor3 x y car # (if carry x y car then rbl_succ else id) (rbl_add xs ys)"
  by (simp add: carry_def xor3_def)

lemma rbl_add_suc_carry_fold:
  "length xs = length ys \<Longrightarrow>
    \<forall>car. (if car then rbl_succ else id) (rbl_add xs ys) =
      (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) (zip xs ys) (\<lambda>_. [])) car"
  apply (erule list_induct2)
   apply simp
  apply (simp only: rbl_add_carry_Cons)
  apply simp
  done

lemma to_bl_plus_carry:
  "to_bl (x + y) =
    rev (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car))
      (rev (zip (to_bl x) (to_bl y))) (\<lambda>_. []) False)"
  using rbl_add_suc_carry_fold[where xs="rev (to_bl x)" and ys="rev (to_bl y)"]
  apply (simp add: word_add_rbl[OF refl refl])
  apply (drule_tac x=False in spec)
  apply (simp add: zip_rev)
  done

definition "rbl_plus cin xs ys =
  foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) (zip xs ys) (\<lambda>_. []) cin"

lemma rbl_plus_simps:
  "rbl_plus cin (x # xs) (y # ys) = xor3 x y cin # rbl_plus (carry x y cin) xs ys"
  "rbl_plus cin [] ys = []"
  "rbl_plus cin xs [] = []"
  by (simp_all add: rbl_plus_def)

lemma rbl_word_plus: "rev (to_bl (x + y)) = rbl_plus False (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: rbl_plus_def to_bl_plus_carry zip_rev)

definition "rbl_succ2 b xs = (if b then rbl_succ xs else xs)"

lemma rbl_succ2_simps:
  "rbl_succ2 b [] = []"
  "rbl_succ2 b (x # xs) = (b \<noteq> x) # rbl_succ2 (x \<and> b) xs"
  by (simp_all add: rbl_succ2_def)

lemma twos_complement: "- x = word_succ (not x)"
  using arg_cong[OF word_add_not[where x=x], where f="\<lambda>a. a - x + 1"]
  by (simp add: word_succ_p1 word_sp_01[unfolded word_succ_p1] del: word_add_not)

lemma rbl_word_neg: "rev (to_bl (- x)) = rbl_succ2 True (map Not (rev (to_bl x)))"
  for x :: \<open>'a::len word\<close>
  by (simp add: twos_complement word_succ_rbl[OF refl] bl_word_not rev_map rbl_succ2_def)

lemma rbl_word_cat:
  "rev (to_bl (word_cat x y :: 'a::len word)) =
    takefill False (LENGTH('a)) (rev (to_bl y) @ rev (to_bl x))"
  by (simp add: word_cat_bl word_rev_tf)

lemma rbl_word_slice:
  "rev (to_bl (slice n w :: 'a::len word)) =
    takefill False (LENGTH('a)) (drop n (rev (to_bl w)))"
  apply (simp add: slice_take word_rev_tf rev_take)
  apply (cases "n < LENGTH('b)", simp_all)
  done

lemma rbl_word_ucast:
  "rev (to_bl (ucast x :: 'a::len word)) = takefill False (LENGTH('a)) (rev (to_bl x))"
  apply (simp add: to_bl_ucast takefill_alt)
  apply (simp add: rev_drop)
  apply (cases "LENGTH('a) < LENGTH('b)")
   apply simp_all
  done

lemma rbl_shiftl:
  "rev (to_bl (w << n)) = takefill False (size w) (replicate n False @ rev (to_bl w))"
  by (simp add: bl_shiftl takefill_alt word_size rev_drop)

lemma rbl_shiftr:
  "rev (to_bl (w >> n)) = takefill False (size w) (drop n (rev (to_bl w)))"
  by (simp add: shiftr_slice rbl_word_slice word_size)

definition "drop_nonempty v n xs = (if n < length xs then drop n xs else [last (v # xs)])"

lemma drop_nonempty_simps:
  "drop_nonempty v (Suc n) (x # xs) = drop_nonempty x n xs"
  "drop_nonempty v 0 (x # xs) = (x # xs)"
  "drop_nonempty v n [] = [v]"
  by (simp_all add: drop_nonempty_def)

definition "takefill_last x n xs = takefill (last (x # xs)) n xs"

lemma takefill_last_simps:
  "takefill_last z (Suc n) (x # xs) = x # takefill_last x n xs"
  "takefill_last z 0 xs = []"
  "takefill_last z n [] = replicate n z"
  by (simp_all add: takefill_last_def) (simp_all add: takefill_alt)

lemma rbl_sshiftr:
  "rev (to_bl (w >>> n)) = takefill_last False (size w) (drop_nonempty False n (rev (to_bl w)))"
  apply (cases "n < size w")
   apply (simp add: bl_sshiftr takefill_last_def word_size
      takefill_alt rev_take last_rev
      drop_nonempty_def)
  apply (subgoal_tac "(w >>> n) = of_bl (replicate (size w) (msb w))")
   apply (simp add: word_size takefill_last_def takefill_alt
      last_rev word_msb_alt word_rev_tf
      drop_nonempty_def take_Cons')
   apply (case_tac "LENGTH('a)", simp_all)
  apply (rule word_eqI)
  apply (simp add: bit_simps word_size test_bit_of_bl
      msb_nth)
  done

lemma nth_word_of_int:
  "bit (word_of_int x :: 'a::len word) n = (n < LENGTH('a) \<and> bit x n)"
  apply (simp add: test_bit_bl word_size to_bl_of_bin)
  apply (subst conj_cong[OF refl], erule bin_nth_bl)
  apply auto
  done

lemma nth_scast:
  "bit (scast (x :: 'a::len word) :: 'b::len word) n =
    (n < LENGTH('b) \<and>
    (if n < LENGTH('a) - 1 then bit x n
     else bit x (LENGTH('a) - 1)))"
  apply transfer
  apply (auto simp add: bit_signed_take_bit_iff min_def)
  done

lemma rbl_word_scast:
  "rev (to_bl (scast x :: 'a::len word)) = takefill_last False (LENGTH('a)) (rev (to_bl x))"
  apply (rule nth_equalityI)
   apply (simp add: word_size takefill_last_def)
  apply (clarsimp simp: nth_scast takefill_last_def
      nth_takefill word_size rev_nth to_bl_nth)
  apply (cases "LENGTH('b)")
   apply simp
  apply (clarsimp simp: less_Suc_eq_le linorder_not_less
      last_rev word_msb_alt[symmetric]
      msb_nth)
  done

definition rbl_mul :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
  where "rbl_mul xs ys = foldr (\<lambda>x sm. rbl_plus False (map ((\<and>) x) ys) (False # sm)) xs []"

lemma rbl_mul_simps:
  "rbl_mul (x # xs) ys = rbl_plus False (map ((\<and>) x) ys) (False # rbl_mul xs ys)"
  "rbl_mul [] ys = []"
  by (simp_all add: rbl_mul_def)

lemma takefill_le2: "length xs \<le> n \<Longrightarrow> takefill x m (takefill x n xs) = takefill x m xs"
  by (simp add: takefill_alt replicate_add[symmetric])

lemma take_rbl_plus: "\<forall>n b. take n (rbl_plus b xs ys) = rbl_plus b (take n xs) (take n ys)"
  apply (simp add: rbl_plus_def take_zip[symmetric])
  apply (rule_tac list="zip xs ys" in list.induct)
   apply simp
  apply (clarsimp simp: split_def)
  apply (case_tac n, simp_all)
  done

lemma word_rbl_mul_induct:
  "length xs \<le> size y \<Longrightarrow>
    rbl_mul xs (rev (to_bl y)) = take (length xs) (rev (to_bl (of_bl (rev xs) * y)))"
  for y :: "'a::len word"
proof (induct xs)
  case Nil
  show ?case by (simp add: rbl_mul_simps)
next
  case (Cons z zs)

  have rbl_word_plus': "to_bl (x + y) = rev (rbl_plus False (rev (to_bl x)) (rev (to_bl y)))"
    for x y :: "'a word"
    by (simp add: rbl_word_plus[symmetric])

  have mult_bit: "to_bl (of_bl [z] * y) = map ((\<and>) z) (to_bl y)"
    by (cases z) (simp cong: map_cong, simp add: map_replicate_const cong: map_cong)

  have shiftl: "of_bl xs * 2 * y = (of_bl xs * y) << 1" for xs
    by (simp add: push_bit_eq_mult shiftl_def)

  have zip_take_triv: "\<And>xs ys n. n = length ys \<Longrightarrow> zip (take n xs) ys = zip xs ys"
    by (rule nth_equalityI) simp_all

  from Cons show ?case
    apply (simp add: trans [OF of_bl_append add.commute]
        rbl_mul_simps rbl_word_plus' distrib_right mult_bit shiftl rbl_shiftl)
    apply (simp add: takefill_alt word_size rev_map take_rbl_plus min_def)
    apply (simp add: rbl_plus_def)
    apply (simp add: zip_take_triv)
    apply (simp only: mult.commute [of _ 2] to_bl_double_eq)
    apply (simp flip: butlast_rev add: take_butlast)
    done
qed

lemma rbl_word_mul: "rev (to_bl (x * y)) = rbl_mul (rev (to_bl x)) (rev (to_bl y))"
  for x :: "'a::len word"
  using word_rbl_mul_induct[where xs="rev (to_bl x)" and y=y] by (simp add: word_size)

text \<open>Breaking up inequalities into bitlist properties.\<close>

definition
  "rev_bl_order F xs ys =
     (length xs = length ys \<and>
       ((xs = ys \<and> F)
          \<or> (\<exists>n < length xs. drop (Suc n) xs = drop (Suc n) ys
                   \<and> \<not> xs ! n \<and> ys ! n)))"

lemma rev_bl_order_simps:
  "rev_bl_order F [] [] = F"
  "rev_bl_order F (x # xs) (y # ys) = rev_bl_order ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> F)) xs ys"
   apply (simp_all add: rev_bl_order_def)
  apply (rule conj_cong[OF refl])
  apply (cases "xs = ys")
   apply (simp add: nth_Cons')
   apply blast
  apply (simp add: nth_Cons')
  apply safe
   apply (rule_tac x="n - 1" in exI)
   apply simp
  apply (rule_tac x="Suc n" in exI)
  apply simp
  done

lemma rev_bl_order_rev_simp:
  "length xs = length ys \<Longrightarrow>
   rev_bl_order F (xs @ [x]) (ys @ [y]) = ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> rev_bl_order F xs ys))"
  by (induct arbitrary: F rule: list_induct2) (auto simp: rev_bl_order_simps)

lemma rev_bl_order_bl_to_bin:
  "length xs = length ys \<Longrightarrow>
    rev_bl_order True xs ys = (bl_to_bin (rev xs) \<le> bl_to_bin (rev ys)) \<and>
    rev_bl_order False xs ys = (bl_to_bin (rev xs) < bl_to_bin (rev ys))"
  apply (induct xs ys rule: list_induct2)
   apply (simp_all add: rev_bl_order_simps bl_to_bin_app_cat concat_bit_Suc)
  apply (auto simp add: bl_to_bin_def add1_zle_eq)
  done

lemma word_le_rbl: "x \<le> y \<longleftrightarrow> rev_bl_order True (rev (to_bl x)) (rev (to_bl y))"
  for x y :: "'a::len word"
  by (simp add: rev_bl_order_bl_to_bin word_le_def)

lemma word_less_rbl: "x < y \<longleftrightarrow> rev_bl_order False (rev (to_bl x)) (rev (to_bl y))"
  for x y :: "'a::len word"
  by (simp add: word_less_alt rev_bl_order_bl_to_bin)

definition "map_last f xs = (if xs = [] then [] else butlast xs @ [f (last xs)])"

lemma map_last_simps:
  "map_last f [] = []"
  "map_last f [x] = [f x]"
  "map_last f (x # y # zs) = x # map_last f (y # zs)"
  by (simp_all add: map_last_def)

lemma word_sle_rbl:
  "x <=s y \<longleftrightarrow> rev_bl_order True (map_last Not (rev (to_bl x))) (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sle_msb_le word_le_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

lemma word_sless_rbl:
  "x <s y \<longleftrightarrow> rev_bl_order False (map_last Not (rev (to_bl x))) (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sless_msb_less word_less_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

text \<open>Lemmas for unpacking \<^term>\<open>rev (to_bl n)\<close> for numerals n and also
  for irreducible values and expressions.\<close>

lemma rev_bin_to_bl_simps:
  "rev (bin_to_bl 0 x) = []"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit0 nm))) = False # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit1 nm))) = True # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.One))) = True # replicate n False"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm))) = False # rev (bin_to_bl n (- numeral nm))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm))) =
    True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One))) = True # replicate n True"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm + num.One))) =
    True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm + num.One))) =
    False # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One + num.One))) =
    False # rev (bin_to_bl n (- numeral num.One))"
  by (simp_all add: bin_to_bl_aux_append bin_to_bl_zero_aux bin_to_bl_minus1_aux replicate_append_same)

lemma to_bl_upt: "to_bl x = rev (map (bit x) [0 ..< size x])"
  by (simp add: to_bl_eq_rev word_size rev_map)

lemma rev_to_bl_upt: "rev (to_bl x) = map (bit x) [0 ..< size x]"
  by (simp add: to_bl_upt)

lemma upt_eq_list_intros:
  "j \<le> i \<Longrightarrow> [i ..< j] = []"
  "i = x \<Longrightarrow> x < j \<Longrightarrow> [x + 1 ..< j] = xs \<Longrightarrow> [i ..< j] = (x # xs)"
  by (simp_all add: upt_eq_Cons_conv)

subsection \<open>Tactic definition\<close>

lemma if_bool_simps:
  "If p True y = (p \<or> y) \<and> If p False y = (\<not> p \<and> y) \<and>
    If p y True = (p \<longrightarrow> y) \<and> If p y False = (p \<and> y)"
  by auto

ML \<open>
structure Word_Bitwise_Tac =
struct

val word_ss = simpset_of \<^theory_context>\<open>Word\<close>;

fun mk_nat_clist ns =
  fold_rev (Thm.mk_binop \<^cterm>\<open>Cons :: nat \<Rightarrow> _\<close>)
    ns \<^cterm>\<open>[] :: nat list\<close>;

fun upt_conv ctxt ct =
  case Thm.term_of ct of
    \<^Const_>\<open>upt for n m\<close> =>
      let
        val (i, j) = apply2 (snd o HOLogic.dest_number) (n, m);
        val ns = map (Numeral.mk_cnumber \<^ctyp>\<open>nat\<close>) (i upto (j - 1))
          |> mk_nat_clist;
        val prop =
          Thm.mk_binop \<^cterm>\<open>(=) :: nat list \<Rightarrow> _\<close> ct ns
          |> Thm.apply \<^cterm>\<open>Trueprop\<close>;
      in
        try (fn () =>
          Goal.prove_internal ctxt [] prop
            (K (REPEAT_DETERM (resolve_tac ctxt @{thms upt_eq_list_intros} 1
                ORELSE simp_tac (put_simpset word_ss ctxt) 1))) |> mk_meta_eq) ()
      end
  | _ => NONE;

val expand_upt_simproc =
  Simplifier.make_simproc \<^context> "expand_upt"
   {lhss = [\<^term>\<open>upt x y\<close>], proc = K upt_conv};

fun word_len_simproc_fn ctxt ct =
  (case Thm.term_of ct of
    \<^Const_>\<open>len_of _ for t\<close> =>
     (let
        val T = fastype_of t |> dest_Type |> snd |> the_single
        val n = Numeral.mk_cnumber \<^ctyp>\<open>nat\<close> (Word_Lib.dest_binT T);
        val prop =
          Thm.mk_binop \<^cterm>\<open>(=) :: nat \<Rightarrow> _\<close> ct n
          |> Thm.apply \<^cterm>\<open>Trueprop\<close>;
      in
        Goal.prove_internal ctxt [] prop (K (simp_tac (put_simpset word_ss ctxt) 1))
        |> mk_meta_eq |> SOME
      end handle TERM _ => NONE | TYPE _ => NONE)
  | _ => NONE);

val word_len_simproc =
  Simplifier.make_simproc \<^context> "word_len"
   {lhss = [\<^term>\<open>len_of x\<close>], proc = K word_len_simproc_fn};

(* convert 5 or nat 5 to Suc 4 when n_sucs = 1, Suc (Suc 4) when n_sucs = 2,
   or just 5 (discarding nat) when n_sucs = 0 *)

fun nat_get_Suc_simproc_fn n_sucs ctxt ct =
  let
    val (f, arg) = dest_comb (Thm.term_of ct);
    val n =
      (case arg of \<^term>\<open>nat\<close> $ n => n | n => n)
      |> HOLogic.dest_number |> snd;
    val (i, j) = if n > n_sucs then (n_sucs, n - n_sucs) else (n, 0);
    val arg' = funpow i HOLogic.mk_Suc (HOLogic.mk_number \<^typ>\<open>nat\<close> j);
    val _ = if arg = arg' then raise TERM ("", []) else ();
    fun propfn g =
      HOLogic.mk_eq (g arg, g arg')
      |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt;
    val eq1 =
      Goal.prove_internal ctxt [] (propfn I)
        (K (simp_tac (put_simpset word_ss ctxt) 1));
  in
    Goal.prove_internal ctxt [] (propfn (curry (op $) f))
      (K (simp_tac (put_simpset HOL_ss ctxt addsimps [eq1]) 1))
    |> mk_meta_eq |> SOME
  end handle TERM _ => NONE;

fun nat_get_Suc_simproc n_sucs ts =
  Simplifier.make_simproc \<^context> "nat_get_Suc"
   {lhss = map (fn t => t $ \<^term>\<open>n :: nat\<close>) ts,
    proc = K (nat_get_Suc_simproc_fn n_sucs)};

val no_split_ss =
  simpset_of (put_simpset HOL_ss \<^context>
    |> Splitter.del_split @{thm if_split});

val expand_word_eq_sss =
  (simpset_of (put_simpset HOL_basic_ss \<^context> addsimps
       @{thms word_eq_rbl_eq word_le_rbl word_less_rbl word_sle_rbl word_sless_rbl}),
  map simpset_of [
   put_simpset no_split_ss \<^context> addsimps
    @{thms rbl_word_plus rbl_word_and rbl_word_or rbl_word_not
                                rbl_word_neg bl_word_sub rbl_word_xor
                                rbl_word_cat rbl_word_slice rbl_word_scast
                                rbl_word_ucast rbl_shiftl rbl_shiftr rbl_sshiftr
                                rbl_word_if},
   put_simpset no_split_ss \<^context> addsimps
    @{thms to_bl_numeral to_bl_neg_numeral to_bl_0 rbl_word_1},
   put_simpset no_split_ss \<^context> addsimps
    @{thms rev_rev_ident rev_replicate rev_map to_bl_upt word_size}
          addsimprocs [word_len_simproc],
   put_simpset no_split_ss \<^context> addsimps
    @{thms list.simps split_conv replicate.simps list.map
                                zip_Cons_Cons zip_Nil drop_Suc_Cons drop_0 drop_Nil
                                foldr.simps list.map zip.simps(1) zip_Nil zip_Cons_Cons takefill_Suc_Cons
                                takefill_Suc_Nil takefill.Z rbl_succ2_simps
                                rbl_plus_simps rev_bin_to_bl_simps append.simps
                                takefill_last_simps drop_nonempty_simps
                                rev_bl_order_simps}
          addsimprocs [expand_upt_simproc,
                       nat_get_Suc_simproc 4
                         [\<^term>\<open>replicate\<close>, \<^term>\<open>takefill x\<close>,
                          \<^term>\<open>drop\<close>, \<^term>\<open>bin_to_bl\<close>,
                          \<^term>\<open>takefill_last x\<close>,
                          \<^term>\<open>drop_nonempty x\<close>]],
    put_simpset no_split_ss \<^context> addsimps @{thms xor3_simps carry_simps if_bool_simps}
  ])

fun tac ctxt =
  let
    val (ss, sss) = expand_word_eq_sss;
  in
    foldr1 (op THEN_ALL_NEW)
      ((CHANGED o safe_full_simp_tac (put_simpset ss ctxt)) ::
        map (fn ss => safe_full_simp_tac (put_simpset ss ctxt)) sss)
  end;

end
\<close>

method_setup word_bitwise =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (Word_Bitwise_Tac.tac ctxt 1))\<close>
  "decomposer for word equalities and inequalities into bit propositions"

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Simple digraphs\<close>
theory CZH_DG_Simple
  imports CZH_DG_TDGHM
begin

subsection\<open>Background\<close>

text\<open>
The section presents a variety of simple digraphs, such as the empty digraph \<open>0\<close>
and a digraph with one object and one arrow \<open>1\<close>. All of the entities
presented in this section are generalizations of certain simple categories,
whose definitions can be found in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

subsection\<open>Empty digraph \<open>0\<close>\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition dg_0 :: V
  where "dg_0 = [0, 0, 0, 0]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dg_0_components:
  shows "dg_0\<lparr>Obj\<rparr> = 0"
    and "dg_0\<lparr>Arr\<rparr> = 0"
    and "dg_0\<lparr>Dom\<rparr> = 0"
    and "dg_0\<lparr>Cod\<rparr> = 0"
  unfolding dg_0_def dg_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>\<open>0\<close> is a digraph\<close>

lemma (in \<Z>) digraph_dg_0[dg_cs_intros]: "digraph \<alpha> dg_0"
proof(intro digraphI)
  show "vfsequence dg_0" unfolding dg_0_def by (simp add: nat_omega_simps)
  show "vcard dg_0 = 4\<^sub>\<nat>" unfolding dg_0_def by (simp add: nat_omega_simps)
qed (auto simp: dg_0_components)

lemmas [dg_cs_intros] = \<Z>.digraph_dg_0

subsubsection\<open>Opposite of the digraph \<open>0\<close>\<close>

lemma op_dg_dg_0[dg_op_simps]: "op_dg (dg_0) = dg_0"
proof(rule dg_eqI, unfold dg_op_simps)
  define \<beta> where "\<beta> = \<omega> + \<omega>"
  interpret \<beta>: \<Z> \<beta> unfolding \<beta>_def by (rule \<Z>_\<omega>\<omega>)
  show "digraph \<beta> (op_dg dg_0)"
    by (cs_concl cs_shallow cs_intro: dg_cs_intros dg_op_intros)
  show "digraph \<beta> dg_0" by (cs_concl cs_shallow cs_intro: dg_cs_intros)
qed (simp_all add: dg_0_components op_dg_components)

subsubsection\<open>Arrow with a domain and a codomain\<close>

lemma dg_0_is_arr_iff[simp]: "\<FF> : \<AA> \<mapsto>\<^bsub>dg_0\<^esub> \<BB> \<longleftrightarrow> False"
  by (rule iffI; (elim is_arrE)?) (auto simp: dg_0_components)

subsubsection\<open>A digraph without objects is empty\<close>

lemma (in digraph) dg_dg_0_if_Obj_0:
  assumes "\<CC>\<lparr>Obj\<rparr> = 0"
  shows "\<CC> = dg_0"
  by (rule dg_eqI[of \<alpha>])
    (
      auto simp:
        dg_cs_intros
        assms
        digraph_dg_0
        dg_0_components
        dg_Arr_vempty_if_Obj_vempty
        dg_Cod_vempty_if_Arr_vempty
        dg_Dom_vempty_if_Arr_vempty
    )

subsection\<open>Empty digraph homomorphism\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition dghm_0 :: "V \<Rightarrow> V"
  where "dghm_0 \<AA> = [0, 0, dg_0, \<AA>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dghm_0_components:
  shows "dghm_0 \<AA>\<lparr>ObjMap\<rparr> = 0"
    and "dghm_0 \<AA>\<lparr>ArrMap\<rparr> = 0"
    and "dghm_0 \<AA>\<lparr>HomDom\<rparr> = dg_0"
    and "dghm_0 \<AA>\<lparr>HomCod\<rparr> = \<AA>"
  unfolding dghm_0_def dghm_field_simps by (simp_all add: nat_omega_simps)

text\<open>Opposite empty digraph homomorphism.\<close>

lemma op_dghm_dghm_0: "op_dghm (dghm_0 \<CC>) = dghm_0 (op_dg \<CC>)"
  unfolding
    dghm_0_def op_dg_def op_dghm_def dg_0_def dghm_field_simps dg_field_simps
  by (simp add: nat_omega_simps)

subsubsection\<open>Object map\<close>

lemma dghm_0_ObjMap_vsv[dg_cs_intros]: "vsv (dghm_0 \<CC>\<lparr>ObjMap\<rparr>)"
  unfolding dghm_0_components by simp

subsubsection\<open>Arrow map\<close>

lemma dghm_0_ArrMap_vsv[dg_cs_intros]: "vsv (dghm_0 \<CC>\<lparr>ArrMap\<rparr>)"
  unfolding dghm_0_components by simp

subsubsection\<open>Empty digraph homomorphism is a faithful digraph homomorphism\<close>

lemma (in \<Z>) dghm_0_is_ft_dghm:
  assumes "digraph \<alpha> \<AA>"
  shows "dghm_0 \<AA> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> \<AA>"
proof(rule is_ft_dghmI)
  show "dghm_0 \<AA> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<AA>"
  proof(rule is_dghmI)
    show "vfsequence (dghm_0 \<AA>)" unfolding dghm_0_def by simp
    show "vcard (dghm_0 \<AA>) = 4\<^sub>\<nat>"
      unfolding dghm_0_def by (simp add: nat_omega_simps)
  qed (auto simp: assms digraph_dg_0 dghm_0_components dg_0_components)
qed (auto simp: dg_0_components dghm_0_components)

lemma (in \<Z>) dghm_0_is_ft_dghm'[dghm_cs_intros]:
  assumes "digraph \<alpha> \<AA>"
    and "\<BB>' = \<AA>"
    and "\<AA>' = dg_0"
  shows "dghm_0 \<AA> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> \<BB>'"
  using assms(1) unfolding assms(2,3) by (rule dghm_0_is_ft_dghm)

lemmas [dghm_cs_intros] = \<Z>.dghm_0_is_ft_dghm'

lemma (in \<Z>) dghm_0_is_dghm:
  assumes "digraph \<alpha> \<AA>"
  shows "dghm_0 \<AA> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<AA>"
  using dghm_0_is_ft_dghm[OF assms] by auto

lemma (in \<Z>) dghm_0_is_dghm'[dg_cs_intros]:
  assumes "digraph \<alpha> \<AA>"
    and "\<BB>' = \<AA>"
    and "\<AA>' = dg_0"
  shows "dghm_0 \<AA> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>'"
  using assms(1) unfolding assms(2,3) by (rule dghm_0_is_dghm)

lemmas [dg_cs_intros] = \<Z>.dghm_0_is_dghm'

subsubsection\<open>Further properties\<close>

lemma is_dghm_is_dghm_0_if_dg_0:
  assumes "\<FF> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<FF> = dghm_0 \<CC>"
proof(rule dghm_eqI)
  interpret \<FF>: is_dghm \<alpha> dg_0 \<CC> \<FF> by (rule assms(1))
  show "\<FF> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(1))
  then have dom_lhs: "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = 0" "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = 0"
    by (cs_concl cs_simp: dg_cs_simps dg_0_components)+
  show "dghm_0 \<CC> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" by (cs_concl cs_intro: dg_cs_intros)
  then have dom_rhs: "\<D>\<^sub>\<circ> (dghm_0 \<CC>\<lparr>ObjMap\<rparr>) = 0" "\<D>\<^sub>\<circ> (dghm_0 \<CC>\<lparr>ArrMap\<rparr>) = 0"
    by (cs_concl cs_simp: dg_cs_simps dg_0_components)+
  show "\<FF>\<lparr>ObjMap\<rparr> = dghm_0 \<CC>\<lparr>ObjMap\<rparr>"
    by (rule vsv_eqI, unfold dom_lhs dom_rhs) (auto intro: dg_cs_intros)
  show "\<FF>\<lparr>ArrMap\<rparr> = dghm_0 \<CC>\<lparr>ArrMap\<rparr>"
    by (rule vsv_eqI, unfold dom_lhs dom_rhs) (auto intro: dg_cs_intros)
qed simp_all

subsection\<open>Empty transformation of digraph homomorphisms\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition tdghm_0 :: "V \<Rightarrow> V"
  where "tdghm_0 \<CC> = [0, dghm_0 \<CC>, dghm_0 \<CC>, dg_0, \<CC>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma tdghm_0_components:
  shows "tdghm_0 \<CC>\<lparr>NTMap\<rparr> = 0"
    and [dg_cs_simps]: "tdghm_0 \<CC>\<lparr>NTDom\<rparr> = dghm_0 \<CC>"
    and [dg_cs_simps]: "tdghm_0 \<CC>\<lparr>NTCod\<rparr> = dghm_0 \<CC>"
    and [dg_cs_simps]: "tdghm_0 \<CC>\<lparr>NTDGDom\<rparr> = dg_0"
    and [dg_cs_simps]: "tdghm_0  \<CC>\<lparr>NTDGCod\<rparr> = \<CC>"
  unfolding tdghm_0_def nt_field_simps by (simp_all add: nat_omega_simps)

text\<open>Duality.\<close>

lemma op_tdghm_tdghm_0: "op_tdghm (tdghm_0 \<CC>) = tdghm_0 (op_dg \<CC>)"
  by
    (
      simp_all add:
        tdghm_0_def op_tdghm_def op_dg_def dg_0_def op_dghm_dghm_0
        nt_field_simps dg_field_simps nat_omega_simps
    )

subsubsection\<open>Transformation map\<close>

lemma tdghm_0_NTMap_vsv[dg_cs_intros]: "vsv (tdghm_0 \<CC>\<lparr>NTMap\<rparr>)"
  unfolding tdghm_0_components by simp

lemma tdghm_0_NTMap_vdomain[dg_cs_simps]: "\<D>\<^sub>\<circ> (tdghm_0 \<CC>\<lparr>NTMap\<rparr>) = 0"
  unfolding tdghm_0_components by simp

lemma tdghm_0_NTMap_vrange[dg_cs_simps]: "\<R>\<^sub>\<circ> (tdghm_0 \<CC>\<lparr>NTMap\<rparr>) = 0"
  unfolding tdghm_0_components by simp

subsubsection\<open>
Empty transformation of digraph homomorphisms
is a transformation of digraph homomorphisms
\<close>

lemma (in digraph) dg_tdghm_0_is_tdghmI:
  "tdghm_0 \<CC> : dghm_0 \<CC> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_0 \<CC> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
proof(intro is_tdghmI)
  show "vfsequence (tdghm_0 \<CC>)" unfolding tdghm_0_def by simp
  show "vcard (tdghm_0 \<CC>) = 5\<^sub>\<nat>"
    unfolding tdghm_0_def by (simp add: nat_omega_simps)
  show "tdghm_0 \<CC>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> : dghm_0 \<CC>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> dghm_0 \<CC>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
    if "a \<in>\<^sub>\<circ> dg_0\<lparr>Obj\<rparr>" for a
    using that unfolding dg_0_components by simp
qed
  (
    cs_concl cs_shallow
      cs_simp: dg_cs_simps dg_0_components(1) cs_intro: dg_cs_intros
  )+

lemma (in digraph) dg_tdghm_0_is_tdghmI'[dg_cs_intros]:
  assumes "\<FF>' = dghm_0 \<CC>"
    and "\<GG>' = dghm_0 \<CC>"
    and "\<AA>' = dg_0"
    and "\<BB>' = \<CC>"
    and "\<FF>' = \<FF>"
    and "\<GG>' = \<GG>"
  shows "tdghm_0 \<CC> : \<FF>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>' : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>'"
  unfolding assms by (rule dg_tdghm_0_is_tdghmI)

lemmas [dg_cs_intros] = digraph.dg_tdghm_0_is_tdghmI'

lemma is_tdghm_is_tdghm_0_if_dg_0:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<NN> = tdghm_0 \<CC>" and "\<FF> = dghm_0 \<CC>" and "\<GG> = dghm_0 \<CC>"
proof-
  interpret \<NN>: is_tdghm \<alpha> dg_0 \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  show \<FF>_def: "\<FF> = dghm_0 \<CC>" and \<GG>_def: "\<GG> = dghm_0 \<CC>"
    by (auto intro: is_dghm_is_dghm_0_if_dg_0 dg_cs_intros)
  show "\<NN> = tdghm_0 \<CC>"
  proof(rule tdghm_eqI)
    show "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(1))
    then have dom_lhs: "\<D>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) = 0"
      by (cs_concl cs_simp: dg_cs_simps dg_0_components(1))
    show "tdghm_0 \<CC> : dghm_0 \<CC> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_0 \<CC> : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
      by (cs_concl cs_intro: dg_cs_intros)
    then have dom_rhs: "\<D>\<^sub>\<circ> (tdghm_0 \<CC>\<lparr>NTMap\<rparr>) = 0"
      by (cs_concl cs_simp: dg_cs_simps dg_0_components(1))
    show "\<NN>\<lparr>NTMap\<rparr> = tdghm_0 \<CC>\<lparr>NTMap\<rparr>"
      by (rule vsv_eqI, unfold dom_lhs dom_rhs) (auto intro: dg_cs_intros)
  qed (auto simp: \<FF>_def \<GG>_def)
qed

subsection\<open>\<open>10\<close>: digraph with one object and no arrows\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition dg_10 :: "V \<Rightarrow> V"
  where "dg_10 \<aa> = [set {\<aa>}, 0, 0, 0]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dg_10_components:
  shows "dg_10 \<aa>\<lparr>Obj\<rparr> = set {\<aa>}"
    and "dg_10 \<aa>\<lparr>Arr\<rparr> = 0"
    and "dg_10 \<aa>\<lparr>Dom\<rparr> = 0"
    and "dg_10 \<aa>\<lparr>Cod\<rparr> = 0"
  unfolding dg_10_def dg_field_simps by (auto simp: nat_omega_simps)

subsubsection\<open>\<open>10\<close> is a digraph\<close>

lemma (in \<Z>) digraph_dg_10:
  assumes "\<aa> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "digraph \<alpha> (dg_10 \<aa>)"
proof(intro digraphI)
  show "vfsequence (dg_10 \<aa>)" unfolding dg_10_def by (simp add: nat_omega_simps)
  show "vcard (dg_10 \<aa>) = 4\<^sub>\<nat>" unfolding dg_10_def by (simp add: nat_omega_simps)
  show "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B. Hom (dg_10 \<aa>) a' b') \<in>\<^sub>\<circ> Vset \<alpha>" for A B
  proof-
    have "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B. Hom (dg_10 \<aa>) a' b') \<subseteq>\<^sub>\<circ> dg_10 \<aa>\<lparr>Arr\<rparr>" by auto
    moreover have "dg_10 \<aa>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> 0" unfolding dg_10_components by auto
    ultimately show ?thesis using vempty_is_zet vsubset_in_VsetI by presburger
  qed
qed (auto simp: assms dg_10_components vsubset_vsingleton_leftI)

subsubsection\<open>Arrow with a domain and a codomain\<close>

lemma dg_10_is_arr_iff: "\<FF> : \<AA> \<mapsto>\<^bsub>dg_10 \<aa>\<^esub> \<BB> \<longleftrightarrow> False"
  unfolding is_arr_def dg_10_components by simp

subsection\<open>\<open>1\<close>: digraph with one object and one arrow\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition dg_1 :: "V \<Rightarrow> V \<Rightarrow> V"
  where "dg_1 \<aa> \<ff> = [set {\<aa>}, set {\<ff>}, set {\<langle>\<ff>, \<aa>\<rangle>}, set {\<langle>\<ff>, \<aa>\<rangle>}]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dg_1_components:
  shows "dg_1 \<aa> \<ff>\<lparr>Obj\<rparr> = set {\<aa>}"
    and "dg_1 \<aa> \<ff>\<lparr>Arr\<rparr> = set {\<ff>}"
    and "dg_1 \<aa> \<ff>\<lparr>Dom\<rparr> = set {\<langle>\<ff>, \<aa>\<rangle>}"
    and "dg_1 \<aa> \<ff>\<lparr>Cod\<rparr> = set {\<langle>\<ff>, \<aa>\<rangle>}"
  unfolding dg_1_def dg_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>\<open>1\<close> is a digraph\<close>

lemma (in \<Z>) digraph_dg_1:
  assumes "\<aa> \<in>\<^sub>\<circ> Vset \<alpha>" and "\<ff> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "digraph \<alpha> (dg_1 \<aa> \<ff>)"
proof(intro digraphI)
  show "vfsequence (dg_1 \<aa> \<ff>)" unfolding dg_1_def by (simp add: nat_omega_simps)
  show "vcard (dg_1 \<aa> \<ff>) = 4\<^sub>\<nat>" unfolding dg_1_def by (simp add: nat_omega_simps)
  show "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B. Hom (dg_1 \<aa> \<ff>) a' b') \<in>\<^sub>\<circ> Vset \<alpha>" for A B
  proof-
    have "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B. Hom (dg_1 \<aa> \<ff>) a' b') \<subseteq>\<^sub>\<circ> dg_1 \<aa> \<ff>\<lparr>Arr\<rparr>" by auto
    moreover have "dg_1 \<aa> \<ff>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> set {\<ff>}" unfolding dg_1_components by auto
    moreover from assms(2) have "set {\<ff>} \<in>\<^sub>\<circ> Vset \<alpha>"
      by (simp add: Limit_vsingleton_in_VsetI)
    ultimately show ?thesis
      unfolding dg_1_components by (auto simp: vsubset_in_VsetI)
  qed
qed (auto simp: assms dg_1_components vsubset_vsingleton_leftI)

subsubsection\<open>Arrow with a domain and a codomain\<close>

lemma dg_1_is_arrI:
  assumes "a = \<aa>" and "b = \<aa>" and "f = \<ff>"
  shows "f : a \<mapsto>\<^bsub>dg_1 \<aa> \<ff>\<^esub> b"
  using assms by (intro is_arrI) (auto simp: dg_1_components)

lemma dg_1_is_arrD:
  assumes "f : a \<mapsto>\<^bsub>dg_1 \<aa> \<ff>\<^esub> b"
  shows "a = \<aa>" and "b = \<aa>" and "f = \<ff>"
  using assms by (all\<open>elim is_arrE\<close>) (auto simp: dg_1_components)

lemma dg_1_is_arrE:
  assumes "f : a \<mapsto>\<^bsub>dg_1 \<aa> \<ff>\<^esub> b"
  obtains "a = \<aa>" and "b = \<aa>" and "f = \<ff>"
  using assms by (elim is_arrE) (force simp: dg_1_components)

lemma dg_1_is_arr_iff: "f : a \<mapsto>\<^bsub>dg_1 \<aa> \<ff>\<^esub> b \<longleftrightarrow> (a = \<aa> \<and> b = \<aa> \<and> f = \<ff>)"
  by (rule iffI; (elim is_arrE)?)
    (auto simp: dg_1_components intro: dg_1_is_arrI)

text\<open>\newpage\<close>

end


theory Szip_smap1
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")
datatype ('a, 'b) Pair2 = Pair2 'a 'b
primcorec szip :: "'a Stream \<Rightarrow> 'b Stream \<Rightarrow> (('a, 'b) Pair2) Stream" where
  "shd (szip s1 s2) = Pair2 (shd s1) (shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"

fun apfst2 :: "('a \<Rightarrow> 'c) \<Rightarrow> ('a,'b) Pair2 \<Rightarrow> ('c,'b) Pair2" where
"apfst2 f (Pair2 a b) = Pair2 (f a) b"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(*hipster_obs Stream Lst obsStream szip smap apfst2
Proving: apfst2 z (Pair22 x2 x3) = Pair22 (z x2) x3
Undefined fact: "Szip_smap1.Pair2.coinduct_strong"*)
theorem szip_smap1:
"szip (smap f xs) ys = smap (apfst2 f) (szip xs ys)"
by hipster_coinduct_sledgehammer
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_bin_nat_plus_assoc
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

theorem property0 :
  "((plus x (plus y z)) = (plus (plus x y) z))"
  oops

end


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

section \<open>Smith normal form algorithm based on two steps in HOL Analysis\<close>

theory SNF_Algorithm_Two_Steps
  imports Diagonalize
begin

text \<open>This file contains an algorithm to transform a matrix to its Smith normal form, based
on two steps: first it is converted into a diagonal matrix and then transformed from diagonal
to Smith.

We assume the existence of a diagonalize operation, and then we just have to connect it to the
existing algorithm (in HOL Analysis) to transform a diagonal matrix into its Smith normal form.
\<close>

subsection \<open>The implementation\<close>

context diagonalize
begin

definition "Smith_normal_form_of A bezout = (
   let (P'',D,Q'') = diagonalize A bezout;
       (P',S,Q') = diagonal_to_Smith_PQ D bezout
   in (P'**P'',S,Q''**Q')
  )"

subsection \<open>Soundness in HOL Analysis\<close>

lemma Smith_normal_form_of_soundness:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes b: "is_bezout_ext bezout"
  assumes PSQ: "(P,S,Q) = Smith_normal_form_of A bezout"
  shows "S = P**A**Q \<and> invertible P \<and> invertible Q \<and> Smith_normal_form S"
proof -
  obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize A bezout"
    by (metis prod_cases3)
  have 1: "invertible P'' \<and> invertible Q'' \<and> isDiagonal D \<and> D = P''**A**Q''"
    by (rule soundness_diagonalize[OF b PDQ_diag[symmetric]])
  obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ D bezout"
    using PSQ PDQ_diag unfolding Smith_normal_form_of_def
    unfolding Let_def by (smt Pair_inject case_prod_beta' surjective_pairing)
  have 2: "invertible P' \<and> invertible Q' \<and> Smith_normal_form S \<and> S = P'**D**Q'"
    using diagonal_to_Smith_PQ' 1 b PSQ_D by blast
  have P: "P = P'**P''"
    by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject
        Smith_normal_form_of_def PSQ old.prod.case)
  have Q: "Q = Q''**Q'"
    by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject
        Smith_normal_form_of_def PSQ old.prod.case)
  have "S = P**A**Q" using 1 2 by (simp add: P Q matrix_mul_assoc)
  moreover have "invertible P" using P by (simp add: 1 2 invertible_mult)
  moreover have "invertible Q" using Q by (simp add: 1 2 invertible_mult)
  ultimately show ?thesis using 2 by auto
qed

end
end