theory a2
  (* Download the file RegExp.thy and put it in the same directory as this one: *)
  imports RegExp
begin

section "Question 1: Higher-Order Logic"

lemma hol_a: "\<not>(\<forall>x. P x) \<longleftrightarrow> (\<exists>x. \<not>P x)"
  (*TODO*)
  apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule allI)
   apply (rule ccontr)
   apply (erule notE)
   apply (rule_tac x = "x" in exI)
   apply assumption
  apply (rule notI)
  apply (erule exE)
  apply (erule notE)
  apply (erule_tac x = "x" in allE)
  apply assumption
  done

lemma hol_b: "(\<forall>x. P \<longrightarrow> Q x) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x. Q x))"
  (*TODO*)
  apply (rule iffI)
   apply (rule impI)
   apply (rule allI)
   apply (erule_tac x = "x" in allE)
   apply (erule impE)
    apply assumption
   apply assumption
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (erule_tac x = "x" in allE)
  apply assumption
  oops

  find_theorems "(_ \<or> _)"

lemma hol_c: "\<forall>x. \<not>f x \<longrightarrow> f (g x) \<Longrightarrow> \<forall>x. f x \<or> f (g x)"
  (*TODO*)
  apply (rule allI)
  apply (erule_tac x = "x" in allE)
  apply (rule classical)
  apply (erule impE)
   apply (rule notI)
   apply (erule notE)
   apply (rule disjI1)
   apply assumption
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

