(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Examples.thy
    Author:     Stefan Berghofer, Lukas Bulwahn
    Copyright   2004 - 2010 TU Muenchen
*)

section \<open>Examples for the 'quickcheck' command\<close>

theory Quickcheck_Examples
imports Complex_Main "~~/src/HOL/Library/Dlist" "~~/src/HOL/Library/DAList_Multiset"
begin

text \<open>
The 'quickcheck' command allows to find counterexamples by evaluating
formulae.
Currently, there are two different exploration schemes:
- random testing: this is incomplete, but explores the search space faster.
- exhaustive testing: this is complete, but increasing the depth leads to
  exponentially many assignments.

quickcheck can handle quantifiers on finite universes.

\<close>

declare [[quickcheck_timeout = 3600]]

subsection \<open>Lists\<close>

theorem "map g (map f xs) = map (g o f) xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, size = 3, expect = no_counterexample]
  oops

theorem "map g (map f xs) = map (f o g) xs"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

theorem "rev (xs @ ys) = rev ys @ rev xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  quickcheck[exhaustive, size = 1000, timeout = 0.1]
  oops

theorem "rev (xs @ ys) = rev xs @ rev ys"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

theorem "rev (rev xs) = xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  oops

theorem "rev xs = xs"
  quickcheck[tester = random, finite_types = true, report = false, expect = counterexample]
  quickcheck[tester = random, finite_types = false, report = false, expect = counterexample]
  quickcheck[tester = random, finite_types = true, report = true, expect = counterexample]
  quickcheck[tester = random, finite_types = false, report = true, expect = counterexample]
  quickcheck[tester = exhaustive, finite_types = true, expect = counterexample]
  quickcheck[tester = exhaustive, finite_types = false, expect = counterexample]
oops

text \<open>An example involving functions inside other data structures\<close>

primrec app :: "('a \<Rightarrow> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "app [] x = x"
  | "app (f # fs) x = app fs (f x)"

lemma "app (fs @ gs) x = app gs (app fs x)"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, size = 2, expect = no_counterexample]
  by (induct fs arbitrary: x) simp_all

lemma "app (fs @ gs) x = app fs (app gs x)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

primrec occurs :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "occurs a [] = 0"
  | "occurs a (x#xs) = (if (x=a) then Suc(occurs a xs) else occurs a xs)"

primrec del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "del1 a [] = []"
  | "del1 a (x#xs) = (if (x=a) then xs else (x#del1 a xs))"

text \<open>A lemma, you'd think to be true from our experience with delAll\<close>
lemma "Suc (occurs a (del1 a xs)) = occurs a xs"
  \<comment> \<open>Wrong. Precondition needed.\<close>
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

lemma "xs ~= [] \<longrightarrow> Suc (occurs a (del1 a xs)) = occurs a xs"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    \<comment> \<open>Also wrong.\<close>
  oops

lemma "0 < occurs a xs \<longrightarrow> Suc (occurs a (del1 a xs)) = occurs a xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  by (induct xs) auto

primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "replace a b [] = []"
  | "replace a b (x#xs) = (if (x=a) then (b#(replace a b xs))
                            else (x#(replace a b xs)))"

lemma "occurs a xs = occurs b (replace a b xs)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  \<comment> \<open>Wrong. Precondition needed.\<close>
  oops

lemma "occurs b xs = 0 \<or> a=b \<longrightarrow> occurs a xs = occurs b (replace a b xs)"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  by (induct xs) simp_all

subsection \<open>Trees\<close>

datatype 'a tree = Twig |  Leaf 'a | Branch "'a tree" "'a tree"

primrec leaves :: "'a tree \<Rightarrow> 'a list" where
  "leaves Twig = []"
  | "leaves (Leaf a) = [a]"
  | "leaves (Branch l r) = (leaves l) @ (leaves r)"

primrec plant :: "'a list \<Rightarrow> 'a tree" where
  "plant [] = Twig "
  | "plant (x#xs) = Branch (Leaf x) (plant xs)"

primrec mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror (Twig) = Twig "
  | "mirror (Leaf a) = Leaf a "
  | "mirror (Branch l r) = Branch (mirror r) (mirror l)"

theorem "plant (rev (leaves xt)) = mirror xt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    \<comment>\<open>Wrong!\<close>
  oops

theorem "plant((leaves xt) @ (leaves yt)) = Branch xt yt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    \<comment>\<open>Wrong!\<close>
  oops

datatype 'a ntree = Tip "'a" | Node "'a" "'a ntree" "'a ntree"

primrec inOrder :: "'a ntree \<Rightarrow> 'a list" where
  "inOrder (Tip a)= [a]"
  | "inOrder (Node f x y) = (inOrder x)@[f]@(inOrder y)"

primrec root :: "'a ntree \<Rightarrow> 'a" where
  "root (Tip a) = a"
  | "root (Node f x y) = f"

theorem "hd (inOrder xt) = root xt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  \<comment>\<open>Wrong!\<close>
  oops

subsection \<open>Exhaustive Testing beats Random Testing\<close>

text \<open>Here are some examples from mutants from the List theory
where exhaustive testing beats random testing\<close>

lemma
  "[] ~= xs ==> hd xs = last (x # xs)"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  assumes "!!i. [| i < n; i < length xs |] ==> P (xs ! i)" "n < length xs ==> ~ P (xs ! n)"
  shows "drop n xs = takeWhile P xs"
quickcheck[random, iterations = 10000, quiet]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < length (List.transpose (List.transpose xs)) ==> xs ! i = map (%xs. xs ! i) [ys<-xs. i < length ys]"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < n - m ==> f (lcm m i) = map f [m..<n] ! i"
quickcheck[random, iterations = 10000, finite_types = false]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "i < n - m ==> f (lcm m i) = map f [m..<n] ! i"
quickcheck[random, iterations = 10000, finite_types = false]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "ns ! k < length ns ==> k <= sum_list ns"
quickcheck[random, iterations = 10000, finite_types = false, quiet]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "[| ys = x # xs1; zs = xs1 @ xs |] ==> ys @ zs = x # xs"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
"i < length xs ==> take (Suc i) xs = [] @ xs ! i # take i xs"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < length xs ==> take (Suc i) xs = (xs ! i # xs) @ take i []"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| sorted (rev (map length xs)); i < length xs |] ==> xs ! i = map (%ys. ys ! i) [ys<-remdups xs. i < length ys]"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| sorted (rev (map length xs)); i < length xs |] ==> xs ! i = map (%ys. ys ! i) [ys<-List.transpose xs. length ys \<in> {..<i}]"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "(ys = zs) = (xs @ ys = splice xs zs)"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Random Testing beats Exhaustive Testing\<close>

lemma mult_inj_if_coprime_nat:
  "inj_on f A \<Longrightarrow> inj_on g B
   \<Longrightarrow> inj_on (%(a,b). f a * g b::nat) (A \<times> B)"
quickcheck[exhaustive]
quickcheck[random]
oops

subsection \<open>Examples with quantifiers\<close>

text \<open>
  These examples show that we can handle quantifiers.
\<close>

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
  quickcheck[random, expect = counterexample]
  quickcheck[expect = counterexample]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
  quickcheck[random, expect = counterexample]
  quickcheck[expect = counterexample]
oops

subsection \<open>Examples with sets\<close>

lemma
  "{} = A Un - A"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| bij_betw f A B; bij_betw f C D |] ==> bij_betw f (A Un C) (B Un D)"
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with relations\<close>

lemma
  "acyclic (R :: ('a * 'a) set) ==> acyclic S ==> acyclic (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "acyclic (R :: (nat * nat) set) ==> acyclic S ==> acyclic (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

(* FIXME: some dramatic performance decrease after changing the code equation of the ntrancl *)
lemma
  "(x, z) : rtrancl (R Un S) ==> \<exists> y. (x, y) : rtrancl R & (y, z) : rtrancl S"
(*quickcheck[exhaustive, expect = counterexample]*)
oops

lemma
  "wf (R :: ('a * 'a) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "wf (R :: (nat * nat) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "wf (R :: (int * int) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with the descriptive operator\<close>

lemma
  "(THE x. x = a) = b"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with Multisets\<close>

lemma
  "X + Y = Y + (Z :: 'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "X - Y = Y - (Z :: 'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "N + M - N = (N::'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with numerical types\<close>

text \<open>
Quickcheck supports the common types nat, int, rat and real.
\<close>

lemma
  "(x :: nat) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma
  "(x :: int) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma
  "(x :: rat) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma "(x :: rat) >= 0"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "(x :: real) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma "(x :: real) >= 0"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsubsection \<open>floor and ceiling functions\<close>

lemma "\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor> = \<lfloor>x + y :: rat\<rfloor>"
quickcheck[expect = counterexample]
oops

lemma "\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor> = \<lfloor>x + y :: real\<rfloor>"
quickcheck[expect = counterexample]
oops

lemma "\<lceil>x\<rceil> + \<lceil>y\<rceil> = \<lceil>x + y :: rat\<rceil>"
quickcheck[expect = counterexample]
oops

lemma "\<lceil>x\<rceil> + \<lceil>y\<rceil> = \<lceil>x + y :: real\<rceil>"
quickcheck[expect = counterexample]
oops

subsection \<open>Examples with abstract types\<close>

lemma
  "Dlist.length (Dlist.remove x xs) = Dlist.length xs - 1"
quickcheck[exhaustive]
quickcheck[random]
oops

lemma
  "Dlist.length (Dlist.insert x xs) = Dlist.length xs + 1"
quickcheck[exhaustive]
quickcheck[random]
oops

subsection \<open>Examples with Records\<close>

record point =
  xpos :: nat
  ypos :: nat

lemma
  "xpos r = xpos r' ==> r = r'"
quickcheck[exhaustive, expect = counterexample]
quickcheck[random, expect = counterexample]
oops

datatype colour = Red | Green | Blue

record cpoint = point +
  colour :: colour

lemma
  "xpos r = xpos r' ==> ypos r = ypos r' ==> (r :: cpoint) = r'"
quickcheck[exhaustive, expect = counterexample]
quickcheck[random, expect = counterexample]
oops

subsection \<open>Examples with locales\<close>

locale Truth

context Truth
begin

lemma "False"
quickcheck[exhaustive, expect = counterexample]
oops

end

interpretation Truth .

context Truth
begin

lemma "False"
quickcheck[exhaustive, expect = counterexample]
oops

end

locale antisym =
  fixes R
  assumes "R x y --> R y x --> x = y"

interpretation equal : antisym "op =" by standard simp
interpretation order_nat : antisym "op <= :: nat => _ => _" by standard simp

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, finite_type_size = 2, expect = no_counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

declare [[quickcheck_locale = "interpret"]]

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, expect = no_counterexample]
oops

declare [[quickcheck_locale = "expand"]]

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, finite_type_size = 2, expect = no_counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with HOL quantifiers\<close>

lemma
  "\<forall> xs ys. xs = [] --> xs = ys"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "ys = [] --> (\<forall>xs. xs = [] --> xs = y # ys)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "\<forall>xs. (\<exists> ys. ys = []) --> xs = ys"
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with underspecified/partial functions\<close>

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

text \<open>with the simple testing scheme\<close>

setup Exhaustive_Generators.setup_exhaustive_datatype_interpretation
declare [[quickcheck_full_support = false]]

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[exhaustive, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[exhaustive, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[exhaustive, expect = no_counterexample]
oops

declare [[quickcheck_full_support = true]]

subsection \<open>Equality Optimisation\<close>

lemma
  "f x = y ==> y = (0 :: nat)"
quickcheck
oops

lemma
  "y = f x ==> y = (0 :: nat)"
quickcheck
oops

lemma
  "f y = zz # zzs ==> zz = (0 :: nat) \<and> zzs = []"
quickcheck
oops

lemma
  "f y = x # x' # xs ==> x = (0 :: nat) \<and> x' = 0 \<and> xs = []"
quickcheck
oops

lemma
  "x = f x \<Longrightarrow> x = (0 :: nat)"
quickcheck
oops

lemma
  "f y = x # x # xs ==> x = (0 :: nat) \<and> xs = []"
quickcheck
oops

lemma
  "m1 k = Some v \<Longrightarrow> (m1 ++ m2) k = Some v"
quickcheck
oops

end


theory search
  imports Main
begin

fun liner_search_iter :: "'a \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat option" where
  "liner_search_iter _ [] _ = None"|
  "liner_search_iter x (x0 # xs) idx = (if x=x0 then (Some idx) else (liner_search_iter x xs (idx+1)))"

fun liner_search :: "'a \<Rightarrow> 'a list \<Rightarrow> nat option" where
  "liner_search a xs = liner_search_iter a xs 0"

value "liner_search (5::int) [3, 4::int, 6, 7, 8, 5]"
value "take (3::nat) [a, b, c, d]"
value "nth [1, 2, 3::int] 1"

lemma liner_search_some: "liner_search_iter x xs v = Some vi \<Longrightarrow> \<exists> ui. liner_search_iter x xs u = Some ui"
  proof(induction xs arbitrary: v u)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x=a"
      then have " liner_search_iter x (a # xs) u = Some u"
        by simp
      then show ?case
        by blast
    next
      assume "\<not> x=a"
      then have "liner_search_iter x (a # xs) u = liner_search_iter x xs (u+1)" by simp
      then show ?case
        by (metis Cons.IH Cons.prems liner_search_iter.simps(2))
    qed
  qed

lemma liner_search_none: "liner_search_iter x xs v = None \<Longrightarrow> liner_search_iter x xs u = None"
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
    by (metis liner_search_some option.exhaust option.simps(2))
qed

lemma "liner_search x xs = None \<Longrightarrow> x \<notin> (set xs)"
  apply(simp)
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then have "liner_search_iter x xs 1 = None"
    by (metis add.left_neutral liner_search_iter.simps(2) option.simps(3))
  then have a0: "liner_search_iter x xs 0 = None"
    by (metis liner_search_none)
  then have "x \<noteq> a"
    using Cons.prems by auto
  then show ?case
    using Cons.IH a0 by auto
qed

  (*
lemma "(a # xs) ! idx = xs ! (THE u. (Suc u) = idx)"
  by *)

lemma liner_search_iter_Suc: "liner_search_iter x xs u = Some v \<Longrightarrow> liner_search_iter x xs (Suc u) = Some (Suc v)"
  proof(induction xs arbitrary: u v)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x=a"
      then show ?case
        using Cons.prems by auto
    next
      assume "\<not> x=a"
      then have "liner_search_iter x (a # xs) (Suc u) = liner_search_iter x xs (Suc(Suc u))" by simp
      then show ?case
        by (metis Cons.IH Cons.prems Suc_eq_plus1 \<open>x \<noteq> a\<close> liner_search_iter.simps(2))
    qed
  qed

lemma liner_search_iter_gt0: "Some idx = liner_search_iter x xs 1 \<Longrightarrow> idx > 0"
  proof(induction xs)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x = a"
      then have "liner_search_iter x (a # xs) 1 = Some 1" by simp
      then show ?case
        using Cons.prems by auto
    next
      assume "\<not> x = a"
      then have "liner_search_iter x (a # xs) 1 = liner_search_iter x xs (Suc 1)" by simp

      then show ?case using liner_search_iter_Suc
        by (metis Cons.prems One_nat_def gr0_conv_Suc liner_search_some option.inject)
    qed
  qed

lemma liner_search_iter_inject: "\<lbrakk>liner_search_iter x xs u = Some w;liner_search_iter x xs v = Some w\<rbrakk> \<Longrightarrow> u = v"
  proof(induction xs arbitrary: w)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume a0: "x = a"
      then have "liner_search_iter x (a # xs) v = Some v" by simp
      then have "liner_search_iter x (a # xs) u = Some u" using a0 by simp

      then show ?case
        using Cons.prems(1) Cons.prems(2) \<open>liner_search_iter x (a # xs) v = Some v\<close> by auto
    next
      assume a1: "\<not> x = a"
      then have a2: "liner_search_iter x (a # xs) u = liner_search_iter x xs (u+1)" by simp
      then have "liner_search_iter x (a # xs) v = liner_search_iter x xs (v+1)" using a1 by simp
      then have "liner_search_iter x xs (u+1) = Some w"
        using Cons.prems(1) \<open>liner_search_iter x (a # xs) u = liner_search_iter x xs (u + 1)\<close> by auto
      then have b1: "liner_search_iter x xs u = Some (w-1)"
        by (metis One_nat_def add.right_neutral add_Suc_right add_implies_diff liner_search_iter_Suc liner_search_some option.inject)
      then have "liner_search_iter x xs (v+1) = Some w"
        using Cons.prems(2) \<open>liner_search_iter x (a # xs) v = liner_search_iter x xs (v + 1)\<close> by auto
      then have b2: "liner_search_iter x xs v = Some (w-1)"
        by (metis One_nat_def add.right_neutral add_Suc_right add_implies_diff liner_search_iter_Suc liner_search_some option.inject)
      then show ?case using b1 b2
        using Cons.IH by blast
    qed

  qed

lemma "liner_search x xs = Some idx \<Longrightarrow> x = xs ! idx"
  apply(simp)
  proof(induction xs arbitrary: idx)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x = a"
      then show ?thesis
        using Cons.prems by auto
    next
      assume "\<not> x = a"
        then have "Some idx = liner_search_iter x xs 1"
          using Cons.prems by auto
      then have "idx \<noteq> 0"
        by (simp add: liner_search_iter_gt0)
      have "(a # xs) ! idx = xs ! (idx - 1)" using nth_Cons_Suc
        by (simp add: \<open>idx \<noteq> 0\<close> nth_Cons')
      then have " liner_search_iter x xs 0 = Some (idx-1)" using liner_search_iter_inject
      proof -
        have f1: "0 < idx"
          by (simp add: \<open>Some idx = liner_search_iter x xs 1\<close> liner_search_iter_gt0)
        obtain nn :: "nat \<Rightarrow> nat" where
          "(\<not> 0 < idx \<or> idx = Suc (nn idx)) \<and> (0 < idx \<or> (\<forall>n. idx \<noteq> Suc n))"
          by (metis (no_types) gr0_conv_Suc)
        then show ?thesis
          using f1 by (metis One_nat_def Suc_eq_plus1_left \<open>Some idx = liner_search_iter x xs 1\<close> add_left_cancel diff_Suc_Suc diff_zero liner_search_iter_Suc liner_search_some option.inject)
      qed
      then show ?thesis
        using Cons.IH \<open>(a # xs) ! idx = xs ! (idx - 1)\<close> by auto
    qed
qed

value "(5::int) div (2::int)"

function binary_search_iter :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> nat option" where
  "binary_search_iter x xs l r = (if l \<le> r then
  (let mid=(l+r) div 2; mid_v=xs ! (nat mid) in
      (if mid_v=x
        then (Some (nat mid))
        else (if mid_v < x
              then (binary_search_iter x xs (mid+1) r)
              else (binary_search_iter x xs l (mid-1))))) else None)"
  by pat_completeness auto
termination apply (relation "measure (\<lambda> (x, xs, l, r). nat (r-l+1))")
    apply auto
  done

value "binary_search_iter (5::int) [1, 2, 3, 4, 5, 6, 7, 8] 0 7"

fun binary_search :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> nat option" where
  bin_Nil: "binary_search _ [] = None"|
  bin_xs: "binary_search x xs = binary_search_iter x xs 0 ((int (length xs))-1)"

value "binary_search (5::int) [1, 3, 4, 6, 7, 8]"
value "binary_search (5::int) [1, 3, 5, 6, 7, 8]"

lemma "\<lbrakk>sorted xs; binary_search x xs=None\<rbrakk> \<Longrightarrow> x \<notin> set xs"
  proof(induction xs)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    assume a0: "sorted xs \<Longrightarrow> binary_search x xs = None \<Longrightarrow> x \<notin> set xs"
      and sorted_a_xs: "sorted (a # xs)"
      and search_a_xs: "binary_search x (a # xs) = None"
    then have "sorted xs" by simp
    then show ?case
        then have
  then show ?case
qed

end


theory Regular
  imports Words
begin

(* Regular Languages *)
type_synonym 'a RegLang = "'a word set"

(* Regular Operations *)
definition concat :: "'a RegLang \<Rightarrow> 'a RegLang \<Rightarrow> 'a RegLang" where
  "concat R S = {u\<cdot>v |u v. u\<in>R & v\<in>S}"

lemma concat_containment: "a \<in> A \<and> b \<in> B \<Longrightarrow> (a \<cdot> b) \<in> (concat A B)"
  by (auto simp add: concat_def)

lemma in_concat_if: "w \<in> (concat A B) \<Longrightarrow> \<exists>a b. w = a\<cdot>b \<and> a \<in> A \<and> b \<in> B "
  by (auto simp add: concat_def)

lemma epsilon_concat_iff: "\<epsilon> \<in> A \<and> \<epsilon> \<in> B \<longleftrightarrow> \<epsilon> \<in> (concat A B)"
  by (auto simp add: concat_def)

lemma epsilon_in_const_iff: "\<epsilon> \<in> {x} \<longleftrightarrow> x = \<epsilon>"
  by auto

primrec pow :: "'a RegLang \<Rightarrow> nat \<Rightarrow> 'a RegLang" where
  "pow s 0 = {\<epsilon>}"|
  "pow s (Suc n) = concat s (pow s n)"

lemma pow_epsilon:"pow {\<epsilon>} n = {\<epsilon>}"
  by (induct n) (auto simp add: in_concat_if epsilon_concat_iff concat_def)

lemma pow_zero_empty: "pow {} 0 = {\<epsilon>}"
  by auto

lemma pow_n_empty: "n > 0 \<Longrightarrow> pow {} n = {}"
  by (induct n) (auto simp add: concat_def)

definition star :: "'a RegLang \<Rightarrow> 'a RegLang" where
  "star R = (\<Union>n. (pow R n))"

lemma epsilon_in_star[simp]: "\<epsilon> \<in> star R"
proof -
  have "\<epsilon> \<in> pow R 0"
    by simp
  then have "EX n. \<epsilon> \<in> pow R n"
    by (rule exI)
  then show ?thesis
    by (auto simp add: star_def)
qed

lemma singleton_set: "{w. (length w) = 1} = {v| a v. v = a#\<epsilon>}"
  by (auto simp add: length_Suc_conv)

lemma epsilon_in_pow:"\<exists>n. \<epsilon> \<in> pow r n"
proof -
  have "\<epsilon> \<in> pow r 0"
    by simp
  thus ?thesis
    by (rule exI)
qed

lemma star_all_pows: "star r = {w|w n. w \<in> pow r n}"
  by (auto simp add: star_def)

lemma pow_not_zero:"n > 0 \<and> w \<in> pow r n \<Longrightarrow> \<exists>m. w \<in> pow r (Suc m)"
  by (induct n) (auto simp add: concat_def)

lemma star_of_epsilon:"star {\<epsilon>} = {\<epsilon>}"
  by (simp add:star_def pow_epsilon)

lemma star_of_empty: "star {} = {\<epsilon>}"
proof
  have "\<forall>x n. x \<in> pow {} n \<longrightarrow> x = \<epsilon>"
    by (metis Regular.pow.simps(1) bot_nat_0.not_eq_extremum empty_iff pow_n_empty singletonD)
  then show  "star {} \<subseteq> {\<epsilon>}"
    by (auto simp add: star_def)
next
  show "{\<epsilon>} \<subseteq> star {}"
    by (simp add: epsilon_in_pow)
qed

lemma concat_trans: "w \<in> r \<longleftrightarrow> a#w \<in> concat {a#\<epsilon>} r"
  by (auto simp add: concat_def)

lemma concat_star_subset: "concat L (star L) \<subseteq> (star L)"
proof
  fix w  assume "w \<in> concat L (star L)"
  then have "w \<in> {w |w n. w \<in> pow L (Suc n)}"
    by (auto simp add: concat_def star_all_pows)
  then have "w \<in> {w |w m. w \<in> pow L m}"
    by blast
  then show "w \<in> (star L)"
    by (simp only: star_all_pows)
qed

lemma concat_star:
  assumes "set ws \<subseteq> R"
  shows "concat_all ws \<in> (star R)"
  using assms
proof (induct ws)
  case Nil
  then show ?case
    by auto
next
  case (Cons a ws)
  then show ?case
    using concat_containment concat_star_subset by force
qed

lemma star_subsumes: "v\<cdot>w \<in> concat {v} (star r) \<and> v \<in> r \<Longrightarrow> v\<cdot>w \<in> (star r)"
  using concat_star_subset concat_containment in_concat_if by blast

lemma star_of_singletons_is_univ: "x \<in> star {v|v a. v = a#\<epsilon>}"
proof (induct x)
  case Nil
  then show ?case by auto
next
  case (Cons a x)
  then have "x \<in> star {uu. \<exists>a v. uu = v \<and> v = a # \<epsilon>}"
    by auto
  then have "x \<in> star {v |v b. v = b#\<epsilon>}"
    by auto
  then have fac1:"a#x \<in> concat {a#\<epsilon>} (star {v |v b. v = b#\<epsilon>})"
    using concat_trans by fastforce
  have fac2: "(a#\<epsilon>) \<in> {v |v b. v = b#\<epsilon>}"
    by simp
  from fac1 fac2 have "a#x \<in> (star {v |v b. v = b#\<epsilon>})"
    using star_subsumes by (metis in_concat_if singletonD)
  then show ?case
    by auto
qed

lemma star_remove_epsilons:
  assumes P: "set ws \<subseteq> R" (is ?P)
  shows "\<exists>wsa. concat_all ws = concat_all wsa \<and> set wsa \<subseteq> R - {\<epsilon>}" (is "\<exists> vs. ?Q vs")
proof
  let ?vs = "filter (\<lambda>u. u \<noteq> \<epsilon>) ws"
  show "?Q ?vs"
    using assms by (induct ws) auto
qed

lemma concat_all_subset_if_pow: "w \<in> pow r n \<Longrightarrow> \<exists>ws. w = concat_all ws \<and> set ws \<subseteq> r"
proof (induct n arbitrary: r  w)
  case 0
  then show ?case
    by (metis Regular.pow.simps(1) concat_all.simps(1) empty_set empty_subsetI singletonD)
next
  case IH:(Suc n)
  then have "w \<in> concat r (pow r n)"
    by force
  then have "\<exists>x y. w = x\<cdot>y \<and> x \<in> r \<and> y \<in> (pow r n)"
    by (force simp add: concat_def)
  then have "\<exists>x y. w = x\<cdot>y \<and> (\<exists>ws. y = concat_all ws \<and> set ws \<subseteq> r)"
    using IH by fastforce
  then have "\<exists>ws. w = concat_all ws \<and> set ws \<subseteq> r"
    by (metis IH.hyps \<open>\<exists>x y. w = x \<cdot> y \<and> x \<in> r \<and> y \<in> pow r n\<close> concat_all.simps(2) insert_subset list.set(2))
  then show ?case
    by simp
qed

lemma star_is_concats: "star R = {concat_all ws|ws. set ws \<subseteq> R}"
proof
  show "star R \<subseteq> {concat_all ws |ws. set ws \<subseteq> R}"
    unfolding star_all_pows
    by (auto simp add: concat_all_subset_if_pow)
next
  have "\<And>ws. set ws \<subseteq> R \<Longrightarrow> \<exists>n. concat_all ws \<in> pow R n"
    by (metis UN_E concat_star star_def)
  then show "{concat_all ws |ws. set ws \<subseteq> R} \<subseteq> star R"
    unfolding star_all_pows by (auto simp add: concat_all_subset_if_pow)
qed

lemma star_rm_epsilon: "star (R-{\<epsilon>}) = star R"
  unfolding star_is_concats by (auto simp add: star_remove_epsilons)

lemma star_if_pow[simp]: "w \<in> pow R n \<Longrightarrow> w \<in> (star R)"
  by (auto simp add: star_def)

(* Derivative of regular languages *)
definition deriv:: "'a \<Rightarrow> 'a RegLang \<Rightarrow> 'a RegLang" where
  "deriv a R = {v |v. (a#v) \<in> R}"

primrec derivw:: "'a word \<Rightarrow> 'a RegLang \<Rightarrow> 'a RegLang" where
  "derivw \<epsilon> R = R" |
  "derivw (a#w) R = derivw w (deriv a R)"

definition null:: "'a RegLang \<Rightarrow> 'a RegLang" where
  "(null L) = (if \<epsilon> \<in> L then {\<epsilon>} else {})"

lemma null_empty[simp]: "null {} = {}"
  by (simp add: Regular.null_def)

lemma null_epsilon[simp]: "null {\<epsilon>} = {\<epsilon>}"
  by (simp add: Regular.null_def)

lemma deriv_empty:"deriv a {} = {}"
  by (simp add: deriv_def)

lemma deriv_const: "deriv a {(b#w)} = (if a = b then {w} else {})"
  by (auto simp add: deriv_def)

lemma deriv_union: "deriv a (l1 \<union> l2) = (deriv a l1) \<union> (deriv a l2)"
  by (auto simp add: deriv_def)

lemma deriv_inter: "deriv a (l1 \<inter> l2) = (deriv a l1) \<inter> (deriv a l2)"
  by (auto simp add: deriv_def)

lemma deriv_concat:"deriv a (concat L R) = (concat (deriv a L) R) \<union> (concat (null L) (deriv a R))"
  unfolding deriv_def concat_def null_def
  apply auto
  by (metis append_eq_Cons_conv)+

lemma pow_not_epsilon_is_succ:"n>0 \<and> w \<in> pow R n \<Longrightarrow> \<exists>m. w \<in> pow R (Suc m)"
  by (induct n) (auto simp add: pow_def)

lemma star_unroll:"star r = (concat r (star r)) \<union> {\<epsilon>}"
proof -
  have "\<And>x n. x \<noteq> \<epsilon> \<Longrightarrow> x \<in> pow r n \<Longrightarrow> \<exists>u v. x = u \<cdot> v \<and> u \<in> r \<and> (\<exists>n. v \<in> pow r n)"
    by (metis Regular.pow.simps(1) Regular.pow.simps(2) bot_nat_0.not_eq_extremum in_concat_if
        pow_not_epsilon_is_succ singletonD)
  moreover
  have "\<And>u v n. u \<in> r \<Longrightarrow> v \<in> pow r n \<Longrightarrow> \<exists>n. u \<cdot> v \<in> pow r n"
    unfolding concat_def star_all_pows using Regular.pow.simps(2) concat_containment by blast
  ultimately
  show ?thesis
    unfolding concat_def star_all_pows by (auto simp add: pow_not_zero concat_def epsilon_in_pow)
qed

lemma deriv_star:"deriv a (star R) = concat (deriv a R) (star R)"
proof -
  have "deriv a (star R) = deriv a (star (R-{\<epsilon>}))" by
      (auto simp only: star_rm_epsilon)
  also have "... = deriv a ((concat (R-{\<epsilon>}) (star (R-{\<epsilon>}))) \<union> {\<epsilon>})"
    by (metis star_unroll)
  also have "... = (deriv a (concat (R-{\<epsilon>}) (star (R-{\<epsilon>})))) \<union> (deriv a {\<epsilon>})"
    by (simp only: deriv_union)
  also have "... = deriv a (concat (R-{\<epsilon>}) (star (R-{\<epsilon>})))"
    by (simp add: deriv_def)
  also have "... = (concat (deriv a (R-{\<epsilon>})) (star (R-{\<epsilon>}))) \<union>
                   (concat (null (R-{\<epsilon>})) (deriv a (star (R-{\<epsilon>}))))"
    by (simp add: deriv_concat)
  also have "... = (concat (deriv a (R-{\<epsilon>})) (star (R-{\<epsilon>}))) \<union> (concat {} (deriv a (star (R-{\<epsilon>}))))"
    by (auto simp add: null_def)
  also have "... =  (concat (deriv a (R-{\<epsilon>})) (star (R-{\<epsilon>})))"
    by (simp add: concat_def)
  also have "... = (concat (deriv a R) (star (R-{\<epsilon>})))"
    by (simp add: deriv_def)
  also have "... = (concat (deriv a R) (star R))"
    by (simp only: star_rm_epsilon)
  finally have "deriv a (star R) = concat (deriv a R) (star R)"
    by simp
  then show ?thesis
    by simp
qed

theorem deriv_correct:"w \<in> deriv a R \<longleftrightarrow> (a#w) \<in> R"
  by (auto simp add: deriv_def)

end


section \<open>Translating terms into Graphs\<close>
text \<open>We define the translation function and its properties.\<close>

theory RuleSemanticsConnection
imports LabeledGraphSemantics RulesAndChains
begin

text \<open>Definition 15.\<close>
fun translation :: "'c allegorical_term \<Rightarrow> ('c, nat) labeled_graph" where
"translation (A_Lbl l) = LG {(l,0,1)} {0,1}" |
"translation (A_Cnv e) = map_graph_fn (translation e) (\<lambda> x. if x<2 then (1-x) else x)" |
"translation (A_Cmp e\<^sub>1 e\<^sub>2)
  = (let G\<^sub>1 = translation e\<^sub>1 ; G\<^sub>2 = translation e\<^sub>2
     in graph_union (map_graph_fn G\<^sub>1 (\<lambda> x. if x=0 then 0 else x+card(vertices G\<^sub>2)-1))
                    (map_graph_fn G\<^sub>2 (\<lambda> x. if x=0 then card (vertices G\<^sub>2) else x)))" |
"translation (A_Int e\<^sub>1 e\<^sub>2)
  = (let G\<^sub>1 = translation e\<^sub>1 ; G\<^sub>2 = translation e\<^sub>2
     in graph_union G\<^sub>1 (map_graph_fn G\<^sub>2 (\<lambda> x. if x<2 then x else x+card(vertices G\<^sub>1)-2)))"

definition inv_translation where
"inv_translation r \<equiv> {0..<card r} = r \<and> {0,1}\<subseteq>r"

lemma inv_translationI4[intro]:
  assumes "finite r" "\<And> x. x < card r \<Longrightarrow> x \<in> r"
  shows "r={0..<card r}"
proof(insert assms,induct "card r" arbitrary:r)
  case (Suc x r)
  let ?r = "r - {x}"
  from Suc have p:"x = card ?r" "finite ?r" by auto
  have p2:"xa < card ?r \<Longrightarrow> xa \<in> ?r" for xa
    using Suc.prems(2)[of xa] Suc.hyps(2) unfolding p(1)[symmetric] by auto
  from Suc.hyps(1)[OF p p2] have "?r={0..<card ?r}".
  with Suc.hyps(2) Suc.prems(1) show ?case
    by (metis atLeast0_lessThan_Suc card_Diff_singleton_if insert_Diff n_not_Suc_n p(1))
qed auto

lemma inv_translationI[intro!]:
assumes "finite r" "\<And> x. x < card r \<Longrightarrow> x \<in> r" "0 \<in> r" "Suc 0 \<in> r"
shows "inv_translation r"
proof -
  from inv_translationI4[OF assms(1,2),symmetric]
  have c:" {0..<card r} = r " by auto
  from assms(3,4) have "{0,1} \<subseteq> r" by auto
  with c inv_translation_def show ?thesis by auto
qed

lemma verts_in_translation_finite[intro]:
"finite (vertices (translation X))"
"finite (edges (translation X))"
"0 \<in> vertices (translation X)"
"Suc 0 \<in> vertices (translation X)"
proof(atomize(full),induction X)
  case (A_Int X1 X2)
  then show ?case by (auto simp:Let_def)
next
  case (A_Cmp X1 X2)
  then show ?case by (auto simp:Let_def)
next
  have [simp]:"{x::nat. x < 2} = {0,1}" by auto
  case (A_Cnv X)
  then show ?case by auto
qed auto

lemma inv_tr_card_min:
  assumes "inv_translation r"
  shows "card r \<ge> 2"
proof -
  note [simp] = inv_translation_def
  have "{0..<x} = r \<Longrightarrow> 2 \<le> x \<longleftrightarrow> 0 \<in> r \<and> 1 \<in> r" for x by auto
  thus ge2:"card r\<ge>2" using assms by auto
qed

lemma verts_in_translation[intro]:
"inv_translation (vertices (translation X))"
proof(induct X)
  { fix r
    assume assms:"inv_translation r"
    note [simp] = inv_translation_def
    from assms have a1:"finite r"
      by (intro card_ge_0_finite) auto
    have [simp]:"{0..<Suc x} = {0..<x} \<union> {x}" for x by auto
    note ge2 = inv_tr_card_min[OF assms]
    from ge2 assms have r0:"r \<inter> {0} = {0}" "r \<inter> {x. x < 2} = {0,1}" by auto
    have [intro!]:"\<And>x. x \<in> r \<Longrightarrow> x < card r"
     and g6:"\<And>x. x < card r \<longleftrightarrow> x \<in> r"
      using assms[unfolded inv_translation_def] atLeastLessThan_iff by blast+
    have g4:"r \<inter> {x. \<not> x < 2} = {2..<card r}"
            "r \<inter> (Collect ((<) 0)) = {1..<card r}" using assms by fastforce+
    have ins:"1 \<in> r" "0 \<in> r" using assms by auto
    have d:"Suc (Suc (card r - 2)) = card r"
      using ge2 One_nat_def Suc_diff_Suc Suc_pred
            numeral_2_eq_2 by presburger
    note ge2 ins g4 g6 r0 d
  } note inv_translationD[simp] = this
  {
    fix a b c
    assume assm:"b \<le> (a::nat)"
    have "(\<lambda>x. x + a - b) ` {b..<c} = {a..<c+a-b}" (is "?lhs = ?rhs")
    proof -
      from assm have "?lhs = (\<lambda>x. x + (a - b)) ` {b..<c}" by auto
      also have "\<dots> = ?rhs"
        unfolding linordered_semidom_class.image_add_atLeastLessThan' using assm by auto
      finally show ?thesis by auto
    qed
  } note e[simp] = this
  { fix r z
    assume a1: "inv_translation z" and a2: "inv_translation r"
    let ?z2 = "card z + card r - 2"
    let ?z1 = "card z + card r - Suc 0"
    from a1 a2
    have le1:"Suc 0 \<le> card r"
      by (metis Suc_leD inv_translationD(1) numerals(2))
    hence le2: "card r \<le> ?z1"
      by (metis Suc_leD a1 inv_translationD(1) numerals(2) ordered_cancel_comm_monoid_diff_class.le_add_diff)
    with le1 have b:"{card r ..< ?z1} \<union> {Suc 0 ..< card r} = {Suc 0 ..< ?z1}"
      by auto
    have a:"(insert (card r) {0..<card z + card r - Suc 0}) = {0..<card z + card r - Suc 0}"
      using le1 le2 a1 a2
      by (metis Suc_leD add_Suc_right atLeastLessThan_iff diff_Suc_Suc insert_absorb inv_translationD(1) linorder_not_less not_less_eq_eq numerals(2) ordered_cancel_comm_monoid_diff_class.le_add_diff)
    from a1 a2
    have "card z + card r - 2 \<ge> card (r::nat set)"
      by (simp add: ordered_cancel_comm_monoid_diff_class.le_add_diff)
    with a2
    have c:"card (r \<union> {card r..<?z2}) = ?z2"
      by (metis atLeast0LessThan card_atLeastLessThan diff_zero inv_translation_def ivl_disj_un_one(2))+
    note a b c
  } note [simp] = this
  have [simp]:"a < x \<Longrightarrow> insert a {Suc a..<x} = {a..<x}" for a x by auto
  { case (A_Int X1 X2)
    let ?v1 = "vertices (translation X1)"
    from A_Int have [simp]:"(insert 0 (insert (Suc 0) (?v1 \<union> x))) = ?v1 \<union> x"
      for x unfolding inv_translation_def by auto
    from A_Int show ?case by (auto simp:Let_def linorder_not_le)
  next
    case (A_Cmp X1 X2)
    hence "2\<le>card (vertices (translation X1))" "2\<le>card (vertices (translation X2))" by auto
    hence "1 \<le>card (vertices (translation X1))" "1\<le>card (vertices (translation X2))"
          "1 < card (vertices (translation X1)) + card (vertices (translation X2)) - 1"
      by auto
    from this A_Cmp
    show ?case by (auto simp:Let_def)
  next
    case (A_Cnv X)
    thus ?case by (auto simp:Let_def)
  }
qed auto

lemma translation_graph[intro]:
"graph (translation X)"
  by (induct X, auto simp:Let_def)

lemma graph_rule_translation[intro]: (* remark at the end of Def 15 *)
"graph_rule (translation X, translation (A_Int X Y))"
  using verts_in_translation_finite[of X] verts_in_translation_finite[of "A_Int X Y"]
        translation_graph[of X] translation_graph[of "A_Int X Y"]
  by (auto simp:Let_def subgraph_def2)

lemma graph_hom_translation[intro]:
  "graph_homomorphism (LG {} {0,1}) (translation X) (Id_on {0,1})"
  using verts_in_translation[of X]
  unfolding inv_translation_def graph_homomorphism_def2 by auto

lemma translation_right_to_left:
  assumes f:"graph_homomorphism (translation e) G f" "(0, x) \<in> f" "(1, y) \<in> f"
  shows "(x, y) \<in> :G:\<lbrakk>e\<rbrakk>"
  using f
proof(induct e arbitrary:f x y)
case (A_Int e\<^sub>1 e\<^sub>2 f x y)
  let ?f\<^sub>1 = "id"
  let ?f\<^sub>2 = "(\<lambda> x. if x < 2 then x else x + card (vertices (translation e\<^sub>1)) - 2)"
  let ?G\<^sub>1 = "translation e\<^sub>1"
  let ?G\<^sub>2 = "translation e\<^sub>2"
  have f1:"(0, x) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f" "(1, y) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f"
   and f2:"(0, x) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f" "(1, y) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f"
    using A_Int.prems(2,3) by (auto simp:BNF_Def.Gr_def relcomp_def)
  from A_Int.prems(1)
  have uni:"graph_homomorphism (graph_union ?G\<^sub>1 (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)) G f"
    by (auto simp:Let_def)
  from graph_homo_union_id(1)[OF uni translation_graph]
  have h1:"graph_homomorphism ?G\<^sub>1 (translation (A_Int e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>1 id)"
    by (auto simp:Let_def graph_homomorphism_def)
  have "graph (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)" by auto
  from graph_homo_union_id(2)[OF uni this]
  have h2:"graph_homomorphism ?G\<^sub>2 (translation (A_Int e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>2 ?f\<^sub>2)"
    by (auto simp:Let_def graph_homomorphism_def)
  from A_Int.hyps(1)[OF graph_homomorphism_composes[OF h1 A_Int.prems(1)] f1]
       A_Int.hyps(2)[OF graph_homomorphism_composes[OF h2 A_Int.prems(1)] f2]
  show ?case by auto
next
  case (A_Cmp e\<^sub>1 e\<^sub>2 f x y)
  let ?f\<^sub>1 =  "(\<lambda> x. if x=0 then 0 else x+card(vertices (translation e\<^sub>2))-1)"
  let ?f\<^sub>2 =  "(\<lambda> x. if x=0 then card (vertices (translation e\<^sub>2)) else x)"
  let ?G\<^sub>1 = "translation e\<^sub>1"
  let ?G\<^sub>2 = "translation e\<^sub>2"
  let ?v = "card (vertices (translation e\<^sub>2))"
  from A_Cmp.prems(1) have "?v \<in> Domain f" by (auto simp:Let_def graph_homomorphism_def)
  then obtain v where v:"(?v,v) \<in> f" by auto
  have f1:"(0, x) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f" "(1, v) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f"
   and f2:"(0, v) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f" "(1, y) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f"
    using A_Cmp.prems(2,3) v by auto
  from A_Cmp.prems(1)
  have uni:"graph_homomorphism (graph_union (map_graph_fn ?G\<^sub>1 ?f\<^sub>1) (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)) G f"
    by (auto simp:Let_def)
  have "graph (map_graph_fn ?G\<^sub>1 ?f\<^sub>1)" by auto
  from graph_homo_union_id(1)[OF uni this]
  have h1:"graph_homomorphism ?G\<^sub>1 (translation (A_Cmp e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>1 ?f\<^sub>1)"
    by (auto simp:Let_def graph_homomorphism_def2)
  have "graph (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)" by auto
  from graph_homo_union_id(2)[OF uni this]
  have h2:"graph_homomorphism ?G\<^sub>2 (translation (A_Cmp e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>2 ?f\<^sub>2)"
    by (auto simp:Let_def graph_homomorphism_def2)
  from A_Cmp.hyps(1)[OF graph_homomorphism_composes[OF h1 A_Cmp.prems(1)] f1]
       A_Cmp.hyps(2)[OF graph_homomorphism_composes[OF h2 A_Cmp.prems(1)] f2]
  show ?case by auto
next
  case (A_Cnv e f x y)
  let ?f = "(\<lambda> x. if x < 2 then 1 - x else x)"
  let ?G = "translation e"
  have i:"graph_homomorphism ?G (map_graph_fn ?G ?f) (on_graph ?G ?f)" using A_Cnv by auto
  have "(0, y) \<in> on_graph ?G ?f O f" "(1, x) \<in> on_graph ?G ?f O f"
    using A_Cnv.prems(3,2) by (auto simp:BNF_Def.Gr_def relcomp_def)
  from A_Cnv.hyps(1)[OF graph_homomorphism_composes[OF i] this] A_Cnv.prems(1)
  show ?case by auto
next
case (A_Lbl l f x y)
  hence "edge_preserving f {(l,0,1)} (edges G)" unfolding graph_homomorphism_def by auto
  with A_Lbl(2,3) show ?case by (auto simp:getRel_def edge_preserving_def)
qed

lemma translation_homomorphism:
  assumes "graph_homomorphism (translation e) G f"
  shows "f `` {0} \<times> f `` {1} \<subseteq> :G:\<lbrakk>e\<rbrakk>" ":G:\<lbrakk>e\<rbrakk> \<noteq> {}"
  using translation_right_to_left[OF assms] assms[unfolded graph_homomorphism_def2]
        verts_in_translation_finite[of e] by auto

text \<open>Lemma 5.\<close>
lemma translation:
  assumes "graph G"
  shows "(x, y) \<in> :G:\<lbrakk>e\<rbrakk> \<longleftrightarrow> (\<exists> f. graph_homomorphism (translation e) G f \<and> (0,x) \<in> f \<and> (1,y) \<in> f)"
(is "?lhs = ?rhs")
proof
  have [dest]:"y + card (vertices (translation (e::'a allegorical_term))) - 2 < 2 \<Longrightarrow> (y::nat) < 2"
    for y e using inv_tr_card_min[OF verts_in_translation,of e] by linarith
  {  fix y fix e::"'a allegorical_term"
     assume "y + card (vertices (translation e)) - 2 \<in> vertices (translation e)"
     hence "y + card (vertices (translation e)) - 2 < card (vertices (translation e))"
       using verts_in_translation[of e,unfolded inv_translation_def] by auto
     hence "y < 2" using inv_tr_card_min[OF verts_in_translation,of e] by auto
  } note [dest!] = this
  {  fix y fix e::"'a allegorical_term"
     assume "y + card (vertices (translation e)) - Suc 0 \<in> vertices (translation e)"
     hence "y + card (vertices (translation e)) - Suc 0 \<in> {0..<card (vertices (translation e))}"
       using verts_in_translation[of e,unfolded inv_translation_def] by simp
     hence "y = 0" using inv_tr_card_min[OF verts_in_translation,of e] by auto
   } note [dest!] = this
   {  fix y fix e::"'a allegorical_term"
     assume "card (vertices (translation e)) \<in> vertices (translation e)"
     hence "card (vertices (translation e)) \<in> {0..<card (vertices (translation e))}"
       using verts_in_translation[of e,unfolded inv_translation_def] by auto
     hence "False" by auto
   } note [dest!] = this
  {  fix y fix e::"'a allegorical_term"
     assume "y + card (vertices (translation e)) \<le> Suc 0"
     hence " card (vertices (translation e)) \<le> Suc 0" by auto
     hence "False" using inv_tr_card_min[OF verts_in_translation[of e]] by auto
   } note [dest!] = this
  assume ?lhs
  then show ?rhs
  proof(induct e arbitrary:x y)
    case (A_Int e\<^sub>1 e\<^sub>2)
    from A_Int have assm:"(x, y) \<in> :G:\<lbrakk>e\<^sub>1\<rbrakk>" "(x, y) \<in> :G:\<lbrakk>e\<^sub>2\<rbrakk>" by auto
    from A_Int(1)[OF assm(1)] obtain f\<^sub>1 where
      f\<^sub>1:"graph_homomorphism (translation e\<^sub>1) G f\<^sub>1" "(0, x) \<in> f\<^sub>1" "(1, y) \<in> f\<^sub>1" by auto
    from A_Int(2)[OF assm(2)] obtain f\<^sub>2 where
      f\<^sub>2:"graph_homomorphism (translation e\<^sub>2) G f\<^sub>2" "(0, x) \<in> f\<^sub>2" "(1, y) \<in> f\<^sub>2" by auto
    from f\<^sub>1 f\<^sub>2 have v:"Domain f\<^sub>1 = vertices (translation e\<^sub>1)" "Domain f\<^sub>2 = vertices (translation e\<^sub>2)"
      unfolding graph_homomorphism_def by auto
    let ?f\<^sub>2 = "(\<lambda> x. if x < 2 then x else x + card (vertices (translation e\<^sub>1)) - 2)"
    let ?tr\<^sub>2 = "on_graph (translation e\<^sub>2) ?f\<^sub>2"
    have inj2:"inj_on ?f\<^sub>2 (vertices (translation e\<^sub>2))" unfolding inj_on_def by auto
    have "(0,0) \<in> ?tr\<^sub>2\<inverse>" "(1,1) \<in> ?tr\<^sub>2\<inverse>" by auto
    from this[THEN relcompI] f\<^sub>2(2,3)
    have zero_one:"(0,x) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2"
                  "(1,y) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2" by auto
    { fix yb zb
      assume "(yb + card (vertices (translation e\<^sub>1)) - 2, zb) \<in> f\<^sub>1"
      hence "yb + card (vertices (translation e\<^sub>1)) - 2 \<in> vertices (translation e\<^sub>1)" using v by auto
    } note in_f[dest!] = this
    have d_a:"Domain f\<^sub>1 \<inter>  Domain (?tr\<^sub>2\<inverse> O f\<^sub>2) = {0,1}"
      using zero_one by (auto simp:v)
    have d_b:"Domain (f\<^sub>1 \<inter> ?tr\<^sub>2\<inverse> O f\<^sub>2) = {0,1}"
      using zero_one f\<^sub>1(2,3) by auto
    note cmp2 = graph_homomorphism_composes[OF graph_homo_inv[OF translation_graph inj2] f\<^sub>2(1)]
    have "graph_homomorphism (translation (A_Int e\<^sub>1 e\<^sub>2)) G (f\<^sub>1 \<union> ?tr\<^sub>2\<inverse> O f\<^sub>2)"
      using graph_homo_union[OF f\<^sub>1(1) cmp2 d_a[folded d_b]]
      by (auto simp:Let_def)
    thus ?case using zero_one[THEN UnI2[of _ _ "f\<^sub>1"]] by blast
  next
    case (A_Cmp e\<^sub>1 e\<^sub>2)
    from A_Cmp obtain z where assm:"(x, z) \<in> :G:\<lbrakk>e\<^sub>1\<rbrakk>" "(z, y) \<in> :G:\<lbrakk>e\<^sub>2\<rbrakk>" by auto
    from A_Cmp(1)[OF assm(1)] obtain f\<^sub>1 where
      f\<^sub>1:"graph_homomorphism (translation e\<^sub>1) G f\<^sub>1" "(0, x) \<in> f\<^sub>1" "(1, z) \<in> f\<^sub>1" by auto
    from A_Cmp(2)[OF assm(2)] obtain f\<^sub>2 where
      f\<^sub>2:"graph_homomorphism (translation e\<^sub>2) G f\<^sub>2" "(0, z) \<in> f\<^sub>2" "(1, y) \<in> f\<^sub>2" by auto
    from f\<^sub>1 f\<^sub>2 have v:"Domain f\<^sub>1 = vertices (translation e\<^sub>1)" "Domain f\<^sub>2 = vertices (translation e\<^sub>2)"
      unfolding graph_homomorphism_def by auto
    let ?f\<^sub>1 = "(\<lambda> x. if x=0 then 0 else x+card(vertices (translation e\<^sub>2))-1)"
    let ?f\<^sub>2 = "(\<lambda> x. if x=0 then card (vertices (translation e\<^sub>2)) else x)"
    let ?tr\<^sub>1 = "on_graph (translation e\<^sub>1) ?f\<^sub>1"
    let ?tr\<^sub>2 = "on_graph (translation e\<^sub>2) ?f\<^sub>2"
    have inj1:"inj_on ?f\<^sub>1 (vertices (translation e\<^sub>1))" unfolding inj_on_def by auto
    have inj2:"inj_on ?f\<^sub>2 (vertices (translation e\<^sub>2))" unfolding inj_on_def by auto
    have "(card (vertices (translation e\<^sub>2)),0) \<in> ?tr\<^sub>2\<inverse>" "(1,1) \<in> ?tr\<^sub>2\<inverse>"
         "(0,0) \<in> ?tr\<^sub>1\<inverse>" "(card (vertices (translation e\<^sub>2)),1) \<in> ?tr\<^sub>1\<inverse>" by auto
    from this[THEN relcompI] f\<^sub>2(2,3) f\<^sub>1(2,3)
    have zero_one:"(card (vertices (translation e\<^sub>2)),z) \<in> ?tr\<^sub>1\<inverse> O f\<^sub>1"
                  "(0,x) \<in> ?tr\<^sub>1\<inverse> O f\<^sub>1"
                  "(card (vertices (translation e\<^sub>2)),z) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2"
                  "(1,y) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2" by auto
    have [simp]:
        "ye \<in> vertices (translation e\<^sub>2) \<Longrightarrow>
       (if ye = 0 then card (vertices (translation e\<^sub>2)) else ye) =
       (if yd = 0 then 0 else yd + card (vertices (translation e\<^sub>2)) - 1) \<longleftrightarrow> ye = 0 \<and> yd = 1"
        for ye yd using v inv_tr_card_min[OF verts_in_translation,of "e\<^sub>2"]
        by(cases "ye=0";cases "yd=0";auto)
    have d_a:"Domain (?tr\<^sub>1\<inverse> O f\<^sub>1) \<inter>  Domain (?tr\<^sub>2\<inverse> O f\<^sub>2) = {card (vertices (translation e\<^sub>2))}"
      using zero_one by (auto simp:v)
    have d_b:"Domain (?tr\<^sub>1\<inverse> O f\<^sub>1 \<inter> ?tr\<^sub>2\<inverse> O f\<^sub>2) = {card (vertices (translation e\<^sub>2))}"
      using zero_one f\<^sub>1(2,3) by auto
    note cmp1 = graph_homomorphism_composes[OF graph_homo_inv[OF translation_graph inj1] f\<^sub>1(1)]
    note cmp2 = graph_homomorphism_composes[OF graph_homo_inv[OF translation_graph inj2] f\<^sub>2(1)]
    have "graph_homomorphism (translation (A_Cmp e\<^sub>1 e\<^sub>2)) G (?tr\<^sub>1\<inverse> O f\<^sub>1 \<union> ?tr\<^sub>2\<inverse> O f\<^sub>2)"
      unfolding Let_def translation.simps
      by (rule graph_homo_union[OF cmp1 cmp2 d_a[folded d_b]])
    thus ?case using zero_one by blast
  next
    case (A_Cnv e)
    let ?G = "translation (A_Cnv e)"
    from A_Cnv obtain f where
      f:"graph_homomorphism (translation e) G f" "(0, y) \<in> f" "(1, x) \<in> f" by auto
    hence v:"Domain f = vertices (translation e)"
      unfolding graph_homomorphism_def by auto
    define n where "n \<equiv> card (vertices (translation e))"
    from verts_in_translation f inv_tr_card_min[OF verts_in_translation] v(1)
    have n:"vertices (translation e) = {0..<n}" "{0..<n} \<inter> {x. x < 2} = {1,0}"
      "Domain f = {0..<n}" "{0..<n} \<inter> {x. \<not> x < 2} = {2..<n}"
      and n2: "n \<ge> 2"
      by (auto simp:n_def inv_translation_def)
    then have [simp]:"insert (Suc 0) {2..<n} = {1..<n}"
      "insert 0 {Suc 0..<n} = {0..<n}" by auto
    let ?f = "on_graph ?G (\<lambda> x. if x < 2 then 1 - x else x)"
    have h:"graph_homomorphism ?G G (?f O f)"
    proof(rule graph_homomorphism_composes[OF _ f(1)],rule graph_homomorphismI)
      show "vertices ?G = Domain ?f"
        by (auto simp:Domain_int_univ)
      show "?f `` vertices ?G \<subseteq> vertices (translation e)" using n2 by auto
      show "univalent ?f" by auto
      show "edge_preserving ?f (edges (translation (A_Cnv e))) (edges (translation e))"
        by (rule edge_preserving_on_graphI,auto simp: BNF_Def.Gr_def)
    qed (auto intro:assms)
    have xy:"(0, x) \<in> ?f O f" "(1, y) \<in> ?f O f" using n2 f(2,3) n(1,2) by auto
    with h show ?case by auto
  next
    case (A_Lbl l)
    let ?f = "{(0,x),(1,y)}"
    have xy:"x \<in> vertices G" "y \<in> vertices G" using assms A_Lbl by (auto simp:getRel_def)
    have "graph_homomorphism (translation (A_Lbl l)) G ?f \<and> (0, x) \<in> ?f \<and> (1, y) \<in> ?f"
      using assms A_Lbl xy unfolding graph_homomorphism_def2
      by (auto simp:univalent_def getRel_def on_triple_def Image_def graph_union_def insert_absorb)
    then show ?case by auto
  qed
qed (insert translation_right_to_left,auto)

abbreviation transl_rule ::
    "'a sentence \<Rightarrow> ('a, nat) labeled_graph \<times> ('a, nat) labeled_graph" where
"transl_rule R \<equiv> (translation (fst R),translation (snd R))"

text \<open>Lemma 6.\<close>
lemma maintained_holds_iff:
  assumes "graph G"
  shows "maintained (translation e\<^sub>L,translation (A_Int e\<^sub>L e\<^sub>R)) G \<longleftrightarrow> G \<Turnstile> e\<^sub>L \<sqsubseteq> e\<^sub>R" (is "?rhs = ?lhs")
proof
  assume lhs:?lhs
  show ?rhs unfolding maintained_def proof(clarify) fix f
    assume f:"graph_homomorphism (fst (translation e\<^sub>L, translation (A_Int e\<^sub>L e\<^sub>R))) G f"
    then obtain x y where f2:"(0,x) \<in> f" "(1,y) \<in> f" unfolding graph_homomorphism_def
      by (metis DomainE One_nat_def prod.sel(1) verts_in_translation_finite(3,4))
    with f have "(x,y) \<in> :G:\<lbrakk>fst (e\<^sub>L \<sqsubseteq> e\<^sub>R)\<rbrakk>" unfolding translation[OF assms] by auto
    with lhs have "(x,y) \<in> :G:\<lbrakk>snd (e\<^sub>L \<sqsubseteq> e\<^sub>R)\<rbrakk>" by auto
    then obtain g where g: "graph_homomorphism (translation (A_Int e\<^sub>L e\<^sub>R)) G g"
                   and g2: "(0, x) \<in> g" "(1, y) \<in> g" unfolding translation[OF assms] by auto
    have v:"vertices (translation (A_Int e\<^sub>L e\<^sub>R)) = Domain g"
           "vertices (translation e\<^sub>L) = Domain f" using f g
      unfolding graph_homomorphism_def by auto
    from subgraph_subset[of "translation e\<^sub>L" "translation (A_Int e\<^sub>L e\<^sub>R)"]
         graph_rule_translation[of e\<^sub>L e\<^sub>R]
    have dom_sub: "Domain f \<subseteq> Domain g"
      using v unfolding prod.sel by argo
    hence dom_le:"card (Domain f) \<le> card (Domain g)"
      by (metis card.infinite card_mono inv_tr_card_min not_less rel_simps(51) v(1) verts_in_translation)
    have c_f:"card (Domain f) \<ge> 2" using inv_tr_card_min[OF verts_in_translation] v by metis
    from f[unfolded graph_homomorphism_def]
    have ep_f:"edge_preserving f (edges (translation e\<^sub>L)) (edges G)"
     and uni_f:"univalent f" by auto
    let ?f = "(\<lambda>x. if x < 2 then x else x + card (vertices (translation e\<^sub>L)) - 2)"
    define GR where "GR = map_graph_fn (translation e\<^sub>R) ?f"
    from g[unfolded graph_homomorphism_def]
    have "edge_preserving g (edges (translation (A_Int e\<^sub>L e\<^sub>R))) (edges G)"
     and uni_g:"univalent g" by auto
    from edge_preserving_subset[OF subset_refl _ this(1)]
    have ep_g:"edge_preserving g (edges GR) (edges G)" by (auto simp:Let_def GR_def)
    { fix a assume a:"a \<in> vertices (translation e\<^sub>R)"
      hence "?f a \<in> vertices (translation (A_Int e\<^sub>L e\<^sub>R))" by (auto simp:Let_def)
      from this[unfolded v] verts_in_translation[of "A_Int e\<^sub>L e\<^sub>R",unfolded inv_translation_def v]
      have "\<not> a < 2 \<Longrightarrow> a + card (Domain f) - 2 < card (Domain g)" by auto
    } note[intro!] = this
    have [intro!]: " \<not> aa < 2 \<Longrightarrow> card (Domain f) \<le> aa + card (Domain f) - 2" for aa by simp
    from v(2) restrictD[OF translation_graph[of e\<^sub>L]]
    have df[dest]:"xa \<notin> Domain f \<Longrightarrow> (l,xa,xb) \<in> edges (translation e\<^sub>L) \<Longrightarrow> False"
                  "xa \<notin> Domain f \<Longrightarrow> (l,xb,xa) \<in> edges (translation e\<^sub>L) \<Longrightarrow> False"
                  for xa l xb unfolding edge_preserving by auto
    { fix l xa xb ya
      assume assm: "(l,xa,xb) \<in> edges GR"
      with c_f dom_le
      have "xa \<in> {0,1} \<union> {card (Domain f)..<card (Domain g)}"
           "xb \<in> {0,1} \<union> {card (Domain f)..<card (Domain g)}"
        unfolding GR_def v by auto
      hence minb:"xa \<in> {0,1} \<or> xa \<ge> card (Domain f)" "xb \<in> {0,1} \<or> xb \<ge> card (Domain f)"
        by auto
      { fix z xa assume minb:"xa \<in> {0,1} \<or> xa \<ge> card (Domain f)" and z:"(xa,z) \<in> f"
        from z verts_in_translation[of e\<^sub>L,unfolded inv_translation_def v]
        have "xa < card(Domain f)" by auto
        with minb verts_in_translation[of "A_Int e\<^sub>L e\<^sub>R",unfolded inv_translation_def v]
        have x:"xa \<in> {0,1} \<and> xa \<in> Domain g" by auto
        then obtain v where g:"(xa,v) \<in> g" by auto
        consider "xa = 0 \<and> z = x" | "xa = 1 \<and> z = y"
          using x f2[THEN univalentD[OF uni_f]] z by auto
        hence "v = z" using g g2[THEN univalentD[OF uni_g]] by metis
        hence "(xa,z) \<in> g" using g by auto
      }
      note minb[THEN this]
    }
    with f2 g2[THEN univalentD[OF uni_g]]
    have dg:"(l,xa,xb) \<in> edges GR \<Longrightarrow> (xa,ya) \<in> f \<Longrightarrow> (xa,ya) \<in> g"
            "(l,xb,xa) \<in> edges GR \<Longrightarrow> (xa,ya) \<in> f \<Longrightarrow> (xa,ya) \<in> g"
            for xa l xb ya
      unfolding edge_preserving by (auto)
    have "vertices (translation e\<^sub>L) \<subseteq> vertices (translation (A_Int e\<^sub>L e\<^sub>R))"
      by(rule subgraph_subset,insert graph_rule_translation,auto)
    hence subdom:"Domain f \<subseteq> Domain g" unfolding v.
    let ?g = "f \<union> (Id_on (UNIV - Domain f) O g)"
    have [simp]:"Domain ?g = Domain g" using subdom unfolding Domain_Un_eq by auto
    have ih:"graph_homomorphism (translation (A_Int e\<^sub>L e\<^sub>R)) G ?g"
    proof(rule graph_homomorphismI)
      show "?g `` vertices (translation (A_Int e\<^sub>L e\<^sub>R)) \<subseteq> vertices G"
        using g[unfolded graph_homomorphism_def] f[unfolded graph_homomorphism_def]
        by (auto simp: v simp del:translation.simps)
      show "edge_preserving ?g (edges (translation (A_Int e\<^sub>L e\<^sub>R))) (edges G)"
        unfolding Let_def translation.simps graph_union_edges proof
        show "edge_preserving ?g (edges (translation e\<^sub>L)) (edges G)"
          using edge_preserving_atomic[OF ep_f] unfolding edge_preserving by auto
        have "edge_preserving ?g (edges GR) (edges G)"
          using edge_preserving_atomic[OF ep_g] dg unfolding edge_preserving by (auto;blast)
        thus "edge_preserving ?g (edges (map_graph_fn (translation e\<^sub>R) ?f)) (edges G)"
          by (auto simp:GR_def)
        qed
    qed (insert f[unfolded graph_homomorphism_def] g[unfolded graph_homomorphism_def],auto simp:Let_def)
    have ie:"agree_on (translation e\<^sub>L) f ?g" unfolding agree_on_def by (auto simp:v)
    from ie ih show "extensible (translation e\<^sub>L, translation (A_Int e\<^sub>L e\<^sub>R)) G f"
      unfolding extensible_def prod.sel by auto
  qed next
  assume rhs:?rhs
  { fix x y assume "(x,y) \<in> :G:\<lbrakk>e\<^sub>L\<rbrakk>"
    with translation[OF assms] obtain f
      where f:"graph_homomorphism (fst (translation e\<^sub>L, translation (A_Int e\<^sub>L e\<^sub>R))) G f"
              "(0, x) \<in> f" "(1, y) \<in> f" by auto
    with rhs[unfolded maintained_def,rule_format,OF f(1),unfolded extensible_def]
    obtain g where g:"graph_homomorphism (translation (A_Int e\<^sub>L e\<^sub>R)) G g"
                     "agree_on (translation e\<^sub>L) f g" by auto
    hence "(x,y) \<in> :G:\<lbrakk>A_Int e\<^sub>L e\<^sub>R\<rbrakk>" using f unfolding agree_on_def translation[OF assms] by auto
  }
  thus ?lhs by auto
qed

lemma translation_self[intro]:
"(0, 1) \<in> :translation e:\<lbrakk>e\<rbrakk>"
proof(induct e)
  case (A_Int e1 e2)
  let ?f = "(\<lambda>x. if x < 2 then x else x + card (vertices (translation e1)) - 2)"
  have f: "(?f 0,?f 1) \<in>:map_graph_fn (translation e2) ?f:\<lbrakk>e2\<rbrakk>"
    using map_graph_in[OF translation_graph A_Int(2),of ?f] by auto
  let ?G = "graph_union (translation e1) (map_graph_fn (translation e2) ?f)"
  have "{(0,1)} \<subseteq> :(translation e1):\<lbrakk>e1\<rbrakk>" using A_Int by auto
  moreover have "{(0,1)} \<subseteq> :map_graph_fn (translation e2) ?f:\<lbrakk>e2\<rbrakk>" using f by auto
  moreover have ":map_graph_fn (translation e2) ?f:\<lbrakk>e2\<rbrakk> \<subseteq> :?G:\<lbrakk>e2\<rbrakk>" ":translation e1:\<lbrakk>e1\<rbrakk> \<subseteq> :?G:\<lbrakk>e1\<rbrakk>"
    using graph_union_semantics by blast+
  ultimately show ?case by (auto simp:Let_def)
next
  case (A_Cmp e1 e2)
  let ?f1 = "\<lambda>x. if x = 0 then 0 else x + card (vertices (translation e2)) - 1"
  have f1: "(?f1 0,?f1 1) \<in>:map_graph_fn (translation e1) ?f1:\<lbrakk>e1\<rbrakk>"
    using map_graph_in[OF translation_graph A_Cmp(1),of ?f1] by auto
  let ?f2 = "\<lambda>x. if x = 0 then card (vertices (translation e2)) else x"
  have f2: "(?f2 0,?f2 1) \<in>:map_graph_fn (translation e2) ?f2:\<lbrakk>e2\<rbrakk>"
    using map_graph_in[OF translation_graph A_Cmp(2),of ?f2] by auto
  let ?G = "graph_union (map_graph_fn (translation e1) ?f1) (map_graph_fn (translation e2) ?f2)"
  have "{(0,1)} = {(0,card (vertices (translation e2)))} O {(card (vertices (translation e2)),1)}"
    by auto
  also have "{(0,card (vertices (translation e2)))} \<subseteq> :map_graph_fn (translation e1) ?f1:\<lbrakk>e1\<rbrakk>"
    using f1 by auto
  also have ":map_graph_fn (translation e1) ?f1:\<lbrakk>e1\<rbrakk> \<subseteq> :?G:\<lbrakk>e1\<rbrakk>"
    using graph_union_semantics by auto
  also have "{(card (vertices (translation e2)),1)} \<subseteq> :map_graph_fn (translation e2) ?f2:\<lbrakk>e2\<rbrakk>"
    using f2 by auto
  also have ":map_graph_fn (translation e2) ?f2:\<lbrakk>e2\<rbrakk> \<subseteq> :?G:\<lbrakk>e2\<rbrakk>"
    using graph_union_semantics by blast
  also have "(:?G:\<lbrakk>e1\<rbrakk>) O (:?G:\<lbrakk>e2\<rbrakk>) = :translation (A_Cmp e1 e2):\<lbrakk>A_Cmp e1 e2\<rbrakk>"
    by (auto simp:Let_def)
  finally show ?case by auto
next
  case (A_Cnv e)
  from map_graph_in[OF translation_graph this,of "(\<lambda>x. if x < (2::nat) then 1 - x else x)"]
  show ?case using map_graph_in[OF translation_graph] by auto
qed (simp add:getRel_def)

text \<open>Lemma 6 is only used on rules of the form @{term "e\<^sub>L \<sqsubseteq> e\<^sub>R"}.
      The requirement of G being a graph can be dropped for one direction.\<close>
lemma maintained_holds[intro]:
  assumes ":G:\<lbrakk>e\<^sub>L\<rbrakk> \<subseteq> :G:\<lbrakk>e\<^sub>R\<rbrakk>"
  shows "maintained (transl_rule (e\<^sub>L \<sqsubseteq> e\<^sub>R)) G"
proof (cases "graph G")
  case True
  thus ?thesis using assms sentence_iff maintained_holds_iff prod.sel by metis
next
  case False
  thus ?thesis by (auto simp:maintained_def graph_homomorphism_def)
qed

lemma maintained_holds_subset_iff[simp]:
  assumes "graph G"
  shows "maintained (transl_rule (e\<^sub>L \<sqsubseteq> e\<^sub>R)) G \<longleftrightarrow> (:G:\<lbrakk>e\<^sub>L\<rbrakk> \<subseteq> :G:\<lbrakk>e\<^sub>R\<rbrakk>)"
  using assms maintained_holds_iff sentence_iff prod.sel by metis

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_26
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = (if x z z2 then True else elem z xs)"

theorem property0 :
  "((elem z xs) ==> (elem z (y xs ys)))"
  find_proof DInd
  apply (induct arbitrary: ys rule: elem.induct)
  apply auto
  done

theorem property0' :
  "((elem z xs) ==> (elem z (y xs ys)))"
  (*Why induction on "xs"?
    Because "elem" is the only recursive function in the premise, which pattern-matches on the
    second parameter, which is "xs" in this case.
    Furthermore, the innermost recursive function "y" is pattern-matches on the first parameter,
    which is "xs" in this case.*)
  apply(induct xs)
  apply auto
  done

theorem property0 :
  "((elem z xs) ==> (elem z (y xs ys)))"
  apply (induct arbitrary: ys rule: y.induct)
   apply (induct z)
  apply(induct_tac y2)
  nitpick
  oops

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.*)
  theory TIP_list_nat_PairUnpair
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun unpair :: "(('t, 't) pair) list => 't list" where
  "unpair (nil2) = nil2"
| "unpair (cons2 (pair2 z y2) xys) =
     cons2 z (cons2 y2 (unpair xys))"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun pairs :: "'t list => (('t, 't) pair) list" where
  "pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

fun lt :: "Nat => Nat => bool" where
  "lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

(*fun did not finish the proof*)
function imod :: "Nat => Nat => Nat" where
  "imod x y = (if lt x y then x else imod (minus x y) y)"
  by pat_completeness auto

theorem property0 :
  "((let eta :: Nat = length xs
     in ((let md :: Nat = imod eta (S (S Z))
          in (if
                ((case eta of
                    Z => Z
                    | S x => (if le eta Z then (case Z of S y => p Z) else S Z) =
                    (if le (S (S Z)) Z then (case Z of S z => minus Z (p Z)) else
                       (case Z of S x2 => p Z))) &
                   (md ~= Z))
                then
                minus md (S (S Z))
                else
                md)) =
           Z)) ==>
      ((unpair (pairs xs)) = xs))"
  oops

end


(*  Title:      HOL/Nitpick_Examples/Induct_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to (co)inductive definitions.
*)

section \<open>Examples Featuring Nitpick Applied to (Co)inductive Definitions\<close>

theory Induct_Nits
imports Main
begin

nitpick_params [verbose, card = 1-8, unary_ints,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
"p1 n \<Longrightarrow> p1 (n + 2)"

coinductive q1 :: "nat \<Rightarrow> bool" where
"q1 0" |
"q1 n \<Longrightarrow> q1 (n + 2)"

lemma "p1 = q1"
nitpick [expect = none]
nitpick [wf, expect = none]
nitpick [non_wf, expect = none]
nitpick [non_wf, dont_star_linear_preds, expect = none]
oops

lemma "p1 \<noteq> q1"
nitpick [expect = potential]
nitpick [wf, expect = potential]
nitpick [non_wf, expect = potential]
nitpick [non_wf, dont_star_linear_preds, expect = potential]
oops

lemma "p1 (n - 2) \<Longrightarrow> p1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

lemma "q1 (n - 2) \<Longrightarrow> q1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

inductive p2 :: "nat \<Rightarrow> bool" where
"p2 n \<Longrightarrow> p2 n"

coinductive q2 :: "nat \<Rightarrow> bool" where
"q2 n \<Longrightarrow> q2 n"

lemma "p2 = bot"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "q2 = bot"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [wf, expect = quasi_genuine]
oops

lemma "p2 = top"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "q2 = top"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
nitpick [wf, expect = quasi_genuine]
sorry

lemma "p2 = q2"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "p2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "q2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> p2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> q2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

inductive p3 and p4 where
"p3 0" |
"p3 n \<Longrightarrow> p4 (Suc n)" |
"p4 n \<Longrightarrow> p3 (Suc n)"

coinductive q3 and q4 where
"q3 0" |
"q3 n \<Longrightarrow> q4 (Suc n)" |
"q4 n \<Longrightarrow> q3 (Suc n)"

lemma "p3 = q3"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p4 = q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p3 = top - p4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "q3 = top - q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "inf p3 q4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "inf q3 p4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup p3 q4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup q3 p4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

end


theory Tutorial
  imports Main
begin

text \<open>This is essentially a clone of \<open>cookbook/src/proofs/finite/Finite.thy\<close> in the cookbook
\<^url>\<open>https://github.com/isabelle-prover/cookbook/blob/master/src/proofs/finite/Finite.thy\<close>.\<close>

section \<open>Lemmas For Proving Finiteness of Sets\<close>

text \<open>In an Isar proof, these two are typically your silver bullets for proving the finiteness
of sets:\<close>
lemmas finite_helpers = finite_imageI finite_subset

text \<open>Some more helpful lemmas:\<close>
lemmas more_finite_helpers = finite_cartesian_product finite_vimageI finite_Un

\<comment> \<open>Example:\<close>
lemma
  "finite {x + y | x y :: nat. x < n \<and> y \<in> {0..3} \<and> x \<noteq> y}" (is "finite ?S")
proof -
  have "?S \<subseteq> (\<lambda>(x, y). x + y) ` ({0..<n} \<times> {0..3})"
    by auto
  also have "finite \<dots>"
    \<comment> \<open>This is just to show what is going on: \<open>by simp\<close> would also do the job.\<close>
    by (intro finite_imageI finite_cartesian_product finite_atLeastLessThan finite_atLeastAtMost)
  finally (finite_subset) show ?thesis .
    \<comment> \<open>Instead of giving @{thm finite_subset} explicitly, we could also have declared it like this:
        \<^verbatim>\<open>lemmas [trans] = finite_subset\<close>.\<close>
qed

text \<open>
  For automated proofs, it can often help to just pass these with the \<^verbatim>\<open>intro\<close> modifier
  to @{method auto} and friends.
  The theorem @{thm finite_imageI} is set up as an default, but it can help to add \<^verbatim>\<open>intro!\<close>.
  Have a look at the example of the end of the file, to see both theorems in action in an
  automated proof.
\<close>

section \<open>Simproc \<^verbatim>\<open>finite_Collect\<close>\<close>
text \<open>
  The simproc \<^verbatim>\<open>finite_Collect\<close> can be used to solve certain finiteness proof oblgations.
  Essentially, the simproc attempts to rewrite set comprehensions to terms that consist
  of applications @{term image}, @{term vimage}, @{term "(\<inter>)"},
  and @{term "(\<times>)"} as far as possible.
  Below is an example from @{theory HOL.Relation}.
\<close>
lemma "finite (r\<inverse>) = finite r"
  unfolding converse_def conversep_iff using [[simproc add: finite_Collect]]
  apply simp \<comment> \<open>The set was rewritten to an application of @{term image}.\<close>
  by (auto elim: finite_imageD simp: inj_on_def)

section \<open>Tuning The Simplifier For Finiteness Proofs\<close>

subsection \<open>Rewriting to Images\<close>
text \<open>
  One useful technique is to rewrite set comprehensions to images of sets under functions as far as
  possible by passing @{thm setcompr_eq_image} or its \<open>n\<close>-ary generalizations to the simplifier.
\<close>

text \<open>Here is the \<open>2\<close>-ary generalization of @{thm setcompr_eq_image}.\<close>
lemma setcompr_eq_image2:
  "{f x y | x y. P x y} = (\<lambda>(x, y). f x y) ` {(x, y). P x y}"
  using setcompr_eq_image[where f = "(\<lambda>(x, y). f x y)" and P = "\<lambda>(x, y). P x y"] by simp

text \<open>In this example, \<^verbatim>\<open>finite_Collect\<close> still does the right thing:\<close>
lemma
  assumes "finite A"
  shows "finite {f x | x. x \<in> A \<and> P x}"
  using assms [[simproc add: finite_Collect]] by simp

text \<open>Here, however, it will produce quite a mess:\<close>
lemma
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
  using assms [[simproc add: finite_Collect]]
  apply simp
  oops

text \<open>Instead, we use @{thm setcompr_eq_image2} to an image:\<close>
lemma
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
  using assms
  apply (simp add: setcompr_eq_image2) \<comment> \<open>Looks much better.\<close>
  \<comment> \<open>\<^verbatim>\<open>auto\<close> will apply the following theorems to solve the goal:\<close>
  thm finite_imageI finite_subset[rotated]
  \<comment> \<open>We rotate @{thm finite_subset} to use it as an \<open>elim\<close>-rule\<close>
  apply (auto elim: finite_subset[rotated])
  done

subsection \<open>Finiteness With Context\<close>
text \<open>The theorem @{thm finite_Collect_bounded_ex} (and its obvious \<open>n\<close>-ary generalizations)
can be highly useful for proving finiteness of sets where some of the finiteness theorems
one wants to apply rely on a precondition to hold. Consider the following example:\<close>
lemma
  "finite {s'. \<exists>s. Some s = x \<and> Some s' = g s}" \<comment> \<open>Clearly there is at most one such \<open>s'\<close>.\<close>
proof -
  \<comment> \<open>The statement follows quite immediately from this lemma.\<close>
  have Some_finite: "finite {x. Some x = y}" for y :: "'x option"
    using not_finite_existsD by fastforce
  show ?thesis
    \<comment> \<open>Something like this will not work, however:\<close>
    \<comment> \<open>apply (auto intro: Some_finite)\<close>
    \<comment> \<open>The reason is that we need \<^emph>\<open>context\<close>.
    The argument should go along the lines: there are only finitely such \<open>s\<close>,
    and for each \<open>s\<close> there are only finitely many such \<open>s'\<close>, thus the whole set is finite.\<close>
    apply (subst finite_Collect_bounded_ex) \<comment> \<open>this gives us what we want\<close>
    apply (intro allI impI Some_finite)+
    done
qed

subsection \<open>Advanced Examples Of Proving Finiteness With the Simplifier\<close>

text \<open>The simplifier can sometimes be surprisingly good at solving finiteness goals.
Here is an example:\<close>
lemma
  assumes "finite A" "finite (Collect P)"
  shows "finite {(a,b,c) | a b c. a \<in> A \<and> b < (n :: nat) \<and> P c}"
  using assms [[simproc add: finite_Collect]] by simp

text \<open>This shows what is going on here:\<close>
lemma
  assumes "finite A" "finite (Collect P)"
  shows "finite {(a,b,c) | a b c. a \<in> A \<and> b < (n :: nat) \<and> P c}"
  using [[simproc add: finite_Collect]] apply simp
  apply (intro finite_SigmaI finite_Collect_less_nat assms)
  done

text \<open>A slightly more complicated variant:\<close>
lemma
  assumes "finite A" "finite (Collect P)"
  shows "finite {(d, c, a, b) | a b c d. d < (n :: nat) \<and> P c \<and> (a, b) \<in> A}"
  using assms [[simproc add: finite_Collect]] by simp

text \<open>Here is a more involved example:\<close>
lemma
  fixes n :: nat
  assumes "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"
  using assms by simp

text \<open>Here is an explanation of what is going on:\<close>
lemma
  fixes n :: nat
  assumes "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"
  apply simp \<comment> \<open>First the simplifier applies some specific procedures for miniscoping\<close>
  apply (subst finite_Collect_bounded_ex) \<comment> \<open>Now, the context rule comes in\<close>
   apply (subst Collect_mem_eq, rule assms) \<comment> \<open>Solve first subgoal\<close>

  supply [simp del] = finite_Collect_bounded_ex
  apply(intro allI impI)
    \<comment> \<open>The simplifier walks down the propositional connectives using congruence rules\<close>
  apply (subst finite_Collect_bounded_ex) \<comment> \<open>Another application of the congruence rule\<close>
  apply (rule finite_Collect_less_nat) \<comment> \<open>Solve first subgoal\<close>
  apply (simp only: singleton_conv) \<comment> \<open>Rewrite to singleton set\<close>
  apply simp \<comment> \<open>The rest is trivial\<close>
  done

section \<open>Further Pointers\<close>
text \<open>For more examples and an attempt at an proof method for finiteness proof obligations,
see \<^url>\<open>https://github.com/wimmers/isabelle-finite\<close>.
It also contains the \<open>n\<close>-ary generalizations of @{thm setcompr_eq_image}
and @{thm finite_Collect_bounded_ex}.\<close>

end


theory Matrix_Invertable
  imports Jordan_Normal_Form.Determinant
  Smith_Normal_Form.SNF_Missing_Lemmas
begin

lemma invertible_right_inverse1:
  fixes A :: "'a::{semiring_1, comm_ring_1} mat"
  assumes "A \<in> carrier_mat n n"
  shows "invertible_mat A \<longleftrightarrow> (\<exists>B \<in> carrier_mat n n. A * B = 1\<^sub>m n)"
  by (metis (no_types, lifting) Determinant.det_mult assms det_one dvdI
      invertible_iff_is_unit_JNF  inverts_mat_def left_mult_one_mat
      obtain_inverse_matrix one_carrier_mat similar_mat_witD(2) similar_mat_wit_refl)

lemma  invertible_det_nz1:
  fixes A::"'a::field mat"
  assumes "A \<in> carrier_mat n n"
  shows "invertible_mat A \<longleftrightarrow> det A \<noteq> 0"
proof(cases "n=0")
  case True
  then show ?thesis
    using assms invertible_mat_zero by auto
next
  case False
  then show ?thesis
  using invertible_det_nz[untransferred, cancel_card_constraint, of A n]
  assms
  by fast
qed

proposition  cramer1:
  fixes A::"'a::field mat"
  assumes "A \<in> carrier_mat n n"
  assumes "b \<in> carrier_vec n"
  assumes "x \<in> carrier_vec n"
  assumes d0: "det A \<noteq> 0"
  shows "A *\<^sub>v x = b \<longleftrightarrow> x = vec n (\<lambda> k. det (replace_col A b k) / det A)"
proof -
  from d0 obtain B where B: "B \<in> carrier_mat n n" "A * B = 1\<^sub>m n" "B * A = 1\<^sub>m n"
    unfolding invertible_det_nz1[symmetric] invertible_mat_def
    by (meson Determinant.mat_mult_left_right_inverse
        \<open>\<And>n A. A \<in> carrier_mat n n \<Longrightarrow> (Determinant.det A \<noteq> 0) = invertible_mat A\<close> assms(1)
        invertible_right_inverse1)
  have "(A * B) *\<^sub>v b = b"
    by (simp add: B assms(2))
  then have "A *\<^sub>v (B *\<^sub>v b) = b"
    using B(1) assms(1) assms(2) by force
  then have xe: "\<exists>x. A *\<^sub>v x = b"
    by blast
  {
    fix x
    assume x: "A *\<^sub>v x = b"
    assume "x \<in> carrier_vec n"
    have "x = vec n (\<lambda> k. det (replace_col A b k) / det A)"
      unfolding x[symmetric]
      using d0
      by (auto simp: vec_eq_iff cramer_lemma_mat[of A n x] field_simps assms `x \<in> carrier_vec n`)
  }
  with xe show ?thesis
    using \<open>\<And>xa. \<lbrakk>A *\<^sub>v xa = b; xa \<in> carrier_vec n\<rbrakk> \<Longrightarrow>
          xa = Matrix.vec n (\<lambda>k. Determinant.det (replace_col A b k) / Determinant.det A)\<close> assms(3)
    by (metis B(1) \<open>A *\<^sub>v (B *\<^sub>v b) = b\<close> assms(2) mult_mat_vec_carrier)
qed

end


section\<open>Ternary Logic\<close>
theory Ternary
imports Main
begin

text\<open>Kleene logic\<close>

datatype ternaryvalue = TernaryTrue | TernaryFalse | TernaryUnknown
datatype ternaryformula = TernaryAnd ternaryformula ternaryformula
                        | TernaryOr ternaryformula ternaryformula
                        | TernaryNot ternaryformula
                        | TernaryValue ternaryvalue

fun ternary_to_bool :: "ternaryvalue \<Rightarrow> bool option" where
  "ternary_to_bool TernaryTrue = Some True" |
  "ternary_to_bool TernaryFalse = Some False" |
  "ternary_to_bool TernaryUnknown = None"

fun bool_to_ternary :: "bool \<Rightarrow> ternaryvalue" where
  "bool_to_ternary True = TernaryTrue" |
  "bool_to_ternary False = TernaryFalse"

lemma "the \<circ> ternary_to_bool \<circ> bool_to_ternary = id"
  by(simp add: fun_eq_iff, clarify, case_tac x, simp_all)
lemma ternary_to_bool_bool_to_ternary: "ternary_to_bool (bool_to_ternary X) = Some X"
by(cases X, simp_all)
lemma ternary_to_bool_None: "ternary_to_bool t = None \<longleftrightarrow> t = TernaryUnknown"
  by(cases t, simp_all)
lemma ternary_to_bool_SomeE: "ternary_to_bool t = Some X \<Longrightarrow>
  (t = TernaryTrue \<Longrightarrow> X = True \<Longrightarrow> P) \<Longrightarrow> (t = TernaryFalse \<Longrightarrow> X = False \<Longrightarrow> P)  \<Longrightarrow> P"
  by(cases t)(simp)+
lemma ternary_to_bool_Some: "ternary_to_bool t = Some X \<longleftrightarrow>
  (t = TernaryTrue \<and> X = True) \<or> (t = TernaryFalse \<and> X = False)"
  by(cases t, simp_all)
lemma bool_to_ternary_Unknown: "bool_to_ternary t = TernaryUnknown \<longleftrightarrow> False"
by(cases t, simp_all)

fun eval_ternary_And :: "ternaryvalue \<Rightarrow> ternaryvalue \<Rightarrow> ternaryvalue" where
  "eval_ternary_And TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_And TernaryTrue TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryTrue = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryUnknown = TernaryFalse" |
  "eval_ternary_And TernaryTrue TernaryUnknown = TernaryUnknown" |
  "eval_ternary_And TernaryUnknown TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryUnknown TernaryTrue = TernaryUnknown"  |
  "eval_ternary_And TernaryUnknown TernaryUnknown = TernaryUnknown"

lemma eval_ternary_And_comm: "eval_ternary_And t1 t2 = eval_ternary_And t2 t1"
  by (cases t1 t2 rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust]) auto

fun eval_ternary_Or :: "ternaryvalue \<Rightarrow> ternaryvalue \<Rightarrow> ternaryvalue" where
  "eval_ternary_Or TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryTrue TernaryFalse = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryFalse = TernaryFalse" |
  "eval_ternary_Or TernaryTrue TernaryUnknown = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryUnknown = TernaryUnknown" |
  "eval_ternary_Or TernaryUnknown TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryUnknown TernaryFalse = TernaryUnknown" |
  "eval_ternary_Or TernaryUnknown TernaryUnknown = TernaryUnknown"

fun eval_ternary_Not :: "ternaryvalue \<Rightarrow>  ternaryvalue" where
  "eval_ternary_Not TernaryTrue = TernaryFalse" |
  "eval_ternary_Not TernaryFalse = TernaryTrue" |
  "eval_ternary_Not TernaryUnknown = TernaryUnknown"

text\<open>Just to hint that we did not make a typo, we add the truth table for
      the implication and show that it is compliant with @{term "a \<longrightarrow> b \<longleftrightarrow> \<not>a \<or> b"}\<close>
fun eval_ternary_Imp :: "ternaryvalue \<Rightarrow> ternaryvalue \<Rightarrow> ternaryvalue" where
  "eval_ternary_Imp TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryTrue TernaryFalse = TernaryFalse" |
  "eval_ternary_Imp TernaryFalse TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryFalse TernaryFalse = TernaryTrue" |
  "eval_ternary_Imp TernaryTrue TernaryUnknown = TernaryUnknown" |
  "eval_ternary_Imp TernaryFalse TernaryUnknown = TernaryTrue" |
  "eval_ternary_Imp TernaryUnknown TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryUnknown TernaryFalse = TernaryUnknown" |
  "eval_ternary_Imp TernaryUnknown TernaryUnknown = TernaryUnknown"
lemma "eval_ternary_Imp a b = eval_ternary_Or (eval_ternary_Not a) b"
apply(cases a)
  apply(case_tac [!] b)
        apply(simp_all)
done

lemma eval_ternary_Not_UnknownD: "eval_ternary_Not t = TernaryUnknown \<Longrightarrow> t = TernaryUnknown"
  by (cases t) auto

lemma eval_ternary_DeMorgan:
  "eval_ternary_Not (eval_ternary_And a b) = eval_ternary_Or (eval_ternary_Not a) (eval_ternary_Not b)"
  "eval_ternary_Not (eval_ternary_Or a b) = eval_ternary_And (eval_ternary_Not a) (eval_ternary_Not b)"
  by (cases a b rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust],auto)+

lemma eval_ternary_idempotence_Not: "eval_ternary_Not (eval_ternary_Not a) = a"
  by (cases a) simp_all

lemma eval_ternary_simps_simple:
  "eval_ternary_And TernaryTrue x = x"
  "eval_ternary_And x TernaryTrue = x"
  "eval_ternary_And TernaryFalse x = TernaryFalse"
  "eval_ternary_And x TernaryFalse = TernaryFalse"
  by(case_tac [!] x)(simp_all)

context
begin
  private lemma bool_to_ternary_simp1: "bool_to_ternary X = TernaryTrue \<longleftrightarrow> X"
    by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
  private lemma bool_to_ternary_simp2:  "bool_to_ternary Y = TernaryFalse \<longleftrightarrow> \<not> Y"
    by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
  private lemma bool_to_ternary_simp3: "eval_ternary_Not (bool_to_ternary X) = TernaryTrue \<longleftrightarrow> \<not> X"
    by (metis (full_types) bool_to_ternary_simp2 eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private

  private lemma bool_to_ternary_simp6: "bool_to_ternary X \<noteq> TernaryUnknown"
    by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) ternaryvalue.distinct(3) ternaryvalue.distinct(5))

  lemmas bool_to_ternary_simps = bool_to_ternary_simp1 bool_to_ternary_simp2
                                 bool_to_ternary_simp3 bool_to_ternary_simp4
                                 bool_to_ternary_simp5 bool_to_ternary_simp6
end

context
begin
  private lemma bool_to_ternary_pullup1:
    "eval_ternary_Not (bool_to_ternary X) = bool_to_ternary (\<not> X)"
    by(cases X)(simp_all)

  private lemma bool_to_ternary_pullup2:
    "eval_ternary_And (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 \<and> X2)"
    by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_simps_simple(2) eval_ternary_simps_simple(4))

  private lemma bool_to_ternary_pullup3:
    "eval_ternary_Imp (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 \<longrightarrow> X2)"
    by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_Imp.simps(1)
        eval_ternary_Imp.simps(2) eval_ternary_Imp.simps(3) eval_ternary_Imp.simps(4))

  private lemma bool_to_ternary_pullup4:
    "eval_ternary_Or (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 \<or> X2)"
    by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) eval_ternary_Or.simps(1) eval_ternary_Or.simps(2) eval_ternary_Or.simps(3) eval_ternary_Or.simps(4))

  lemmas bool_to_ternary_pullup = bool_to_ternary_pullup1 bool_to_ternary_pullup2
                                  bool_to_ternary_pullup3 bool_to_ternary_pullup4
