(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

theory WellfoundedExtras
  imports Main Wellfounded Transitive_Closure
begin

text {* The accessible part of a relation has no trivial loops. *}
lemma no_self_loops:
  assumes accp: "Wellfounded.accp R x"
  shows "\<not>R x x"
proof -
  from accp
  have "R x x \<longrightarrow> False"
  proof(rule accp.induct, intro impI)
    fix x
    assume "R x x"
       and "\<And>y. R y x \<Longrightarrow> R y y \<longrightarrow> False"
    thus False by(blast)
  qed
  thus ?thesis by(blast)
qed

lemma tranclp_rtranclp_absorb:
  "(R\<^sup>+\<^sup>+)\<^sup>*\<^sup>* = R\<^sup>*\<^sup>*"
  by(intro ext, simp add:rtranclp_rtrancl_eq tranclp_unfold)

text {* The accessible part of the transitive closure of a relation is exactly that of the
  original relation. *}
lemma accp_tranclp:
  "Wellfounded.accp R\<^sup>+\<^sup>+ = Wellfounded.accp R"
proof(rule antisym)
  show "Wellfounded.accp R \<le> Wellfounded.accp R\<^sup>+\<^sup>+"
  proof
    fix x
    assume wf: "Wellfounded.accp R x"
    have "Wellfounded.accp R x \<longrightarrow> Wellfounded.accp R\<^sup>+\<^sup>+ x"
    proof(rule accp.induct[OF wf], intro impI)
      fix x
      assume IH1: "\<And>y. R y x \<Longrightarrow> Wellfounded.accp R y"
         and IH2: "\<And>y. R y x \<Longrightarrow> Wellfounded.accp R y \<longrightarrow> Wellfounded.accp R\<^sup>+\<^sup>+ y"
         and accpR: "Wellfounded.accp R x"
      show "Wellfounded.accp R\<^sup>+\<^sup>+ x"
      proof(rule accpI)
        fix y
        assume "R\<^sup>+\<^sup>+ y x"
        hence "tranclp (conversep R) x y" by(simp add:tranclp_converse)
        then obtain z where "(conversep R)\<^sup>*\<^sup>* z y" and "conversep R x z"
          by(blast dest:tranclpD)
        hence rest: "rtranclp R y z" and step: "R z x" by(auto dest:rtranclp_converseD)
        with IH1 IH2 have "Wellfounded.accp (tranclp R) z" by(blast)
        with rest show "Wellfounded.accp (tranclp R) y"
          by(auto intro:accp_downwards simp:tranclp_rtranclp_absorb)
      qed
    qed
    with wf show "Wellfounded.accp R\<^sup>+\<^sup>+ x" by(blast)
  qed

  from tranclp.r_into_trancl have "R \<le> R\<^sup>+\<^sup>+" by(auto)
  thus "Wellfounded.accp R\<^sup>+\<^sup>+ \<le> Wellfounded.accp R" by(rule accp_subset)
qed

text {* The accessible part of a relation contains no loops. *}
lemma no_loops:
  "Wellfounded.accp R x \<Longrightarrow> \<not>R\<^sup>+\<^sup>+ x x"
  by(rule no_self_loops[where R="R\<^sup>+\<^sup>+"], simp add:accp_tranclp)

lemmas no_loops_acc = no_loops[to_set]

lemma union_comprehension:
  "(\<Union>x\<in>{g y |y. P y}. f x) = (\<Union>{f (g y) |y. P y})"
  by(auto)

lemma compr_cong:
  assumes rw: "\<And>x. P x \<Longrightarrow> f x = g x"
  shows "{f x |x. P x} = {g x |x. P x}"
proof(intro antisym subsetI)
  fix y
  assume "y \<in> {f x |x. P x}"
  then obtain x where "P x" and "y = f x" by(auto)
  with rw show "y \<in> {g x |x. P x}" by(auto)
next
  fix y
  assume "y \<in> {g x |x. P x}"
  then obtain x where "P x" and "y = g x" by(auto)
  with rw[symmetric] show "y \<in> {f x |x. P x}" by(auto)
qed

lemma accp_image_pull:
  assumes accp: "Wellfounded.accp R x"
      and pull: "\<And>x y. S x (f y) \<Longrightarrow> \<exists>z. R z y \<and> x = f z"
    shows "Wellfounded.accp S (f x)"
  using accp
proof(induct)
  fix x
  assume accp: "Wellfounded.accp R x"
     and IH: "\<And>y. R y x \<Longrightarrow> Wellfounded.accp S (f y)"

  show "Wellfounded.accp S (f x)"
  proof
    fix y
    assume "S y (f x)"
    then obtain z where "R z x" "y = f z" by(blast dest:pull)
    thus "Wellfounded.accp S y" by(simp add:IH)
  qed
qed

lemma accp_image_push:
  assumes accp_f: "Wellfounded.accp S (f x)"
      and inj: "inj f"
      and homo: "\<And>x y. R x y \<Longrightarrow> S (f x) (f y)"
    shows "Wellfounded.accp R x"
proof -
  from accp_f have "f x \<in> range f \<Longrightarrow> Wellfounded.accp R (inv f (f x))"
  proof(induct)
    fix x
    assume accp_x: "Wellfounded.accp S x"
       and IH: "\<And>y. S y x \<Longrightarrow> y \<in> range f \<Longrightarrow> Wellfounded.accp R (inv f y)"
       and range: "x \<in> range f"

    show "Wellfounded.accp R (inv f x)"
    proof
      fix y
      assume "R y (inv f x)"
      hence "S (f y) (f (inv f x))" by(rule homo)
      with inj range have "S (f y) x" by(auto)
      hence "Wellfounded.accp R (inv f (f y))" by(blast intro:IH)
      with inj show "Wellfounded.accp R y" by(simp)
    qed
  qed
  with inj show ?thesis by(simp)
qed

end


section \<open>Coinductively Defined Operations Are Standard\<close>

(*<*)
theory Coinductive_Regular_Set
imports "Regular-Sets.Regular_Set" Coinductive_Language
begin
(*>*)

lemma to_language_empty[simp]: "to_language {} = Zero"
  by (coinduction) auto

lemma in_language_Zero[simp]: "\<not> in_language Zero xs"
  by (induct xs) auto

lemma in_language_One[simp]: "in_language One xs \<Longrightarrow> xs = []"
  by (cases xs) auto

lemma in_language_Atom[simp]: "in_language (Atom a) xs \<Longrightarrow> xs = [a]"
  by (cases xs) (auto split: if_splits)

lemma to_language_eps[simp]: "to_language {[]} = One"
  by (rule bij_is_inj[OF in_language_bij, THEN injD]) auto

lemma to_language_singleton[simp]: "to_language {[a]} = (Atom a)"
  by (rule bij_is_inj[OF in_language_bij, THEN injD]) auto

lemma to_language_Un[simp]: "to_language (A \<union> B) = Plus (to_language A) (to_language B)"
  by (coinduction arbitrary: A B) (auto simp: Collect_disj_eq)

lemma to_language_Int[simp]: "to_language (A \<inter> B) = Inter (to_language A) (to_language B)"
  by (coinduction arbitrary: A B) (auto simp: Collect_conj_eq)

lemma to_language_Neg[simp]: "to_language (- A) = Not (to_language A)"
  by (coinduction arbitrary: A) (auto simp: Collect_neg_eq)

lemma to_language_Diff[simp]: "to_language (A - B) = Inter (to_language A) (Not (to_language B))"
  by (auto simp: Diff_eq)

lemma to_language_conc[simp]: "to_language (A @@ B) = Times (to_language A) (to_language B)"
  by (coinduction arbitrary: A B rule: language_coinduct_upto_Plus)
    (auto simp: Deriv_def[symmetric])

lemma to_language_star[simp]: "to_language (star A) = Star (to_language A)"
  by (coinduction arbitrary: A rule: language_coinduct_upto_regular)
    (auto simp: Deriv_def[symmetric])

lemma to_language_shuffle[simp]: "to_language (A \<parallel> B) = Shuffle (to_language A) (to_language B)"
  by (coinduction arbitrary: A B rule: language_coinduct_upto_Plus)
    (force simp: Deriv_def[symmetric])

(*<*)
end
(*>*)


theory FiniteListGraph_Impl
imports
  FiniteListGraph
  (*"../../Collections/ICF/impl/RBTSetImpl" (*red black trees*)*)
    "~~/src/HOL/Library/RBT_Impl"
    "~~/src/HOL/Library/RBT"
  "~~/src/HOL/Library/Product_Lexorder"
  (*maybe import the following only at the end*)
  "Efficient_Distinct"
  "~~/src/HOL/Library/Code_Char"
  "~~/src/HOL/Library/Code_Target_Nat"
begin

text {* A graph's well-formed-ness can be tested with an executable function. *}
  fun wf_list_graph_impl::"'v list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> bool" where
    "wf_list_graph_impl V [] = True" |
    "wf_list_graph_impl V ((v1,v2)#Es) = (v1 \<in> set V \<and> v2 \<in> set V \<and> wf_list_graph_impl V Es)"

  lemma wf_list_graph_impl_axioms_locale_props:
    "wf_list_graph_impl V E \<longleftrightarrow> fst` set E \<subseteq> set V \<and> snd` set E \<subseteq> set V"
  by (induction E) auto

definition rbt_fromlist :: "'a list \<Rightarrow> ('a::linorder, unit) RBT.rbt" where
  "rbt_fromlist ls \<equiv> RBT.bulkload (map (\<lambda>l. (l, ())) ls)"
definition "rbt_contains a rbt \<equiv> RBT.lookup rbt a \<noteq> None"

lemma rbt_contains: "rbt_contains a (rbt_fromlist V) \<longleftrightarrow> a \<in> set V"
  apply(simp add: rbt_contains_def rbt_fromlist_def)
  apply(induction V)
   by(simp)+

  (*making the \<in> more efficient*)
  fun wf_list_graph_impl_rs::"('v::linorder,unit) RBT.rbt \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> bool" where
    "wf_list_graph_impl_rs V [] = True" |
    "wf_list_graph_impl_rs V ((v1,v2)#Es) = (rbt_contains v1 V \<and> rbt_contains v2 V \<and> wf_list_graph_impl_rs V Es)"

 lemma[code]: "wf_list_graph_impl V E = wf_list_graph_impl_rs (rbt_fromlist V) E"
   apply(induction E)
    apply(simp; fail)
   apply(rename_tac e Es)
   apply(case_tac e)
   by(simp add: rbt_contains)

  lemma[code]: "FiniteListGraph.wf_list_graph_axioms G = wf_list_graph_impl (nodesL G) (edgesL G)"
    by(simp add: FiniteListGraph.wf_list_graph_axioms_def wf_list_graph_impl_axioms_locale_props)

  text{*The list implementation matches the @{term "wf_graph"} definition*}
  theorem wf_list_graph_iff_wf_graph:
    "wf_graph (list_graph_to_graph G) \<longleftrightarrow> wf_list_graph_axioms G"
  apply(unfold list_graph_to_graph_def wf_graph_def wf_list_graph_axioms_def wf_list_graph_impl_axioms_locale_props)
    by simp
  corollary wf_list_graph_iff_wf_graph_simplified:
  "wf_graph \<lparr>nodes = set (nodesL G), edges = set (edgesL G)\<rparr> \<longleftrightarrow> wf_list_graph_axioms G"
  apply(simp add: wf_list_graph_iff_wf_graph[unfolded list_graph_to_graph_def, simplified])
  done

text {* Code examples. *}
  definition wf_graph_example where
  "wf_graph_example \<equiv> \<lparr> nodesL = [1::nat,4,6], edgesL = [(1,4), (1,6), (6,4)] \<rparr>"

  value "wf_list_graph wf_graph_example"

  definition wf_graph_impl_example where
  "wf_graph_impl_example \<equiv> wf_list_graph wf_graph_example"

  export_code wf_list_graph empty add_node delete_node add_edge delete_edge in Scala

end


theory Index
imports Vector
begin

definition incr :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "incr x y = (if x \<le> y then Suc y else y)"

definition decr :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "decr x y = (if x < y then y - 1 else y)"

definition var_reduce :: "nat \<Rightarrow> nat set \<Rightarrow> nat set" where
  "var_reduce x xs = decr x ` (xs - {x})"

lemma [simp]: "lookup (insert_at x a' as) y = Some a \<Longrightarrow> x \<le> length as \<Longrightarrow> x \<noteq> y \<Longrightarrow>
    lookup as (decr x y) = Some a"
  by (cases y) (auto simp add: decr_def)

lemma [simp]: "x < length as \<Longrightarrow> lookup (remove as x) y = lookup as (incr x y)"
  proof (induction as x arbitrary: y rule: remove.induct)
  case 3
    thus ?case by (induction y) (simp_all add: incr_def)
  qed (simp_all add: incr_def)

lemma [simp]: "x \<ge> length as' \<Longrightarrow> lookup as (x - length as') = lookup (as' @ as) x"
  proof (induction as' arbitrary: x)
  case Cons
    thus ?case by (induction x) simp_all
  qed simp_all

lemma [simp]: "incr 0 x = Suc x"
  by (simp add: incr_def)

lemma [simp]: "incr (Suc x) 0 = 0"
  by (simp add: incr_def)

lemma [simp]: "incr x x = Suc x"
  by (simp add: incr_def)

lemma [simp]: "incr y x \<noteq> y"
  by (simp add: incr_def)

lemma [simp]: "decr y (incr y x) = x"
  by (simp add: incr_def decr_def)

lemma [simp]: "decr x (Suc x) = x"
  by (simp add: decr_def)

lemma [simp]: "decr 0 (Suc x) = x"
  by (simp add: decr_def)

lemma [simp]: "x \<noteq> y \<Longrightarrow> incr y (decr y x) = x"
  by (auto simp add: incr_def decr_def)

lemma [simp]: "y \<noteq> x \<Longrightarrow> decr (Suc y) (incr y x) = x"
  by (simp add: incr_def decr_def)

lemma [simp]: "y \<le> x \<Longrightarrow> incr y (incr x z) = incr (Suc x) (incr y z)"
  by (simp add: incr_def)

lemma [simp]: "y \<le> x \<Longrightarrow> y \<noteq> z \<Longrightarrow> decr y (incr (Suc x) z) = incr x (decr y z)"
  by (auto simp add: incr_def decr_def)

lemma [simp]: "y \<le> x \<Longrightarrow> incr y (decr x z) = decr (Suc x) (incr y z)"
  by (auto simp add: incr_def decr_def)

lemma [simp]: "y \<notin> xs \<Longrightarrow> (x \<in> decr y ` xs) = (incr y x \<in> xs)"
  proof rule
    assume "x \<in> decr y ` xs"
    then obtain x' where X: "x' \<in> xs \<and> x = decr y x'" by auto
    moreover assume "y \<notin> xs"
    moreover with X have "y \<noteq> x'" by auto
    ultimately show "incr y x \<in> xs" by simp
  next
    assume "incr y x \<in> xs"
    moreover hence "x = decr y (incr y x)" by simp
    ultimately show "x \<in> decr y ` xs" by blast
  qed

lemma [simp]: "(x \<in> var_reduce y xs) = (incr y x \<in> xs)"
  by (simp add: var_reduce_def)

lemma [simp]: "(x \<in> incr y ` xs) = (if x = y then False else decr y x \<in> xs)"
  proof -
    have "(x \<in> (\<lambda>z. incr y z) ` xs) = (if x = y then False else decr y x \<in> xs)"
      by (cases x) (auto simp add: incr_def decr_def)
    thus "(x \<in> incr y ` xs) = (if x = y then False else decr y x \<in> xs)" by simp
  qed

lemma [simp]: "y \<le> x \<Longrightarrow> var_reduce y (incr (Suc x) ` xs) = incr x ` var_reduce y xs"
  by (auto split: if_splits) (auto simp add: incr_def)

lemma [simp]: "var_reduce x (incr x ` xs) = xs"
  by auto

lemma [simp]: "x \<notin> xs \<Longrightarrow> incr x ` decr x ` xs = xs"
  by (auto simp add: decr_def incr_def)

lemma [simp]: "incr x ` var_reduce x xs = xs - {x}"
  by (simp add: var_reduce_def)

lemma [simp]: "y \<le> x \<Longrightarrow> var_reduce y (insert (Suc x) xs) = insert x (var_reduce y xs)"
  by (auto simp add: incr_def split: if_splits)

lemma [simp]: "y \<le> x \<Longrightarrow> Suc x \<notin> xs \<Longrightarrow> var_reduce y (decr (Suc x) ` xs) = decr x ` var_reduce y xs"
  by (auto simp add: incr_def decr_def split: if_splits)

lemma [simp]: "y \<le> x \<Longrightarrow> var_reduce y (var_reduce (Suc x) xs) = var_reduce x (var_reduce y xs)"
  by auto

lemma [simp]: "var_reduce x (xs \<union> ys) = var_reduce x xs \<union> var_reduce x ys"
  by (auto simp add: var_reduce_def)

lemma [simp]: "var_reduce 0 xs \<inter> (op +) y ` ys = {} \<Longrightarrow> xs \<inter> (op +) (Suc y) ` ys = {}"
  by (auto simp add: var_reduce_def)

lemma [simp]: "var_reduce x {x} = {}"
  by (simp add: var_reduce_def)

lemma [simp]: "var_reduce x {} = {}"
  by (simp add: var_reduce_def)

lemma [simp]: "x \<notin> set xs \<Longrightarrow> distinct xs \<Longrightarrow> distinct (map (decr x) xs)"
  by (induction xs) simp_all

lemma [simp]: "y < Suc k \<Longrightarrow> x < Suc k \<Longrightarrow> x \<noteq> y \<Longrightarrow> decr x y < k"
  by (auto simp add: decr_def)

lemma [simp]: "finite xs \<Longrightarrow> finite (var_reduce x xs)"
  by (simp add: var_reduce_def)

end


theory Bellman_Ford_Tryconstruct
  imports "../DP_Lifting" "../DP_CRelVS" "../DP_Proof"
begin

consts n :: nat
consts W :: "nat \<Rightarrow> nat \<Rightarrow> int"
term 0 (**)

  (*
fun bf :: "nat\<times>nat \<Rightarrow> int" where
  "bf (0,j) = W 0 j"
| "bf (Suc k, j) = fold min [bf (k, i) + W i j. i \<leftarrow> [0..<n]] (bf (k, j))"
term 0 (**)
*)

fun bf :: "nat\<times>nat \<Rightarrow> int" where
  "bf (0, j) = W 0 j"
| "bf (Suc k, j) =
    fold
      (min)
      (map
          (\<lambda>i. plus (W i j) (bf (k, i)))
          (upt 0 n))
      (bf (k, j))"
thm bf.simps
thm bf.induct
term 0 (**)

lemma map\<^sub>T_return_return_cong[fundef_cong]:
  fixes f g xs
  assumes "\<And>x. x\<in>set xs \<Longrightarrow> f x = g x"
  shows "map\<^sub>T . \<langle>f\<rangle> . \<langle>xs\<rangle> = map\<^sub>T . \<langle>g\<rangle> . \<langle>xs\<rangle>"
  sorry
term 0 (**)

fun bf\<^sub>T :: "nat\<times>nat \<Rightarrow>\<^sub>T int" where
  "bf\<^sub>T$ (0, j) =CHECKMEM= \<langle>W 0 j\<rangle>"
| "bf\<^sub>T$ (Suc k, j) =CHECKMEM=
    fold\<^sub>T
    . min\<^sub>T
    . (map\<^sub>T
      . (\<lambda>\<^sub>Ti. plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i)))
      . \<langle>upt 0 n\<rangle>)
    . (bf\<^sub>T (k, j))"
thm bf\<^sub>T.simps
thm bf\<^sub>T.induct
term 0 (**)

interpretation bf: dp_consistency bf .

notation bf.rel_fun_lifted (infixr "===>\<^sub>T" 55)

notepad
begin

  {
    fix j::nat
    have "W 0 j = W 0 j"
      by (fact refl)
    have "bf.crel_vs op = (W 0 j) \<langle>W 0 j\<rangle>"
      by (fact bf.crel_vs_return[where R="op =", OF \<open>W 0 j = W 0 j\<close>])
  }
next
  {
    fix k::nat and j::nat
    assume IH1: "bf.crel_vs op = (bf (k, j)) (bf\<^sub>T (k, j))"
    assume IH2: "x \<in> set [0..<n] \<Longrightarrow> bf.crel_vs op = (bf (k, x)) (bf\<^sub>T (k, x))" for x
    note bf.fold_transfer
    note bf.min_transfer
    have "bf.crel_vs (list_all2 op = ===>\<^sub>T op = ===>\<^sub>T op =) (fold min) (fold\<^sub>T . min\<^sub>T)"
      by (fact bf.crel_vs_fun_app[OF bf.fold_transfer, OF bf.min_transfer])
    {
      fix i::nat
      assume "i \<in> set [0..<n]"
      note bf.plus_transfer
      have "W i j = W i j"
        by (fact refl)
      have "bf.crel_vs op = (W i j) \<langle>W i j\<rangle>"
        by (fact bf.crel_vs_return[where R="op =", OF \<open>W i j = W i j\<close>])
      have "bf.crel_vs (op = ===>\<^sub>T op =) (op + (W i j)) (plus\<^sub>T . \<langle>W i j\<rangle>)"
        by (fact bf.crel_vs_fun_app[OF bf.plus_transfer, OF \<open>bf.crel_vs op = (W i j) \<langle>W i j\<rangle>\<close>])
      note IH2
      have "bf.crel_vs op = (bf (k, i)) (bf\<^sub>T (k, i))"
        by (fact IH2[OF \<open>i \<in> set [0..<n]\<close>])
      have "bf.crel_vs op = (W i j + bf (k, i)) (plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i)))"
        by (fact bf.crel_vs_fun_app[OF \<open>bf.crel_vs (op = ===>\<^sub>T op =) (op + (W i j)) (plus\<^sub>T . \<langle>W i j\<rangle>)\<close> \<open>bf.crel_vs op = (bf (k, i)) (bf\<^sub>T (k, i))\<close>])
          thm \<open>bf.crel_vs op = ((\<lambda>i. W i j + bf (k, i)) i) ((\<lambda>i. plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i))) i)\<close>
      have "bf.crel_vs op = ((\<lambda>i. W i j + bf (k, i)) i) ((\<lambda>i. plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i))) i)"
        by (fact \<open>bf.crel_vs op = (W i j + bf (k, i)) (plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i)))\<close>)
    }
    have "list_all2 op = [0..<n] [0..<n]"
      by (fact refl[of "[0..<n]", folded list.rel_eq])
    have "bf.crel_vs (list_all2 op =) [0..<n] \<langle>[0..<n]\<rangle>"
      by (insert \<open>list_all2 op = [0..<n] [0..<n]\<close>) (fact bf.crel_vs_return)
      term 0 (**
    have "bf.crel_vs op = [0..<n] \<langle>[0..<n]\<rangle>"
      by (fact bf.crel_vs_return[where R="op =", OF \<open>[0..<n] = [0..<n]\<close>])
    have "bf.crel_vs op = (map (\<lambda>i. W i j + bf (k, i)) [0..<n]) (map\<^sub>T . \<langle>\<lambda>i. plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i))\<rangle> . \<langle>[0..<n]\<rangle>)"
      by (insert \<open>\<And>i. i \<in> set [0..<n] \<Longrightarrow> bf.crel_vs op = (W i j + bf (k, i)) (plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i)))\<close> \<open>bf.crel_vs op = [0..<n] \<langle>[0..<n]\<rangle>\<close>) (fact bf.crel_vs_map_simple)
        have