lemma hol_d: "\<lbrakk>\<forall>x. \<not>f x \<longrightarrow> f (g x); \<exists>x. f x\<rbrakk> \<Longrightarrow> \<exists>x. f x \<and> f (g (g x))"
  (*TODO*)
  apply (erule exE)
  apply (case_tac "f (g (g x))")
   apply (rule_tac x = "x" in exI)
   apply (rule conjI)
    apply assumption
   apply assumption
  apply (rule_tac x = "g x" in exI)
  apply (rule conjI)
   apply (drule hol_c)
   apply (erule_tac x = "g x" in allE)
   apply (erule disjE)
    apply assumption
   apply (erule notE)
   apply assumption
  apply (erule_tac x = "g (g x)" in allE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma hol_e: "(\<forall>x. Q x = P x) \<and> ((\<exists>x. P x) \<longrightarrow> H) \<and> (\<exists>x. Q x) \<longrightarrow> H"
  (*TODO*)
  apply (rule impI)
  apply (erule conjE)
  apply (erule conjE)
  apply (erule exE)
  apply (erule_tac x = "x" in allE)
  apply (drule iffD1)
   apply assumption
  apply (erule impE)
   apply (rule_tac x = "x" in exI)
   apply assumption
  apply assumption
  done

lemma hol_f: "(\<forall>Q. (\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> Q) \<longrightarrow> (\<exists>x. P x)"
  (*TODO*)
  apply (rule impI)
  apply (erule_tac x = "\<exists>x . P x" in allE)
  apply (erule impE)
   prefer 2
   apply assumption
  apply (rule allI)
  apply (rule impI)
  apply (rule_tac x = "x" in exI)
  apply assumption
  done

(*---------------------------------------------------------*)
section "Question 2: Strings and Regular Expressions"

(* An example string with newline characters *)
definition
  test_str :: string
  where
  "test_str =
''some
test
abc hello
text''"

definition
  new_line :: char
  where
  "new_line = CHR ''\<newline>''"

(*----------------*)
(* Question 2 (a) *)
primrec
  glue :: "'a \<Rightarrow> 'a list list \<Rightarrow> 'a list"
  where
  "glue a [] = []" |
  "glue a (xs # xss) = (if xss = [] then xs else xs @ a # glue a xss)"

(* test on some examples *)

value "glue (Suc 0) [[0, 0], [2, 2], [0]]"
value "glue (Suc 0) [[0, 0], [2, 2], [0], []]"
value "glue (Suc 0) [[],[]]"

(* Define and test on some examples:
  chop :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list list"
*)

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

definition "chop = chop' []"

(*----------------*)
(* Question 2 (b) *)
primrec
  num_of :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
  where
  "num_of a [] = 0" |
  "num_of a (x # xs ) = (if a = x then Suc (num_of a xs) else num_of a xs)"

lemma length_glue:
  "length (glue a xss) = sum_list (map length xss) + length xss - 1"
  (*TODO*)
  apply (induct xss)
  apply auto
  done

lemma length_chop' [simp]:
  "length (chop' ys x xs) = num_of x xs + 1"
  apply (induct xs arbitrary: ys)
  apply auto
  done

lemma length_chop:
  "length (chop x xs) = num_of x xs + 1"
  (*TODO*)
  apply (unfold chop_def)
  apply (simp add: chop_def)
  done

(*----------------*)
(* Question 2 (c) *)
lemma chop'_set:
  "\<lbrakk> ls \<in> set (chop' ys a xs); a \<notin> set ys \<rbrakk> \<Longrightarrow> a \<notin> set ls"
  apply (induct xs arbitrary: ys ls)
  apply (auto split: if_split_asm)
  done

lemma chop_sep:
  "ls \<in> set (chop a xs) \<Longrightarrow> a \<notin> set ls"
  (*TODO*)
  apply (simp add: chop'_set chop_def)
  done

lemma chop'_neq_Nil[simp]:
  "chop' ys a xs \<noteq> []"
  by (induct xs arbitrary: ys) auto

lemma glue_chop'[simp]:
  "glue a (chop' ys a xs) = ys @ xs"
  by (induct xs arbitrary: ys) auto

lemma glue_chop:
  "glue a (chop a xs) = xs"
  (*TODO*)
   apply (simp add: chop_def)
  done

(*----------------*)
(* Question 2 (d) *)

(* TODO: define
  any_of :: "regexp list \<Rightarrow> regexp"
*)

definition
  any_of :: "regexp list \<Rightarrow> regexp"
  where
  "any_of xs = fold Alt xs null"

lemma lang_fold_Alt[simp]:
  "lang (fold Alt rs r) = \<Union> (lang ` set rs) \<union> lang r"
  apply (induct rs arbitrary: r)
   apply auto
  done

lemma lang_any_of[simp]:
  "lang (any_of rs) = \<Union> (lang ` set rs)"
  (* TODO *)
  apply (simp add: any_of_def)
  done

primrec
  repeat :: "word set \<Rightarrow> nat \<Rightarrow> word set"
  where
  "repeat A 0 = {[]}"
| "repeat A (Suc n) = conc A (repeat A n)"

lemma concI[elim]:
  "\<lbrakk> as \<in> A; bs \<in> B \<rbrakk> \<Longrightarrow> as @ bs \<in> conc A B"
  apply (auto simp: conc_def)
  done

lemma concD[dest!]:
  "xs \<in> conc A B \<Longrightarrow> \<exists>as bs. as \<in> A \<and> bs \<in> B \<and> xs = as @ bs"
  apply (auto simp: conc_def)
  done

lemma repeat_0[simp,intro!]:
  "[] \<in> repeat A 0"
  apply simp
  done

lemma repeat_Suc[elim]:
  "\<lbrakk> as \<in> A; xs \<in> repeat A n \<rbrakk> \<Longrightarrow> as @ xs \<in> repeat A (Suc n)"
  apply auto
  done

lemma star_repeat_Ex:
  "as \<in> star A \<Longrightarrow> \<exists>n. as \<in> repeat A n"
  apply (erule star.induct)
    apply auto
  done

lemma repeat_n_star:
  "as \<in> repeat A n \<Longrightarrow> as \<in> star A"
  apply (induct n arbitrary: as)
    apply auto
  done

lemma star_repeat:
  "star A = (\<Union>n. repeat A n)"
  apply auto
  apply (auto simp: star_repeat_Ex repeat_n_star)
  done

(*----------------*)
(* Question 2 (e) *)
definition
  matches :: "regexp \<Rightarrow> string \<Rightarrow> bool"
  where
  "matches r w \<equiv> w \<in> lang r"

definition
  matches_sub :: "regexp \<Rightarrow> string \<Rightarrow> bool"
  where
  "matches_sub r = matches TODO"

primrec
  string :: "string \<Rightarrow> regexp"
  where
  "string [] = TODO"

primrec
  is_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where
  "is_prefix [] ys = TODO"

primrec
  is_substring :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where
  "is_substring xs [] = TODO"

(* TODO: test on some examples *)

lemma matches_sub:
  "matches_sub r xs = (\<exists>xs' ys zs. xs = ys @ xs' @ zs \<and> matches r xs')"
  (* TODO *)
  oops

lemma matches_string[simp]:
  "matches (string xs) ys = (ys = xs)"
  (* TODO *)
  oops

lemma is_substring:
  "is_substring xs ys = (\<exists>bs cs. ys = bs @ xs @ cs)"
  (* TODO *)
  oops

lemma matches_substring:
  "matches_sub (string xs) l = is_substring xs l"
  (* TODO *)
  oops

(*----------------*)
(* Question 2 (f) *)
primrec
  rlen :: "regexp \<Rightarrow> nat option"
  where
  "rlen (Atom a) = TODO"

lemma rlen_string[simp]:
  "rlen (string xs) = Some (length xs)"
  (* TODO *)
  oops

lemma rlen_lang:
  "rlen r = Some n \<Longrightarrow> \<forall>xs \<in> lang r. length xs = n"
  (* TODO *)
  oops

(*---------------------------------------------------------*)
section "Question 3: Normal Forms"

(*----------------*)
(* Question 3 (a) *)
fun
  find_pat :: "'a list \<Rightarrow> 'a list"
  where
  (* TODO *)

value "find_pat ''cababc''"

lemma hd_find_pat[simp]:
  "hd (find_pat xs) = hd xs"
  (* TODO *)
  oops

lemma last_find_pat[simp]:
  "last (find_pat xs) = last xs"
  (* TODO *)
  oops

lemma find_pat_neq:
  "(find_pat xs \<noteq> xs) = (\<exists>as bs x y. xs = as @ x # y # x # bs)"
  (* TODO *)
  oops

lemma find_pat_eq:
  "(find_pat xs = xs) = (\<forall>as bs x y. xs \<noteq> as @ x # y # x # bs)"
  by (metis find_pat_neq)

(*----------------*)
(* Question 3 (b) *)

lemma find_pat_neq_Cons:
  "find_pat xs \<noteq> xs \<Longrightarrow> find_pat (x#xs) \<noteq> x#xs"
  oops (* helper *)

lemma find_pat_eq_Cons:
  "find_pat (x#xs) = x#xs \<Longrightarrow> find_pat xs = xs"
  oops (* helper *)

lemma find_pat_Cons_find_pat:
  "find_pat (x#find_pat xs) = find_pat (find_pat (x#xs))"
  (* TODO *)
  oops

lemma find_pat_app_find_pat:
  "find_pat (find_pat xs @ [x]) = find_pat (find_pat (xs @ [x]))"
  (* TODO *)
  oops

lemma find_pat_appendD:
  "find_pat (xs @ ys) = xs @ ys \<Longrightarrow> find_pat xs = xs"
  oops (* helper *)

lemma find_pat_eq_rev:
  "find_pat xs = xs \<Longrightarrow> find_pat (rev xs) = rev xs"
  (* TODO *)
  oops

lemma find_pat_rev:
  "find_pat xs = xs \<Longrightarrow> find_pat (rev xs @ [x]) = rev (find_pat (x # xs))"
  (* TODO *)
  oops

(*----------------*)
(* Question 3 (c) *)
fun
  nf :: "'a list \<Rightarrow> 'a list"
  where
  "nf xs = (if find_pat xs = xs then xs else nf (find_pat xs))"
  (* Extract a lemma that helps Isabelle to prove termination here. Make it [simp]. *)
  sorry

(* This means simp will not automatically unfold nf. Use "subst nf.simps" to unfold manually. *)
declare nf.simps[simp del]

value "nf ''cabacacb''"

lemma nf_singles[simp]:
  "nf [] = []"
  "nf [x] = [x]"
  "nf [x,y] = [x,y]"
  by (auto simp: nf.simps)

lemma nf_find_pat:
  "nf (find_pat xs) = nf xs"
  (* TODO *)
  oops

lemma nf_fp:
  "find_pat (nf xs) = nf xs"
  (* TODO *)
  oops

lemma nf_nf:
  "nf (nf xs) = nf xs"
  (* TODO *)
  oops

lemma hd_nf:
  "hd (nf xs) = hd xs"
  (* TODO *)
  oops

lemma last_nf:
  "last (nf xs) = last xs"
  (* TODO *)
  oops

(*----------------*)
(* Question 3 (d) *)

lemma find_pat_nf_Cons:
  "find_pat xs = xs \<Longrightarrow> nf (x#xs) = find_pat (x#xs)"
  oops (* helper *)

lemma nf_find_pat_Cons:
  "find_pat xs \<noteq> xs \<Longrightarrow> nf (x # find_pat xs) = nf (x # xs)"
  oops (* helper *)

lemma nf_Cons_nf:
  "nf (x#nf xs) = nf (x#xs)"
  (* TODO *)
  oops

lemma nf_hd_dist:
  "nf (x#xs) = find_pat (x#nf xs)"
  (* TODO *)
  oops

lemma nf_last_dist:
  "nf (xs @ [x]) = find_pat (nf xs @ [x])"
  (* TODO *)
  oops

lemma find_pat_rev_Cons:
  "rev (find_pat (x#nf xs)) = find_pat (rev (x#nf xs))"
  oops (* helper *)

lemma nf_rev:
  "nf (rev xs) = rev (nf xs)"
  (* TODO *)
  oops

end


theory XC_Definition
  imports "Karp21.Polynomial_Reductions"
          "HOL-Library.Disjoint_Sets"
          "../../poly-reductions/Lib/SAT_Definition"
begin

subsection "Exact cover definitions"

definition "exact_cover_alter_def \<equiv>
   {(X, S). \<Union>S \<subseteq> X \<and>
    (\<exists>S' \<subseteq> S. \<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t))}"

definition "exact_cover \<equiv> {(X, S). \<Union>S \<subseteq> X \<and> (\<exists>S' \<subseteq> S. \<Union>S' = X \<and> disjoint S')}"

lemma exact_cover_alter_def_eq: "(X, S) \<in> exact_cover_alter_def \<longleftrightarrow> (X, S) \<in> exact_cover"
proof (standard, goal_cases)
  assume 1: "(X, S) \<in> exact_cover_alter_def"
  hence "\<Union>S \<subseteq> X" unfolding exact_cover_alter_def_def
    by blast
  from 1 obtain S' where s_def: "S' \<subseteq> S" "\<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t)"
    unfolding exact_cover_alter_def_def
    by blast
  hence "\<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s"
    by blast
  then have "X \<subseteq> \<Union>S'"
    by blast
  moreover have "\<Union>S' \<subseteq> X"
    using \<open>S' \<subseteq> S\<close> \<open>\<Union>S \<subseteq> X\<close>
    by blast
  ultimately have "X = \<Union>S'"
    by simp
  have "disjoint S'"
  proof (rule disjointI)
    fix a b
    assume ab_def: "a \<in> S'" "b \<in> S'" "a \<noteq> b"

    with s_def have
      "\<forall>x \<in> X. x \<in> a \<longrightarrow> x \<notin> b"
      "\<forall>x \<in> X. x \<in> b \<longrightarrow> x \<notin> a"
       by metis+
    hence "\<forall>x\<in>X. x \<notin> a \<inter> b"
      by blast
    moreover from \<open>\<Union>S' \<subseteq> X\<close> have "\<forall>x \<in> a \<inter> b. x \<in> X"
      using ab_def
      by blast
    ultimately show "a \<inter> b = {}"
      by blast
  qed
  from \<open>X = \<Union>S'\<close> \<open>disjoint S'\<close> \<open>S' \<subseteq> S\<close> \<open>\<Union>S \<subseteq> X\<close>
  show "(X, S) \<in> exact_cover"
    unfolding exact_cover_def
    by blast
next
  assume 2:"(X, S) \<in> exact_cover"
  then have "\<Union>S \<subseteq> X"
    unfolding exact_cover_def
    by blast
  from 2 obtain S' where S'_def: "S' \<subseteq> S" "\<Union>S' = X" "disjoint S'"
    unfolding exact_cover_def
    by blast
  have "\<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t)"
  proof
    fix x
    assume "x \<in> X"
    then obtain s where "s \<in> S'" "x \<in> s"
      using S'_def
      by blast
    moreover then have "\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t"
      using disjointD[OF \<open>disjoint S'\<close>]
      by blast
    ultimately show "\<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t)"
      by blast
  qed
  then show "(X, S) \<in> exact_cover_alter_def"
    using \<open>\<Union>S \<subseteq> X\<close> \<open>S' \<subseteq> S\<close>
    unfolding exact_cover_alter_def_def
    by blast
qed

definition cover :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
"cover S' X \<longleftrightarrow> \<Union>S' = X \<and> disjoint S'"

lemma exact_cover_I: "\<lbrakk>S' \<subseteq> S; \<Union>S \<subseteq> X; cover S' X\<rbrakk> \<Longrightarrow> (X, S) \<in> exact_cover"
  unfolding exact_cover_def cover_def
  by blast

lemma exact_cover_D: "\<lbrakk>(X, S) \<in> exact_cover; \<Union>S \<subseteq> X\<rbrakk> \<Longrightarrow> (\<exists>S' \<subseteq> S. cover S' X)"
  unfolding exact_cover_def cover_def
  by blast

definition
  "cnf_sat \<equiv> {F. sat F}"
end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_prop_16
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "even (t2 x x)"
  oops

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Small examples for evaluation mechanisms\<close>

theory Eval_Examples
imports Complex_Main
begin

text \<open>evaluation oracle\<close>

lemma "True \<or> False" by eval
lemma "Suc 0 \<noteq> Suc 1" by eval
lemma "[] = ([] :: int list)" by eval
lemma "[()] = [()]" by eval
lemma "fst ([] :: nat list, Suc 0) = []" by eval

text \<open>normalization\<close>

lemma "True \<or> False" by normalization
lemma "Suc 0 \<noteq> Suc 1" by normalization
lemma "[] = ([] :: int list)" by normalization
lemma "[()] = [()]" by normalization
lemma "fst ([] :: nat list, Suc 0) = []" by normalization

text \<open>term evaluation\<close>

value "(Suc 2 + 1) * 4"

value "(Suc 2 + Suc 0) * Suc 3"

value "nat 100"

value "(10::int) \<le> 12"

value "max (2::int) 4"

value "of_int 2 / of_int 4 * (1::rat)"

value "[] :: nat list"

value "[(nat 100, ())]"

text \<open>a fancy datatype\<close>

datatype ('a, 'b) foo =
    Foo "'a::order" 'b
  | Bla "('a, 'b) bar"
  | Dummy nat
and ('a, 'b) bar =
    Bar 'a 'b
  | Blubb "('a, 'b) foo"

value "Bla (Bar (4::nat) [Suc 0])"

end


theory tut4
  imports Main

(* Isar, structured proofs *)

begin
(* Exercise 1 *)

(*- takes the assumptions and puts them in the proof*)
lemma "(P \<longrightarrow> (Q \<longrightarrow> R)) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R))"
proof
  assume "P \<longrightarrow> (Q \<longrightarrow> R)"
  show "(P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R)"
  proof
    assume "P \<longrightarrow> Q"
    show "P \<longrightarrow> R"
    proof
      assume P
      show R
      proof (rule mp)
        show "Q \<longrightarrow> R" by (rule mp) fact+
        show Q by (rule mp) fact+
      qed
    qed
  qed
qed

lemma "(P \<longrightarrow> (Q \<longrightarrow> R)) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R))"
proof (rule impI)+
  assume "P" "P \<longrightarrow> Q \<longrightarrow> R" then have qr: "Q \<longrightarrow> R"
(*try sledgehammer *)
    by fast
  assume "P" "P \<longrightarrow> Q" then have "Q"
    by blast
  then show "R" using qr
    by blast
qed

lemma "(\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> (\<exists>x. P x \<longrightarrow> Q)"
proof
  assume "\<forall>x. P x \<longrightarrow> Q"
  then have "P a \<longrightarrow> Q" by (erule_tac x="a" in allE)
  then show "(\<exists>x. P x \<longrightarrow> Q)" by (rule exI)
qed

lemma assumes 0: "(\<not>(\<exists>x. P x))" shows "(\<forall>x. \<not>P x)"
proof (rule allI, rule notI)
  fix x
  assume 0: "\<not>(\<exists>x. P x)" and forContra: "P x"
  have 1: "\<exists>x. P x" using forContra by (rule exI)
qed

(*method safe*)
(* -, do nothing, don't do natural deduction steps*)
lemma assumes n_all: "(\<not>(\<forall>x. P x))" shows "(\<exists>x. \<not>P x)"
proof (rule ccontr) (* can use classical too *)
  assume n_ex: "(\<nexists>x. \<not>P x)"
  have "\<forall>x. P x"
  proof -
    {fix x
      have "P x"
      proof (rule ccontr)
        assume "\<not> P x" then have "\<exists>x. \<not> P x" ..
        then show False using n_ex by simp
      qed
    }
    then show ?thesis ..
  qed
  then show False using n_all by simp
qed

lemma "(R \<longrightarrow> P) \<longrightarrow> (((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S))"
proof
  assume 0: "R \<longrightarrow> P"
  show "((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S)"
  proof
    assume 1: "\<not>R \<or> P"
    show "Q \<longrightarrow> S"

(* Exercise 2 *)
lemma "(\<forall>x. \<not>rich x \<longrightarrow> rich(father x)) \<longrightarrow> (\<exists>x. rich(father(father x)) \<and> rich x)"
proof cases
  assume "(\<forall>x. \<not>rich x \<longrightarrow> rich(father x))"
  show "(\<exists>x. rich(father(father x)) \<and> rich x)"
  next

qed

end


(* Author: Tobias Nipkow *)

section \<open>Red-Black Tree Implementation of Sets\<close>

theory RBT_Set
imports
  Complex_Main
  RBT
  Cmp
  Isin2
begin

definition empty :: "'a rbt" where
"empty = Leaf"

fun ins :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"ins x Leaf = R Leaf x Leaf" |
"ins x (B l a r) =
  (case cmp x a of
     LT \<Rightarrow> baliL (ins x l) a r |
     GT \<Rightarrow> baliR l a (ins x r) |
     EQ \<Rightarrow> B l a r)" |
"ins x (R l a r) =
  (case cmp x a of
    LT \<Rightarrow> R (ins x l) a r |
    GT \<Rightarrow> R l a (ins x r) |
    EQ \<Rightarrow> R l a r)"

definition insert :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"insert x t = paint Black (ins x t)"

fun color :: "'a rbt \<Rightarrow> color" where
"color Leaf = Black" |
"color (Node _ (_, c) _) = c"

fun del :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"del x Leaf = Leaf" |
"del x (Node l (a, _) r) =
  (case cmp x a of
     LT \<Rightarrow> if l \<noteq> Leaf \<and> color l = Black
           then baldL (del x l) a r else R (del x l) a r |
     GT \<Rightarrow> if r \<noteq> Leaf\<and> color r = Black
           then baldR l a (del x r) else R l a (del x r) |
     EQ \<Rightarrow> join l r)"

definition delete :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"delete x t = paint Black (del x t)"

subsection "Functional Correctness Proofs"

lemma inorder_paint: "inorder(paint c t) = inorder t"
by(cases t) (auto)

lemma inorder_baliL:
  "inorder(baliL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliL.cases) (auto)

lemma inorder_baliR:
  "inorder(baliR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliR.cases) (auto)

lemma inorder_ins:
  "sorted(inorder t) \<Longrightarrow> inorder(ins x t) = ins_list x (inorder t)"
by(induction x t rule: ins.induct)
  (auto simp: ins_list_simps inorder_baliL inorder_baliR)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by (simp add: insert_def inorder_ins inorder_paint)

lemma inorder_baldL:
  "inorder(baldL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldL.cases)
  (auto simp:  inorder_baliL inorder_baliR inorder_paint)

lemma inorder_baldR:
  "inorder(baldR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldR.cases)
  (auto simp:  inorder_baliL inorder_baliR inorder_paint)

lemma inorder_join:
  "inorder(join l r) = inorder l @ inorder r"
by(induction l r rule: join.induct)
  (auto simp: inorder_baldL inorder_baldR split: tree.split color.split)

lemma inorder_del:
 "sorted(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
by(induction x t rule: del.induct)
  (auto simp: del_list_simps inorder_join inorder_baldL inorder_baldR)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by (auto simp: delete_def inorder_del inorder_paint)

subsection \<open>Structural invariants\<close>

lemma neq_Black[simp]: "(c \<noteq> Black) = (c = Red)"
by (cases c) auto

text\<open>The proofs are due to Markus Reiter and Alexander Krauss.\<close>

fun bheight :: "'a rbt \<Rightarrow> nat" where
"bheight Leaf = 0" |
"bheight (Node l (x, c) r) = (if c = Black then bheight l + 1 else bheight l)"

fun invc :: "'a rbt \<Rightarrow> bool" where
"invc Leaf = True" |
"invc (Node l (a,c) r) =
  ((c = Red \<longrightarrow> color l = Black \<and> color r = Black) \<and> invc l \<and> invc r)"

text \<open>Weaker version:\<close>
abbreviation invc2 :: "'a rbt \<Rightarrow> bool" where
"invc2 t \<equiv> invc(paint Black t)"

fun invh :: "'a rbt \<Rightarrow> bool" where
"invh Leaf = True" |
"invh (Node l (x, c) r) = (bheight l = bheight r \<and> invh l \<and> invh r)"

lemma invc2I: "invc t \<Longrightarrow> invc2 t"
by (cases t rule: tree2_cases) simp+

definition rbt :: "'a rbt \<Rightarrow> bool" where
"rbt t = (invc t \<and> invh t \<and> color t = Black)"

lemma color_paint_Black: "color (paint Black t) = Black"
by (cases t) auto

lemma paint2: "paint c2 (paint c1 t) = paint c2 t"
by (cases t) auto

lemma invh_paint: "invh t \<Longrightarrow> invh (paint c t)"
by (cases t) auto

lemma invc_baliL:
  "\<lbrakk>invc2 l; invc r\<rbrakk> \<Longrightarrow> invc (baliL l a r)"
by (induct l a r rule: baliL.induct) auto

lemma invc_baliR:
  "\<lbrakk>invc l; invc2 r\<rbrakk> \<Longrightarrow> invc (baliR l a r)"
by (induct l a r rule: baliR.induct) auto

lemma bheight_baliL:
  "bheight l = bheight r \<Longrightarrow> bheight (baliL l a r) = Suc (bheight l)"
by (induct l a r rule: baliL.induct) auto

lemma bheight_baliR:
  "bheight l = bheight r \<Longrightarrow> bheight (baliR l a r) = Suc (bheight l)"
by (induct l a r rule: baliR.induct) auto

lemma invh_baliL:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliL l a r)"
by (induct l a r rule: baliL.induct) auto

lemma invh_baliR:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliR l a r)"
by (induct l a r rule: baliR.induct) auto

text \<open>All in one:\<close>

lemma inv_baliR: "\<lbrakk> invh l; invh r; invc l; invc2 r; bheight l = bheight r \<rbrakk>
 \<Longrightarrow> invc (baliR l a r) \<and> invh (baliR l a r) \<and> bheight (baliR l a r) = Suc (bheight l)"
by (induct l a r rule: baliR.induct) auto

lemma inv_baliL: "\<lbrakk> invh l; invh r; invc2 l; invc r; bheight l = bheight r \<rbrakk>
 \<Longrightarrow> invc (baliL l a r) \<and> invh (baliL l a r) \<and> bheight (baliL l a r) = Suc (bheight l)"
by (induct l a r rule: baliL.induct) auto

subsubsection \<open>Insertion\<close>

lemma invc_ins: "invc t \<longrightarrow> invc2 (ins x t) \<and> (color t = Black \<longrightarrow> invc (ins x t))"
by (induct x t rule: ins.induct) (auto simp: invc_baliL invc_baliR invc2I)

lemma invh_ins: "invh t \<Longrightarrow> invh (ins x t) \<and> bheight (ins x t) = bheight t"
by(induct x t rule: ins.induct)
  (auto simp: invh_baliL invh_baliR bheight_baliL bheight_baliR)

theorem rbt_insert: "rbt t \<Longrightarrow> rbt (insert x t)"
by (simp add: invc_ins invh_ins color_paint_Black invh_paint rbt_def insert_def)

text \<open>All in one:\<close>

lemma inv_ins: "\<lbrakk> invc t; invh t \<rbrakk> \<Longrightarrow>
  invc2 (ins x t) \<and> (color t = Black \<longrightarrow> invc (ins x t)) \<and>
  invh(ins x t) \<and> bheight (ins x t) = bheight t"
by (induct x t rule: ins.induct) (auto simp: inv_baliL inv_baliR invc2I)

theorem rbt_insert2: "rbt t \<Longrightarrow> rbt (insert x t)"
by (simp add: inv_ins color_paint_Black invh_paint rbt_def insert_def)

subsubsection \<open>Deletion\<close>

lemma bheight_paint_Red:
  "color t = Black \<Longrightarrow> bheight (paint Red t) = bheight t - 1"
by (cases t) auto

lemma invh_baldL_invc:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
by (induct l a r rule: baldL.induct)
   (auto simp: invh_baliR invh_paint bheight_baliR bheight_paint_Red)

lemma invh_baldL_Black:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  color r = Black \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
by (induct l a r rule: baldL.induct) (auto simp add: invh_baliR bheight_baliR)

lemma invc_baldL: "\<lbrakk>invc2 l; invc r; color r = Black\<rbrakk> \<Longrightarrow> invc (baldL l a r)"
by (induct l a r rule: baldL.induct) (simp_all add: invc_baliR)

lemma invc2_baldL: "\<lbrakk> invc2 l; invc r \<rbrakk> \<Longrightarrow> invc2 (baldL l a r)"
by (induct l a r rule: baldL.induct) (auto simp: invc_baliR paint2 invc2I)

lemma invh_baldR_invc:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1;  invc l \<rbrakk>
  \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l"
by(induct l a r rule: baldR.induct)
  (auto simp: invh_baliL bheight_baliL invh_paint bheight_paint_Red)

lemma invc_baldR: "\<lbrakk>invc l; invc2 r; color l = Black\<rbrakk> \<Longrightarrow> invc (baldR l a r)"
by (induct l a r rule: baldR.induct) (simp_all add: invc_baliL)

lemma invc2_baldR: "\<lbrakk> invc l; invc2 r \<rbrakk> \<Longrightarrow>invc2 (baldR l a r)"
by (induct l a r rule: baldR.induct) (auto simp: invc_baliL paint2 invc2I)

lemma invh_join:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk>
  \<Longrightarrow> invh (join l r) \<and> bheight (join l r) = bheight l"
by (induct l r rule: join.induct)
   (auto simp: invh_baldL_Black split: tree.splits color.splits)

lemma invc_join:
  "\<lbrakk> invc l; invc r \<rbrakk> \<Longrightarrow>
  (color l = Black \<and> color r = Black \<longrightarrow> invc (join l r)) \<and> invc2 (join l r)"
by (induct l r rule: join.induct)
   (auto simp: invc_baldL invc2I split: tree.splits color.splits)

text \<open>All in one:\<close>

lemma inv_baldL:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r; invc2 l; invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r
  \<and> invc2 (baldL l a r) \<and> (color r = Black \<longrightarrow> invc (baldL l a r))"
by (induct l a r rule: baldL.induct)
   (auto simp: inv_baliR invh_paint bheight_baliR bheight_paint_Red paint2 invc2I)

lemma inv_baldR:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1; invc l; invc2 r \<rbrakk>
   \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l
  \<and> invc2 (baldR l a r) \<and> (color l = Black \<longrightarrow> invc (baldR l a r))"
by (induct l a r rule: baldR.induct)
   (auto simp: inv_baliL invh_paint bheight_baliL bheight_paint_Red paint2 invc2I)

lemma inv_join:
  "\<lbrakk> invh l; invh r; bheight l = bheight r; invc l; invc r \<rbrakk>
  \<Longrightarrow> invh (join l r) \<and> bheight (join l r) = bheight l
  \<and> invc2 (join l r) \<and> (color l = Black \<and> color r = Black \<longrightarrow> invc (join l r))"
by (induct l r rule: join.induct)
   (auto simp: invh_baldL_Black inv_baldL invc2I split: tree.splits color.splits)

lemma neq_LeafD: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x c r. t = Node l (x,c) r"
by(cases t rule: tree2_cases) auto

lemma inv_del: "\<lbrakk> invh t; invc t \<rbrakk> \<Longrightarrow>
   invh (del x t) \<and>
   (color t = Red \<longrightarrow> bheight (del x t) = bheight t \<and> invc (del x t)) \<and>
   (color t = Black \<longrightarrow> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
by(induct x t rule: del.induct)
  (auto simp: inv_baldL inv_baldR inv_join dest!: neq_LeafD)

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete x t)"
by (metis delete_def rbt_def color_paint_Black inv_del invh_paint)

text \<open>Overall correctness:\<close>

interpretation S: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = rbt
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by (simp add: rbt_def empty_def)
next
  case 6 thus ?case by (simp add: rbt_insert)
next
  case 7 thus ?case by (simp add: rbt_delete)
qed

subsection \<open>Height-Size Relation\<close>

lemma rbt_height_bheight_if: "invc t \<Longrightarrow> invh t \<Longrightarrow>
  height t \<le> 2 * bheight t + (if color t = Black then 0 else 1)"
by(induction t) (auto split: if_split_asm)

lemma rbt_height_bheight: "rbt t \<Longrightarrow> height t / 2 \<le> bheight t "
by(auto simp: rbt_def dest: rbt_height_bheight_if)

lemma bheight_size_bound:  "invc t \<Longrightarrow> invh t \<Longrightarrow> 2 ^ (bheight t) \<le> size1 t"
by (induction t) auto

lemma rbt_height_le: assumes "rbt t" shows "height t \<le> 2 * log 2 (size1 t)"
proof -
  have "2 powr (height t / 2) \<le> 2 powr bheight t"
    using rbt_height_bheight[OF assms] by (simp)
  also have "\<dots> \<le> size1 t" using assms
    by (simp add: powr_realpow bheight_size_bound rbt_def)
  finally have "2 powr (height t / 2) \<le> size1 t" .
  hence "height t / 2 \<le> log 2 (size1 t)"
    by (simp add: le_log_iff size1_size del: divide_le_eq_numeral1(1))
  thus ?thesis by simp
qed

end


theory Peterson
imports Main
begin

text {*
The Peterson mutual exclusion algorithm (for 2 processes numbered 0 and 1). Code for process i:
while (true)
  v1: idle_i = false
  v2: turn = (i+1) mod 2
  v3: await idle_[(i+1) mod 2] or turn = i
  v4: critical section
  v5: idle_i = true *}

section {* Specification of the algorithm *}

typedecl State
  -- "The state of the system"

type_synonym 'a StateFun = "State \<Rightarrow> 'a"
-- "The type of variables"

datatype label1 = p1_l1 | p1_l2 | p1_l3 | p1_l4
datatype label2 = p2_l1 | p2_l2 | p2_l3 | p2_l4

datatype Proc = P1 | P2

(*The variables*)
consts
  pc1       ::       "label1 StateFun"
  pc2       ::       "label2 StateFun"
  flag1     ::       "bool StateFun"
  flag2     ::       "bool StateFun"
  turn      ::       "Proc StateFun"

definition unchanged :: "('a StateFun) \<Rightarrow> State \<Rightarrow> State \<Rightarrow> bool" where
  "unchanged \<equiv> \<lambda> fun s s' . fun s = fun s'"

definition transition :: "(State \<times> State) set" where
  "transition \<equiv>
      {(s,s').
        (pc1 s = p1_l1 \<and> pc1 s' = p1_l2 \<and> flag1 s' = True \<and> unchanged (\<lambda> s . (pc2 s, flag2 s, turn s)) s s')
        \<or>(pc1 s = p1_l2 \<and> pc1 s' = p1_l3 \<and> turn s' = P2  \<and> unchanged (\<lambda> s .(pc2 s, flag1 s, flag2 s)) s s')
        \<or>(pc1 s = p1_l3 \<and> pc1 s' = p1_l4 \<and> (flag2 s = False \<or> turn s = P1)  \<and> unchanged (\<lambda> s . (pc2 s, flag1 s, flag2 s, turn s)) s s')
        \<or>(pc1 s = p1_l4 \<and> pc1 s' = p1_l1 \<and> flag1 s' = False  \<and> unchanged (\<lambda> s . (pc2 s, flag1 s, flag2 s, turn s)) s s')

        \<or>(pc2 s = p2_l1 \<and> pc2 s' = p2_l2 \<and> flag2 s' = True \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, turn s)) s s')
        \<or>(pc2 s = p2_l2 \<and> pc2 s' = p2_l3 \<and> turn s' = P1 \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, flag2 s)) s s')
        \<or>(pc2 s = p2_l3 \<and> pc2 s' = p2_l4 \<and> (flag1 s = False \<or> turn s = P2) \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, flag2 s, turn s)) s s')
        \<or>(pc2 s = p2_l4 \<and> pc2 s' = p2_l1 \<and> flag2 s' = False \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, turn s)) s s')
    }"

definition initial :: "State set" where
  "initial \<equiv> {s.
  pc1 s = p1_l1
  \<and> pc2 s = p2_l1
  \<and> flag1 s = False
  \<and> flag2 s = False
  \<and> turn s = P1}"

definition safe :: "State set" where
  -- "Definition of the safety property of the algorithm"
  "safe \<equiv> {s. \<not> (pc1 s = p1_l4 \<and> pc2 s = p2_l4) }"

section {*Safety proof*}

definition ind_inv :: "State set \<Rightarrow> bool" where
-- "The definition of an inductive state invariant"
  "ind_inv p \<equiv> initial \<subseteq> p \<and> (\<forall> s s'. (s : p \<and> (s,s') \<in> transition) \<longrightarrow> s' : p)"

subsection {* Four invariants that imply the safety property *}

definition inv1_p1 :: "State set" where
  "inv1_p1 \<equiv> {s. pc1 s : {p1_l2, p1_l3, p1_l4} \<longrightarrow> (flag1 s = True)}"

definition inv1_p2 :: "State set" where
  "inv1_p2 \<equiv> {s. pc2 s : {p2_l2, p2_l3, p2_l4} \<longrightarrow> (flag2 s = True)}"

definition inv2_p1 :: "State set" where
  "inv2_p1 \<equiv> {s. pc1 s = p1_l4 \<longrightarrow> (flag2 s = False \<or> turn s = P1 \<or> pc2 s = p2_l2)}"

definition inv2_p2 :: "State set" where
  "inv2_p2 \<equiv> {s. pc2 s = p2_l4 \<longrightarrow> (flag1 s = False \<or> turn s = P2 \<or> pc1 s = p1_l2)}"

lemma invariants_inductive: "ind_inv inv1_p1 \<and> ind_inv inv2_p2 \<and> ind_inv inv1_p2 \<and> ind_inv inv2_p1"
  -- "Proof that the invariants are inductive"
unfolding ind_inv_def initial_def inv1_p1_def inv1_p2_def inv2_p1_def inv2_p2_def transition_def unchanged_def
by auto

theorem safety: "inv1_p1 Int inv1_p2 Int inv2_p1 Int inv2_p2 \<subseteq> safe"
  -- "Proof that the invariants imply the safety property"
unfolding inv1_p1_def inv1_p2_def inv2_p1_def inv2_p2_def safe_def
by auto

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Surjective\<close>
theory SBinary_Relations_Surjective
  imports
    SBinary_Relation_Functions
begin

consts set_surjective_at :: "'a \<Rightarrow> set \<Rightarrow> bool"

overloading
  set_surjective_at_pred \<equiv> "set_surjective_at :: (set \<Rightarrow> bool) \<Rightarrow> set \<Rightarrow> bool"
  set_surjective_at_set \<equiv> "set_surjective_at :: set \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_surjective_at_pred P R \<equiv> \<forall>y. P y \<longrightarrow> y \<in> rng R"
  definition "set_surjective_at_set B R \<equiv> set_surjective_at (mem_of B) R"
end

lemma set_surjective_at_set_iff_set_surjective_at [iff]:
  "set_surjective_at B R \<longleftrightarrow> set_surjective_at (mem_of B) R"
  unfolding set_surjective_at_set_def by simp

lemma set_surjective_atI [intro]:
  assumes "\<And>y. P y \<Longrightarrow> y \<in> rng R"
  shows "set_surjective_at P R"
  unfolding set_surjective_at_pred_def using assms by blast

lemma set_surjective_atE [elim]:
  assumes "set_surjective_at P R"
  and "P y"
  obtains x where "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding set_surjective_at_pred_def by blast

lemma antimono_set_surjective_at_pred:
  "antimono (\<lambda>P. set_surjective_at (P :: set \<Rightarrow> bool) R)"
  by (intro antimonoI) fastforce

lemma mono_set_surjective_at_set:
  "mono (\<lambda>R. set_surjective_at (P :: set \<Rightarrow> bool) R)"
  by (intro monoI) fastforce

lemma subset_rng_if_set_surjective_at [simp]:
  "set_surjective_at B R \<Longrightarrow> B \<subseteq> rng R"
  by auto

lemma set_surjective_at_compI:
  fixes P :: "set \<Rightarrow> bool"
  assumes surj_R: "set_surjective_at (dom S) R"
  and surj_S: "set_surjective_at P S"
  shows "set_surjective_at P (S \<circ> R)"
proof
  fix y assume "P y"
  then obtain x where "\<langle>x, y\<rangle> \<in> S" using surj_S by auto
  moreover then have "x \<in> dom S" by auto
  moreover then obtain z where "\<langle>z, x\<rangle> \<in> R" using surj_R by auto
  ultimately show "y \<in> rng (S \<circ> R)" by blast
qed

end


chapter \<open>Instantiating the Framework with a simple While-Language\<close>

section \<open>Commands\<close>

theory Com imports Main begin

subsection \<open>Variables and Values\<close>

type_synonym vname = string \<comment> \<open>names for variables\<close>

datatype val
  = Bool bool      \<comment> \<open>Boolean value\<close>
  | Intg int       \<comment> \<open>integer value\<close>

abbreviation "true == Bool True"
abbreviation "false == Bool False"

subsection \<open>Expressions and Commands\<close>

datatype bop = Eq | And | Less | Add | Sub     \<comment> \<open>names of binary operations\<close>

datatype expr
  = Val val                                          \<comment> \<open>value\<close>
  | Var vname                                        \<comment> \<open>local variable\<close>
  | BinOp expr bop expr    ("_ \<guillemotleft>_\<guillemotright> _" [80,0,81] 80)  \<comment> \<open>binary operation\<close>

fun binop :: "bop \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val option"
where "binop Eq v\<^sub>1 v\<^sub>2               = Some(Bool(v\<^sub>1 = v\<^sub>2))"
  | "binop And (Bool b\<^sub>1) (Bool b\<^sub>2)  = Some(Bool(b\<^sub>1 \<and> b\<^sub>2))"
  | "binop Less (Intg i\<^sub>1) (Intg i\<^sub>2) = Some(Bool(i\<^sub>1 < i\<^sub>2))"
  | "binop Add (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 + i\<^sub>2))"
  | "binop Sub (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 - i\<^sub>2))"
  | "binop bop v\<^sub>1 v\<^sub>2                = None"

datatype cmd
  = Skip
  | LAss vname expr        ("_:=_" [70,70] 70)  \<comment> \<open>local assignment\<close>
  | Seq cmd cmd            ("_;;/ _" [61,60] 60)
  | Cond expr cmd cmd      ("if '(_') _/ else _" [80,79,79] 70)
  | While expr cmd         ("while '(_') _" [80,79] 70)

fun num_inner_nodes :: "cmd \<Rightarrow> nat" ("#:_")
where "#:Skip              = 1"
  | "#:(V:=e)              = 2"       (* zusätzlicher Skip-Knoten *)
  | "#:(c\<^sub>1;;c\<^sub>2)            = #:c\<^sub>1 + #:c\<^sub>2"
  | "#:(if (b) c\<^sub>1 else c\<^sub>2) = #:c\<^sub>1 + #:c\<^sub>2 + 1"
  | "#:(while (b) c)       = #:c + 2" (* zusätzlicher Skip-Knoten *)

lemma num_inner_nodes_gr_0:"#:c > 0"
by(induct c) auto

lemma [dest]:"#:c = 0 \<Longrightarrow> False"
by(induct c) auto

subsection \<open>The state\<close>

type_synonym state = "vname \<rightharpoonup> val"

fun "interpret" :: "expr \<Rightarrow> state \<Rightarrow> val option"
where Val: "interpret (Val v) s = Some v"
  | Var: "interpret (Var V) s = s V"
  | BinOp: "interpret (e\<^sub>1\<guillemotleft>bop\<guillemotright>e\<^sub>2) s =
    (case interpret e\<^sub>1 s of None \<Rightarrow> None
                         | Some v\<^sub>1 \<Rightarrow> (case interpret e\<^sub>2 s of None \<Rightarrow> None
                                                           | Some v\<^sub>2 \<Rightarrow> (
      case binop bop v\<^sub>1 v\<^sub>2 of None \<Rightarrow> None | Some v \<Rightarrow> Some v)))"

end


(*  Title:      JinjaDCI/Common/Auxiliary.thy

    Author:     David von Oheimb, Tobias Nipkow, Susannah Mansky
    Copyright   1999 TU Muenchen, 2019-20 UIUC

    Based on the Jinja theory Common/Auxiliary.thy by David von Oheimb and Tobias Nipkow
*)

chapter \<open> Jinja Source Language \label{cha:j} \<close>

section \<open> Auxiliary Definitions \<close>

theory Auxiliary imports Main begin
(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j \<le> m) = (n + i \<le> m \<and> n + j \<le> m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j) \<le> m) = (Suc(n + i) \<le> m \<and> Suc(n + j) \<le> m)"
(*<*)by arith(*>*)

notation Some  ("(\<lfloor>_\<rfloor>)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
 Cons_eq_map_conv [iff]
(*>*)

subsection \<open>@{text distinct_fst}\<close>

definition distinct_fst  :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
(*<*)
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
(*>*)

lemma distinct_fst_appendD:
 "distinct_fst(kxs @ kxs') \<Longrightarrow> distinct_fst kxs \<and> distinct_fst kxs'"
(*<*)by(induct kxs, auto)(*>*)

lemma map_of_SomeI:
  "\<lbrakk> distinct_fst kxs; (k,x) \<in> set kxs \<rbrakk> \<Longrightarrow> map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)

subsection \<open> Using @{term list_all2} for relations \<close>

definition fun_of :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "fun_of S \<equiv> \<lambda>x y. (x,y) \<in> S"

text \<open> Convenience lemmas \<close>
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) =
   ((x,y) \<in> S \<and> list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys =
  (\<exists>z zs. ys = z#zs \<and> (x,z) \<in> S \<and> list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) =
  (\<exists>z zs. xs = z#zs \<and> (z,y) \<in> S \<and> list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(\<And>x. (x,x) \<in> S) \<Longrightarrow> list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  "\<lbrakk> (\<And>x y. \<lbrakk>(x,y) \<in> S; (y,x) \<in> T\<rbrakk> \<Longrightarrow> x = y);
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans:
  "\<lbrakk> \<And>a b c. \<lbrakk>(a,b) \<in> R; (b,c) \<in> S\<rbrakk> \<Longrightarrow> (a,c) \<in> T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs\<rbrakk>
  \<Longrightarrow> list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  "\<lbrakk> i<size xs; list_all2 (fun_of S) xs ys; (x,y) \<in> S \<rbrakk>
  \<Longrightarrow> list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  "\<lbrakk> list_all2 (fun_of S) xs ys; p < size xs \<rbrakk> \<Longrightarrow> (xs!p,ys!p) \<in> S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  "\<lbrakk> length a = length b; \<And>n. n < length a \<Longrightarrow> (a!n,b!n) \<in> S \<rbrakk> \<Longrightarrow> list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)

subsection \<open> Auxiliary properties of @{text "map_of"} function \<close>

lemma map_of_set_pcs_notin: "C \<notin> (\<lambda>t. snd (fst t)) ` set FDTs \<Longrightarrow> map_of FDTs (F, C) = None"
(*<*)by (metis image_eqI image_image map_of_eq_None_iff snd_conv)(*>*)

lemma map_of_insertmap_SomeD':
  "map_of fs F = Some y \<Longrightarrow> map_of (map (\<lambda>(F, y). (F, D, y)) fs) F = Some(D,y)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_reinsert_neq_None:
  "Ca \<noteq> D \<Longrightarrow> map_of (map (\<lambda>(F, y). ((F, Ca), y)) fs) (F, D) = None"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_remap_insertmap:
  "map_of (map ((\<lambda>((F, D), b, T). (F, D, b, T)) \<circ> (\<lambda>(F, y). ((F, D), y))) fs)
    = map_of (map (\<lambda>(F, y). (F, D, y)) fs)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_reinsert_SomeD:
  "map_of (map (\<lambda>(F, y). ((F, D), y)) fs) (F, D) = Some T \<Longrightarrow> map_of fs F = Some T"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_filtered_SomeD:
"map_of fs (F,D) = Some (a, T) \<Longrightarrow> Q ((F,D),a,T) \<Longrightarrow>
       map_of (map (\<lambda>((F,D), b, T). ((F,D), P T)) (filter Q fs))
        (F,D) = Some (P T)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_remove_filtered_SomeD:
"map_of fs (F,C) = Some (a, T) \<Longrightarrow> Q ((F,C),a,T) \<Longrightarrow>
       map_of (map (\<lambda>((F,D), b, T). (F, P T)) [((F, D), b, T)\<leftarrow>fs . Q ((F, D), b, T) \<and> D = C])
        F = Some (P T)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_Some_None_split:
assumes "t = map (\<lambda>(F, y). ((F, C), y)) fs @ t'" "map_of t' (F, C) = None" "map_of t (F, C) = Some y"
shows "map_of (map (\<lambda>((F, D), b, T). (F, D, b, T)) t) F = Some (C, y)"
(*<*)
proof -
  have "map_of (map (\<lambda>(F, y). ((F, C), y)) fs) (F, C) = Some y" using assms by auto
  then have "\<forall>p. map_of fs F = Some p \<or> Some y \<noteq> Some p"
    by (metis map_of_reinsert_SomeD)
  then have "\<forall>f b p pa. ((f ++ map_of (map (\<lambda>(a, p). (a, b::'b, p)) fs)) F = Some p \<or> Some (b, pa) \<noteq> Some p)
     \<or> Some y \<noteq> Some pa"
    by (metis (no_types) map_add_find_right map_of_insertmap_SomeD')
  then have "(map_of (map (\<lambda>((a, b), c, d). (a, b, c, d)) t')
                     ++ map_of (map (\<lambda>(a, p). (a, C, p)) fs)) F = Some (C, y)"
    by blast
  then have "(map_of (map (\<lambda>((a, b), c, d). (a, b, c, d)) t')
      ++ map_of (map ((\<lambda>((a, b), c, d). (a, b, c, d)) \<circ> (\<lambda>(a, y). ((a, C), y))) fs)) F = Some (C, y)"
    by (simp add: map_of_remap_insertmap)
  then show ?thesis using assms by auto
qed
(*>*)

end


section \<open>Generic laws about complements\<close>

theory Laws_Complement
  imports Laws Axioms_Complement
begin

notation comp_update (infixl "*\<^sub>u" 55)
notation tensor_update (infixr "\<otimes>\<^sub>u" 70)

definition \<open>complements F G \<longleftrightarrow> compatible F G \<and> iso_register (F;G)\<close>

lemma complementsI: \<open>compatible F G \<Longrightarrow> iso_register (F;G) \<Longrightarrow> complements F G\<close>
  using complements_def by blast

lemma complements_sym: \<open>complements G F\<close> if \<open>complements F G\<close>
proof (rule complementsI)
  show [simp]: \<open>compatible G F\<close>
    using compatible_sym complements_def that by blast
  from that have \<open>iso_register (F;G)\<close>
    by (meson complements_def)
  then obtain I where [simp]: \<open>register I\<close> and \<open>(F;G) o I = id\<close> and \<open>I o (F;G) = id\<close>
    using iso_register_def by blast
  have \<open>register (swap o I)\<close>
    using \<open>register I\<close> register_comp register_swap by blast
  moreover have \<open>(G;F) o (swap o I) = id\<close>
    by (simp add: \<open>(F;G) \<circ> I = id\<close> rewriteL_comp_comp)
  moreover have \<open>(swap o I) o (G;F) = id\<close>
    by (metis (no_types, opaque_lifting) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
  ultimately show \<open>iso_register (G;F)\<close>
    using \<open>compatible G F\<close> iso_register_def pair_is_register by blast
qed

definition complement :: \<open>('a::domain update \<Rightarrow> 'b::domain update) \<Rightarrow> (('a,'b) complement_domain update \<Rightarrow> 'b update)\<close> where
  \<open>complement F = (SOME G :: ('a, 'b) complement_domain update \<Rightarrow> 'b update. compatible F G \<and> iso_register (F;G))\<close>

lemma register_complement[simp]: \<open>register (complement F)\<close> if \<open>register F\<close>
  using complement_exists[OF that]
  by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)

lemma complement_is_complement:
  assumes \<open>register F\<close>
  shows \<open>complements F (complement F)\<close>
  using complement_exists[OF assms] unfolding complements_def
  by (metis (mono_tags, lifting) complement_def some_eq_imp)

lemma complement_unique:
  assumes \<open>complements F G\<close>
  shows \<open>equivalent_registers G (complement F)\<close>
  apply (rule complement_unique[where F=F])
  using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+

lemma compatible_complement[simp]: \<open>register F \<Longrightarrow> compatible F (complement F)\<close>
  using complement_is_complement complements_def by blast

lemma complements_register_tensor:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  shows \<open>complements (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
proof (rule complementsI)
  have sep4: \<open>separating TYPE('z::domain) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d) |a b c d. True}\<close>
    apply (rule separating_tensor'[where A=\<open>{(a \<otimes>\<^sub>u b) |a b. True}\<close> and B=\<open>{(c \<otimes>\<^sub>u d) |c d. True}\<close>])
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
    by auto
  show compat: \<open>compatible (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
    by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
  let ?reorder = \<open>((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
  have [simp]: \<open>register ?reorder\<close>
    by auto
  have [simp]: \<open>?reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close>
    for a::\<open>'t::domain update\<close> and b::\<open>'u::domain update\<close> and c::\<open>'v::domain update\<close> and d::\<open>'w::domain update\<close>
    by (simp add: register_pair_apply Fst_def Snd_def tensor_update_mult)
  have [simp]: \<open>iso_register ?reorder\<close>
    apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
     apply (rule register_eqI[OF sep4]) apply auto[3]
    apply (rule register_eqI[OF sep4]) by auto
  have \<open>(F \<otimes>\<^sub>r G; complement F \<otimes>\<^sub>r complement G) = ((F; complement F) \<otimes>\<^sub>r (G; complement G)) o ?reorder\<close>
    apply (rule register_eqI[OF sep4])
    by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
        simp: compat register_pair_apply tensor_update_mult)
  moreover have \<open>iso_register \<dots>\<close>
    apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
    using assms complement_is_complement complements_def by blast+
  ultimately show \<open>iso_register (F \<otimes>\<^sub>r G;complement F \<otimes>\<^sub>r complement G)\<close>
    by simp
qed

definition is_unit_register where
  \<open>is_unit_register U \<longleftrightarrow> complements U id\<close>

lemma register_unit_register[simp]: \<open>is_unit_register U \<Longrightarrow> register U\<close>
  by (simp add: compatible_def complements_def is_unit_register_def)

lemma unit_register_compatible[simp]: \<open>compatible U X\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
  by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))

lemma unit_register_compatible'[simp]: \<open>compatible X U\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
  using compatible_sym that(1) that(2) unit_register_compatible by blast

lemma compatible_complement_left[simp]: \<open>register X \<Longrightarrow> compatible (complement X) X\<close>
  using compatible_sym complement_is_complement complements_def by blast

lemma compatible_complement_right[simp]: \<open>register X \<Longrightarrow> compatible X (complement X)\<close>
  using complement_is_complement complements_def by blast

lemma unit_register_pair[simp]: \<open>equivalent_registers X (U; X)\<close> if [simp]: \<open>is_unit_register U\<close> \<open>register X\<close>
proof -
  have \<open>equivalent_registers id (U; id)\<close>
    using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
  also have \<open>equivalent_registers \<dots> (U; (X; complement X))\<close>
    apply (rule equivalent_registers_pair_right)
     apply (auto intro!: unit_register_compatible)
    using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
  also have \<open>equivalent_registers \<dots> ((U; X); complement X)\<close>
    apply (rule equivalent_registers_assoc)
    by auto
  finally have \<open>complements (U; X) (complement X)\<close>
    by (auto simp: equivalent_registers_def complements_def)
  moreover have \<open>equivalent_registers (X; complement X) id\<close>
    by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
  ultimately show ?thesis
    by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed

lemma unit_register_compose_left:
  assumes [simp]: \<open>is_unit_register U\<close>
  assumes [simp]: \<open>register A\<close>
  shows \<open>is_unit_register (A o U)\<close>
proof -
  have \<open>compatible (A o U) (A; complement A)\<close>
    apply (auto intro!: compatible3')
    by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
  then have compat[simp]: \<open>compatible (A o U) id\<close>
    by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
  have \<open>equivalent_registers (A o U; id) (A o U; (A; complement A))\<close>
    apply (auto intro!: equivalent_registers_pair_right)
    using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
  also have \<open>equivalent_registers \<dots> ((A o U; A o id); complement A)\<close>
    apply auto
    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
  also have \<open>equivalent_registers \<dots> (A o (U; id); complement A)\<close>
    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
  also have \<open>equivalent_registers \<dots> (A o id; complement A)\<close>
    apply (intro equivalent_registers_pair_left equivalent_registers_comp)
      apply (auto simp: assms)
    using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
  also have \<open>equivalent_registers \<dots> id\<close>
    by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
  finally show ?thesis
    using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed

lemma unit_register_compose_right:
  assumes [simp]: \<open>is_unit_register U\<close>
  assumes [simp]: \<open>iso_register A\<close>
  shows \<open>is_unit_register (U o A)\<close>
proof (unfold is_unit_register_def, rule complementsI)
  show \<open>compatible (U \<circ> A) id\<close>
    by (simp add: iso_register_is_register)
  have 1: \<open>iso_register ((U;id) \<circ> A \<otimes>\<^sub>r id)\<close>
    by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
  have 2: \<open>id \<circ> ((U;id) \<circ> A \<otimes>\<^sub>r id) = (U \<circ> A;id)\<close>
    by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
  show \<open>iso_register (U \<circ> A;id)\<close>
    using 1 2 by auto
qed

lemma unit_register_unique:
  assumes \<open>is_unit_register F\<close>
  assumes \<open>is_unit_register G\<close>
  shows \<open>equivalent_registers F G\<close>
proof -
  have \<open>complements F id\<close> \<open>complements G id\<close>
    using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
  then show ?thesis
    by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed

lemma unit_register_domains_isomorphic:
  fixes F :: \<open>'a::domain update \<Rightarrow> 'c::domain update\<close>
  fixes G :: \<open>'b::domain update \<Rightarrow> 'd::domain update\<close>
  assumes \<open>is_unit_register F\<close>
  assumes \<open>is_unit_register G\<close>
  shows \<open>\<exists>I :: 'a update \<Rightarrow> 'b update. iso_register I\<close>
proof -
  have \<open>is_unit_register ((\<lambda>d. tensor_update id_update d) o G)\<close>
    by (simp add: assms(2) unit_register_compose_left)
  moreover have \<open>is_unit_register ((\<lambda>c. tensor_update c id_update) o F)\<close>
    using assms(1) register_tensor_left unit_register_compose_left by blast
  ultimately have \<open>equivalent_registers ((\<lambda>d. tensor_update id_update d) o G) ((\<lambda>c. tensor_update c id_update) o F)\<close>
    using unit_register_unique by blast
  then show ?thesis
    unfolding equivalent_registers_def by auto
qed

lemma id_complement_is_unit_register[simp]: \<open>is_unit_register (complement id)\<close>
  by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)

type_synonym unit_register_domain = \<open>(some_domain, some_domain) complement_domain\<close>
definition unit_register :: \<open>unit_register_domain update \<Rightarrow> 'a::domain update\<close> where \<open>unit_register = (SOME U. is_unit_register U)\<close>

lemma unit_register_is_unit_register[simp]: \<open>is_unit_register (unit_register :: unit_register_domain update \<Rightarrow> 'a::domain update)\<close>
proof -
  let ?U0 = \<open>complement id :: unit_register_domain update \<Rightarrow> some_domain update\<close>
  let ?U1 = \<open>complement id :: ('a, 'a) complement_domain update \<Rightarrow> 'a update\<close>
  have \<open>is_unit_register ?U0\<close> \<open>is_unit_register ?U1\<close>
    by auto
  then obtain I :: \<open>unit_register_domain update \<Rightarrow> ('a, 'a) complement_domain update\<close> where \<open>iso_register I\<close>
    apply atomize_elim by (rule unit_register_domains_isomorphic)
  with \<open>is_unit_register ?U1\<close> have \<open>is_unit_register (?U1 o I)\<close>
    by (rule unit_register_compose_right)
  then show ?thesis
    by (metis someI_ex unit_register_def)
qed

lemma unit_register_domain_tensor_unit:
  fixes U :: \<open>'a::domain update \<Rightarrow> _\<close>
  assumes \<open>is_unit_register U\<close>
  shows \<open>\<exists>I :: 'b::domain update \<Rightarrow> ('a*'b) update. iso_register I\<close>
  (* Can we show that I = (\<lambda>x. tensor_update id_update x) ? It would be nice but I do not see how to prove it. *)
proof -
  have \<open>equivalent_registers (id :: 'b update \<Rightarrow> _) (complement id; id)\<close>
    using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
  then obtain J :: \<open>'b update \<Rightarrow> ((('b, 'b) complement_domain * 'b) update)\<close> where \<open>iso_register J\<close>
    using equivalent_registers_def iso_register_inv by blast
  moreover obtain K :: \<open>('b, 'b) complement_domain update \<Rightarrow> 'a update\<close> where \<open>iso_register K\<close>
    using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
  ultimately have \<open>iso_register ((K \<otimes>\<^sub>r id) o J)\<close>
    by auto
  then show ?thesis
    by auto
qed

lemma compatible_complement_pair1:
  assumes \<open>compatible F G\<close>
  shows \<open>compatible F (complement (F;G))\<close>
  by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)

lemma compatible_complement_pair2:
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>compatible G (complement (F;G))\<close>
proof -
  have \<open>compatible (F;G) (complement (F;G))\<close>
    by simp
  then have \<open>compatible ((F;G) o Snd) (complement (F;G))\<close>
    by auto
  then show ?thesis
    by (auto simp: register_pair_Snd)
qed

lemma equivalent_complements:
  assumes \<open>complements F G\<close>
  assumes \<open>equivalent_registers G G'\<close>
  shows \<open>complements F G'\<close>
  apply (rule complementsI)
   apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
  by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)

lemma complements_complement_pair:
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>complements F (G; complement (F;G))\<close>
proof (rule complementsI)
  have \<open>equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))\<close>
    apply (rule equivalent_registers_assoc)
    by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
  also have \<open>equivalent_registers \<dots> id\<close>
    by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
  finally show \<open>iso_register (F;(G;complement (F;G)))\<close>
    using equivalent_registers_sym iso_register_equivalent_id by blast
  show \<open>compatible F (G;complement (F;G))\<close>
    using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed

lemma equivalent_registers_complement:
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers (complement F) (complement G)\<close>
proof -
  have \<open>complements F (complement F)\<close>
    using assms complement_is_complement equivalent_registers_register_left by blast
  with assms have \<open>complements G (complement F)\<close>
    by (meson complements_sym equivalent_complements)
  then show ?thesis
    by (rule complement_unique)
qed

lemma complements_complement_pair':
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>complements G (F; complement (F;G))\<close>
proof -
  have \<open>equivalent_registers (F;G) (G;F)\<close>
    apply (rule equivalent_registersI[where I=swap])
    by auto
  then have \<open>equivalent_registers (complement (F;G)) (complement (G;F))\<close>
    by (rule equivalent_registers_complement)
  then have \<open>equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))\<close>
    apply (rule equivalent_registers_pair_right[rotated])
    using assms compatible_complement_pair1 by blast
  moreover have \<open>complements G (F; complement (G;F))\<close>
    apply (rule complements_complement_pair)
    using assms compatible_sym by blast
  ultimately show ?thesis
    by (meson equivalent_complements equivalent_registers_sym)
qed

lemma complements_chain:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  shows \<open>complements (F o G) (complement F; F o complement G)\<close>
proof (rule complementsI)
  show \<open>compatible (F o G) (complement F; F o complement G)\<close>
    by auto
  have \<open>equivalent_registers (F \<circ> G;(complement F;F \<circ> complement G)) (F \<circ> G;(F \<circ> complement G;complement F))\<close>
    apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r swap\<close>])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have \<open>equivalent_registers \<dots> ((F \<circ> G;F \<circ> complement G);complement F)\<close>
    apply (rule equivalent_registersI[where I=assoc])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have \<open>equivalent_registers \<dots> (F o (G; complement G);complement F)\<close>
    by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
        equivalent_registers_sym equivalent_registers_trans register_comp_pair)
  also have \<open>equivalent_registers \<dots> (F o id;complement F)\<close>
    apply (rule equivalent_registers_pair_left, simp)
    apply (rule equivalent_registers_comp, simp)
    by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
  also have \<open>equivalent_registers \<dots> id\<close>
    by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
  finally show \<open>iso_register (F \<circ> G;(complement F;F \<circ> complement G))\<close>
    using equivalent_registers_sym iso_register_equivalent_id by blast
