(*by Ammer*)
theory VEBT_MinMax imports VEBT_Member
begin

section \<open>The Minimum and Maximum Operation\<close>

fun vebt_mint :: "VEBT \<Rightarrow> nat option" where
  "vebt_mint (Leaf a b) = (if a then Some 0 else if b then Some 1 else None)"|
  "vebt_mint (Node None _ _ _) = None"|
  "vebt_mint (Node (Some (mi,ma)) _ _ _ ) = Some mi"

fun vebt_maxt :: "VEBT \<Rightarrow> nat option" where
  "vebt_maxt (Leaf a b) = (if b then Some 1 else if a then Some 0 else None)"|
  "vebt_maxt (Node None _ _ _) = None"|
  "vebt_maxt (Node (Some (mi,ma)) _ _ _ ) = Some ma"

context VEBT_internal begin

fun option_shift::"('a\<Rightarrow>'a\<Rightarrow>'a) \<Rightarrow>'a option \<Rightarrow>'a option\<Rightarrow> 'a option" where
"option_shift _ None _ = None"|
"option_shift _ _ None = None"|
"option_shift f (Some a) (Some b) = Some (f a b)"

definition power::"nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl"^\<^sub>o" 81) where
"power= option_shift (^)"

definition add::"nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl"+\<^sub>o" 79) where
"add= option_shift (+)"

definition mul::"nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl"*\<^sub>o" 80) where
"mul = option_shift (*)"

fun option_comp_shift::"('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
"option_comp_shift _ None _ = False"|
"option_comp_shift _ _ None = False"|
"option_comp_shift f (Some x) (Some y) =  f x y"

fun less::"nat option \<Rightarrow> nat option \<Rightarrow> bool" (infixl"<\<^sub>o" 80) where
"less x y= option_comp_shift (<) x y"

fun lesseq::"nat option \<Rightarrow> nat option \<Rightarrow> bool" (infixl"\<le>\<^sub>o" 80) where
"lesseq x y = option_comp_shift (\<le>) x y"

fun greater::"nat option \<Rightarrow> nat option \<Rightarrow> bool" (infixl">\<^sub>o" 80) where
"greater x y = option_comp_shift (>) x y"

lemma add_shift:"x+y = z \<longleftrightarrow> Some x +\<^sub>o Some y = Some z"
  by (simp add: add_def)

lemma mul_shift:"x*y = z \<longleftrightarrow> Some x *\<^sub>o Some y = Some z" by (simp add: mul_def)

lemma power_shift:"x^y = z \<longleftrightarrow> Some x ^\<^sub>o Some y = Some z" by (simp add: power_def)

lemma less_shift: "x < y \<longleftrightarrow> Some x <\<^sub>o Some y" by simp

lemma lesseq_shift: "x \<le> y \<longleftrightarrow> Some x \<le>\<^sub>o Some y" by simp

lemma greater_shift: "x > y \<longleftrightarrow> Some x >\<^sub>o Some y" by simp

definition max_in_set :: "nat set \<Rightarrow> nat \<Rightarrow> bool" where
  "max_in_set xs x \<longleftrightarrow> (x \<in> xs \<and> (\<forall> y \<in> xs. y \<le> x))"

lemma maxt_member: "invar_vebt t n \<Longrightarrow> vebt_maxt t = Some maxi \<Longrightarrow> vebt_member t maxi"
proof(induction t n  arbitrary: maxi rule: invar_vebt.induct)
case (1 a b)
  then show ?case
    by (metis VEBT_Member.vebt_member.simps(1) vebt_maxt.simps(1) option.distinct(1) option.inject zero_neq_one)
next
case (2 treeList n summary m deg)
  then show ?case
    by simp
next
case (3 treeList n summary m deg)
  then show ?case
    by simp
next
  case (4 treeList n summary m deg mi ma)
  hence "deg \<ge> 2"
    by (metis One_nat_def Suc_le_eq add_mono deg_not_0 numeral_2_eq_2 plus_1_eq_Suc)
  then show ?case
    by (metis "4.prems" VEBT_Member.vebt_member.simps(5) Suc_diff_Suc Suc_pred lessI less_le_trans vebt_maxt.simps(3) numeral_2_eq_2 option.inject zero_less_Suc)
next
  case (5 treeList n summary m deg mi ma)
  hence "deg \<ge> 2"
    by (metis Suc_leI le_add2 less_add_same_cancel2 less_le_trans not_less_iff_gr_or_eq not_one_le_zero numeral_2_eq_2 plus_1_eq_Suc set_n_deg_not_0)
  then show ?case
    by (metis "5.prems" VEBT_Member.vebt_member.simps(5) add_2_eq_Suc le_add_diff_inverse vebt_maxt.simps(3) option.inject)
qed

lemma maxt_corr_help: "invar_vebt t n \<Longrightarrow> vebt_maxt t = Some maxi \<Longrightarrow> vebt_member t x \<Longrightarrow> maxi \<ge> x "
  by (smt VEBT_Member.vebt_member.simps(1) le_less vebt_maxt.elims member_inv mi_ma_2_deg option.simps(1) option.simps(3) zero_le_one)