term 0 (*
    ML_prf \<open>
val t0 = @{thm bf.crel_vs_map_simple};
val t1 = @{thm \<open>\<And>i. i \<in> set [0..<n] \<Longrightarrow> bf.crel_vs op = (W i j + bf (k, i)) (plus\<^sub>T . \<langle>W i j\<rangle> . (bf\<^sub>T (k, i)))\<close>};
val t2 = @{thm \<open>bf.crel_vs op = [0..<n] \<langle>[0..<n]\<rangle>\<close>};
t0 OF [t1, t2];
(*Drule.compose (t0, 1, t1);*)
\<close>
  }
end
  term 0 (*
lemma "list_all2 op = l l"
  thm list.rel_eq list_all2_eq
    thm bf.map_transfer_inset_unfolded'
    term option.rel_option
    term list.list_all2
    ML_prf \<open>
[@{type_name list}, @{type_name option}, @{type_name prod}, @{type_name fun}]
|> map (BNF_Def.rel_of_bnf o the o BNF_Def.bnf_of @{context});
\<close>
    have "cre(map (\<lambda>i. plus (W i j) (bf (k, i))) (upt 0 n))"
      thm map_cong


theory TC_To_ChrN_Aux
  imports Main "HOL-ex.Sketch_and_Explore" "HOL-Eisbach.Eisbach" "../CNF_SAT_To_TC/TS_To_TC"
begin

lemma nodes_different:"ugraph E \<Longrightarrow> {{(v1, 0), (v2, 0)} |v1 v2. {v1, v2} \<in> E} =
                                    {{(v1, 0), (v2, 0)} |v1 v2. {v1, v2} \<in> E \<and> v1 \<noteq> v2} "
  unfolding ugraph_def
  by fastforce

lemma nodes_different2:"ugraph E \<Longrightarrow>  {{(v1, 0), (v2, 0)} |v1 v2. {v1, v2} \<in> E} \<subseteq>
                                      {{(v1, 0), (v2, 0)} |v1 v2. v1\<in>(\<Union>E) \<and> v2\<in>(\<Union>E) \<and> v1 \<noteq> v2}"
  unfolding ugraph_def
  by (smt Collect_mono_iff Sup_upper card_2_iff doubleton_eq_iff insert_subset)

lemma chromatik_card2:"ugraph E \<Longrightarrow> (\<forall>e\<in>{{(v1, 0), (v2, 0)} |v1 v2. {v1, v2} \<in> E}. card e = 2)"
proof -
  assume asms: "ugraph E"
  from asms have "\<forall> v1 v2. {v1, v2} \<in> E \<longrightarrow> v1 \<noteq> v2"
    unfolding ugraph_def
    by auto
  from this have "\<forall> v1 v2. {v1, v2} \<in> E \<longrightarrow> (v1, 0) \<noteq> (v2, 0)"
    by blast
  from this show ?thesis
    by auto
qed

lemma card_one_para: "card {{(ca, cb), (cc, k)} |k. k \<in> {1..x}} = x"
proof (induction x)
  case 0
  then show ?case
    by simp
next
  case (Suc x)
  define nodes where nodes_def:"nodes={{(ca, cb), (cc, k)} |k. k \<in> {1..Suc x}}"
  define split1 where split1_def:"split1 = {{(ca, cb), (cc, k)} |k. k \<in> {1..x}}"
  define split2 where split2_def:"split2 = {{(ca, cb), (cc, Suc x)}}"
  have "\<forall>k. k \<in> {1..x} \<longrightarrow> k \<noteq> Suc x"
    by auto
  from this split1_def split2_def have split_dis:"split1 \<inter> split2 = {}"
    by (smt Pair_inject disjoint_iff_not_equal doubleton_eq_iff mem_Collect_eq singletonD)
  from split1_def have fin1:"finite split1"
    by auto
  from split2_def have fin2:"finite split2"
    by auto
  have
        "{{(ca, cb), (cc, k)} |k. k \<in> {1..Suc x}} =
          {{(ca, cb), (cc, k)} |k. k \<in> {1..x}} \<union>
          {{(ca, cb), (cc, Suc x)}} "
    by fastforce
  from this split1_def split2_def nodes_def have "nodes = split1 \<union> split2"
    by fastforce
  from this split_dis card_Un_disjoint fin1 fin2 have "card nodes = card split1 + card split2"
    by blast
  from this Suc show ?case
    by (simp add:  nodes_def split1_def split2_def)
qed

lemma card_one_para2: "finite (\<Union>E) \<Longrightarrow> card {{(ca, cb), (v, cc)} |v. v \<in> (\<Union>E)} = card (\<Union>E)"
proof (induction "card (\<Union>E)"  arbitrary: E)
  case 0
  from this have "(\<Union>E) = {}"
    by simp
  then show ?case
    by (simp add: card_eq_0_iff equals0D)
next
  case (Suc x)
  from Suc(2) have "\<Union>E \<noteq> {}"
    by fastforce
  from this Suc(2) Suc(3) obtain E' v where E'_def:
    "\<Union>E = \<Union>E' \<union> {v} \<and> \<Union>E' \<inter> {v} = {}"
    unfolding ugraph_def
    by (metis Int_empty_right Int_insert_right_if0
        Un_empty_right Un_insert_right all_not_in_conv
        ccpo_Sup_singleton mk_disjoint_insert)
  from E'_def Suc(2) have E'_card:"x = card (\<Union>E')"
    using Suc.prems by auto
  from E'_def Suc(3) have finE':"finite (\<Union>E')"
    by auto

  define nodes where nodes_def:"nodes={{(ca, cb), (v, cc)} |v. v \<in> (\<Union>E)}"
  define split1 where split1_def:"split1 = {{(ca, cb), (v, cc)} |v. v \<in> (\<Union>E')}"
  define split2 where split2_def:"split2 = {{(ca, cb), (v, cc)}}"

  from E'_def have "\<forall>x\<in>E'. v \<notin> x"
    by blast
  from this have split_dis:"split1 \<inter> split2 = {}"
    unfolding split1_def split2_def
    apply auto
    by (metis doubleton_eq_iff prod.inject)

  from Suc(1) finE' E'_card have card1:"card split1 = card (\<Union> E')"
    unfolding split1_def
    by blast
  from this have fin1:"finite split1"
  proof (cases "card split1 = 0")
    case True
    from this card1 have "card (\<Union> E') = 0"
      by argo
    from this finE' have "\<Union>E' = {}"
      by simp
    then show ?thesis
      unfolding split1_def
      by (simp add: \<open>\<Union> E' = {}\<close>)
  next
    case False
    then show ?thesis
      by (simp add: card_eq_0_iff)
  qed

  from split2_def have fin2:"finite split2"
    by auto

  from E'_def have
        "{{(ca, cb), (v, cc)} |v. v \<in> (\<Union>E)} =
         {{(ca, cb), (v, cc)} |v. v \<in> (\<Union>E')} \<union>
         {{(ca, cb), (v, cc)}} "
    by auto
  from this split1_def split2_def nodes_def have "nodes = split1 \<union> split2"
    by fastforce
  from this split_dis card_Un_disjoint fin1 fin2 have "card nodes = card split1 + card split2"
    by blast
  from this card1 Suc(2) E'_card show ?case
    unfolding nodes_def split2_def
    by simp
qed

lemma chromatik_card1:"ugraph E \<Longrightarrow>
  card {{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E} =  card E"
proof (induction "card E" arbitrary: E)
  case zero:0
  then show ?case
  proof (cases "E = {}")
    case True
    then show ?thesis
      by simp
  next
    case False
    from this zero(1) have E_infin:"infinite E"
      by fastforce
    from this zero(2) have "False" unfolding ugraph_def
      by blast
    from this show ?thesis
      by simp
  qed
next
  case (Suc x)
  from Suc(2) have E_fin:"finite E"
    using card.infinite by fastforce
  from Suc(2) have "E \<noteq> {}"
    by auto
  from this Suc(2) Suc(3) obtain E' ver1 ver2 where E'_def:
    "E = E' \<union> {{ver1,ver2}} \<and> E' \<inter> {{ver1,ver2}} = {}"
    unfolding ugraph_def
    by (metis Int_empty_right Int_insert_right_if0 Un_empty_right
        Un_insert_right card_2_iff equals0I mk_disjoint_insert)
  from this Suc(2) have E'_card:"card E' = x"
    by (metis Un_empty_right Un_insert_right Zero_not_Suc card.infinite
        card_insert_disjoint disjoint_insert(2) finite_Un old.nat.inject)
  from E'_def E_fin have E'_fin:"finite E'"
    by blast
  from E'_def have E'subE:"E' \<subseteq> E"
    by blast
  from this Suc(3) E'_fin have E'_ugraph:"ugraph E'" unfolding ugraph_def
    by blast
  define E'split1 where E'split1_def: "E'split1 = {{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E'}"
  define E'split2 where E'split2_def: "E'split2 = {{(ver1, 0::nat), (ver2, 0)}}"
  from E'_ugraph Suc(1)[where E = E'] E'_card E'split1_def have cardspliteq:"card E'split1 = card E'"
    by blast
  from this E'split1_def have split_fin:"finite E'split1"
    using E'_fin card.infinite by fastforce
  from E'split2_def have cardspliteq2:"card E'split2 = 1"
    by simp

  from E'split2_def have split_fin2:"finite E'split2"
    by blast
  from E'_def have graph_split:"{{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E} = E'split1 \<union> E'split2"
    by (auto simp: E'split1_def E'split2_def)
  from E'_def have "E'split1 \<inter> E'split2 = {}"
    apply (simp add: E'split1_def E'split2_def)
    by (metis Pair_inject doubleton_eq_iff)
  from this split_fin split_fin2 card_Un_disjoint have
                   "card (E'split1 \<union> E'split2) = card E'split1 + card E'split2"
    by blast
  from this graph_split have
                   "card {{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E} =
                    card E'split1 + card E'split2"
    by presburger
  from this cardspliteq2 cardspliteq have "card {{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E} = card E' + 1"
    by argo
  from this E'_card Suc(2)  show ?case
    by presburger
qed

lemma splitNaturalNumbers:"k \<in> {1.. (Suc x)} \<longleftrightarrow> k \<in> {1..(x)} \<or> k = Suc x"
  using le_Suc_eq by auto

lemma finite_chrn1:
"finite (\<Union>E) \<Longrightarrow> finite {{(v1, 0), (0, Suc x)} |v1. v1 \<in> \<Union> E} "
proof -
  assume asms: "finite (\<Union>E)"
  let ?S = "(((\<Union>E)\<times>{0}) \<times> ({0}\<times> {Suc x}))"
  from asms show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma card_para2: "finite (\<Union>E) \<Longrightarrow> card {{(v1, 0), (0, Suc x)} |v1. v1 \<in> \<Union> E} = card (\<Union>E)"
proof (induction "card (\<Union>E)" arbitrary: E)
  case zero:0
  then show ?case
  proof (cases "(\<Union>E) = {}")
    case True
    from this zero show ?thesis
      by (smt card_0_eq card.infinite empty_Collect_eq empty_iff)
  next
    case False
    from this zero(1) have "infinite (\<Union>E)"
      by force
    from this zero(2) have "False"
      by blast
    then show ?thesis by simp
  qed
next
  case (Suc n)
  from Suc(2) have "\<Union>E \<noteq> {}"
    by fastforce
  from this Suc(2) Suc(3) obtain E' v where E'_def:
    "\<Union>E = \<Union>E' \<union> {v} \<and> \<Union>E' \<inter> {v} = {}"
    unfolding ugraph_def
    by (metis Int_empty_right Int_insert_right_if0
        Un_empty_right Un_insert_right all_not_in_conv
        ccpo_Sup_singleton mk_disjoint_insert)
  from E'_def Suc(2) have E'_card:"card (\<Union>E') = n"
    using Suc.prems by auto
  from E'_def have fin_E':"finite (\<Union>E')"
    using Suc.prems by auto

  define split1 where split1_def: " split1 = {{(v1, 0), (0, Suc x)} |v1. v1 \<in> \<Union> E'}"
  define split2 where split2_def: " split2 = {{(v, 0), (0, Suc x)}}"
  from split1_def fin_E' have fin1:"finite split1" using finite_chrn1
    by blast
  from split2_def have fin2:"finite split2"
    by blast
  from E'_def split1_def split2_def have split_dis:"split1 \<inter> split2 = {}"
    by fastforce
  from split1_def fin_E' Suc(1) E'_card have split1_card:"card split1 = n"
    by blast
  from split1_def split2_def E'_def have "{{(v1, 0), (0, Suc x)} |v1. v1 \<in> \<Union> E} = split1 \<union> split2 "
    by auto
  from this fin1 fin2 split_dis have "card {{(v1, 0), (0, Suc x)} |v1. v1 \<in> \<Union> E} = card split1 + card split2"
    using card_Un_disjoint
    by fastforce
  from this split1_card Suc(2) split2_def show ?case
    by simp
qed

lemma chromatik_card3:"finite (\<Union>E) \<Longrightarrow>
  card {{(v1, 0), (0, k)} |v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} =  card (\<Union>E) * card (\<Union>E)"
proof (induction "card (\<Union> E)" arbitrary: E)
  case zero:0
  then show ?case
  proof (cases "\<Union> E = {}")
    case True
    from this zero show ?thesis
      by auto
  next
    case False
    from this zero(1) have E_infin:"infinite (\<Union> E)"
      by fastforce
    from this zero(2) have "False" unfolding ugraph_def
      using finite_Union by fastforce
    from this show ?thesis
      by simp
  qed
next
  case (Suc x)
  from Suc(2) have "\<Union>E \<noteq> {}"
    by fastforce
  from this Suc(2) Suc(3) obtain E' v where E'_def:
    "\<Union>E = \<Union>E' \<union> {v} \<and> \<Union>E' \<inter> {v} = {}"
    unfolding ugraph_def
    by (metis Int_empty_right Int_insert_right_if0
        Un_empty_right Un_insert_right all_not_in_conv
        ccpo_Sup_singleton mk_disjoint_insert)
  from E'_def Suc(2) have E'_card:"card (\<Union>E') = x"
    using Suc.prems by auto
  define split1 where split1_def: "split1 = {{(v1, 0::nat), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<and> (k \<in> {1..(x)}))}"
  define split2 where split2_def: "split2 = {{(v, 0::nat), (0, k)} |k. ((k \<in> {1..(x)}))}"
  define split3 where split3_def: "split3 = {{(v1, 0::nat), (0, Suc x)} |v1. (v1\<in> (\<Union> E'))}"
  define split4 where split4_def: "split4 = {{(v, 0::nat), (0, Suc x)}}"
  from E'_def have fin_E':"finite (\<Union>E')"
    using Suc.prems by auto
  from this Suc(1)[where E = E'] E'_card split1_def have split1_card:"card split1 =x*x"
    by blast
  from fin_E' split2_def E'_card have split2_card:"card split2 = x"
    using card_one_para
    by fast
  from fin_E' split3_def E'_card have split3_card:"card split3 = x"
    using card_para2
    by blast
  from split4_def have split4_card:"card split4 = 1"
    by simp
  from split1_def split2_def split3_def split4_def have disjoint1:"(split1 \<union> split2) \<inter> (split3 \<union> split4) = {}"
    by auto
  from  E'_def have disjoint2:"split1 \<inter> split2 = {}"
    apply (simp add: split1_def split2_def)
    by (auto simp: doubleton_eq_iff)
  from E'_def have disjoint3:"split3 \<inter> split4 = {}"
    apply (simp add: split3_def split4_def)
    by fast

  from fin_E' split1_def split1_card have fin1:"finite split1"
    by auto

   from split2_def split2_card have fin2:"finite split2"
     by simp

   from fin_E' split3_def split3_card have fin3:"finite split3"
     by (smt E'_card card_0_eq card.infinite empty_Collect_eq empty_iff finite.emptyI)

  from split4_def split4_card have fin4:"finite split4"
    by blast

  from E'_def Suc(2) have step1:"{{(v1, 0), (0, k)} |v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} =
        {{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<or> v1 = v) \<and> (k \<in> {1..Suc(x)}) }"
    by auto
  from E'_def have "{{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<or> v1 = v) \<and> (k \<in> {1..Suc(x)}) } =
        {{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<and> (k \<in> {1..(x)}))} \<union>
        {{(v1, 0), (0, k)} |v1 k. (v1 = v \<and> (k \<in> {1..(x)}))}\<union>
        {{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<and> (k = Suc x))}\<union>
        {{(v1, 0), (0, k)} |v1 k. (v1 = v \<and> (k = Suc x))}"
    using splitNaturalNumbers[where x= x]
    by fast
  from this split1_def split2_def split3_def split4_def have
        "{{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<or> v1 = v) \<and> (k \<in> {1..Suc(x)}) } =
        split1 \<union> split2 \<union> split3 \<union> split4"
    by simp
  from this fin1 fin2 fin3 fin4 disjoint1 disjoint2 disjoint3 have
       "card {{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<or> v1 = v) \<and> (k \<in> {1..Suc(x)}) } =
        card split1 + card split2 + card split3 + card split4"
    using card_Un_disjoint
    by (metis (no_types, lifting) Suc_eq_plus1 Un_assoc add_Suc_right finite_UnI split4_card)
  from this split1_card split2_card split3_card split4_card have
    "card {{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<or> v1 = v) \<and> (k \<in> {1..Suc(x)}) } = x * x + x + x +1 "
    by argo
  from this have
    "card {{(v1, 0), (0, k)} |v1 k. (v1\<in> (\<Union> E') \<or> v1 = v) \<and> (k \<in> {1..Suc(x)}) } = Suc x * Suc x"
    by simp

  from this Suc(2) show ?case
    using step1 by auto
qed

lemma card_additional_nodes:"card {{(0::nat, n)} |n. n \<in> {1..x}} = x"
proof (induction x)
  case 0
  then show ?case
    by simp
next
  case (Suc x)
  define step1 where step1_def:"step1= {{(0::nat, n)} |n. n \<in> {1..x}}"
  define step2 where step2_def:"step2= {{(0::nat, n)} |n. n = Suc x}"
  from step1_def step2_def have un:"{{(0::nat, n)} |n. n \<in> {1..Suc x}} = (step1 \<union> step2)"
    by force
  from step1_def Suc have card1:"card step1 = x"
    by blast
  from step2_def have card2:"card step2 = 1"
    by auto
  from card1 step1_def have fin1: "finite step1"
    by auto
  from card2 step2_def have fin2: "finite step2"
    by auto
  from step1_def step2_def have disjoint:"step1 \<inter> step2 = {}"
    by simp
  from disjoint un fin1 fin2 have "card {{(0::nat, n)} |n. n \<in> {1..Suc x}} = card step1 + card step2"
    using card_Un_disjoint[where A = step1 and B = step2]
    by presburger
  from this card1 card2 show ?case
    by presburger
qed

lemma finite_chrn2:
"finite {{(0::nat, k), (0, k')} |k k'. ((k \<in> {1..x::nat}\<and>k' \<in> {1..x} \<and> k \<noteq> k'))}"
proof -
  let ?S = "(({0}\<times>{1..x}) \<times> ({0}\<times> {1..x}))"
  show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma chromatik_card4:"
  card {{(0::nat, k), (0::nat, k')} |k k'. k \<in> {1..x} \<and> k' \<in> {1..x} \<and> k \<noteq> k'} =
  (x * (x-1)) div 2"
proof (induction "x")
  case zero:0
  then show ?case
    by auto
next
  case (Suc x)
  define graph where graph_def: "graph = {{(0::nat, k), (0, k')} |k k'. k \<in> {1..Suc x} \<and> k' \<in> {1..Suc x} \<and> k \<noteq> k'}"
  define split1 where split1_def: "split1 = {{(0::nat, k), (0, k')} |k k'. ((k \<in> {1..x}\<and>k' \<in> {1..x} \<and> k \<noteq> k'))}"
  define split2 where split2_def: "split2 = {{(0::nat, k), (0, k')} |k k'. ((k \<in> {1..x} \<and> k' = Suc x \<and> k \<noteq> k'))}"
  define split3 where split3_def: "split3 = {{(0::nat, k), (0, k')} |k k'. ((k = Suc x \<and> k' \<in> {1..x} \<and> k \<noteq> k'))}"
  define split4 where split4_def: "split4 = {{(0::nat, k), (0, k')} |k k'. ((k = Suc x \<and> k' = Suc x \<and> k \<noteq> k'))}"
  from split2_def have split2_def': "split2 = {{(0::nat, k), (0, Suc x)} |k . k \<in> {1..x}}"
    by fastforce
  from split3_def have split3_def': "split3 = {{(0::nat, k), (0, Suc x)} |k . k \<in> {1..x}}"
    by fastforce
  from split2_def' split3_def' have sp2sp3_eq:"split2 = split3"
    by argo
  from split4_def have sp4_empty:"split4 = {}"
    by blast

  define split_step where split_step_def:
      "split_step = {{(0::nat, k), (0, k')} |k k'. (k \<in> {1..x} \<or> k = Suc x) \<and> (k' \<in> {1..x} \<or> k' = Suc x)\<and> k \<noteq> k'}"
  from split_step_def graph_def have sp_1:" graph =
          split_step"
    by fastforce
  from split_step_def have sp_2:"split_step =
        {{(0, k), (0, k')} |k k'. ((k \<in> {1..x}\<and>k' \<in> {1..x} \<and> k \<noteq> k'))} \<union>
        {{(0, k), (0, k')} |k k'. ((k \<in> {1..x} \<and> k' = Suc x \<and> k \<noteq> k'))} \<union>
        {{(0, k), (0, k')} |k k'. ((k = Suc x \<and> k' \<in> {1..x} \<and> k \<noteq> k'))} \<union>
        {{(0, k), (0, k')} |k k'. ((k = Suc x \<and> k' = Suc x \<and> k \<noteq> k'))}"
    by auto
  from sp_1 sp_2 have "graph = split1 \<union> split2 \<union> split3 \<union> split4"
    by (simp add: split1_def split2_def split3_def split4_def)

  from this sp2sp3_eq sp4_empty have graph_split:
    "graph = split1 \<union> split2"
    by auto

  from split1_def Suc have split1_card:"card split1 = (x * (x-1)) div 2"
    by simp

  from split2_def have split2_card:"card split2 = x"
  proof -
    from split2_def have "split2 = {{(0::nat, k), (0, Suc x)} |k.  (k \<in> {1..x} )}"
      by fastforce
    from this have "split2 = {{(0, Suc x), (0::nat, k)} |k.  (k \<in> {1..x} )}"
      by blast
    from this show "card split2 = x"
      using card_one_para[where ca = "0::nat" and cb = "Suc x" and cc = "0::nat" and x= x] by simp
  qed

  have disjoint:"split1 \<inter> split2 = {}"
    apply (simp add: split1_def split2_def)
    by (auto simp: doubleton_eq_iff)

  have fin1:"finite split1"
    using finite_chrn2
    by (simp add: split1_def)
  have fin2: "finite split2"
    by (simp add: split2_def)

  from graph_split fin1 fin2 disjoint have
    " card graph =
      card split1 + card split2 "
    using card_Un_disjoint[where A = split1 and B = split2] by simp

  from this split1_card split2_card have " card graph =
      (x * (x-1)) div 2 + x "
    by argo

  from this have " card graph =
      ((x * (x-1)) + (2*x)) div 2"
    by simp
  from this show ?case
    by (metis add.commute diff_Suc_1 graph_def left_add_twice mult.commute mult_Suc mult_eq_if)
qed

lemma connection_card:"card {{(0::nat, k), (0::nat, k')} |
                        k k'. k \<in> {1..(card (\<Union>E))} \<and>
                              k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'} =
                              ((card (\<Union>E)) * ((card (\<Union>E))-1)) div 2"
  using chromatik_card4
  by blast

lemma chromatik_finite1:"ugraph E \<Longrightarrow>
  finite {{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E}"
proof -
  assume asms: "ugraph E"
  from this have "card {{(v1, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E} = card E"
    by (simp add: chromatik_card1)
  from this asms show ?thesis unfolding ugraph_def
    using card.infinite by fastforce
qed

lemma chromatik_finite2:"finite (\<Union>E) \<Longrightarrow>
  finite {{(v1, 0), (0, k)} |v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
proof -
  assume asms: "finite (\<Union>E)"
  from this have "card {{(v1, 0), (0, k)} |v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} = card (\<Union>E) * card (\<Union>E)"
    using chromatik_card3
    by blast
  from this asms show ?thesis
    using card.infinite not_finite_existsD by fastforce
qed

lemma chromatik_finite3:"finite (\<Union>E) \<Longrightarrow>
  finite {{(0::nat, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'}"
proof (cases "card (\<Union>E) = 0")
  case True
  from True show ?thesis
    by auto
next
  case F1:False
  then show ?thesis
  proof (cases "card (\<Union>E) = 1")
    case True
    then show ?thesis
      by simp
  next
    case F2:False

    obtain x where x_def:"x = card (\<Union>E)"
      by blast
    from this F1 F2 have x_greater_one:"1 < x"
      by linarith
    from this have card_greater_zero:"(x * (x-1)) div 2 > 0"
      by (metis divisors_zero mod2_gr_0 mod_eq_self_iff_div_eq_0
          nat_1_eq_mult_iff nat_neq_iff not_gr0 not_one_less_zero zero_less_diff)
    from x_def have "card {{(0::nat, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'} =
      (x * (x-1)) div 2"
      using chromatik_card4
      by blast

    from this card_greater_zero have
      "card {{(0::nat, k), (0::nat, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'} > 0"
      by presburger
    from this show ?thesis
      using Finite_Set.card_ge_0_finite
      by blast
  qed
qed

lemma seteqUniondiff:"A \<inter> B = {} \<Longrightarrow> A \<inter> C = {} \<Longrightarrow> A \<union> B = A \<union> C \<Longrightarrow> B = C"
  by blast

end


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

Examples featuring Nitpick applied to natural numbers and integers.
*)

section \<open>Examples Featuring Nitpick Applied to Natural Numbers and Integers\<close>

theory Integer_Nits
imports MainRLT
begin

nitpick_params [verbose, card = 1-5, bits = 1,2,3,4,6,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

lemma "Suc x = x + 1"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x < Suc x"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x + y \<ge> (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y \<noteq> 0 \<Longrightarrow> x + y > (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x + y = y + (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x > y \<Longrightarrow> x - y \<noteq> (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<le> y \<Longrightarrow> x - y = (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x - (0::nat) = x"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<noteq> (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "0 * y = (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y * 0 = (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (y::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x * y div y = (x::nat)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "y \<noteq> 0 \<Longrightarrow> x * y div y = (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "5 * 55 < (260::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
nitpick [binary_ints, bits = 9, expect = genuine]
oops

lemma "nat (of_nat n) = n"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x + y \<ge> (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "\<lbrakk>x \<ge> 0; y \<ge> 0\<rbrakk> \<Longrightarrow> x + y \<ge> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y \<ge> 0 \<Longrightarrow> x + y \<ge> (x::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<ge> 0 \<Longrightarrow> x + y \<ge> (y::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<ge> 0 \<Longrightarrow> x + y \<ge> (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "\<lbrakk>x \<le> 0; y \<le> 0\<rbrakk> \<Longrightarrow> x + y \<le> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y \<noteq> 0 \<Longrightarrow> x + y > (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "x + y = y + (x::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x > y \<Longrightarrow> x - y \<noteq> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<le> y \<Longrightarrow> x - y = (0::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "x - (0::int) = x"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<noteq> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "0 * y = (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y * 0 = (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (y::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "x * y div y = (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "y \<noteq> 0 \<Longrightarrow> x * y div y = (x::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, card = 1-4, bits = 1-4, expect = none]
sorry

lemma "(x * y < 0) \<longleftrightarrow> (x > 0 \<and> y < 0) \<or> (x < 0 \<and> y > (0::int))"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "-5 * 55 > (-260::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
nitpick [binary_ints, bits = 9, expect = genuine]
oops

lemma "nat (of_nat n) = n"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

datatype tree = Null | Node nat tree tree

primrec labels where
"labels Null = {}" |
"labels (Node x t u) = {x} \<union> labels t \<union> labels u"

lemma "labels (Node x t u) \<noteq> labels (Node y v w)"
nitpick [expect = potential] (* unfortunate *)
oops

lemma "labels (Node x t u) \<noteq> {}"
nitpick [expect = none]
oops

lemma "card (labels t) > 0"
nitpick [expect = potential] (* unfortunate *)
oops

lemma "(\<Sum>n \<in> labels t. n + 2) \<ge> 2"
nitpick [expect = potential] (* unfortunate *)
oops

lemma "t \<noteq> Null \<Longrightarrow> (\<Sum>n \<in> labels t. n + 2) \<ge> 2"
nitpick [expect = potential] (* unfortunate *)
sorry

lemma "(\<Sum>i \<in> labels (Node x t u). f i::nat) = f x + (\<Sum>i \<in> labels t. f i) + (\<Sum>i \<in> labels u. f i)"
nitpick [expect = potential] (* unfortunate *)
oops

end


(*File: PBIJ.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory PBIJ imports OBJ begin

subsection\<open>Partial bijections\<close>

text\<open>Partial bijections between locations will be used in the next
section to define indistinguishability of objects and heaps. We define
such bijections as sets of pairs which satisfy the obvious
condition.\<close>

type_synonym PBij = "(Location \<times> Location) set"
definition Pbij :: "PBij set"
where "Pbij = { \<beta> . \<forall> l1 l2 l3 l4. (l1,l2):\<beta> \<longrightarrow> (l3,l4):\<beta> \<longrightarrow>
                              ((l1 = l3) = (l2 = l4))}"

text\<open>Domain and codomain are defined as expected.\<close>

definition Pbij_Dom::"PBij \<Rightarrow> (Location set)"
where "Pbij_Dom \<beta> = {l . \<exists> ll .(l,ll):\<beta>}"

definition Pbij_Rng::"PBij \<Rightarrow> (Location set)"
where "Pbij_Rng \<beta> = {ll . \<exists> l .(l,ll):\<beta>}"

text\<open>We also define the inverse operation, the composition, and a
test deciding when one bijection extends another.\<close>

definition Pbij_inverse::"PBij \<Rightarrow> PBij"
where "Pbij_inverse \<beta> = {(l,ll) . (ll,l):\<beta>}"
(*<*)
lemma Pbij_inverseI:"(l1,l2):\<beta> \<Longrightarrow> (l2,l1):Pbij_inverse \<beta>"
by (simp add: Pbij_inverse_def)
lemma Pbij_inverseD:"(l1,l2):Pbij_inverse \<beta> \<Longrightarrow> (l2,l1):\<beta>"
by (simp add: Pbij_inverse_def)
(*>*)

definition Pbij_compose::"PBij \<Rightarrow> PBij \<Rightarrow> PBij"
where "Pbij_compose \<beta> \<gamma> = {(l,ll) . \<exists> l1 . (l,l1):\<beta> \<and> (l1,ll):\<gamma>}"
(*<*)
lemma Pbij_composeI: "\<lbrakk>(l1, l2) \<in> \<beta>; (l2, l3) \<in> \<gamma>\<rbrakk> \<Longrightarrow> (l1, l3) \<in> Pbij_compose \<beta> \<gamma>"
by (simp add: Pbij_compose_def, rule_tac x=l2 in exI, simp)
lemma Pbij_composeD: "(l1, l3) \<in> Pbij_compose \<beta> \<gamma> \<Longrightarrow> \<exists> l2 . (l1, l2) \<in> \<beta> \<and> (l2, l3) \<in> \<gamma>"
by (simp add: Pbij_compose_def)
(*>*)

definition Pbij_extends ::"PBij \<Rightarrow> PBij \<Rightarrow> bool"
where "Pbij_extends \<gamma> \<beta> = (\<beta> \<subseteq> \<gamma>)"

text\<open>These definitions satisfy the following properties.\<close>

lemma Pbij_insert:
  "\<lbrakk>\<beta> \<in> Pbij;l \<notin> Pbij_Rng \<beta>; ll \<notin> Pbij_Dom \<beta>\<rbrakk>
  \<Longrightarrow> insert (ll, l) \<beta> \<in> Pbij"
(*<*)
apply (simp add: Pbij_def)
apply clarsimp
apply rule
  apply clarsimp apply (simp add: Pbij_Dom_def Pbij_Rng_def) apply fast
  apply clarsimp apply (simp add: Pbij_Dom_def Pbij_Rng_def) apply fast
done
(*>*)

lemma Pbij_injective:
  "\<beta>:Pbij \<Longrightarrow> (\<forall> l l1 l2 . (l1,l):\<beta> \<longrightarrow> (l2,l):\<beta> \<longrightarrow> l1=l2)"
(*<*)
by (simp add: Pbij_def)
(*>*)

lemma Pbij_inverse_DomRng[rule_format]:
  "\<gamma> = Pbij_inverse \<beta> \<Longrightarrow>
   (Pbij_Dom \<beta> = Pbij_Rng \<gamma> \<and> Pbij_Dom \<gamma> = Pbij_Rng \<beta>)"
(*<*)
by (simp add: Pbij_inverse_def Pbij_Dom_def Pbij_Rng_def)
(*>*)

lemma Pbij_inverse_Dom: "Pbij_Dom \<beta> = Pbij_Rng (Pbij_inverse \<beta>)"
(*<*)
by (simp add: Pbij_inverse_def Pbij_Dom_def Pbij_Rng_def)
(*>*)

lemma Pbij_inverse_Rng: "Pbij_Dom (Pbij_inverse \<beta>) = Pbij_Rng \<beta>"
(*<*)
by (simp add: Pbij_inverse_def Pbij_Dom_def Pbij_Rng_def)
(*>*)

lemma Pbij_inverse_Pbij: "\<beta>:Pbij \<Longrightarrow> (Pbij_inverse \<beta>) : Pbij"
(*<*)
by (simp add: Pbij_def Pbij_inverse_def)
(*>*)

lemma Pbij_inverse_Inverse[rule_format]:
  "\<gamma> = Pbij_inverse \<beta> \<Longrightarrow> (\<forall> l ll . ((l,ll):\<beta>) = ((ll,l):\<gamma>))"
(*<*)
by (simp add: Pbij_inverse_def)
(*>*)

lemma Pbij_compose_Dom:
  "Pbij_Dom (Pbij_compose \<beta> \<gamma>) \<subseteq> Pbij_Dom \<beta>"
(*<*)
by (simp add: Pbij_compose_def Pbij_Dom_def, fast)
(*>*)

lemma Pbij_compose_Rng:
  "Pbij_Rng (Pbij_compose \<beta> \<gamma>) \<subseteq> Pbij_Rng \<gamma>"
(*<*)
by (simp add: Pbij_compose_def Pbij_Rng_def, fast)
(*>*)

lemma Pbij_compose_Pbij:
  "\<lbrakk>\<beta> : Pbij; \<gamma> : Pbij\<rbrakk> \<Longrightarrow> Pbij_compose \<beta> \<gamma> : Pbij"
(*<*)
by (simp add: Pbij_compose_def Pbij_def, clarsimp)
(*>*)

lemma Pbij_extends_inverse:
 "Pbij_extends \<gamma> (Pbij_inverse \<beta>) = Pbij_extends (Pbij_inverse \<gamma>) \<beta>"
(*<*)
by (simp add: Pbij_extends_def Pbij_inverse_def, fast)
(*>*)

lemma Pbij_extends_reflexive:"Pbij_extends \<beta> \<beta>"
(*<*)
by (simp add: Pbij_extends_def)
(*>*)

lemma Pbij_extends_transitive:
"\<lbrakk>Pbij_extends \<beta> \<gamma>; Pbij_extends \<gamma> \<delta>\<rbrakk> \<Longrightarrow> Pbij_extends \<beta> \<delta>"
(*<*)
by (simp add: Pbij_extends_def)
(*>*)

(*<*)
lemma Pbij_inverse_extends_twice_Aux:
"\<lbrakk> \<delta> = Pbij_inverse \<epsilon>; Pbij_extends \<epsilon> \<gamma>; \<gamma> = Pbij_inverse  \<beta>\<rbrakk>
 \<Longrightarrow> Pbij_extends \<delta> \<beta>"
by (simp add: Pbij_extends_def Pbij_inverse_def, fastforce)
(*>*)

lemma Pbij_inverse_extends_twice:
" Pbij_extends (Pbij_inverse (Pbij_inverse \<beta>)) \<beta>"
(*<*)
by (simp add: Pbij_extends_def Pbij_inverse_def)
(*>*)

text\<open>The identity bijection on a heap associates each element of the
heap's domain with itself.\<close>

definition mkId::"Heap \<Rightarrow> (Location \<times> Location) set"
where "mkId h = {(l1,l2) . l1 = l2 \<and> l1 : Dom h}"

lemma mkId1: "(mkId h):Pbij"
(*<*)
by (simp add: mkId_def Pbij_def)
(*>*)

lemma mkId2: "Pbij_Dom (mkId h) = Dom h"
(*<*)
by (simp add: Dom_def Pbij_Dom_def mkId_def)
(*>*)

lemma mkId2b: "Pbij_Rng (mkId h) = Dom h"
(*<*)
by (simp add: Dom_def Pbij_Rng_def mkId_def)
(*>*)

lemma mkId4: "l:Dom h \<Longrightarrow> (l,l):(mkId h)"
(*<*)
by (simp add: mkId_def)
(*>*)

lemma mkId4b: "(l,ll):(mkId h) \<Longrightarrow> l:Dom h \<and> l = ll"
(*<*)
by (simp add: mkId_def, clarsimp)
(*>*)

text\<open>End of theory PBIJ\<close>
end