qed

lemma complements_Fst_Snd[simp]: \<open>complements Fst Snd\<close>
  by (auto intro!: complementsI simp: pair_Fst_Snd)

lemma complements_Snd_Fst[simp]: \<open>complements Snd Fst\<close>
  by (auto intro!: complementsI simp flip: swap_def)

lemma compatible_unit_register[simp]: \<open>register F \<Longrightarrow> compatible F unit_register\<close>
  using compatible_sym unit_register_compatible unit_register_is_unit_register by blast

lemma complements_id_unit_register[simp]: \<open>complements id unit_register\<close>
  using complements_sym is_unit_register_def unit_register_is_unit_register by blast

lemma complements_iso_unit_register: \<open>iso_register I \<Longrightarrow> is_unit_register U \<Longrightarrow> complements I U\<close>
  using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast

lemma iso_register_complement_is_unit_register[simp]:
  assumes \<open>iso_register F\<close>
  shows \<open>is_unit_register (complement F)\<close>
  by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)

text \<open>Adding support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> to the [@{attribute register}] attribute\<close>
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of \<open>is_unit_register _\<close>]

no_notation comp_update (infixl "*\<^sub>u" 55)
no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)

end


theory ex2_08 imports Main begin

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

value "intersperse 0 [1,2,3]"