end

fun ternary_ternary_eval :: "ternaryformula \<Rightarrow> ternaryvalue" where
  "ternary_ternary_eval (TernaryAnd t1 t2) = eval_ternary_And (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
  "ternary_ternary_eval (TernaryOr t1 t2) = eval_ternary_Or (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
  "ternary_ternary_eval (TernaryNot t) = eval_ternary_Not (ternary_ternary_eval t)" |
  "ternary_ternary_eval (TernaryValue t) = t"

lemma ternary_ternary_eval_DeMorgan: "ternary_ternary_eval (TernaryNot (TernaryAnd a b)) =
    ternary_ternary_eval (TernaryOr (TernaryNot a) (TernaryNot b))"
by (simp add: eval_ternary_DeMorgan)

lemma ternary_ternary_eval_idempotence_Not:
  "ternary_ternary_eval (TernaryNot (TernaryNot a)) = ternary_ternary_eval a"
by (simp add: eval_ternary_idempotence_Not)

lemma ternary_ternary_eval_TernaryAnd_comm:
  "ternary_ternary_eval (TernaryAnd t1 t2) = ternary_ternary_eval (TernaryAnd t2 t1)"
by (simp add: eval_ternary_And_comm)

lemma "eval_ternary_Not (ternary_ternary_eval t) = (ternary_ternary_eval (TernaryNot t))" by simp