lemma maxt_corr_help_empty: "invar_vebt t n \<Longrightarrow> vebt_maxt t = None \<Longrightarrow> set_vebt' t = {}"
  by (metis (full_types) VEBT_Member.vebt_member.simps(1) empty_Collect_eq vebt_maxt.elims minNull.simps(4) min_Null_member option.distinct(1) set_vebt'_def)

theorem maxt_corr:assumes "invar_vebt t n" and "vebt_maxt t = Some x" shows "max_in_set (set_vebt' t) x"
  unfolding set_vebt'_def Max_def max_in_set_def
  using assms(1) assms(2) maxt_corr_help maxt_member by blast

theorem maxt_sound:assumes "invar_vebt t n" and  "max_in_set (set_vebt' t) x" shows "vebt_maxt t = Some x"
  by (metis (no_types, opaque_lifting) assms(1) assms(2) empty_Collect_eq le_less max_in_set_def
 maxt_corr_help maxt_corr_help_empty maxt_member mem_Collect_eq not_le option.exhaust set_vebt'_def)

definition min_in_set :: "nat set \<Rightarrow> nat \<Rightarrow> bool" where
  "min_in_set xs x \<longleftrightarrow> (x \<in> xs \<and> (\<forall> y \<in> xs. y \<ge> x))"

lemma mint_member: "invar_vebt t n \<Longrightarrow> vebt_mint t = Some maxi \<Longrightarrow> vebt_member t maxi"
proof(induction t n  arbitrary: maxi rule: invar_vebt.induct)
case (1 a b)
  then show ?case
    by (metis VEBT_Member.vebt_member.simps(1) vebt_mint.simps(1) option.distinct(1) option.inject zero_neq_one)
next
case (2 treeList n summary m deg)
  then show ?case
    by simp
next
case (3 treeList n summary m deg)
  then show ?case
    by simp
next
  case (4 treeList n summary m deg mi ma)
  hence "deg \<ge> 2"
    by (metis One_nat_def Suc_le_eq add_mono deg_not_0 numeral_2_eq_2 plus_1_eq_Suc)
  then show ?case
    by (metis "4.prems" VEBT_Member.vebt_member.simps(5) One_nat_def Suc_diff_Suc Suc_pred dual_order.strict_trans1 le_imp_less_Suc le_numeral_extra(4) vebt_mint.simps(3) numeral_2_eq_2 option.inject zero_le_one)
next
  case (5 treeList n summary m deg mi ma)
  hence "deg \<ge> 2"
    by (metis Suc_leI le_add2 less_add_same_cancel2 less_le_trans not_less_iff_gr_or_eq not_one_le_zero numeral_2_eq_2 plus_1_eq_Suc set_n_deg_not_0)
  then show ?case using  "5.prems" VEBT_Member.vebt_member.simps(5) add_2_eq_Suc  le_add_diff_inverse vebt_mint.simps(3)
    by (metis option.inject)
qed

lemma mint_corr_help: "invar_vebt t n \<Longrightarrow> vebt_mint t = Some mini \<Longrightarrow> vebt_member t x \<Longrightarrow> mini \<le> x "
  by (smt VEBT_Member.vebt_member.simps(1) eq_iff option.inject less_imp_le_nat member_inv mi_ma_2_deg vebt_mint.elims of_nat_0 of_nat_0_le_iff of_nat_le_iff option.simps(3))

lemma mint_corr_help_empty: "invar_vebt t n \<Longrightarrow> vebt_mint t = None \<Longrightarrow> set_vebt' t = {}"
  by (metis VEBT_internal.maxt_corr_help_empty option.distinct(1) vebt_maxt.simps(1) vebt_maxt.simps(2) vebt_mint.elims)

theorem mint_corr:assumes "invar_vebt t n" and "vebt_mint t = Some x" shows "min_in_set (set_vebt' t) x"
  using assms(1) assms(2) min_in_set_def mint_corr_help mint_member set_vebt'_def by auto

theorem mint_sound:assumes "invar_vebt t n" and  "min_in_set (set_vebt' t) x" shows "vebt_mint t = Some x"
  by (metis assms(1) assms(2) empty_Collect_eq eq_iff mem_Collect_eq min_in_set_def
 mint_corr_help mint_corr_help_empty mint_member option.exhaust set_vebt'_def)

lemma summaxma:assumes "invar_vebt (Node (Some (mi, ma)) deg treeList summary) deg" and "mi \<noteq> ma"
  shows "the (vebt_maxt summary) = high ma (deg div 2)"
proof-
  from assms(1) show ?thesis
  proof(cases)
    case (4 n m)
    have "both_member_options summary (high ma n)"
      using "4"(10) "4"(2) "4"(4) "4"(5) "4"(6) "4"(9) assms(2) deg_not_0 exp_split_high_low(1) by blast
    have "high ma n \<le> the (vebt_maxt summary)" using  "4"(2) \<open>both_member_options summary
          (high ma n)\<close> empty_Collect_eq option.inject maxt_corr_help maxt_corr_help_empty
          not_None_eq set_vebt'_def valid_member_both_member_options
      by (metis option.exhaust_sel)
    have "high ma n < the (vebt_maxt summary) \<Longrightarrow> False"
    proof-
      assume "high ma n < the (vebt_maxt summary)"
      obtain maxs where "Some maxs = vebt_maxt summary"
        by (metis "4"(2) \<open>both_member_options summary (high ma n)\<close> empty_Collect_eq maxt_corr_help_empty
            not_None_eq set_vebt'_def valid_member_both_member_options)
      hence "\<exists> x. both_member_options (treeList ! maxs) x"
        by (metis "4"(2) "4"(6) both_member_options_equiv_member maxt_member member_bound)
      then obtain x where "both_member_options (treeList ! maxs) x"
        by auto
      hence "vebt_member (treeList ! maxs) x"
        by (metis "4"(1) "4"(2) "4"(3) \<open>Some maxs = vebt_maxt summary\<close> maxt_member member_bound nth_mem valid_member_both_member_options)
      have "maxs < 2^m"
        by (metis "4"(2) \<open>Some maxs = vebt_maxt summary\<close> maxt_member member_bound)
      have "invar_vebt (treeList ! maxs) n"
        by (metis "4"(1) "4"(3) \<open>maxs < 2 ^ m\<close> inthall member_def)
      hence "x < 2^n"
        using \<open>vebt_member (treeList ! maxs) x\<close> member_bound by auto
      let ?X =  "2^n*maxs + x"
      have "high ?X n = maxs"
        by (simp add: \<open>x < 2 ^ n\<close> high_inv mult.commute)
      hence "both_member_options (Node (Some (mi, ma)) deg treeList summary) (2^n*maxs + x)"
        by (metis "4"(3) "4"(4) "4"(5) One_nat_def Suc_leI \<open>both_member_options (treeList ! maxs) x\<close> \<open>maxs < 2 ^ m\<close> \<open>x < 2 ^ n\<close> add_self_div_2 assms(1) both_member_options_from_chilf_to_complete_tree deg_not_0 low_inv mult.commute)
      hence "vebt_member (Node (Some (mi, ma)) deg treeList summary) ?X"
        using assms(1) both_member_options_equiv_member by auto
      have "high ?X n> high ma n"
        by (metis \<open>Some maxs = vebt_maxt summary\<close> \<open>high (2 ^ n * maxs + x) n = maxs\<close> \<open>high ma n < the (vebt_maxt summary)\<close> option.exhaust_sel option.inject option.simps(3))
     hence "?X > ma"
        by (metis div_le_mono high_def not_le)
      then show ?thesis
        by (metis "4"(8) \<open>vebt_member (Node (Some (mi, ma)) deg treeList summary) (2 ^ n * maxs + x)\<close> leD member_inv not_less_iff_gr_or_eq)
    qed
    then show ?thesis
      using "4"(4) "4"(5) \<open>high ma n \<le> the (vebt_maxt summary)\<close> by fastforce
next
  case (5 n m)
   have "both_member_options summary (high ma n)"
     by (metis "5"(10) "5"(5) "5"(6) "5"(9) div_eq_0_iff assms(2) div_exp_eq high_def nat.simps(3) numerals(2) power_not_zero)
      have "high ma n \<le> the (vebt_maxt summary)"
        by (metis "5"(2) VEBT_Member.vebt_member.simps(2) \<open>both_member_options summary (high ma n)\<close> vebt_maxt.elims maxt_corr_help minNull.simps(1) min_Null_member option.exhaust_sel option.simps(3) valid_member_both_member_options)
   have "high ma n < the (vebt_maxt summary) \<Longrightarrow> False"
    proof-
      assume "high ma n < the (vebt_maxt summary)"
      obtain maxs where "Some maxs = vebt_maxt summary"
        by (metis "5"(2) \<open>both_member_options summary (high ma n)\<close> empty_Collect_eq maxt_corr_help_empty
         not_None_eq set_vebt'_def valid_member_both_member_options)
      hence "\<exists> x. both_member_options (treeList ! maxs) x"
        by (metis "5"(2) "5"(6) both_member_options_equiv_member maxt_member member_bound)
      then obtain x where "both_member_options (treeList ! maxs) x"
        by auto
      hence "vebt_member (treeList ! maxs) x"
        by (metis "5"(1) "5"(2) "5"(3) \<open>Some maxs = vebt_maxt summary\<close> both_member_options_equiv_member maxt_member member_bound nth_mem)
      have "maxs < 2^m"
        by (metis "5"(2) \<open>Some maxs = vebt_maxt summary\<close> maxt_member member_bound)
      have "invar_vebt (treeList ! maxs) n"
        by (metis "5"(1) "5"(3) \<open>maxs < 2 ^ m\<close> inthall member_def)
      hence "x < 2^n"
        using \<open>vebt_member (treeList ! maxs) x\<close> member_bound by auto
      let ?X =  "2^n*maxs + x"
      have "high ?X n = maxs"
        by (simp add: \<open>x < 2 ^ n\<close> high_inv mult.commute)
      hence "both_member_options (Node (Some (mi, ma)) deg treeList summary) (2^n*maxs + x)"
        by (smt (z3) "5"(3) "5"(4) "5"(5) \<open>both_member_options (treeList ! maxs) x\<close> \<open>maxs < 2 ^ m\<close> \<open>x < 2 ^ n\<close> add_Suc_right add_self_div_2 both_member_options_from_chilf_to_complete_tree even_Suc_div_two le_add1 low_inv mult.commute odd_add plus_1_eq_Suc)
    hence "vebt_member (Node (Some (mi, ma)) deg treeList summary) ?X"
        using assms(1) both_member_options_equiv_member by auto
      have "high ?X n> high ma n"
        by (metis \<open>Some maxs = vebt_maxt summary\<close> \<open>high (2 ^ n * maxs + x) n = maxs\<close> \<open>high ma n < the (vebt_maxt summary)\<close> option.sel)
     hence "?X > ma"
        by (metis div_le_mono high_def not_le)
      then show ?thesis
        by (metis "5"(8) \<open>vebt_member (Node (Some (mi, ma)) deg treeList summary) (2 ^ n * maxs + x)\<close> leD member_inv not_less_iff_gr_or_eq)
    qed
    then show ?thesis
      using "5"(4) "5"(5) \<open>high ma n \<le> the(vebt_maxt summary)\<close> by fastforce
  qed
qed

lemma maxbmo: "vebt_maxt t = Some x \<Longrightarrow> both_member_options t x"
  apply(induction t rule: vebt_maxt.induct)
    apply auto
  apply (metis both_member_options_def naive_member.simps(1) option.distinct(1) option.sel zero_neq_one)
  by (metis One_nat_def Suc_le_D both_member_options_def div_by_1 div_greater_zero_iff membermima.simps(3) membermima.simps(4) not_gr0)

lemma misiz:"invar_vebt t n \<Longrightarrow> Some m = vebt_mint t \<Longrightarrow> m < 2^n"
  by (metis member_bound mint_member)

lemma mintlistlength: assumes "invar_vebt (Node (Some (mi, ma)) deg treeList summary) n " "
    mi \<noteq> ma " shows " ma > mi \<and> (\<exists> m. Some m = vebt_mint summary \<and> m < 2^(n - n div 2))"
  using assms(1)
proof cases
  case (4 n m)
  hence "both_member_options (treeList ! high ma n) (low ma n)"
    by (metis assms(2) high_bound_aux)
  moreover  hence "both_member_options summary (high ma n)"
    using "4"(10) "4"(6) "4"(7) high_bound_aux by blast
  moreover  then obtain mini where "Some mini = vebt_mint summary"
    by (metis "4"(3) empty_Collect_eq mint_corr_help_empty option.exhaust_sel set_vebt'_def valid_member_both_member_options)
  moreover hence "mini < 2^m"
    by (metis "4"(3)  mint_member member_bound)
  moreover have "m = (deg - deg div 2)" using 4(6) 4(5)
    by auto
  ultimately show ?thesis using 4(1) assms 4(9) by auto
next
  case (5 n m)
  hence "both_member_options (treeList ! high ma n) (low ma n)"
    by (metis assms(2) high_bound_aux)
  moreover  hence "both_member_options summary (high ma n)"
    using "5"(10) "5"(6) "5"(7) high_bound_aux by blast
  moreover  then obtain mini where "Some mini = vebt_mint summary"
    by (metis "5"(3) empty_Collect_eq mint_corr_help_empty option.exhaust_sel set_vebt'_def valid_member_both_member_options)
  moreover hence "mini < 2^m"
    by (metis "5"(3)  mint_member member_bound)
  moreover have "m = (deg - deg div 2)" using 5(6) 5(5)
    by auto
  ultimately show ?thesis using 5(1) assms 5(9) by auto
qed

lemma power_minus_is_div:
  "b \<le> a \<Longrightarrow> (2 :: nat) ^ (a - b) = 2 ^ a div 2 ^ b"
  apply (induct a arbitrary: b)
   apply simp
  apply (erule le_SucE)
   apply (clarsimp simp:Suc_diff_le le_iff_add power_add)
  apply simp
  done

lemma nested_mint:assumes "invar_vebt (Node (Some (mi, ma)) deg treeList summary) n " "n = Suc (Suc va) ""
    \<not> ma < mi "" ma \<noteq> mi " shows "
    high (the (vebt_mint summary) * (2 * 2 ^ (va div 2)) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2))
    < length treeList"
proof-
  have setprop: "t \<in> set treeList \<Longrightarrow> invar_vebt t (n div 2 )" for t using assms(1)
    by (cases) simp+
  have listlength: "length treeList = 2^(n - n div 2)" using assms(1)
    by (cases) simp+
  have sumprop: "invar_vebt summary (n - n div 2)" using assms(1)
    by (cases) simp+
  have mimaxprop: "mi \<le> ma \<and> ma \<le> 2^n" using assms(1)
    by cases  simp+
  hence xbound: "mi \<le> x \<Longrightarrow> x \<le> ma \<Longrightarrow> high x (n div 2) \<le> length treeList " for x
    using div_le_dividend div_le_mono high_def listlength power_minus_is_div by auto
  have contcong:"i < length treeList \<Longrightarrow> \<exists> x. both_member_options (treeList ! i) x \<longleftrightarrow> both_member_options summary i " for i
    using assms(1)by cases  auto+
  obtain m where " Some m = vebt_mint summary \<and> m < 2^(n - n div 2)"
    using assms(1) assms(4) mintlistlength by blast
  then obtain miny where "(vebt_mint (treeList ! the (vebt_mint summary))) =Some miny"
    by (metis both_member_options_equiv_member contcong empty_Collect_eq listlength mint_corr_help_empty mint_member nth_mem option.exhaust_sel option.sel setprop sumprop set_vebt'_def)
  hence "miny < 2^(n div 2)"
    by (metis \<open>\<And>thesis. (\<And>m. Some m = vebt_mint summary \<and> m < 2 ^ (n - n div 2) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> listlength misiz nth_mem option.sel setprop)
  then show ?thesis
    by (metis \<open>\<And>thesis. (\<And>m. Some m = vebt_mint summary \<and> m < 2 ^ (n - n div 2) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>vebt_mint (treeList ! the (vebt_mint summary)) = Some miny\<close> assms(2) div2_Suc_Suc high_inv listlength option.sel power_Suc)
qed

lemma minminNull: "vebt_mint t = None \<Longrightarrow> minNull t"
  by (metis minNull.simps(1) minNull.simps(4) vebt_mint.elims option.distinct(1))

lemma minNullmin: "minNull t \<Longrightarrow> vebt_mint t = None"
  by (metis minNull.elims(2) vebt_mint.simps(1) vebt_mint.simps(2))

end
end


theory Concrete_Semantics_2_2_ex6
imports Main
begin

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

fun contents :: "'a tree => 'a list" where
"contents Tip = []" |
"contents (Node l a r) = (contents r) @ (a # (contents l))"

fun sum_tree :: "nat tree => nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r) = (sum_tree l) + a + (sum_tree r)"

lemma "sum_tree t = sum_list (contents t)"
apply(induction t)
apply(auto)
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_23
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "((max a b) = (max b a))"
  (*why "induct a arbitrary: b" rather than "induct b arbitrary: a"?
    \<rightarrow> both work well.*)
  apply(induct a arbitrary: b)
   apply(induct_tac b)(*"case_tac" works well. See below.*)
    apply fastforce+
  apply(induct_tac b)(*"case_tac" works well. See below.*)
   apply fastforce+
  done

theorem property0' :
  "((max a b) = (max b a))"
  apply(induct a arbitrary: b)
   apply (case_tac b)
    apply fastforce+
  apply (case_tac b)
   apply fastforce+
  done

theorem property0'' :
  "((max a b) = (max b a))"
  apply(induct b arbitrary: a)
   apply (induct_tac a)
    apply fastforce+
  apply (induct_tac a)
   apply fastforce+
  done

theorem property0''' :
  "((max a b) = (max b a))"
  apply(induct b arbitrary: a)
   apply (case_tac a)
    apply fastforce+
  apply (case_tac a)
   apply fastforce+
  done

end


(*  Title:      ZF/Ordinal.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Transitive Sets and Ordinals\<close>

theory Ordinal imports WF Bool equalities begin

definition
  Memrel        :: "i\<Rightarrow>i"  where
    "Memrel(A)   \<equiv> {z\<in>A*A . \<exists>x y. z=\<langle>x,y\<rangle> \<and> x\<in>y }"

definition
  Transset  :: "i\<Rightarrow>o"  where
    "Transset(i) \<equiv> \<forall>x\<in>i. x<=i"

definition
  Ord  :: "i\<Rightarrow>o"  where
    "Ord(i)      \<equiv> Transset(i) \<and> (\<forall>x\<in>i. Transset(x))"

definition
  lt        :: "[i,i] \<Rightarrow> o"  (infixl \<open><\<close> 50)   (*less-than on ordinals*)  where
    "i<j         \<equiv> i\<in>j \<and> Ord(j)"

definition
  Limit         :: "i\<Rightarrow>o"  where
    "Limit(i)    \<equiv> Ord(i) \<and> 0<i \<and> (\<forall>y. y<i \<longrightarrow> succ(y)<i)"

abbreviation
  le  (infixl \<open>\<le>\<close> 50) where
  "x \<le> y \<equiv> x < succ(y)"

subsection\<open>Rules for Transset\<close>

subsubsection\<open>Three Neat Characterisations of Transset\<close>

lemma Transset_iff_Pow: "Transset(A) <-> A<=Pow(A)"
by (unfold Transset_def, blast)

lemma Transset_iff_Union_succ: "Transset(A) <-> \<Union>(succ(A)) = A"
  unfolding Transset_def
apply (blast elim!: equalityE)
done

lemma Transset_iff_Union_subset: "Transset(A) <-> \<Union>(A) \<subseteq> A"
by (unfold Transset_def, blast)

subsubsection\<open>Consequences of Downwards Closure\<close>

lemma Transset_doubleton_D:
    "\<lbrakk>Transset(C); {a,b}: C\<rbrakk> \<Longrightarrow> a\<in>C \<and> b\<in>C"
by (unfold Transset_def, blast)

lemma Transset_Pair_D:
    "\<lbrakk>Transset(C); \<langle>a,b\<rangle>\<in>C\<rbrakk> \<Longrightarrow> a\<in>C \<and> b\<in>C"
apply (simp add: Pair_def)
apply (blast dest: Transset_doubleton_D)
done

lemma Transset_includes_domain:
    "\<lbrakk>Transset(C); A*B \<subseteq> C; b \<in> B\<rbrakk> \<Longrightarrow> A \<subseteq> C"
by (blast dest: Transset_Pair_D)

lemma Transset_includes_range:
    "\<lbrakk>Transset(C); A*B \<subseteq> C; a \<in> A\<rbrakk> \<Longrightarrow> B \<subseteq> C"
by (blast dest: Transset_Pair_D)

subsubsection\<open>Closure Properties\<close>

lemma Transset_0: "Transset(0)"
by (unfold Transset_def, blast)

lemma Transset_Un:
    "\<lbrakk>Transset(i);  Transset(j)\<rbrakk> \<Longrightarrow> Transset(i \<union> j)"
by (unfold Transset_def, blast)

lemma Transset_Int:
    "\<lbrakk>Transset(i);  Transset(j)\<rbrakk> \<Longrightarrow> Transset(i \<inter> j)"
by (unfold Transset_def, blast)

lemma Transset_succ: "Transset(i) \<Longrightarrow> Transset(succ(i))"
by (unfold Transset_def, blast)

lemma Transset_Pow: "Transset(i) \<Longrightarrow> Transset(Pow(i))"
by (unfold Transset_def, blast)

lemma Transset_Union: "Transset(A) \<Longrightarrow> Transset(\<Union>(A))"
by (unfold Transset_def, blast)

lemma Transset_Union_family:
    "\<lbrakk>\<And>i. i\<in>A \<Longrightarrow> Transset(i)\<rbrakk> \<Longrightarrow> Transset(\<Union>(A))"
by (unfold Transset_def, blast)

lemma Transset_Inter_family:
    "\<lbrakk>\<And>i. i\<in>A \<Longrightarrow> Transset(i)\<rbrakk> \<Longrightarrow> Transset(\<Inter>(A))"
by (unfold Inter_def Transset_def, blast)

lemma Transset_UN:
     "(\<And>x. x \<in> A \<Longrightarrow> Transset(B(x))) \<Longrightarrow> Transset (\<Union>x\<in>A. B(x))"
by (rule Transset_Union_family, auto)

lemma Transset_INT:
     "(\<And>x. x \<in> A \<Longrightarrow> Transset(B(x))) \<Longrightarrow> Transset (\<Inter>x\<in>A. B(x))"
by (rule Transset_Inter_family, auto)

subsection\<open>Lemmas for Ordinals\<close>

lemma OrdI:
    "\<lbrakk>Transset(i);  \<And>x. x\<in>i \<Longrightarrow> Transset(x)\<rbrakk>  \<Longrightarrow>  Ord(i)"
by (simp add: Ord_def)

lemma Ord_is_Transset: "Ord(i) \<Longrightarrow> Transset(i)"
by (simp add: Ord_def)

lemma Ord_contains_Transset:
    "\<lbrakk>Ord(i);  j\<in>i\<rbrakk> \<Longrightarrow> Transset(j) "
by (unfold Ord_def, blast)

lemma Ord_in_Ord: "\<lbrakk>Ord(i);  j\<in>i\<rbrakk> \<Longrightarrow> Ord(j)"
by (unfold Ord_def Transset_def, blast)

(*suitable for rewriting PROVIDED i has been fixed*)
lemma Ord_in_Ord': "\<lbrakk>j\<in>i; Ord(i)\<rbrakk> \<Longrightarrow> Ord(j)"
by (blast intro: Ord_in_Ord)

(* Ord(succ(j)) \<Longrightarrow> Ord(j) *)
lemmas Ord_succD = Ord_in_Ord [OF _ succI1]

lemma Ord_subset_Ord: "\<lbrakk>Ord(i);  Transset(j);  j<=i\<rbrakk> \<Longrightarrow> Ord(j)"
by (simp add: Ord_def Transset_def, blast)

lemma OrdmemD: "\<lbrakk>j\<in>i;  Ord(i)\<rbrakk> \<Longrightarrow> j<=i"
by (unfold Ord_def Transset_def, blast)

lemma Ord_trans: "\<lbrakk>i\<in>j;  j\<in>k;  Ord(k)\<rbrakk> \<Longrightarrow> i\<in>k"
by (blast dest: OrdmemD)

lemma Ord_succ_subsetI: "\<lbrakk>i\<in>j;  Ord(j)\<rbrakk> \<Longrightarrow> succ(i) \<subseteq> j"
by (blast dest: OrdmemD)

subsection\<open>The Construction of Ordinals: 0, succ, Union\<close>

lemma Ord_0 [iff,TC]: "Ord(0)"
by (blast intro: OrdI Transset_0)

lemma Ord_succ [TC]: "Ord(i) \<Longrightarrow> Ord(succ(i))"
by (blast intro: OrdI Transset_succ Ord_is_Transset Ord_contains_Transset)

lemmas Ord_1 = Ord_0 [THEN Ord_succ]

lemma Ord_succ_iff [iff]: "Ord(succ(i)) <-> Ord(i)"
by (blast intro: Ord_succ dest!: Ord_succD)

lemma Ord_Un [intro,simp,TC]: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> Ord(i \<union> j)"
  unfolding Ord_def
apply (blast intro!: Transset_Un)
done

lemma Ord_Int [TC]: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> Ord(i \<inter> j)"
  unfolding Ord_def
apply (blast intro!: Transset_Int)
done

text\<open>There is no set of all ordinals, for then it would contain itself\<close>
lemma ON_class: "\<not> (\<forall>i. i\<in>X <-> Ord(i))"
proof (rule notI)
  assume X: "\<forall>i. i \<in> X \<longleftrightarrow> Ord(i)"
  have "\<forall>x y. x\<in>X \<longrightarrow> y\<in>x \<longrightarrow> y\<in>X"
    by (simp add: X, blast intro: Ord_in_Ord)
  hence "Transset(X)"
     by (auto simp add: Transset_def)
  moreover have "\<And>x. x \<in> X \<Longrightarrow> Transset(x)"
     by (simp add: X Ord_def)
  ultimately have "Ord(X)" by (rule OrdI)
  hence "X \<in> X" by (simp add: X)
  thus "False" by (rule mem_irrefl)
qed

subsection\<open>< is 'less Than' for Ordinals\<close>

lemma ltI: "\<lbrakk>i\<in>j;  Ord(j)\<rbrakk> \<Longrightarrow> i<j"
by (unfold lt_def, blast)

lemma ltE:
    "\<lbrakk>i<j;  \<lbrakk>i\<in>j;  Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  unfolding lt_def
apply (blast intro: Ord_in_Ord)
done

lemma ltD: "i<j \<Longrightarrow> i\<in>j"
by (erule ltE, assumption)

lemma not_lt0 [simp]: "\<not> i<0"
by (unfold lt_def, blast)

lemma lt_Ord: "j<i \<Longrightarrow> Ord(j)"
by (erule ltE, assumption)

lemma lt_Ord2: "j<i \<Longrightarrow> Ord(i)"
by (erule ltE, assumption)

(* @{term"ja \<le> j \<Longrightarrow> Ord(j)"} *)
lemmas le_Ord2 = lt_Ord2 [THEN Ord_succD]

(* i<0 \<Longrightarrow> R *)
lemmas lt0E = not_lt0 [THEN notE, elim!]

lemma lt_trans [trans]: "\<lbrakk>i<j;  j<k\<rbrakk> \<Longrightarrow> i<k"
by (blast intro!: ltI elim!: ltE intro: Ord_trans)

lemma lt_not_sym: "i<j \<Longrightarrow> \<not> (j<i)"
  unfolding lt_def
apply (blast elim: mem_asym)
done

(* \<lbrakk>i<j;  \<not>P \<Longrightarrow> j<i\<rbrakk> \<Longrightarrow> P *)
lemmas lt_asym = lt_not_sym [THEN swap]

lemma lt_irrefl [elim!]: "i<i \<Longrightarrow> P"
by (blast intro: lt_asym)

lemma lt_not_refl: "\<not> i<i"
apply (rule notI)
apply (erule lt_irrefl)
done

text\<open>Recall that  \<^term>\<open>i \<le> j\<close>  abbreviates  \<^term>\<open>i<succ(j)\<close>!\<close>

lemma le_iff: "i \<le> j <-> i<j | (i=j \<and> Ord(j))"
by (unfold lt_def, blast)

(*Equivalently, i<j \<Longrightarrow> i < succ(j)*)
lemma leI: "i<j \<Longrightarrow> i \<le> j"
by (simp add: le_iff)

lemma le_eqI: "\<lbrakk>i=j;  Ord(j)\<rbrakk> \<Longrightarrow> i \<le> j"
by (simp add: le_iff)

lemmas le_refl = refl [THEN le_eqI]

lemma le_refl_iff [iff]: "i \<le> i <-> Ord(i)"
by (simp (no_asm_simp) add: lt_not_refl le_iff)

lemma leCI: "(\<not> (i=j \<and> Ord(j)) \<Longrightarrow> i<j) \<Longrightarrow> i \<le> j"
by (simp add: le_iff, blast)

lemma leE:
    "\<lbrakk>i \<le> j;  i<j \<Longrightarrow> P;  \<lbrakk>i=j;  Ord(j)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (simp add: le_iff, blast)

lemma le_anti_sym: "\<lbrakk>i \<le> j;  j \<le> i\<rbrakk> \<Longrightarrow> i=j"
apply (simp add: le_iff)
apply (blast elim: lt_asym)
done

lemma le0_iff [simp]: "i \<le> 0 <-> i=0"
by (blast elim!: leE)

lemmas le0D = le0_iff [THEN iffD1, dest!]

subsection\<open>Natural Deduction Rules for Memrel\<close>

(*The lemmas MemrelI/E give better speed than [iff] here*)
lemma Memrel_iff [simp]: "\<langle>a,b\<rangle> \<in> Memrel(A) <-> a\<in>b \<and> a\<in>A \<and> b\<in>A"
by (unfold Memrel_def, blast)

lemma MemrelI [intro!]: "\<lbrakk>a \<in> b;  a \<in> A;  b \<in> A\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> Memrel(A)"
by auto

lemma MemrelE [elim!]:
    "\<lbrakk>\<langle>a,b\<rangle> \<in> Memrel(A);
        \<lbrakk>a \<in> A;  b \<in> A;  a\<in>b\<rbrakk>  \<Longrightarrow> P\<rbrakk>
     \<Longrightarrow> P"
by auto

lemma Memrel_type: "Memrel(A) \<subseteq> A*A"
by (unfold Memrel_def, blast)

lemma Memrel_mono: "A<=B \<Longrightarrow> Memrel(A) \<subseteq> Memrel(B)"
by (unfold Memrel_def, blast)

lemma Memrel_0 [simp]: "Memrel(0) = 0"
by (unfold Memrel_def, blast)

lemma Memrel_1 [simp]: "Memrel(1) = 0"
by (unfold Memrel_def, blast)

lemma relation_Memrel: "relation(Memrel(A))"
by (simp add: relation_def Memrel_def)

(*The membership relation (as a set) is well-founded.
  Proof idea: show A<=B by applying the foundation axiom to A-B *)
lemma wf_Memrel: "wf(Memrel(A))"
  unfolding wf_def
apply (rule foundation [THEN disjE, THEN allI], erule disjI1, blast)
done

text\<open>The premise \<^term>\<open>Ord(i)\<close> does not suffice.\<close>
lemma trans_Memrel:
    "Ord(i) \<Longrightarrow> trans(Memrel(i))"
by (unfold Ord_def Transset_def trans_def, blast)

text\<open>However, the following premise is strong enough.\<close>
lemma Transset_trans_Memrel:
    "\<forall>j\<in>i. Transset(j) \<Longrightarrow> trans(Memrel(i))"
by (unfold Transset_def trans_def, blast)

(*If Transset(A) then Memrel(A) internalizes the membership relation below A*)
lemma Transset_Memrel_iff:
    "Transset(A) \<Longrightarrow> \<langle>a,b\<rangle> \<in> Memrel(A) <-> a\<in>b \<and> b\<in>A"
by (unfold Transset_def, blast)

subsection\<open>Transfinite Induction\<close>

(*Epsilon induction over a transitive set*)
lemma Transset_induct:
    "\<lbrakk>i \<in> k;  Transset(k);
        \<And>x.\<lbrakk>x \<in> k;  \<forall>y\<in>x. P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>
     \<Longrightarrow>  P(i)"
apply (simp add: Transset_def)
apply (erule wf_Memrel [THEN wf_induct2], blast+)
done

(*Induction over an ordinal*)
lemma Ord_induct [consumes 2]:
  "i \<in> k \<Longrightarrow> Ord(k) \<Longrightarrow> (\<And>x. x \<in> k \<Longrightarrow> (\<And>y. y \<in> x \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(i)"
  using Transset_induct [OF _ Ord_is_Transset, of i k P] by simp

(*Induction over the class of ordinals -- a useful corollary of Ord_induct*)
lemma trans_induct [consumes 1, case_names step]:
  "Ord(i) \<Longrightarrow> (\<And>x. Ord(x) \<Longrightarrow> (\<And>y. y \<in> x \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(i)"
  apply (rule Ord_succ [THEN succI1 [THEN Ord_induct]], assumption)
  apply (blast intro: Ord_succ [THEN Ord_in_Ord])
  done

section\<open>Fundamental properties of the epsilon ordering (< on ordinals)\<close>

subsubsection\<open>Proving That < is a Linear Ordering on the Ordinals\<close>

lemma Ord_linear:
     "Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> i\<in>j | i=j | j\<in>i"
proof (induct i arbitrary: j rule: trans_induct)
  case (step i)
  note step_i = step
  show ?case using \<open>Ord(j)\<close>
    proof (induct j rule: trans_induct)
      case (step j)
      thus ?case using step_i
        by (blast dest: Ord_trans)
    qed
qed

text\<open>The trichotomy law for ordinals\<close>
lemma Ord_linear_lt:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (eq) "i=j" | (gt) "j<i"
apply (simp add: lt_def)
apply (rule_tac i1=i and j1=j in Ord_linear [THEN disjE])
apply (blast intro: o)+
done

lemma Ord_linear2:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI sym o) +
done

lemma Ord_linear_le:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (le) "i \<le> j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI o) +
done

lemma le_imp_not_lt: "j \<le> i \<Longrightarrow> \<not> i<j"
by (blast elim!: leE elim: lt_asym)

lemma not_lt_imp_le: "\<lbrakk>\<not> i<j;  Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> j \<le> i"
by (rule_tac i = i and j = j in Ord_linear2, auto)

subsubsection \<open>Some Rewrite Rules for \<open><\<close>, \<open>\<le>\<close>\<close>

lemma Ord_mem_iff_lt: "Ord(j) \<Longrightarrow> i\<in>j <-> i<j"
by (unfold lt_def, blast)

lemma not_lt_iff_le: "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> \<not> i<j <-> j \<le> i"
by (blast dest: le_imp_not_lt not_lt_imp_le)

lemma not_le_iff_lt: "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> \<not> i \<le> j <-> j<i"
by (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])

(*This is identical to 0<succ(i) *)
lemma Ord_0_le: "Ord(i) \<Longrightarrow> 0 \<le> i"
by (erule not_lt_iff_le [THEN iffD1], auto)

lemma Ord_0_lt: "\<lbrakk>Ord(i);  i\<noteq>0\<rbrakk> \<Longrightarrow> 0<i"
apply (erule not_le_iff_lt [THEN iffD1])
apply (rule Ord_0, blast)
done

lemma Ord_0_lt_iff: "Ord(i) \<Longrightarrow> i\<noteq>0 <-> 0<i"
by (blast intro: Ord_0_lt)

subsection\<open>Results about Less-Than or Equals\<close>

(** For ordinals, @{term"j\<subseteq>i"} implies @{term"j \<le> i"} (less-than or equals) **)

lemma zero_le_succ_iff [iff]: "0 \<le> succ(x) <-> Ord(x)"
by (blast intro: Ord_0_le elim: ltE)

lemma subset_imp_le: "\<lbrakk>j<=i;  Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> j \<le> i"
apply (rule not_lt_iff_le [THEN iffD1], assumption+)
apply (blast elim: ltE mem_irrefl)
done

lemma le_imp_subset: "i \<le> j \<Longrightarrow> i<=j"
by (blast dest: OrdmemD elim: ltE leE)

lemma le_subset_iff: "j \<le> i <-> j<=i \<and> Ord(i) \<and> Ord(j)"
by (blast dest: subset_imp_le le_imp_subset elim: ltE)

lemma le_succ_iff: "i \<le> succ(j) <-> i \<le> j | i=succ(j) \<and> Ord(i)"
apply (simp (no_asm) add: le_iff)
apply blast
done

(*Just a variant of subset_imp_le*)
lemma all_lt_imp_le: "\<lbrakk>Ord(i);  Ord(j);  \<And>x. x<j \<Longrightarrow> x<i\<rbrakk> \<Longrightarrow> j \<le> i"
by (blast intro: not_lt_imp_le dest: lt_irrefl)

subsubsection\<open>Transitivity Laws\<close>

lemma lt_trans1: "\<lbrakk>i \<le> j;  j<k\<rbrakk> \<Longrightarrow> i<k"
by (blast elim!: leE intro: lt_trans)

lemma lt_trans2: "\<lbrakk>i<j;  j \<le> k\<rbrakk> \<Longrightarrow> i<k"
by (blast elim!: leE intro: lt_trans)

lemma le_trans: "\<lbrakk>i \<le> j;  j \<le> k\<rbrakk> \<Longrightarrow> i \<le> k"
by (blast intro: lt_trans1)

lemma succ_leI: "i<j \<Longrightarrow> succ(i) \<le> j"
apply (rule not_lt_iff_le [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done

(*Identical to  succ(i) < succ(j) \<Longrightarrow> i<j  *)
lemma succ_leE: "succ(i) \<le> j \<Longrightarrow> i<j"
apply (rule not_le_iff_lt [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done

lemma succ_le_iff [iff]: "succ(i) \<le> j <-> i<j"
by (blast intro: succ_leI succ_leE)

lemma succ_le_imp_le: "succ(i) \<le> succ(j) \<Longrightarrow> i \<le> j"
by (blast dest!: succ_leE)

lemma lt_subset_trans: "\<lbrakk>i \<subseteq> j;  j<k;  Ord(i)\<rbrakk> \<Longrightarrow> i<k"
apply (rule subset_imp_le [THEN lt_trans1])
apply (blast intro: elim: ltE) +
done

lemma lt_imp_0_lt: "j<i \<Longrightarrow> 0<i"
by (blast intro: lt_trans1 Ord_0_le [OF lt_Ord])

lemma succ_lt_iff: "succ(i) < j <-> i<j \<and> succ(i) \<noteq> j"
apply auto
apply (blast intro: lt_trans le_refl dest: lt_Ord)
apply (frule lt_Ord)
apply (rule not_le_iff_lt [THEN iffD1])
  apply (blast intro: lt_Ord2)
 apply blast
apply (simp add: lt_Ord lt_Ord2 le_iff)
apply (blast dest: lt_asym)
done

lemma Ord_succ_mem_iff: "Ord(j) \<Longrightarrow> succ(i) \<in> succ(j) <-> i\<in>j"
apply (insert succ_le_iff [of i j])
apply (simp add: lt_def)
done

subsubsection\<open>Union and Intersection\<close>

lemma Un_upper1_le: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> i \<le> i \<union> j"
by (rule Un_upper1 [THEN subset_imp_le], auto)

lemma Un_upper2_le: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> j \<le> i \<union> j"
by (rule Un_upper2 [THEN subset_imp_le], auto)

(*Replacing k by succ(k') yields the similar rule for le!*)
lemma Un_least_lt: "\<lbrakk>i<k;  j<k\<rbrakk> \<Longrightarrow> i \<union> j < k"
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (auto simp add: Un_commute le_subset_iff subset_Un_iff lt_Ord)
done

lemma Un_least_lt_iff: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> i \<union> j < k  <->  i<k \<and> j<k"
apply (safe intro!: Un_least_lt)
apply (rule_tac [2] Un_upper2_le [THEN lt_trans1])
apply (rule Un_upper1_le [THEN lt_trans1], auto)
done

lemma Un_least_mem_iff:
    "\<lbrakk>Ord(i); Ord(j); Ord(k)\<rbrakk> \<Longrightarrow> i \<union> j \<in> k  <->  i\<in>k \<and> j\<in>k"
apply (insert Un_least_lt_iff [of i j k])
apply (simp add: lt_def)
done

(*Replacing k by succ(k') yields the similar rule for le!*)
lemma Int_greatest_lt: "\<lbrakk>i<k;  j<k\<rbrakk> \<Longrightarrow> i \<inter> j < k"
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (auto simp add: Int_commute le_subset_iff subset_Int_iff lt_Ord)
done

lemma Ord_Un_if:
     "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> i \<union> j = (if j<i then i else j)"
by (simp add: not_lt_iff_le le_imp_subset leI
              subset_Un_iff [symmetric]  subset_Un_iff2 [symmetric])

lemma succ_Un_distrib:
     "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> succ(i \<union> j) = succ(i) \<union> succ(j)"
by (simp add: Ord_Un_if lt_Ord le_Ord2)

lemma lt_Un_iff:
     "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> k < i \<union> j <-> k < i | k < j"
apply (simp add: Ord_Un_if not_lt_iff_le)
apply (blast intro: leI lt_trans2)+
done

lemma le_Un_iff:
     "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> k \<le> i \<union> j <-> k \<le> i | k \<le> j"
by (simp add: succ_Un_distrib lt_Un_iff [symmetric])

lemma Un_upper1_lt: "\<lbrakk>k < i; Ord(j)\<rbrakk> \<Longrightarrow> k < i \<union> j"
by (simp add: lt_Un_iff lt_Ord2)

lemma Un_upper2_lt: "\<lbrakk>k < j; Ord(i)\<rbrakk> \<Longrightarrow> k < i \<union> j"
by (simp add: lt_Un_iff lt_Ord2)

(*See also Transset_iff_Union_succ*)
lemma Ord_Union_succ_eq: "Ord(i) \<Longrightarrow> \<Union>(succ(i)) = i"
by (blast intro: Ord_trans)

subsection\<open>Results about Limits\<close>

lemma Ord_Union [intro,simp,TC]: "\<lbrakk>\<And>i. i\<in>A \<Longrightarrow> Ord(i)\<rbrakk> \<Longrightarrow> Ord(\<Union>(A))"
apply (rule Ord_is_Transset [THEN Transset_Union_family, THEN OrdI])
apply (blast intro: Ord_contains_Transset)+
done

lemma Ord_UN [intro,simp,TC]:
     "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> Ord(B(x))\<rbrakk> \<Longrightarrow> Ord(\<Union>x\<in>A. B(x))"
by (rule Ord_Union, blast)

lemma Ord_Inter [intro,simp,TC]:
    "\<lbrakk>\<And>i. i\<in>A \<Longrightarrow> Ord(i)\<rbrakk> \<Longrightarrow> Ord(\<Inter>(A))"
apply (rule Transset_Inter_family [THEN OrdI])
apply (blast intro: Ord_is_Transset)
apply (simp add: Inter_def)
apply (blast intro: Ord_contains_Transset)
done

lemma Ord_INT [intro,simp,TC]:
    "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> Ord(B(x))\<rbrakk> \<Longrightarrow> Ord(\<Inter>x\<in>A. B(x))"
by (rule Ord_Inter, blast)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma UN_least_le:
    "\<lbrakk>Ord(i);  \<And>x. x\<in>A \<Longrightarrow> b(x) \<le> i\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. b(x)) \<le> i"
apply (rule le_imp_subset [THEN UN_least, THEN subset_imp_le])
apply (blast intro: Ord_UN elim: ltE)+
done

lemma UN_succ_least_lt:
    "\<lbrakk>j<i;  \<And>x. x\<in>A \<Longrightarrow> b(x)<j\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. succ(b(x))) < i"
apply (rule ltE, assumption)
apply (rule UN_least_le [THEN lt_trans2])
apply (blast intro: succ_leI)+
done

lemma UN_upper_lt:
     "\<lbrakk>a\<in>A;  i < b(a);  Ord(\<Union>x\<in>A. b(x))\<rbrakk> \<Longrightarrow> i < (\<Union>x\<in>A. b(x))"
by (unfold lt_def, blast)

lemma UN_upper_le:
     "\<lbrakk>a \<in> A;  i \<le> b(a);  Ord(\<Union>x\<in>A. b(x))\<rbrakk> \<Longrightarrow> i \<le> (\<Union>x\<in>A. b(x))"
apply (frule ltD)
apply (rule le_imp_subset [THEN subset_trans, THEN subset_imp_le])
apply (blast intro: lt_Ord UN_upper)+
done

lemma lt_Union_iff: "\<forall>i\<in>A. Ord(i) \<Longrightarrow> (j < \<Union>(A)) <-> (\<exists>i\<in>A. j<i)"
by (auto simp: lt_def Ord_Union)

lemma Union_upper_le:
     "\<lbrakk>j \<in> J;  i\<le>j;  Ord(\<Union>(J))\<rbrakk> \<Longrightarrow> i \<le> \<Union>J"
apply (subst Union_eq_UN)
apply (rule UN_upper_le, auto)
done

lemma le_implies_UN_le_UN:
    "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> c(x) \<le> d(x)\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. c(x)) \<le> (\<Union>x\<in>A. d(x))"
apply (rule UN_least_le)
apply (rule_tac [2] UN_upper_le)
apply (blast intro: Ord_UN le_Ord2)+
done

lemma Ord_equality: "Ord(i) \<Longrightarrow> (\<Union>y\<in>i. succ(y)) = i"
by (blast intro: Ord_trans)

(*Holds for all transitive sets, not just ordinals*)
lemma Ord_Union_subset: "Ord(i) \<Longrightarrow> \<Union>(i) \<subseteq> i"
by (blast intro: Ord_trans)

subsection\<open>Limit Ordinals -- General Properties\<close>

lemma Limit_Union_eq: "Limit(i) \<Longrightarrow> \<Union>(i) = i"
  unfolding Limit_def
apply (fast intro!: ltI elim!: ltE elim: Ord_trans)
done

lemma Limit_is_Ord: "Limit(i) \<Longrightarrow> Ord(i)"
  unfolding Limit_def
apply (erule conjunct1)
done

lemma Limit_has_0: "Limit(i) \<Longrightarrow> 0 < i"
  unfolding Limit_def
apply (erule conjunct2 [THEN conjunct1])
done

lemma Limit_nonzero: "Limit(i) \<Longrightarrow> i \<noteq> 0"
by (drule Limit_has_0, blast)

lemma Limit_has_succ: "\<lbrakk>Limit(i);  j<i\<rbrakk> \<Longrightarrow> succ(j) < i"
by (unfold Limit_def, blast)

lemma Limit_succ_lt_iff [simp]: "Limit(i) \<Longrightarrow> succ(j) < i <-> (j<i)"
apply (safe intro!: Limit_has_succ)
apply (frule lt_Ord)
apply (blast intro: lt_trans)
done

lemma zero_not_Limit [iff]: "\<not> Limit(0)"
by (simp add: Limit_def)

lemma Limit_has_1: "Limit(i) \<Longrightarrow> 1 < i"
by (blast intro: Limit_has_0 Limit_has_succ)

lemma increasing_LimitI: "\<lbrakk>0<l; \<forall>x\<in>l. \<exists>y\<in>l. x<y\<rbrakk> \<Longrightarrow> Limit(l)"
apply (unfold Limit_def, simp add: lt_Ord2, clarify)
apply (drule_tac i=y in ltD)
apply (blast intro: lt_trans1 [OF _ ltI] lt_Ord2)
done

lemma non_succ_LimitI:
  assumes i: "0<i" and nsucc: "\<And>y. succ(y) \<noteq> i"
  shows "Limit(i)"
proof -
  have Oi: "Ord(i)" using i by (simp add: lt_def)
  { fix y
    assume yi: "y<i"
    hence Osy: "Ord(succ(y))" by (simp add: lt_Ord Ord_succ)
    have "\<not> i \<le> y" using yi by (blast dest: le_imp_not_lt)
    hence "succ(y) < i" using nsucc [of y]
      by (blast intro: Ord_linear_lt [OF Osy Oi]) }
  thus ?thesis using i Oi by (auto simp add: Limit_def)
qed

lemma succ_LimitE [elim!]: "Limit(succ(i)) \<Longrightarrow> P"
apply (rule lt_irrefl)
apply (rule Limit_has_succ, assumption)
apply (erule Limit_is_Ord [THEN Ord_succD, THEN le_refl])
done

lemma not_succ_Limit [simp]: "\<not> Limit(succ(i))"
by blast

lemma Limit_le_succD: "\<lbrakk>Limit(i);  i \<le> succ(j)\<rbrakk> \<Longrightarrow> i \<le> j"
by (blast elim!: leE)

subsubsection\<open>Traditional 3-Way Case Analysis on Ordinals\<close>

lemma Ord_cases_disj: "Ord(i) \<Longrightarrow> i=0 | (\<exists>j. Ord(j) \<and> i=succ(j)) | Limit(i)"
by (blast intro!: non_succ_LimitI Ord_0_lt)

lemma Ord_cases:
 assumes i: "Ord(i)"
 obtains ("0") "i=0" | (succ) j where "Ord(j)" "i=succ(j)" | (limit) "Limit(i)"
by (insert Ord_cases_disj [OF i], auto)

lemma trans_induct3_raw:
     "\<lbrakk>Ord(i);
         P(0);
         \<And>x. \<lbrakk>Ord(x);  P(x)\<rbrakk> \<Longrightarrow> P(succ(x));
         \<And>x. \<lbrakk>Limit(x);  \<forall>y\<in>x. P(y)\<rbrakk> \<Longrightarrow> P(x)
\<rbrakk> \<Longrightarrow> P(i)"
apply (erule trans_induct)
apply (erule Ord_cases, blast+)
done

lemma trans_induct3 [case_names 0 succ limit, consumes 1]:
  "Ord(i) \<Longrightarrow> P(0) \<Longrightarrow> (\<And>x. Ord(x) \<Longrightarrow> P(x) \<Longrightarrow> P(succ(x))) \<Longrightarrow> (\<And>x. Limit(x) \<Longrightarrow> (\<And>y. y \<in> x \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(i)"
  using trans_induct3_raw [of i P] by simp

text\<open>A set of ordinals is either empty, contains its own union, or its
union is a limit ordinal.\<close>

lemma Union_le: "\<lbrakk>\<And>x. x\<in>I \<Longrightarrow> x\<le>j; Ord(j)\<rbrakk> \<Longrightarrow> \<Union>(I) \<le> j"
  by (auto simp add: le_subset_iff Union_least)

lemma Ord_set_cases:
  assumes I: "\<forall>i\<in>I. Ord(i)"
  shows "I=0 \<or> \<Union>(I) \<in> I \<or> (\<Union>(I) \<notin> I \<and> Limit(\<Union>(I)))"
proof (cases "\<Union>(I)" rule: Ord_cases)
  show "Ord(\<Union>I)" using I by (blast intro: Ord_Union)
next
  assume "\<Union>I = 0" thus ?thesis by (simp, blast intro: subst_elem)
next
  fix j
  assume j: "Ord(j)" and UIj:"\<Union>(I) = succ(j)"
  { assume "\<forall>i\<in>I. i\<le>j"
    hence "\<Union>(I) \<le> j"
      by (simp add: Union_le j)
    hence False
      by (simp add: UIj lt_not_refl) }
  then obtain i where i: "i \<in> I" "succ(j) \<le> i" using I j
    by (atomize, auto simp add: not_le_iff_lt)
  have "\<Union>(I) \<le> succ(j)" using UIj j by auto
  hence "i \<le> succ(j)" using i
    by (simp add: le_subset_iff Union_subset_iff)
  hence "succ(j) = i" using i
    by (blast intro: le_anti_sym)
  hence "succ(j) \<in> I" by (simp add: i)
  thus ?thesis by (simp add: UIj)
next
  assume "Limit(\<Union>I)" thus ?thesis by auto
qed

text\<open>If the union of a set of ordinals is a successor, then it is an element of that set.\<close>
lemma Ord_Union_eq_succD: "\<lbrakk>\<forall>x\<in>X. Ord(x);  \<Union>X = succ(j)\<rbrakk> \<Longrightarrow> succ(j) \<in> X"
  by (drule Ord_set_cases, auto)

lemma Limit_Union [rule_format]: "\<lbrakk>I \<noteq> 0;  (\<And>i. i\<in>I \<Longrightarrow> Limit(i))\<rbrakk> \<Longrightarrow> Limit(\<Union>I)"
apply (simp add: Limit_def lt_def)
apply (blast intro!: equalityI)
done

end


(*
  Boolean Expression Checkers Based on Binary Decision Trees
  Author: Tobias Nipkow
*)

theory Boolean_Expression_Checkers
  imports Main "HOL-Library.Mapping"
begin

section \<open>Tautology (etc) Checking via Binary Decision Trees\<close>

subsection \<open>Binary Decision Trees\<close>

datatype 'a ifex = Trueif | Falseif | IF 'a "'a ifex" "'a ifex"

fun val_ifex :: "'a ifex \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "val_ifex Trueif s = True"
| "val_ifex Falseif s = False"
| "val_ifex (IF n t1 t2) s = (if s n then val_ifex t1 s else val_ifex t2 s)"

subsubsection \<open>Environment\<close>

text \<open>Environments are substitutions of values for variables:\<close>

type_synonym 'a env_bool = "('a, bool) mapping"

definition agree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a env_bool \<Rightarrow> bool"
where
  "agree s env = (\<forall>x b. Mapping.lookup env x = Some b \<longrightarrow> s x = b)"

lemma agree_Nil:
  "agree s Mapping.empty"
  by (simp add: agree_def lookup_empty)

lemma lookup_update_unfold:
  "Mapping.lookup (Mapping.update k v m) k' = (if k = k' then Some v else Mapping.lookup m k')"
  using lookup_update lookup_update_neq by metis

lemma agree_Cons:
  "x \<notin> Mapping.keys env \<Longrightarrow> agree s (Mapping.update x b env) = ((if b then s x else \<not> s x) \<and> agree s env)"
  by (simp add: agree_def lookup_update_unfold; unfold keys_is_none_rep lookup_update_unfold Option.is_none_def; blast)

lemma agreeDT:
  "agree s env \<Longrightarrow> Mapping.lookup env x = Some True \<Longrightarrow> s x"
  by (simp add: agree_def)

lemma agreeDF:
  "agree s env \<Longrightarrow> Mapping.lookup env x = Some False \<Longrightarrow> \<not>s x"
  by (auto simp add: agree_def)

subsection \<open>Recursive Tautology Checker\<close>

text \<open>Provided for completeness. However, it is recommend to use the checkers based on reduced trees.\<close>

fun taut_test_rec :: "'a ifex \<Rightarrow> 'a env_bool \<Rightarrow> bool"
where
  "taut_test_rec Trueif env = True"
| "taut_test_rec Falseif env = False"
| "taut_test_rec (IF x t1 t2) env = (case Mapping.lookup env x of
  Some b \<Rightarrow> taut_test_rec (if b then t1 else t2) env |
  None \<Rightarrow> taut_test_rec t1 (Mapping.update x True env) \<and> taut_test_rec t2 (Mapping.update x False env))"

lemma taut_test_rec:
  "taut_test_rec t env = (\<forall>s. agree s env \<longrightarrow> val_ifex t s)"
proof (induction t arbitrary: env)
  case Falseif
    have "agree (\<lambda>x. the (Mapping.lookup env x)) env"
      by (auto simp: agree_def)
    thus ?case
      by auto
next
  case (IF x t1 t2)
    thus ?case
    proof (cases "Mapping.lookup env x")
      case None
        with IF show ?thesis
          by simp (metis is_none_simps(1) agree_Cons keys_is_none_rep)
    qed (simp add: agree_def)
qed simp

definition taut_test_ifex :: "'a ifex \<Rightarrow> bool"
where
  "taut_test_ifex t = taut_test_rec t Mapping.empty"

corollary taut_test_ifex:
  "taut_test_ifex t = (\<forall>s. val_ifex t s)"
  by (auto simp: taut_test_ifex_def taut_test_rec agree_Nil)

subsection \<open>Reduced Binary Decision Trees\<close>

subsubsection \<open>Normalisation\<close>

text \<open>A normalisation avoiding duplicate variables and collapsing @{term "If x t t"} to \<open>t\<close>.\<close>

definition mkIF :: "'a \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "mkIF x t1 t2 = (if t1=t2 then t1 else IF x t1 t2)"

fun reduce :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "reduce env (IF x t1 t2) = (case Mapping.lookup env x of
     None \<Rightarrow> mkIF x (reduce (Mapping.update x True env) t1) (reduce (Mapping.update x False env) t2) |
     Some b \<Rightarrow> reduce env (if b then t1 else t2))"
| "reduce _ t = t"

primrec normif :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "normif env Trueif t1 t2 = reduce env t1"
| "normif env Falseif t1 t2 = reduce env t2"
| "normif env (IF x t1 t2) t3 t4 =
    (case Mapping.lookup env x of
       None \<Rightarrow> mkIF x (normif (Mapping.update x True env) t1 t3 t4) (normif (Mapping.update x False env) t2 t3 t4) |
       Some b \<Rightarrow> if b then normif env t1 t3 t4 else normif env t2 t3 t4)"

subsubsection \<open>Functional Correctness Proof\<close>

lemma val_mkIF:
  "val_ifex (mkIF x t1 t2) s = val_ifex (IF x t1 t2) s"
  by (auto simp: mkIF_def Let_def)

theorem val_reduce:
  "agree s env \<Longrightarrow> val_ifex (reduce env t) s = val_ifex t s"
  by (induction t arbitrary: s env)
     (auto simp: map_of_eq_None_iff val_mkIF agree_Cons Let_def keys_is_none_rep
           dest: agreeDT agreeDF split: option.splits)

lemma val_normif:
  "agree s env \<Longrightarrow> val_ifex (normif env t t1 t2) s = val_ifex (if val_ifex t s then t1 else t2) s"
  by (induct t arbitrary: t1 t2 s env)
     (auto simp: val_reduce val_mkIF agree_Cons map_of_eq_None_iff keys_is_none_rep
           dest: agreeDT agreeDF split: option.splits)

subsubsection \<open>Reduced If-Expressions\<close>

text \<open>An expression reduced iff no variable appears twice on any branch and there is no subexpression @{term "IF x t t"}.\<close>

fun reduced :: "'a ifex \<Rightarrow> 'a set \<Rightarrow> bool" where
"reduced (IF x t1 t2) X =
  (x \<notin> X \<and> t1 \<noteq> t2 \<and> reduced t1 (insert x X) \<and> reduced t2 (insert x X))" |
"reduced _ _ = True"

lemma reduced_antimono:
  "X \<subseteq> Y \<Longrightarrow> reduced t Y \<Longrightarrow> reduced t X"
  by (induction t arbitrary: X Y)
     (auto, (metis insert_mono)+)

lemma reduced_mkIF:
  "x \<notin> X \<Longrightarrow> reduced t1 (insert x X) \<Longrightarrow> reduced t2 (insert x X) \<Longrightarrow> reduced (mkIF x t1 t2) X"
  by (auto simp: mkIF_def intro:reduced_antimono)

lemma reduced_reduce:
  "reduced (reduce env t) (Mapping.keys env)"
proof(induction t arbitrary: env)
  case (IF x t1 t2)
    thus ?case
      using IF.IH(1) IF.IH(2)
      apply (auto simp: map_of_eq_None_iff image_iff reduced_mkIF split: option.split)
      by (metis is_none_code(1) keys_is_none_rep keys_update reduced_mkIF)
qed auto

lemma reduced_normif:
  "reduced (normif env t t1 t2) (Mapping.keys env)"
proof(induction t arbitrary: t1 t2 env)
  case (IF x s1 s2)
  thus ?case using IF.IH
    apply (auto simp: reduced_mkIF map_of_eq_None_iff split: option.split)
    by (metis is_none_code(1) keys_is_none_rep keys_update reduced_mkIF)
qed (auto simp: reduced_reduce)

subsubsection \<open>Checkers Based on Reduced Binary Decision Trees\<close>

text \<open>The checkers are parameterized over the translation function to binary decision trees.
  They rely on the fact that @{term ifex_of} produces reduced trees\<close>

definition taut_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> bool"
where
  "taut_test ifex_of b = (ifex_of b = Trueif)"

definition sat_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> bool"
where
  "sat_test ifex_of b = (ifex_of b \<noteq> Falseif)"

definition impl_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "impl_test ifex_of b1 b2 = (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif = Trueif)"

definition equiv_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "equiv_test ifex_of b1 b2 = (let t1 = ifex_of b1; t2 = ifex_of b2
    in Trueif = normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif))"

locale reduced_bdt_checkers =
  fixes
    ifex_of :: "'b \<Rightarrow> 'a ifex"
  fixes
    val :: "'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  assumes
    val_ifex: "val_ifex (ifex_of b) s = val b s"
  assumes
    reduced_ifex: "reduced (ifex_of b) {}"
begin

text \<open>Proof that reduced if-expressions are @{const Trueif}, @{const Falseif}
or can evaluate to both @{const True} and @{const False}.\<close>

lemma same_val_if_reduced:
  "reduced t X \<Longrightarrow> \<forall>x. x \<notin> X \<longrightarrow> s1 x = s2 x \<Longrightarrow> val_ifex t s1 = val_ifex t s2"
  by (induction t arbitrary: X) auto

lemma reduced_IF_depends:
  "\<lbrakk> reduced t X; t \<noteq> Trueif; t \<noteq> Falseif \<rbrakk> \<Longrightarrow> \<exists>s1 s2. val_ifex t s1 \<noteq> val_ifex t s2"
proof(induction t arbitrary: X)
  case (IF x t1 t2)
  let ?t = "IF x t1 t2"
  have 1: "reduced t1 (insert x X)" using IF.prems(1) by simp
  have 2: "reduced t2 (insert x X)" using IF.prems(1) by simp
  show ?case
  proof(cases t1)
    case [simp]: Trueif
    show ?thesis
    proof (cases t2)
      case Trueif thus ?thesis using IF.prems(1) by simp
    next
      case Falseif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case [simp]: Falseif
    show ?thesis
    proof (cases t2)
      case Falseif thus ?thesis using IF.prems(1) by simp
    next
      case Trueif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case IF
    then obtain s1 s2 where "val_ifex t1 s1 \<noteq> val_ifex t1 s2"
      using IF.IH(1)[OF 1] IF.prems(1) by auto
    hence "val_ifex ?t (s1(x:=True)) \<noteq> val_ifex ?t (s2(x:=True))"
      using same_val_if_reduced[OF 1, of "s1(x:=True)" s1]
          same_val_if_reduced[OF 1, of "s2(x:=True)" s2] by simp
    thus ?thesis by blast
  qed
qed auto

corollary taut_test:
  "taut_test ifex_of b = (\<forall>s. val b s)"
  by (metis taut_test_def reduced_IF_depends[OF reduced_ifex] val_ifex val_ifex.simps(1,2))

corollary sat_test:
  "sat_test ifex_of b = (\<exists>s. val b s)"
  by (metis sat_test_def reduced_IF_depends[OF reduced_ifex] val_ifex val_ifex.simps(1,2))

corollary impl_test:
  "impl_test ifex_of b1 b2 = (\<forall>s. val b1 s \<longrightarrow> val b2 s)"
proof -
  have "impl_test ifex_of b1 b2 = (\<forall>s. val_ifex (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif) s)"
    using reduced_IF_depends[OF reduced_normif] by (fastforce  simp: impl_test_def)
  also
  have "(\<forall>s. val_ifex (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif) s) \<longleftrightarrow> (\<forall>s. val b1 s \<longrightarrow> val b2 s)"
    using reduced_IF_depends[OF reduced_ifex] val_ifex unfolding val_normif[OF agree_Nil] by simp
  finally
  show ?thesis .
qed

corollary equiv_test:
  "equiv_test ifex_of b1 b2 = (\<forall>s. val b1 s = val b2 s)"
proof -
  have "equiv_test ifex_of b1 b2 = (\<forall>s. val_ifex (let t1 = ifex_of b1; t2 = ifex_of b2 in normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif)) s)"
    by (simp add: equiv_test_def Let_def; insert reduced_IF_depends[OF reduced_normif]; force)
  moreover
  {
    fix s
    have "val_ifex (let t1 = ifex_of b1; t2 = ifex_of b2 in normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif)) s
      = (val b1 s = val b2 s)"
      using val_ifex by (simp add: Let_def val_normif[OF agree_Nil])
  }
  ultimately
  show ?thesis
    by blast
qed

end

subsection \<open>Boolean Expressions\<close>

text \<open>This is the simplified interface to the tautology checker. If you have your own type of Boolean
expressions you can either define your own translation to reduced binary decision trees or you can just
translate into this type.\<close>

datatype 'a bool_expr =
  Const_bool_expr bool |
  Atom_bool_expr 'a |
  Neg_bool_expr "'a bool_expr" |
  And_bool_expr "'a bool_expr" "'a bool_expr" |
  Or_bool_expr "'a bool_expr" "'a bool_expr" |
  Imp_bool_expr "'a bool_expr" "'a bool_expr" |
  Iff_bool_expr "'a bool_expr" "'a bool_expr"

primrec val_bool_expr :: "'a bool_expr \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"val_bool_expr (Const_bool_expr b) s = b" |
"val_bool_expr (Atom_bool_expr x) s = s x" |
"val_bool_expr (Neg_bool_expr b) s = (\<not> val_bool_expr b s)" |
"val_bool_expr (And_bool_expr b1 b2) s = (val_bool_expr b1 s \<and> val_bool_expr b2 s)" |
"val_bool_expr (Or_bool_expr b1 b2) s = (val_bool_expr b1 s \<or> val_bool_expr b2 s)" |
"val_bool_expr (Imp_bool_expr b1 b2) s = (val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" |
"val_bool_expr (Iff_bool_expr b1 b2) s = (val_bool_expr b1 s = val_bool_expr b2 s)"

fun ifex_of :: "'a bool_expr \<Rightarrow> 'a ifex" where
"ifex_of (Const_bool_expr b) = (if b then Trueif else Falseif)" |
"ifex_of (Atom_bool_expr x)   = IF x Trueif Falseif" |
"ifex_of (Neg_bool_expr b)   = normif Mapping.empty (ifex_of b) Falseif Trueif" |
"ifex_of (And_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Falseif" |
"ifex_of (Or_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) Trueif (ifex_of b2)" |
"ifex_of (Imp_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif" |
"ifex_of (Iff_bool_expr b1 b2) = (let t1 = ifex_of b1; t2 = ifex_of b2 in
   normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif))"

theorem val_ifex:
  "val_ifex (ifex_of b) s = val_bool_expr b s"
  by (induct_tac b) (auto simp: val_normif agree_Nil Let_def)

theorem reduced_ifex:
  "reduced (ifex_of b) {}"
  by (induction b) (simp add: Let_def; metis keys_empty reduced_normif)+

definition "bool_taut_test \<equiv> taut_test ifex_of"
definition "bool_sat_test \<equiv> sat_test ifex_of"
definition "bool_impl_test \<equiv> impl_test ifex_of"
definition "bool_equiv_test \<equiv> equiv_test ifex_of"

lemma bool_tests:
  "bool_taut_test b = (\<forall>s. val_bool_expr b s)" (is ?t1)
  "bool_sat_test b = (\<exists>s. val_bool_expr b s)" (is ?t2)
  "bool_impl_test b1 b2 = (\<forall>s. val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" (is ?t3)
  "bool_equiv_test b1 b2 = (\<forall>s. val_bool_expr b1 s \<longleftrightarrow> val_bool_expr b2 s)" (is ?t4)
proof -
  interpret reduced_bdt_checkers ifex_of val_bool_expr
    by (unfold_locales; insert val_ifex reduced_ifex; blast)
  show ?t1 ?t2 ?t3 ?t4
    by (simp_all add: bool_taut_test_def bool_sat_test_def bool_impl_test_def bool_equiv_test_def taut_test sat_test impl_test equiv_test)
qed

end


section \<open>Augmenting Flows\<close>
theory Augmenting_Flow
imports Residual_Graph
begin

text \<open>
  In this theory, we define the concept of an augmenting flow,
  augmentation with a flow, and show that augmentation of a flow
  with an augmenting flow yields a valid flow again.
  \<close>

text \<open>We assume that there is a network with a flow @{term f} on it\<close>
context NFlow
begin

subsection \<open>Augmentation of a Flow\<close>
text \<open>The flow can be augmented by another flow, by adding the flows
  of edges parallel to edges in the network, and subtracting the edges
  reverse to edges in the network.\<close>
(* TODO: Define in network locale, with \<up> syntax. *)
definition augment :: "'capacity flow \<Rightarrow> 'capacity flow"
where "augment f' \<equiv> \<lambda>(u, v).
  if (u, v) \<in> E then
    f (u, v) + f' (u, v) - f' (v, u)
  else
    0"

text \<open>We define a syntax similar to Cormen et el.:\<close>
abbreviation (input) augment_syntax (infix "\<up>" 55)
  where "\<And>f f'. f\<up>f' \<equiv> NFlow.augment c f f'"
text \<open>such that we can write @{term [source] "f\<up>f'"} for the flow @{term f}
  augmented by @{term f'}.\<close>

subsection \<open>Augmentation yields Valid Flow\<close>
text \<open>We show that, if we augment the flow with a valid flow of
  the residual graph, the augmented flow is a valid flow again, i.e.
  it satisfies the capacity and conservation constraints:\<close>
context
  \<comment> \<open>Let the \emph{residual flow} @{term f'} be a flow in the residual graph\<close>
  fixes f' :: "'capacity flow"
  assumes f'_flow: "Flow cf s t f'"
begin

interpretation f': Flow cf s t f' by (rule f'_flow)

subsubsection \<open>Capacity Constraint\<close>
text \<open>First, we have to show that the new flow satisfies the capacity constraint:\<close>
(* FIXME: Indentation unfortunate, but required to extract snippet for latex presentation *)
text_raw \<open>\DefineSnippet{augment_flow_presv_cap}{\<close>
lemma augment_flow_presv_cap:
  shows "0 \<le> (f\<up>f')(u,v) \<and> (f\<up>f')(u,v) \<le> c(u,v)"
proof (cases "(u,v)\<in>E"; rule conjI)
  assume [simp]: "(u,v)\<in>E"
  hence "f(u,v) = cf(v,u)"
    using no_parallel_edge by (auto simp: residualGraph_def)
  also have "cf(v,u) \<ge> f'(v,u)" using f'.capacity_const by auto
  finally(*<*)(xtrans)(*>*) have "f'(v,u) \<le> f(u,v)" .

(*<*){
    note [trans] = xtrans
  (*>*)text_raw \<open>\isanewline\<close>

  text_raw \<open>\ \ \<close>have "(f\<up>f')(u,v) = f(u,v) + f'(u,v) - f'(v,u)"
    by (auto simp: augment_def)
  also have "\<dots> \<ge> f(u,v) + f'(u,v) - f(u,v)"
  (*<*)(is "_ \<ge> \<dots>")(*>*)  using \<open>f'(v,u) \<le> f(u,v)\<close> by auto
  also have "\<dots> = f'(u,v)" by auto
  also have "\<dots> \<ge> 0" using f'.capacity_const by auto
  finally show "(f\<up>f')(u,v) \<ge> 0" .
  (*<*)}(*>*)

  have "(f\<up>f')(u,v) = f(u,v) + f'(u,v) - f'(v,u)"
    by (auto simp: augment_def)
  also have "\<dots> \<le> f(u,v) + f'(u,v)" using f'.capacity_const by auto
  also have "\<dots> \<le> f(u,v) + cf(u,v)" using f'.capacity_const by auto
  also have "\<dots> = f(u,v) + c(u,v) - f(u,v)"
    by (auto simp: residualGraph_def)
  also have "\<dots> = c(u,v)" by auto
  finally show "(f\<up>f')(u, v) \<le> c(u, v)" .
qed (auto simp: augment_def cap_positive)
text_raw \<open>}%EndSnippet\<close>

subsubsection \<open>Conservation Constraint\<close>
text \<open>In order to show the conservation constraint, we need some
  auxiliary lemmas first.\<close>

text \<open>As there are no parallel edges in the network, and all edges
  in the residual graph are either parallel or reverse to a network edge,
  we can split summations of the residual flow over outgoing/incoming edges in the
  residual graph to summations over outgoing/incoming edges in the network.

  Note that the term @{term \<open>E``{u}\<close>} characterizes the successor nodes of @{term \<open>u\<close>},
  and @{term \<open>E\<inverse>``{u}\<close>} characterizes the predecessor nodes of @{term \<open>u\<close>}.
\<close>
(* TODO: Introduce pred/succ functions on Graph *)
private lemma split_rflow_outgoing:
  "(\<Sum>v\<in>cf.E``{u}. f' (u,v)) = (\<Sum>v\<in>E``{u}. f'(u,v)) + (\<Sum>v\<in>E\<inverse>``{u}. f'(u,v))"
  (is "?LHS = ?RHS")
proof -
  from no_parallel_edge have DJ: "E``{u} \<inter> E\<inverse>``{u} = {}" by auto

  have "?LHS = (\<Sum>v\<in>E``{u} \<union> E\<inverse>``{u}. f' (u,v))"
    apply (rule sum.mono_neutral_left)
    using cfE_ss_invE
    by (auto intro: finite_Image)
  also have "\<dots> = ?RHS"
    apply (subst sum.union_disjoint[OF _ _ DJ])
    by (auto intro: finite_Image)
  finally show "?LHS = ?RHS" .
qed

private lemma split_rflow_incoming:
  "(\<Sum>v\<in>cf.E\<inverse>``{u}. f' (v,u)) = (\<Sum>v\<in>E``{u}. f'(v,u)) + (\<Sum>v\<in>E\<inverse>``{u}. f'(v,u))"
  (is "?LHS = ?RHS")
proof -
  from no_parallel_edge have DJ: "E``{u} \<inter> E\<inverse>``{u} = {}" by auto

  have "?LHS = (\<Sum>v\<in>E``{u} \<union> E\<inverse>``{u}. f' (v,u))"
    apply (rule sum.mono_neutral_left)
    using cfE_ss_invE
    by (auto intro: finite_Image)
  also have "\<dots> = ?RHS"
    apply (subst sum.union_disjoint[OF _ _ DJ])
    by (auto intro: finite_Image)
  finally show "?LHS = ?RHS" .
qed

text \<open>For proving the conservation constraint, let's fix a node @{term u}, which
  is neither the source nor the sink: \<close>
context
  fixes u :: node
  assumes U_ASM: "u\<in>V - {s,t}"
begin

text \<open>We first show an auxiliary lemma to compare the
  effective residual flow on incoming network edges to
  the effective residual flow on outgoing network edges.

  Intuitively, this lemma shows that the effective residual flow added to the
  network edges satisfies the conservation constraint.
\<close>
private lemma flow_summation_aux:
  shows "(\<Sum>v\<in>E``{u}. f' (u,v))  - (\<Sum>v\<in>E``{u}. f' (v,u))
       = (\<Sum>v\<in>E\<inverse>``{u}. f' (v,u)) - (\<Sum>v\<in>E\<inverse>``{u}. f' (u,v))"
   (is "?LHS = ?RHS" is "?A - ?B = ?RHS")
proof -
  text \<open>The proof is by splitting the flows, and careful
    cancellation of the summands.\<close>
  have "?A = (\<Sum>v\<in>cf.E``{u}. f' (u, v)) - (\<Sum>v\<in>E\<inverse>``{u}. f' (u, v))"
    by (simp add: split_rflow_outgoing)
  also have "(\<Sum>v\<in>cf.E``{u}. f' (u, v)) = (\<Sum>v\<in>cf.E\<inverse>``{u}. f' (v, u))"
    using U_ASM
    by (simp add: f'.conservation_const_pointwise)
  finally have "?A = (\<Sum>v\<in>cf.E\<inverse>``{u}. f' (v, u)) - (\<Sum>v\<in>E\<inverse>``{u}. f' (u, v))"
    by simp
  moreover
  have "?B = (\<Sum>v\<in>cf.E\<inverse>``{u}. f' (v, u)) - (\<Sum>v\<in>E\<inverse>``{u}. f' (v, u))"
    by (simp add: split_rflow_incoming)
  ultimately show "?A - ?B = ?RHS" by simp
qed

text \<open>Finally, we are ready to prove that the augmented flow satisfies the
  conservation constraint:\<close>
lemma augment_flow_presv_con:
  shows "(\<Sum>e \<in> outgoing u. augment f' e) = (\<Sum>e \<in> incoming u. augment f' e)"
    (is "?LHS = ?RHS")
proof -
  text \<open>We define shortcuts for the successor and predecessor nodes of @{term u}
    in the network:\<close>
  let ?Vo = "E``{u}" let ?Vi = "E\<inverse>``{u}"

  text \<open>Using the auxiliary lemma for the effective residual flow,
    the proof is straightforward:\<close>
  have "?LHS = (\<Sum>v\<in>?Vo. augment f' (u,v))"
    by (auto simp: sum_outgoing_pointwise)
  also have "\<dots>
    = (\<Sum>v\<in>?Vo. f (u,v) + f'(u,v) - f'(v,u))"
    by (auto simp: augment_def)
  also have "\<dots>
    = (\<Sum>v\<in>?Vo. f (u,v)) + (\<Sum>v\<in>?Vo. f' (u,v)) - (\<Sum>v\<in>?Vo. f' (v,u))"
    by (auto simp: sum_subtractf sum.distrib)
  also have "\<dots>
    = (\<Sum>v\<in>?Vi. f (v,u)) + (\<Sum>v\<in>?Vi. f' (v,u)) - (\<Sum>v\<in>?Vi. f' (u,v))"
    by (auto simp: conservation_const_pointwise[OF U_ASM] flow_summation_aux)
  also have "\<dots>
    = (\<Sum>v\<in>?Vi. f (v,u) + f' (v,u) - f' (u,v))"
    by (auto simp: sum_subtractf sum.distrib)
  also have "\<dots>
    = (\<Sum>v\<in>?Vi. augment f' (v,u))"
    by (auto simp: augment_def)
  also have "\<dots>
    = ?RHS"
    by (auto simp: sum_incoming_pointwise)
  finally show "?LHS = ?RHS" .
qed
text \<open>Note that we tried to follow the proof presented by Cormen et al.~\cite{CLRS09}
  as closely as possible. Unfortunately, this proof generalizes the summation to all
  nodes immediately, rendering the first equation invalid.
  Trying to fix this error, we encountered that the step that uses the conservation
  constraints on the augmenting flow is more subtle as indicated in the original proof.
  Thus, we moved this argument to an auxiliary lemma. \<close>

end \<comment> \<open>@{term u} is node\<close>

text \<open>As main result, we get that the augmented flow is again a valid flow.\<close>
corollary augment_flow_presv: "Flow c s t (f\<up>f')"
  using augment_flow_presv_cap augment_flow_presv_con
  by (rule_tac intro_Flow) auto

subsection \<open>Value of the Augmented Flow\<close>
text \<open>Next, we show that the value of the augmented flow is the sum of the values
  of the original flow and the augmenting flow.\<close>

lemma augment_flow_value: "Flow.val c s (f\<up>f') = val + Flow.val cf s f'"
proof -
  interpret f'': Flow c s t "f\<up>f'" using augment_flow_presv .

  txt \<open>For this proof, we set up Isabelle's rewriting engine for rewriting of sums.
    In particular, we add lemmas to convert sums over incoming or outgoing
    edges to sums over all vertices. This allows us to write the summations
    from Cormen et al.~a bit more concise, leaving some of the tedious
    calculation work to the computer.\<close>
  note sum_simp_setup[simp] =
    sum_outgoing_alt[OF capacity_const] s_node
    sum_incoming_alt[OF capacity_const]
    cf.sum_outgoing_alt[OF f'.capacity_const]
    cf.sum_incoming_alt[OF f'.capacity_const]
    sum_outgoing_alt[OF f''.capacity_const]
    sum_incoming_alt[OF f''.capacity_const]
    sum_subtractf sum.distrib

  txt \<open>Note that, if neither an edge nor its reverse is in the graph,
    there is also no edge in the residual graph, and thus the flow value
    is zero.\<close>
  have aux1: "f'(u,v) = 0" if "(u,v)\<notin>E" "(v,u)\<notin>E" for u v
  proof -
    from that cfE_ss_invE have "(u,v)\<notin>cf.E" by auto
    thus "f'(u,v) = 0" by auto
  qed

  txt \<open>Now, the proposition follows by straightforward rewriting of
    the summations:\<close>
  have "f''.val = (\<Sum>u\<in>V. augment f' (s, u) - augment f' (u, s))"
    unfolding f''.val_def by simp
  also have "\<dots> = (\<Sum>u\<in>V. f (s, u) - f (u, s) + (f' (s, u) - f' (u, s)))"
    \<comment> \<open>Note that this is the crucial step of the proof, which Cormen et al. leave as an exercise.\<close>
    by (rule sum.cong) (auto simp: augment_def no_parallel_edge aux1)
  also have "\<dots> = val + Flow.val cf s f'"
    unfolding val_def f'.val_def by simp
  finally show "f''.val = val + f'.val" .
qed

txt \<open>Note, there is also an automatic proof. When creating the above
    explicit proof, this automatic one has been used to extract meaningful
    subgoals, abusing Isabelle as a term rewriter.\<close>
lemma "Flow.val c s (f\<up>f') = val + Flow.val cf s f'"
proof -
  interpret f'': Flow c s t "f\<up>f'" using augment_flow_presv .

  have aux1: "f'(u,v) = 0" if A: "(u,v)\<notin>E" "(v,u)\<notin>E" for u v
  proof -
    from A cfE_ss_invE have "(u,v)\<notin>cf.E" by auto
    thus "f'(u,v) = 0" by auto
  qed

  show ?thesis
    unfolding val_def f'.val_def f''.val_def
    apply (simp del:
      add:
      sum_outgoing_alt[OF capacity_const] s_node
      sum_incoming_alt[OF capacity_const]
      sum_outgoing_alt[OF f''.capacity_const]
      sum_incoming_alt[OF f''.capacity_const]
      cf.sum_outgoing_alt[OF f'.capacity_const]
      cf.sum_incoming_alt[OF f'.capacity_const]
      sum_subtractf[symmetric] sum.distrib[symmetric]
      )
    apply (rule sum.cong)
    apply (auto simp: augment_def no_parallel_edge aux1)
    done
qed

end \<comment> \<open>Augmenting flow\<close>
end \<comment> \<open>Network flow\<close>

end \<comment> \<open>Theory\<close>


theory Ch5
imports Main "~~/src/Doc/Prog_Prove/Logic"
begin

(* 5.1 *)
lemma
  assumes T: "\<forall> x y. T x y \<or> T y x"
  and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall> x y. T x y \<longrightarrow> A x y"
  and "A x y"
  shows "T x y"
proof -
  have "T x y \<or> T y x" using T by simp
  thus "?thesis"
  proof
    assume "T x y"
    thus "?thesis" by assumption
  next
    assume "T y x"
    hence "A y x" using TA by simp
    hence "A x y \<and> A y x" using \<open>A x y\<close> by simp
    hence "x = y" using A by simp
    thus "T x y" using \<open>T y x\<close> by simp
  qed
qed

(* 5.2 *)
lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof -
  let ?n = "(length xs + 1) div 2"
  let ?ys = "take ?n xs"
  let ?zs = "drop ?n xs"
  have "xs = ?ys @ ?zs \<and> (length ?ys = length ?zs \<or> length ?ys = length ?zs + 1)" by auto
  thus "?thesis" by blast
qed

(* 5.3 *)
lemma assumes a: "ev (Suc(Suc n))" shows "ev n"
proof -
  show "?thesis" using a by cases
qed

(* 5.4 *)
lemma "\<not>ev (Suc (Suc (Suc 0)))" (is "\<not>?P")
proof
  assume "?P"
  hence "ev (Suc 0)" by cases
  thus "False" by cases
qed

(* 5.5 *)
inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  iter0: "iter r 0 x x" |
  iterS: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (S n) x z"

lemma "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
proof (induction rule: star.induct)
  case (refl x)
  hence "iter r 0 x x" by (simp add: iter0)
  thus ?case by auto
next
  case (step x y z)
  then obtain n where "iter r n y z" by auto
  hence "iter r (Suc n) x z" using "step.hyps"(1) by (simp add: iterS)
  thus ?case by auto
qed

(* 5.6 *)
fun elems :: "'a list \<Rightarrow> 'a set" where
  "elems [] = {}" |
  "elems (x # xs) = {x} \<union> elems xs"

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
  proof (cases "a = x")
    case True
    let ?ys = "[]"
    let ?zs = "xs"
    have "a # xs = ?ys @ x # ?zs \<and> x \<notin> elems ?ys" using True by auto
    thus ?thesis using True by blast
  next
    case False
    hence "x \<in> elems xs" using Cons.prems by auto
    then obtain ys zs where "xs = ys @ x # zs \<and> x \<notin> elems ys" using Cons.IH by auto
    hence "a # xs = (a # ys) @ x # zs \<and> x \<notin> elems (a # ys)" using False by auto
    thus ?thesis by blast
  qed
qed

(* 5.7 *)
datatype alpha = A | B

inductive S :: "alpha list \<Rightarrow> bool" where
  S_empty: "S []" |
  S_surround: "S w \<Longrightarrow> S (A # w @ [B])" |
  S_double: "S w1 \<Longrightarrow> S w2 \<Longrightarrow> S (w1 @ w2)"

inductive T :: "alpha list \<Rightarrow> bool" where
  T_empty: "T []" |
  T_step: "T w1 \<Longrightarrow> T w2 \<Longrightarrow> T (w1 @ [A] @ w2 @ [B])"

declare S.intros[simp,intro]

declare T.intros[simp,intro]

theorem T_S: "T w \<Longrightarrow> S w"
  by (simp add: T.inducts)

lemma T_app: "\<lbrakk> T w2 ; T w1 \<rbrakk> \<Longrightarrow> T (w1 @ w2)"
  apply(induction rule: T.induct)
  apply(simp)
  apply(metis T_step append_assoc)
done

theorem S_T: "S w \<Longrightarrow> T w"
  by(metis S.induct T.simps T_app append_Cons append_Nil)

theorem S_T_equiv: "S w = T w"
  by(metis T_S S_T)

fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
  "balanced 0 [] = True" |
  "balanced n (A # w) = balanced (Suc n) w" |
  "balanced (Suc n) (B # w) = balanced n w" |
  "balanced _ _ = False"

lemma balanced_nil: "balanced n [] \<Longrightarrow> n = 0"
  by (induction n, auto)

lemma balanced_cons: "balanced n (a # w) \<Longrightarrow>
    a = A \<and> balanced (Suc n) w \<or>
    a = B \<and> (\<exists> m. n = Suc m \<and> balanced m w)"
  using balanced.elims(2) by auto

lemma balanced_snoc: "balanced n w \<Longrightarrow> balanced (Suc n) (w @ [B])"
  by (induction n w rule: balanced.induct, auto)

lemma balanced_app: "balanced m v \<Longrightarrow> balanced n w \<Longrightarrow> balanced (m + n) (v @ w)"
  using balanced_cons by (induction v arbitrary: m, subst balanced_nil, auto, fastforce)

lemma replicate_cons_snoc: "replicate n a = a # as \<Longrightarrow> a # as = as @ [a]"
proof (induction as)
  case Nil
  then show ?case by (simp add: Cons_replicate_eq)
next
  case (Cons a as)
  then show ?case by (metis Cons_replicate_eq replicate_append_same)
qed

lemma T_replicate_Nil: "T (replicate n A) \<Longrightarrow> n = 0"
proof (induction "replicate n A" rule: T.induct)
  case T_empty
  then show ?case by auto
next
  case (T_step w1 w2)
  then show ?case
  proof (cases "replicate n A")
    case Nil
    then show ?thesis by auto
  next
    case (Cons a as)
    hence "a = A" by (metis Cons_replicate_eq)
    hence "replicate n A = as @ [A]" using Cons replicate_cons_snoc by fastforce
    hence "B = A" using T_step.hyps(5) by fastforce
    then show ?thesis by simp
  qed
qed

lemma S_replicate_Nil: "S (replicate n A) \<Longrightarrow> n = 0"
  using S_T_equiv T_replicate_Nil by blast

lemma S_balanced: "S (replicate n A @ w) \<Longrightarrow> balanced n w"
proof (induction "replicate n A @ w" arbitrary: n w rule: S.induct)
  case S_empty
  then show ?case by simp
next
  case (S_surround v)
  then show ?case
  proof (cases w)
    case Nil
    then show ?thesis
      using S.S_surround S_replicate_Nil S_surround.hyps(1) S_surround.hyps(3) by fastforce
  next
    let ?xs = "butlast w"
    let ?x = "last w"
    case (Cons a w')
    hence 0: "w = ?xs @ [?x]" by simp
    hence 1: "(A # v) @ [B] = (replicate n A @ ?xs) @ [?x]" using S_surround by simp
    hence 2: "B = ?x \<and> A # v = replicate n A @ ?xs" by simp
    then show ?thesis
    proof (cases n)
      case 0
      then show ?thesis
      proof (cases ?xs)
        case Nil
        then show ?thesis using 0 2 by simp
      next
        case (Cons x xs)
        hence 3: "A = x \<and> v = replicate 0 A @ xs" using 0 2 by simp
        hence 4: "balanced 0 xs" using S_surround by simp
        hence "w = A # xs @ [B]" using S_surround 0 3 by auto
        then show ?thesis using 0 4 balanced_snoc by force
      qed
    next
      case (Suc n')
      hence "v = replicate n' A @ ?xs" using 2 by simp
      hence "balanced n' ?xs" using S_surround by simp
      then show ?thesis using 0 balanced_snoc using 2 Suc by fastforce
    qed
  qed
next
  case (S_double w1 w2)
  hence "(\<exists>v. w1 = replicate n A @ v \<and> v @ w2 = w \<or> w1 @ v = replicate n A \<and> w2 = v @ w)"
    (is "\<exists>v. ?P v") by (simp add: append_eq_append_conv2)
  then obtain v where p: "?P v" by auto
  then show ?case
  proof
    assume 0: "w1 = replicate n A @ v \<and> v @ w2 = w"
    hence "balanced n v" using S_double by simp
    then show ?thesis
      by (metis S_double.hyps(4) 0 add.right_neutral append_Nil balanced_app replicate_0)
  next
    assume 1: "w1 @ v = replicate n A \<and> w2 = v @ w"
    then show ?thesis
    proof (cases n)
      case 0
      then show ?thesis using 1 S_double by simp
    next
      case (Suc n')
      hence "w1 @ v = replicate n' A @ [A]" using 1 by (simp add: replicate_append_same)
      then show ?thesis
        by (smt (verit, ccfv_threshold) 1 S_double.hyps S_replicate_Nil append_eq_append_conv
                length_0_conv length_append length_replicate replicate_add self_append_conv2)
    qed
  qed
qed

lemma S_app_in: "S (u @ w) \<Longrightarrow> S v \<Longrightarrow> S (u @ v @ w)"
proof (induction "u @ w" arbitrary: u w rule: S.induct)
  case S_empty
  then show ?case by simp
next
  case (S_surround v')
  then show ?case
  proof (cases w)
    case Nil
    hence "S u" using S.S_surround S_surround by auto
    then show ?thesis by (simp add: S_surround Nil)
  next
    case (Cons a w')
    let ?xs = "butlast w"
    let ?x = "last w"
    have 0: "w = ?xs @ [?x]" using Cons by simp
    hence 1: "(A # v') @ [B] = (u @ ?xs) @ [?x]" using S_surround by simp
    hence 2: "B = ?x \<and> A # v' = u @ ?xs" by simp
    then show ?thesis
    proof (cases u)
      case Nil
      hence 3: "A # v' = ?xs" using 2 by simp
      then show ?thesis
      proof (cases ?xs)
        case Nil
        then show ?thesis using \<open>A # v' = ?xs\<close> by simp
      next
        case (Cons x xs)
        hence 4: "A = x \<and> v' = xs" using 3 by simp
        hence "S (v @ xs)" using S_double S_surround by simp
        moreover have "v @ (x # xs) @ [?x] = v @ w" using 0 Nil S_surround Cons by simp
        hence "S w" using 2 4 S.S_surround S_surround by auto
        then show ?thesis using S_double S_surround Nil by simp
      qed
    next
      case (Cons b u')
      hence "A # v' = b # (u' @ ?xs)" using 2 by simp
      hence "A = b \<and> v' = u' @ ?xs" using 2 by simp
      hence "S (u' @ v @ ?xs)" using S_double S_surround by simp
      hence "S (A # (u' @ v @ ?xs) @ [B])" using S.S_surround by fastforce
      then show ?thesis using 0 2 Cons by auto
    qed
  qed
next
  case (S_double u' w')
  hence "\<exists>uw. u' = u @ uw \<and> uw @ w' = w \<or>
              u' @ uw = u \<and> w' = uw @ w" (is "\<exists>uw. ?P uw") by (simp add: append_eq_append_conv2)
  then obtain uw where p: "?P uw" by fastforce
  thus ?case
  proof
    assume "u' = u @ uw \<and> uw @ w' = w"
    hence "S (u @ v @ uw)" and "w = uw @ w'" using S_double.prems(1) S_double.hyps(2) by auto
    hence "S ((u @ v @ uw) @ w')" using S_double.hyps(3) S.S_double by blast
    thus ?thesis using \<open>w = uw @ w'\<close> by auto
  next
    assume "u' @ uw = u \<and> w' = uw @ w"
    hence "S (uw @ v @ w)" and "u = u' @ uw" using S_double.prems(1) S_double.hyps(4) by auto
    hence "S (u' @ uw @ v @ w)" using S_double.hyps(1) S.S_double by blast
    thus ?thesis using \<open>u = u' @ uw\<close> by auto
  qed
qed

lemma balanced_S: "balanced n w \<Longrightarrow> S (replicate n A @ w)"
proof (induction w arbitrary: n)
  case Nil
  hence "n = 0" by (cases n, auto)
  thus ?case by auto
next
  case (Cons a w)
  thus ?case
  proof (induction a arbitrary: n w)
    case A
    hence "balanced (Suc n) w" by simp
    hence "S (replicate (Suc n) A @ w)" using A.prems(1) by fastforce
    thus ?case using A by (simp add: replicate_app_Cons_same)
  next
    have "S [A, B]" using S.simps by blast
    case B
    hence "\<exists> m. n = Suc m \<and> balanced m w" using balanced_cons by fastforce
    then obtain m where p: "n = Suc m \<and> balanced m w" by fastforce
    hence "S (replicate m A @ w)" using B.prems(1) by simp
    hence "S (replicate m A @ [A, B] @ w)" using S_app_in \<open>S [A, B]\<close> by fastforce
    thus ?case by (simp add: p replicate_app_Cons_same)
  qed
qed

theorem balanced_S_equiv: "balanced n w = S (replicate n A @ w)" using S_balanced balanced_S by auto

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
    Author: Martin Strecker
*)

header {* Searching in Lists *}

(*<*) theory ex imports Main begin (*>*)

text {* Define a function @{text first_pos} that computes the index
of the first element in a list that satisfies a given predicate: *}

(*<*) consts (*>*)
  first_pos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"

text {* The smallest index is @{text 0}.  If no element in the
list satisfies the predicate, the behaviour of @{text first_pos} should
be as described below. *}

text {* Verify your definition by computing
\begin{itemize}
\item the index of the first number equal to @{text 3} in the list
  @{text "[1::nat, 3, 5, 3, 1]"},
\item the index of the first number greater than @{text 4} in the list
  @{text "[1::nat, 3, 5, 7]"},
\item the index of  the first list with more than one element in the list
  @{text "[[], [1, 2], [3]]"}.
\end{itemize}

\emph{Note:} Isabelle does not know the operators @{text ">"} and @{text
"\<ge>"}.  Use @{text "<"} and @{text "\<le>"} instead. *}

text {* Prove that @{text first_pos} returns the length of the list if
and only if no element in the list satisfies the given predicate. *}

text {* Now prove: *}

lemma "list_all (\<lambda> x. \<not> P x) (take (first_pos P xs) xs)"
(*<*) oops (*>*)

text {* How can @{text "first_pos (\<lambda> x. P x \<or> Q x) xs"} be computed from
@{text "first_pos P xs"} and @{text "first_pos Q xs"}?  Can something
similar be said for the conjunction of @{text P} and @{text Q}?  Prove
your statement(s). *}

text {* Suppose @{text P} implies @{text Q}. What can be said about the
relation between @{text "first_pos P xs"} and @{text "first_pos Q xs"}?
Prove your statement. *}

text {* Define a function @{text count} that counts the number of
elements in a list that satisfy a given predicate. *}

(*<*) consts (*>*)
  count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"

text {* Show: The number of elements with a given property stays the
same when one reverses a list with @{text rev}.  The proof will require
a lemma. *}

text {* Find and prove a connection between the two functions @{text filter}
and @{text count}. *}

(*<*) end (*>*)


theory ExF009
  imports Main
begin

lemma "(\<exists>x. P x) =  (\<not>(\<forall>x. \<not>P x))"
proof -
  {
    assume a:"\<exists>x. P x"
    {
      assume b:"\<forall>x. \<not>P x"
      {
        fix aa
        assume c:"P aa"
        from b have "\<not>P aa" by (rule allE)
        with c have False by contradiction
      }
      with a have False by (rule exE)
    }
    hence "\<not>(\<forall>x. \<not>P x)" by (rule notI)
  }
  moreover
  {
    assume d:"\<not>(\<forall>x. \<not>P x)"
    {
      assume e:"\<not>(\<exists>x. P x)"
      {
        fix aa
        {
          assume "P aa"
          hence "\<exists>x. P x" by (rule exI)
          with e have False by contradiction
        }
        hence "\<not>P aa" by (rule notI)
      }
      hence "\<forall>x. \<not>P x" by (rule allI)
      with d have False by contradiction
    }
    hence "\<not>\<not>(\<exists>x. P x)" by (rule notI)
    hence "(\<exists>x. P x)" by (rule notnotD)
  }
  ultimately show ?thesis by (rule iffI)
qed