theorem "map f (intersperse a xs) = intersperse (f a) (map f xs)"
apply(induction xs rule: intersperse.induct)
apply auto
done

end


theory ShortestPath
imports
  HOL.Complex
  "../Graph_Theory/Graph_Theory"
  "HOL-Library.Extended_Nat"
begin

section {*Shortest Path (with non-negative edge costs)*}
text{* The following theory is used in the verification of a certifying algorithm's checker for shortest path. For more information see \cite{FrameworkVerificationofCertifyingComputations}. *}

locale basic_sp =
  fin_digraph +
  fixes dist :: "'a \<Rightarrow> ereal"
  fixes c :: "'b \<Rightarrow> real"
  fixes s :: "'a"
  assumes s_in_G: "s \<in> verts G"
  assumes general_source_val: "dist s \<le> 0"
  assumes trian:
    "\<And>e. e \<in> arcs G \<Longrightarrow>
      dist (head G e) \<le> dist (tail G e) + c e"

locale basic_just_sp =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

locale shortest_path_pos_cost =
  basic_just_sp +
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

locale basic_just_sp_pred =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        pred v = Some e \<and>
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

sublocale basic_just_sp_pred \<subseteq> basic_just_sp
using basic_just_sp_pred_axioms
unfolding basic_just_sp_pred_def
   basic_just_sp_pred_axioms_def
  by unfold_locales (blast)

locale shortest_path_pos_cost_pred =
  basic_just_sp_pred +
  assumes s_in_G: "s \<in> verts G"
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

sublocale shortest_path_pos_cost_pred \<subseteq> shortest_path_pos_cost
using shortest_path_pos_cost_pred_axioms
by unfold_locales
   (auto simp: shortest_path_pos_cost_pred_def
   shortest_path_pos_cost_pred_axioms_def)

lemma tail_value_helper:
  assumes "hd p = last p"
  assumes "distinct p"
  assumes "p \<noteq> []"
  shows "p = [hd p]"
  by (metis assms distinct.simps(2) list.sel(1) neq_Nil_conv last_ConsR last_in_set)

lemma (in basic_sp) dist_le_cost:
  fixes v :: 'a
  fixes p :: "'b list"
  assumes "awalk s p v"
  shows "dist v \<le> awalk_cost c p"
  using assms
proof (induct "length p" arbitrary: p v)
  case 0
  hence "s = v" by auto
  thus ?case using 0(1) general_source_val
    by (metis awalk_cost_Nil length_0_conv zero_ereal_def)
next
  case (Suc n)
  then obtain p' e where p'e: "p = p' @ [e]"
    by (cases p rule: rev_cases) auto
  then obtain u where ewu: "awalk s p' u \<and> awalk u [e] v"
    using awalk_append_iff Suc(3) by simp
  hence du: "dist u \<le> ereal (awalk_cost c p')"
    using Suc p'e by simp
  from ewu have ust: "u = tail G e" and vta: "v = head G e"
    by auto
  hence "dist v \<le> dist u + c e"
    using ewu du ust trian[where e=e] by force
  with du have "dist v \<le> ereal (awalk_cost c p') + c e"
    by (metis add_right_mono order_trans)
  thus "dist v \<le> awalk_cost c p"
    using awalk_cost_append p'e by simp
qed

lemma (in fin_digraph) witness_path:
  assumes "\<mu> c s v = ereal r"
  shows "\<exists> p. apath s p v \<and> \<mu> c s v = awalk_cost c p"
proof -
  have sv: "s \<rightarrow>\<^sup>* v"
    using shortest_path_inf[of s v c] assms by fastforce
  {
    fix p assume "awalk s p v"
    then have no_neg_cyc:
    "\<not> (\<exists>w q. awalk w q w \<and> w \<in> set (awalk_verts s p) \<and> awalk_cost c q < 0)"
      using neg_cycle_imp_inf_\<mu> assms by force
  }
  thus ?thesis using no_neg_cyc_reach_imp_path[OF sv] by presburger
qed

lemma (in basic_sp)  dist_le_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<le> \<mu> c s v"
proof (rule ccontr)
  assume nt: "\<not> ?thesis"
  show False
  proof (cases "\<mu> c s v")
    show "\<And>r. \<mu> c s v = ereal r \<Longrightarrow> False"
    proof -
      fix r assume r_asm: "\<mu> c s v = ereal r"
      hence sv: "s \<rightarrow>\<^sup>* v"
        using shortest_path_inf[where u=s and v=v and f=c] by auto
      obtain p where
        "awalk s p v"
        "\<mu> c s v = awalk_cost c p"
        using witness_path[OF r_asm] unfolding apath_def by force
      thus False using nt dist_le_cost by simp
    qed
  next
    show "\<mu> c s v = \<infinity> \<Longrightarrow> False" using nt by simp
  next
    show "\<mu> c s v = - \<infinity> \<Longrightarrow> False" using dist_le_cost
    proof -
      assume asm: "\<mu> c s v = - \<infinity>"
      let ?C = "(\<lambda>x. ereal (awalk_cost c x)) ` {p. awalk s p v}"
      have "\<exists>x\<in> ?C. x < dist v"
        using nt unfolding \<mu>_def not_le INF_less_iff by simp
      then obtain p where
        "awalk s p v"
        "awalk_cost c p < dist v"
        by force
      thus False using dist_le_cost by force
    qed
  qed
qed

lemma (in basic_just_sp) dist_ge_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "num v \<noteq> \<infinity>"
  assumes "dist v \<noteq> -\<infinity>"
  assumes "\<mu> c s s = ereal 0"
  assumes "dist s = 0"
  assumes "\<And>u. u\<in>verts G \<Longrightarrow> u\<noteq>s \<Longrightarrow>
            num u \<noteq> \<infinity> \<Longrightarrow> num u \<noteq> enat 0"
  shows "dist v \<ge> \<mu> c s v"
proof -
  obtain n where "enat n = num v" using assms(2) by force
  thus ?thesis using assms
  proof(induct n arbitrary: v)
  case 0 thus ?case by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "v = head G e"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(4) Suc(2) by force
      have  ds: "dist (tail G e) = \<mu> c s (tail G e)"
        using Suc(1)[OF ns tail_in_verts[OF e_assms(1)] nsinf]
        Suc(5-8) e_assms(3) dist_le_\<mu>[OF tail_in_verts[OF e_assms(1)]]
        by simp
      have dmuc:"dist v \<ge> \<mu> c s (tail G e) + ereal (c e)"
        using e_assms(3) ds  by auto
      thus ?thesis
      proof (cases "dist v = \<infinity>")
      case False
        have "arc_to_ends G e = (tail G e, v)"
          unfolding arc_to_ends_def
          by (simp add: e_assms(2))
        obtain r where  \<mu>r: "\<mu> c s (tail G e) = ereal r"
           using e_assms(3) Suc(5) ds False
           by (cases "\<mu> c s (tail G e)", auto)
        obtain p where
          "awalk s p (tail G e)" and
          \<mu>s: "\<mu> c s (tail G e) = ereal (awalk_cost c p)"
          using witness_path[OF \<mu>r] unfolding apath_def
          by blast
        then have pe: "awalk s (p @ [e]) v"
          using e_assms(1,2) by (auto simp: awalk_simps)
        hence muc:"\<mu> c s v \<le> \<mu> c s (tail G e) + ereal (c e)"
        using \<mu>s min_cost_le_walk_cost[OF pe] by simp
        thus  "dist v \<ge> \<mu> c s v"  using dmuc by simp
      qed simp
    qed (simp add: Suc(6,7))
  qed
qed

lemma (in shortest_path_pos_cost) num_not0:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "num v \<noteq> \<infinity>"
  shows "num v \<noteq> enat 0"
proof -
  obtain ku where "num v = ku + enat 1"
    using assms just by blast
  thus ?thesis  by (induct ku) auto
qed

lemma (in shortest_path_pos_cost) dist_ne_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<noteq> -\<infinity>"
proof (cases "num v = \<infinity>")
case False
  obtain n where "enat n = num v"
    using False by force
  thus ?thesis using assms False
  proof(induct n arbitrary: v)
  case 0 thus ?case
    using num_not0 tail_val by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case True
      thus ?thesis using tail_val by simp
    next
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(3) Suc(2) by force
      have "dist (tail G e ) \<noteq> - \<infinity>"
        by (rule Suc(1) [OF ns tail_in_verts[OF e_assms(1)] nsinf])
      thus ?thesis using e_assms(2) by simp
    qed
  qed
next
case True
  thus ?thesis using no_path[OF assms] by simp
qed

theorem (in shortest_path_pos_cost) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using no_path[OF assms(1)] dist_le_\<mu>[OF assms(1)]
    dist_ge_\<mu>[OF assms(1) _ dist_ne_ninf[OF assms(1)]
    tail_value_check[OF s_in_G] tail_val num_not0]
    by fastforce

corollary (in shortest_path_pos_cost_pred) correct_shortest_path_pred:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using correct_shortest_path assms by simp

end


(*  Title:      ZF/AC/AC16_lemmas.thy
    Author:     Krzysztof Grabczewski

Lemmas used in the proofs concerning AC16
*)

theory AC16_lemmas
imports AC_Equiv Hartog Cardinal_aux
begin

lemma cons_Diff_eq: "a\<notin>A \<Longrightarrow> cons(a,A)-{a}=A"
by fast

lemma nat_1_lepoll_iff: "1\<lesssim>X \<longleftrightarrow> (\<exists>x. x \<in> X)"
  unfolding lepoll_def
apply (rule iffI)
apply (fast intro: inj_is_fun [THEN apply_type])
apply (erule exE)
apply (rule_tac x = "\<lambda>a \<in> 1. x" in exI)
apply (fast intro!: lam_injective)
done

lemma eqpoll_1_iff_singleton: "X\<approx>1 \<longleftrightarrow> (\<exists>x. X={x})"
apply (rule iffI)
apply (erule eqpollE)
apply (drule nat_1_lepoll_iff [THEN iffD1])
apply (fast intro!: lepoll_1_is_sing)
apply (fast intro!: singleton_eqpoll_1)
done

lemma cons_eqpoll_succ: "\<lbrakk>x\<approx>n; y\<notin>x\<rbrakk> \<Longrightarrow> cons(y,x)\<approx>succ(n)"
  unfolding succ_def
apply (fast elim!: cons_eqpoll_cong mem_irrefl)
done

lemma subsets_eqpoll_1_eq: "{Y \<in> Pow(X). Y\<approx>1} = {{x}. x \<in> X}"
apply (rule equalityI)
apply (rule subsetI)
apply (erule CollectE)
apply (drule eqpoll_1_iff_singleton [THEN iffD1])
apply (fast intro!: RepFunI)
apply (rule subsetI)
apply (erule RepFunE)
apply (rule CollectI, fast)
apply (fast intro!: singleton_eqpoll_1)
done

lemma eqpoll_RepFun_sing: "X\<approx>{{x}. x \<in> X}"
  unfolding eqpoll_def bij_def
apply (rule_tac x = "\<lambda>x \<in> X. {x}" in exI)
apply (rule IntI)
apply (unfold inj_def surj_def, simp)
apply (fast intro!: lam_type RepFunI intro: singleton_eq_iff [THEN iffD1], simp)
apply (fast intro!: lam_type)
done

lemma subsets_eqpoll_1_eqpoll: "{Y \<in> Pow(X). Y\<approx>1}\<approx>X"
apply (rule subsets_eqpoll_1_eq [THEN ssubst])
apply (rule eqpoll_RepFun_sing [THEN eqpoll_sym])
done

lemma InfCard_Least_in:
     "\<lbrakk>InfCard(x); y \<subseteq> x; y \<approx> succ(z)\<rbrakk> \<Longrightarrow> (\<mu> i. i \<in> y) \<in> y"
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll,
                         THEN succ_lepoll_imp_not_empty, THEN not_emptyE])