context
begin
  private lemma eval_ternary_simps_2:
      "eval_ternary_And (bool_to_ternary P) T = TernaryTrue \<longleftrightarrow> P \<and> T = TernaryTrue"
      "eval_ternary_And T (bool_to_ternary P) = TernaryTrue \<longleftrightarrow> P \<and> T = TernaryTrue"
  apply(case_tac [!] P)
     apply(simp_all add: eval_ternary_simps_simple)
  done

  private lemma eval_ternary_simps_3:
      "eval_ternary_And (ternary_ternary_eval x) T = TernaryTrue \<longleftrightarrow>
        ternary_ternary_eval x = TernaryTrue \<and> T = TernaryTrue"
      "eval_ternary_And T (ternary_ternary_eval x) = TernaryTrue \<longleftrightarrow>
        ternary_ternary_eval x = TernaryTrue \<and> T = TernaryTrue"
  apply(case_tac [!] T)
       apply(simp_all add: eval_ternary_simps_simple)
   apply(case_tac [!] "(ternary_ternary_eval x)")
       apply(simp_all)
  done

  lemmas eval_ternary_simps = eval_ternary_simps_simple eval_ternary_simps_2 eval_ternary_simps_3
end

definition ternary_eval :: "ternaryformula \<Rightarrow> bool option" where
  "ternary_eval t = ternary_to_bool (ternary_ternary_eval t)"