apply (fast intro: LeastI
            dest!: InfCard_is_Card [THEN Card_is_Ord]
            elim: Ord_in_Ord)
done

lemma subsets_lepoll_lemma1:
     "\<lbrakk>InfCard(x); n \<in> nat\<rbrakk>
      \<Longrightarrow> {y \<in> Pow(x). y\<approx>succ(succ(n))} \<lesssim> x*{y \<in> Pow(x). y\<approx>succ(n)}"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>y \<in> {y \<in> Pow(x) . y\<approx>succ (succ (n))}.
                      <\<mu> i. i \<in> y, y-{\<mu> i. i \<in> y}>" in exI)
apply (rule_tac d = "\<lambda>z. cons (fst(z), snd(z))" in lam_injective)
 apply (blast intro!: Diff_sing_eqpoll intro: InfCard_Least_in)
apply (simp, blast intro: InfCard_Least_in)
done

lemma set_of_Ord_succ_Union: "(\<forall>y \<in> z. Ord(y)) \<Longrightarrow> z \<subseteq> succ(\<Union>(z))"
apply (rule subsetI)
apply (case_tac "\<forall>y \<in> z. y \<subseteq> x", blast )
apply (simp, erule bexE)
apply (rule_tac i=y and j=x in Ord_linear_le)
apply (blast dest: le_imp_subset elim: leE ltE)+
done