subsection\<open>Negation Normal Form\<close>

text\<open>A formula is in Negation Normal Form (NNF) if negations only occur at the atoms (not before and/or)\<close>
inductive NegationNormalForm :: "ternaryformula \<Rightarrow> bool" where
  "NegationNormalForm (TernaryValue v)" |
  "NegationNormalForm (TernaryNot (TernaryValue v))" |
  "NegationNormalForm \<phi> \<Longrightarrow> NegationNormalForm \<psi> \<Longrightarrow> NegationNormalForm (TernaryAnd \<phi> \<psi>)"|
  "NegationNormalForm \<phi> \<Longrightarrow> NegationNormalForm \<psi> \<Longrightarrow> NegationNormalForm (TernaryOr \<phi> \<psi>)"

text\<open>Convert a @{typ ternaryformula} to a  @{typ ternaryformula} in NNF.\<close>
fun NNF_ternary :: "ternaryformula \<Rightarrow> ternaryformula" where
  "NNF_ternary (TernaryValue v) = TernaryValue v" |
  "NNF_ternary (TernaryAnd t1 t2) = TernaryAnd (NNF_ternary t1) (NNF_ternary t2)" |
  "NNF_ternary (TernaryOr t1 t2) = TernaryOr (NNF_ternary t1) (NNF_ternary t2)" |
  "NNF_ternary (TernaryNot (TernaryNot t)) = NNF_ternary t" |
  "NNF_ternary (TernaryNot (TernaryValue v)) = TernaryValue (eval_ternary_Not v)" |
  "NNF_ternary (TernaryNot (TernaryAnd t1 t2)) = TernaryOr (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))" |
  "NNF_ternary (TernaryNot (TernaryOr t1 t2)) = TernaryAnd (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))"