lemma subset_not_mem: "j \<subseteq> i \<Longrightarrow> i \<notin> j"
by (fast elim!: mem_irrefl)

lemma succ_Union_not_mem:
     "(\<And>y. y \<in> z \<Longrightarrow> Ord(y)) \<Longrightarrow> succ(\<Union>(z)) \<notin> z"
apply (rule set_of_Ord_succ_Union [THEN subset_not_mem], blast)
done

lemma Union_cons_eq_succ_Union:
     "\<Union>(cons(succ(\<Union>(z)),z)) = succ(\<Union>(z))"
by fast

lemma Un_Ord_disj: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> i \<union> j = i | i \<union> j = j"
by (fast dest!: le_imp_subset elim: Ord_linear_le)

lemma Union_eq_Un: "x \<in> X \<Longrightarrow> \<Union>(X) = x \<union> \<Union>(X-{x})"
by fast

lemma Union_in_lemma [rule_format]:
     "n \<in> nat \<Longrightarrow> \<forall>z. (\<forall>y \<in> z. Ord(y)) \<and> z\<approx>n \<and> z\<noteq>0 \<longrightarrow> \<Union>(z) \<in> z"
apply (induct_tac "n")
apply (fast dest!: eqpoll_imp_lepoll [THEN lepoll_0_is_0])
apply (intro allI impI)
apply (erule natE)
apply (fast dest!: eqpoll_1_iff_singleton [THEN iffD1]
            intro!: Union_singleton, clarify)
apply (elim not_emptyE)
apply (erule_tac x = "z-{xb}" in allE)
apply (erule impE)
apply (fast elim!: Diff_sing_eqpoll
                   Diff_sing_eqpoll [THEN eqpoll_succ_imp_not_empty])
apply (subgoal_tac "xb \<union> \<Union>(z - {xb}) \<in> z")
apply (simp add: Union_eq_Un [symmetric])
apply (frule bspec, assumption)
apply (drule bspec)
apply (erule Diff_subset [THEN subsetD])
apply (drule Un_Ord_disj, assumption, auto)
done

lemma Union_in: "\<lbrakk>\<forall>x \<in> z. Ord(x); z\<approx>n; z\<noteq>0; n \<in> nat\<rbrakk> \<Longrightarrow> \<Union>(z) \<in> z"
by (blast intro: Union_in_lemma)

lemma succ_Union_in_x:
     "\<lbrakk>InfCard(x); z \<in> Pow(x); z\<approx>n; n \<in> nat\<rbrakk> \<Longrightarrow> succ(\<Union>(z)) \<in> x"
apply (rule Limit_has_succ [THEN ltE])
prefer 3 apply assumption
apply (erule InfCard_is_Limit)
apply (case_tac "z=0")
apply (simp, fast intro!: InfCard_is_Limit [THEN Limit_has_0])
apply (rule ltI [OF PowD [THEN subsetD] InfCard_is_Card [THEN Card_is_Ord]], assumption)
apply (blast intro: Union_in
                    InfCard_is_Card [THEN Card_is_Ord, THEN Ord_in_Ord])+