lemma NNF_ternary_correct: "ternary_ternary_eval (NNF_ternary t) = ternary_ternary_eval t"
  proof(induction t rule: NNF_ternary.induct)
  qed(simp_all add: eval_ternary_DeMorgan eval_ternary_idempotence_Not)

lemma NNF_ternary_NegationNormalForm: "NegationNormalForm (NNF_ternary t)"
  proof(induction t rule: NNF_ternary.induct)
  qed(auto simp add: eval_ternary_DeMorgan eval_ternary_idempotence_Not intro: NegationNormalForm.intros)

context
begin
  private lemma ternary_lift1: "eval_ternary_Not tv \<noteq> TernaryFalse \<longleftrightarrow> tv = TernaryFalse \<or> tv = TernaryUnknown"
    using eval_ternary_Not.elims by blast
  private lemma ternary_lift2: "eval_ternary_Not tv \<noteq> TernaryTrue \<longleftrightarrow> tv = TernaryTrue \<or> tv = TernaryUnknown"
    using eval_ternary_Not.elims by blast
  private lemma ternary_lift3: "eval_ternary_Not tv = TernaryFalse \<longleftrightarrow> tv = TernaryTrue"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma ternary_lift4: "eval_ternary_Not tv = TernaryTrue \<longleftrightarrow> tv = TernaryFalse"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma ternary_lift5: "eval_ternary_Not tv = TernaryUnknown \<longleftrightarrow> tv = TernaryUnknown"
    by (metis eval_ternary_Not.simps(3) eval_ternary_idempotence_Not)

  private lemma ternary_lift6: "eval_ternary_And t1 t2 = TernaryFalse \<longleftrightarrow> t1 = TernaryFalse \<or> t2 = TernaryFalse"
    using eval_ternary_And.elims by blast
  private lemma ternary_lift7: "eval_ternary_And t1 t2 = TernaryTrue \<longleftrightarrow> t1 = TernaryTrue \<and> t2 = TernaryTrue"
    using eval_ternary_And.elims by blast

  lemmas ternary_lift = ternary_lift1 ternary_lift2 ternary_lift3 ternary_lift4 ternary_lift5 ternary_lift6 ternary_lift7
end

context
begin
  private lemma l1: "eval_ternary_Not tv = TernaryTrue \<Longrightarrow> tv = TernaryFalse"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma l2: "eval_ternary_And t1 t2 = TernaryFalse \<Longrightarrow> t1 = TernaryFalse \<or> t2 = TernaryFalse"
    using eval_ternary_And.elims by blast

  lemmas eval_ternaryD = l1 l2
end

end