done

lemma succ_lepoll_succ_succ:
     "\<lbrakk>InfCard(x); n \<in> nat\<rbrakk>
      \<Longrightarrow> {y \<in> Pow(x). y\<approx>succ(n)} \<lesssim> {y \<in> Pow(x). y\<approx>succ(succ(n))}"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>z \<in> {y\<in>Pow(x). y\<approx>succ(n)}. cons(succ(\<Union>(z)), z)"
       in exI)
apply (rule_tac d = "\<lambda>z. z-{\<Union>(z) }" in lam_injective)
apply (blast intro!: succ_Union_in_x succ_Union_not_mem
             intro: cons_eqpoll_succ Ord_in_Ord
             dest!: InfCard_is_Card [THEN Card_is_Ord])
apply (simp only: Union_cons_eq_succ_Union)
apply (rule cons_Diff_eq)
apply (fast dest!: InfCard_is_Card [THEN Card_is_Ord]
            elim: Ord_in_Ord
            intro!: succ_Union_not_mem)
done

lemma subsets_eqpoll_X:
     "\<lbrakk>InfCard(X); n \<in> nat\<rbrakk> \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)} \<approx> X"
apply (induct_tac "n")
apply (rule subsets_eqpoll_1_eqpoll)
apply (rule eqpollI)
apply (rule subsets_lepoll_lemma1 [THEN lepoll_trans], assumption+)
apply (rule eqpoll_trans [THEN eqpoll_imp_lepoll])
 apply (erule eqpoll_refl [THEN prod_eqpoll_cong])
apply (erule InfCard_square_eqpoll)
apply (fast elim: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
            intro!: succ_lepoll_succ_succ)
done

lemma image_vimage_eq:
     "\<lbrakk>f \<in> surj(A,B); y \<subseteq> B\<rbrakk> \<Longrightarrow> f``(converse(f)``y) = y"
  unfolding surj_def
apply (fast dest: apply_equality2 elim: apply_iff [THEN iffD2])
done

lemma vimage_image_eq: "\<lbrakk>f \<in> inj(A,B); y \<subseteq> A\<rbrakk> \<Longrightarrow> converse(f)``(f``y) = y"
by (fast elim!: inj_is_fun [THEN apply_Pair] dest: inj_equality)

lemma subsets_eqpoll:
     "A\<approx>B \<Longrightarrow> {Y \<in> Pow(A). Y\<approx>n}\<approx>{Y \<in> Pow(B). Y\<approx>n}"
  unfolding eqpoll_def
apply (erule exE)
apply (rule_tac x = "\<lambda>X \<in> {Y \<in> Pow (A) . \<exists>f. f \<in> bij (Y, n) }. f``X" in exI)
apply (rule_tac d = "\<lambda>Z. converse (f) ``Z" in lam_bijective)
apply (fast intro!: bij_is_inj [THEN restrict_bij, THEN bij_converse_bij,
                                THEN comp_bij]
            elim!: bij_is_fun [THEN fun_is_rel, THEN image_subset])
apply (blast intro!:  bij_is_inj [THEN restrict_bij]
                      comp_bij bij_converse_bij
                      bij_is_fun [THEN fun_is_rel, THEN image_subset])
apply (fast elim!: bij_is_inj [THEN vimage_image_eq])
apply (fast elim!: bij_is_surj [THEN image_vimage_eq])
done

lemma WO2_imp_ex_Card: "WO2 \<Longrightarrow> \<exists>a. Card(a) \<and> X\<approx>a"
  unfolding WO2_def
apply (drule spec [of _ X])
apply (blast intro: Card_cardinal eqpoll_trans
          well_ord_Memrel [THEN well_ord_cardinal_eqpoll, THEN eqpoll_sym])
done

lemma lepoll_infinite: "\<lbrakk>X\<lesssim>Y; \<not>Finite(X)\<rbrakk> \<Longrightarrow> \<not>Finite(Y)"
by (blast intro: lepoll_Finite)

lemma infinite_Card_is_InfCard: "\<lbrakk>\<not>Finite(X); Card(X)\<rbrakk> \<Longrightarrow> InfCard(X)"
  unfolding InfCard_def
apply (fast elim!: Card_is_Ord [THEN nat_le_infinite_Ord])
done

lemma WO2_infinite_subsets_eqpoll_X: "\<lbrakk>WO2; n \<in> nat; \<not>Finite(X)\<rbrakk>
        \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
apply (drule WO2_imp_ex_Card)
apply (elim allE exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (drule infinite_Card_is_InfCard, assumption)
apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans)
done

lemma well_ord_imp_ex_Card: "well_ord(X,R) \<Longrightarrow> \<exists>a. Card(a) \<and> X\<approx>a"
by (fast elim!: well_ord_cardinal_eqpoll [THEN eqpoll_sym]
         intro!: Card_cardinal)

lemma well_ord_infinite_subsets_eqpoll_X:
     "\<lbrakk>well_ord(X,R); n \<in> nat; \<not>Finite(X)\<rbrakk> \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
apply (drule well_ord_imp_ex_Card)
apply (elim allE exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (drule infinite_Card_is_InfCard, assumption)
apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans)
done

end