(*  Title:      HOL/MicroJava/BV/Listn.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Lists of a fixed length.
*)

section \<open>Fixed Length Lists\<close>

theory Listn
imports Err
begin

definition list :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
where
  "list n A = {xs. size xs = n \<and> set xs \<subseteq> A}"

definition le :: "'a ord \<Rightarrow> ('a list)ord"
where
  "le r = list_all2 (\<lambda>x y. x \<sqsubseteq>\<^sub>r y)"

abbreviation
  lesublist :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubseteq>\<^bsub>_\<^esub>] _)" [50, 0, 51] 50) where
  "x [\<sqsubseteq>\<^bsub>r\<^esub>] y == x <=_(Listn.le r) y"

abbreviation
  lesssublist :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubset>\<^bsub>_\<^esub>] _)" [50, 0, 51] 50) where
  "x [\<sqsubset>\<^bsub>r\<^esub>] y == x <_(Listn.le r) y"

(*<*)
notation (ASCII)
  lesublist  ("(_ /[<=_] _)" [50, 0, 51] 50) and
  lesssublist  ("(_ /[<_] _)" [50, 0, 51] 50)

abbreviation (input)
  lesublist2 :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubseteq>\<^sub>_] _)" [50, 0, 51] 50) where
  "x [\<sqsubseteq>\<^sub>r] y == x [\<sqsubseteq>\<^bsub>r\<^esub>] y"

abbreviation (input)
  lesssublist2 :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubset>\<^sub>_] _)" [50, 0, 51] 50) where
  "x [\<sqsubset>\<^sub>r] y == x [\<sqsubset>\<^bsub>r\<^esub>] y"
(*>*)

abbreviation
  plussublist :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
    ("(_ /[\<squnion>\<^bsub>_\<^esub>] _)" [65, 0, 66] 65) where
  "x [\<squnion>\<^bsub>f\<^esub>] y == x \<squnion>\<^bsub>map2 f\<^esub> y"

(*<*)
notation (ASCII)
  plussublist  ("(_ /[+_] _)" [65, 0, 66] 65)

abbreviation (input)
  plussublist2 :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
    ("(_ /[\<squnion>\<^sub>_] _)" [65, 0, 66] 65) where
  "x [\<squnion>\<^sub>f] y == x [\<squnion>\<^bsub>f\<^esub>] y"
(*>*)

primrec coalesce :: "'a err list \<Rightarrow> 'a list err"
where
  "coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"

definition sl :: "nat \<Rightarrow> 'a sl \<Rightarrow> 'a list sl"
where
  "sl n = (\<lambda>(A,r,f). (list n A, le r, map2 f))"

definition sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list err"
where
  "sup f = (\<lambda>xs ys. if size xs = size ys then coalesce(xs [\<squnion>\<^bsub>f\<^esub>] ys) else Err)"

definition upto_esl :: "nat \<Rightarrow> 'a esl \<Rightarrow> 'a list esl"
where
  "upto_esl m = (\<lambda>(A,r,f). (Union{list n A |n. n \<le> m}, le r, sup f))"

lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list: "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys = Listn.le r xs ys"
(*<*) by (simp add: lesub_def) (*>*)

lemma Nil_le_conv [iff]: "([] [\<sqsubseteq>\<^bsub>r\<^esub>] ys) = (ys = [])"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_notle_Nil [iff]: "\<not> x#xs [\<sqsubseteq>\<^bsub>r\<^esub>] []"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_le_Cons [iff]: "x#xs [\<sqsubseteq>\<^bsub>r\<^esub>] y#ys = (x \<sqsubseteq>\<^sub>r y \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys)"
(*<*)
by (simp add: lesub_def Listn.le_def)
(*>*)

lemma Cons_less_Conss [simp]:
  "order r \<Longrightarrow>  x#xs [\<sqsubset>\<^sub>r] y#ys = (x \<sqsubset>\<^sub>r y \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<or> x = y \<and> xs [\<sqsubset>\<^sub>r] ys)"
(*<*)
apply (unfold lesssub_def)
apply blast
done
(*>*)

lemma list_update_le_cong:
  "\<lbrakk> i<size xs; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; x \<sqsubseteq>\<^sub>r y \<rbrakk> \<Longrightarrow> xs[i:=x] [\<sqsubseteq>\<^bsub>r\<^esub>] ys[i:=y]"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
(*>*)

lemma le_listD: "\<lbrakk> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p \<sqsubseteq>\<^sub>r ys!p"
(*<*)
by (simp add: Listn.le_def lesub_def list_all2_nthD)
(*>*)

lemma le_list_refl: "\<forall>x. x \<sqsubseteq>\<^sub>r x \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs"
(*<*)
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
(*>*)

lemma le_list_trans: "\<lbrakk> order r; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<rbrakk> \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_trans)
apply (erule order_trans)
apply assumption+
done
(*>*)

lemma le_list_antisym: "\<lbrakk> order r; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs \<rbrakk> \<Longrightarrow> xs = ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_antisym)
apply (rule order_antisym)
apply assumption+
done
(*>*)

lemma order_listI [simp, intro!]: "order r \<Longrightarrow> order(Listn.le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
             dest: order_refl)
done
(*>*)

lemma lesub_list_impl_same_size [simp]: "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<Longrightarrow> size ys = size xs"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
(*>*)

lemma lesssub_lengthD: "xs [\<sqsubset>\<^sub>r] ys \<Longrightarrow> size ys = size xs"
(*<*)
apply (unfold lesssub_def)
apply auto
done
(*>*)

lemma le_list_appendI: "a [\<sqsubseteq>\<^bsub>r\<^esub>] b \<Longrightarrow> c [\<sqsubseteq>\<^bsub>r\<^esub>] d \<Longrightarrow> a@c [\<sqsubseteq>\<^bsub>r\<^esub>] b@d"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
(*>*)

lemma le_listI:
  assumes "length a = length b"
  assumes "\<And>n. n < length a \<Longrightarrow> a!n \<sqsubseteq>\<^sub>r b!n"
  shows "a [\<sqsubseteq>\<^bsub>r\<^esub>] b"
(*<*)
proof -
  from assms have "list_all2 r a b"
    by (simp add: list_all2_all_nthI lesub_def)
  then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
(*>*)

lemma listI: "\<lbrakk> size xs = n; set xs \<subseteq> A \<rbrakk> \<Longrightarrow> xs \<in> list n A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

(* FIXME: remove simp *)
lemma listE_length [simp]: "xs \<in> list n A \<Longrightarrow> size xs = n"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma less_lengthI: "\<lbrakk> xs \<in> list n A; p < n \<rbrakk> \<Longrightarrow> p < size xs"
(*<*) by simp (*>*)

lemma listE_set [simp]: "xs \<in> list n A \<Longrightarrow> set xs \<subseteq> A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma list_0 [simp]: "list 0 A = {[]}"
(*<*)
apply (unfold list_def)
apply auto
done
(*>*)

lemma in_list_Suc_iff:
  "(xs \<in> list (Suc n) A) = (\<exists>y\<in>A. \<exists>ys \<in> list n A. xs = y#ys)"
(*<*)
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done
(*>*)

lemma Cons_in_list_Suc [iff]:
  "(x#xs \<in> list (Suc n) A) = (x\<in>A \<and> xs \<in> list n A)"
(*<*)
apply (simp add: in_list_Suc_iff)
done
(*>*)

lemma list_not_empty:
  "\<exists>a. a\<in>A \<Longrightarrow> \<exists>xs. xs \<in> list n A"
(*<*)
apply (induct "n")
 apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done
(*>*)

lemma nth_in [rule_format, simp]:
  "\<forall>i n. size xs = n \<longrightarrow> set xs \<subseteq> A \<longrightarrow> i < n \<longrightarrow> (xs!i) \<in> A"
(*<*)
apply (induct "xs")
 apply simp
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma listE_nth_in: "\<lbrakk> xs \<in> list n A; i < n \<rbrakk> \<Longrightarrow> xs!i \<in> A"
(*<*) by auto (*>*)

lemma listn_Cons_Suc [elim!]:
  "l#xs \<in> list n A \<Longrightarrow> (\<And>n'. n = Suc n' \<Longrightarrow> l \<in> A \<Longrightarrow> xs \<in> list n' A \<Longrightarrow> P) \<Longrightarrow> P"
(*<*) by (cases n) auto (*>*)

lemma listn_appendE [elim!]:
  "a@b \<in> list n A \<Longrightarrow> (\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P) \<Longrightarrow> P"
(*<*)
proof -
  have "\<And>n. a@b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n=n1+n2 \<and> a \<in> list n1 A \<and> b \<in> list n2 A"
    (is "\<And>n. ?list a n \<Longrightarrow> \<exists>n1 n2. ?P a n n1 n2")
  proof (induct a)
    fix n assume "?list [] n"
    hence "?P [] n 0 n" by simp
    thus "\<exists>n1 n2. ?P [] n n1 n2" by fast
  next
    fix n l ls
    assume "?list (l#ls) n"
    then obtain n' where n: "n = Suc n'" "l \<in> A" and n': "ls@b \<in> list n' A" by fastforce
    assume "\<And>n. ls @ b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A"
    from this and n' have "\<exists>n1 n2. n' = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A" .
    then obtain n1 n2 where "n' = n1 + n2" "ls \<in> list n1 A" "b \<in> list n2 A" by fast
    with n have "?P (l#ls) n (n1+1) n2" by simp
    thus "\<exists>n1 n2. ?P (l#ls) n n1 n2" by fastforce
  qed
  moreover
  assume "a@b \<in> list n A" "\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P"
  ultimately
  show ?thesis by blast
qed
(*>*)

lemma listt_update_in_list [simp, intro!]:
  "\<lbrakk> xs \<in> list n A; x\<in>A \<rbrakk> \<Longrightarrow> xs[i := x] \<in> list n A"
(*<*)
apply (unfold list_def)
apply simp
done
(*>*)

lemma list_appendI [intro?]:
  "\<lbrakk> a \<in> list n A; b \<in> list m A \<rbrakk> \<Longrightarrow> a @ b \<in> list (n+m) A"
(*<*) by (unfold list_def) auto (*>*)

lemma list_map [simp]: "(map f xs \<in> list (size xs) A) = (f ` set xs \<subseteq> A)"
(*<*) by (unfold list_def) simp (*>*)

lemma list_replicateI [intro]: "x \<in> A \<Longrightarrow> replicate n x \<in> list n A"
(*<*) by (induct n) auto (*>*)

lemma plus_list_Nil [simp]: "[] [\<squnion>\<^bsub>f\<^esub>] xs = []"
(*<*)
apply (unfold plussub_def)
apply simp
done
(*>*)

lemma plus_list_Cons [simp]:
  "(x#xs) [\<squnion>\<^bsub>f\<^esub>] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x \<squnion>\<^sub>f y)#(xs [\<squnion>\<^bsub>f\<^esub>] ys))"
(*<*) by (simp add: plussub_def split: list.split) (*>*)

lemma length_plus_list [rule_format, simp]:
  "\<forall>ys. size(xs [\<squnion>\<^bsub>f\<^esub>] ys) = min(size xs) (size ys)"
(*<*)
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
(*>*)

lemma nth_plus_list [rule_format, simp]:
  "\<forall>xs ys i. size xs = n \<longrightarrow> size ys = n \<longrightarrow> i<n \<longrightarrow> (xs [\<squnion>\<^bsub>f\<^esub>] ys)!i = (xs!i) \<squnion>\<^sub>f (ys!i)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
(*>*)

lemma (in Semilat) plus_list_ub1 [rule_format]:
 "\<lbrakk> set xs \<subseteq> A; set ys \<subseteq> A; size xs = size ys \<rbrakk>
  \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs [\<squnion>\<^bsub>f\<^esub>] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_ub2:
 "\<lbrakk>set xs \<subseteq> A; set ys \<subseteq> A; size xs = size ys \<rbrakk> \<Longrightarrow> ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs [\<squnion>\<^bsub>f\<^esub>] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_lub [rule_format]:
shows "\<forall>xs ys zs. set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> set zs \<subseteq> A
  \<longrightarrow> size xs = n \<and> size ys = n \<longrightarrow>
  xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<longrightarrow> xs [\<squnion>\<^bsub>f\<^esub>] ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) list_update_incr [rule_format]:
 "x\<in>A \<Longrightarrow> set xs \<subseteq> A \<longrightarrow>
  (\<forall>i. i<size xs \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs[i := x \<squnion>\<^sub>f xs!i])"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma acc_le_listI [intro!]:
  "\<lbrakk> order r; acc r \<rbrakk> \<Longrightarrow> acc(Listn.le r)"
(*<*)
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le r) ys})")
 apply (erule wf_subset)
 apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "\<exists>x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m \<in> M")
apply (thin_tac "maxA#xs \<in> M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply blast
done
(*>*)

lemma closed_listI:
  "closed S f \<Longrightarrow> closed (list n S) (map2 f)"
(*<*)
apply (unfold closed_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done
(*>*)

lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
  apply (unfold Listn.sl_def)
  apply (simp (no_asm) only: semilat_Def split_conv)
  apply (rule conjI)
   apply simp
  apply (rule conjI)
   apply (simp only: closedI closed_listI)
  apply (simp (no_asm) only: list_def)
  apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
  done
qed
(*>*)

lemma Listn_sl: "semilat L \<Longrightarrow> semilat (Listn.sl n L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all) (*>*)

lemma coalesce_in_err_list [rule_format]:
  "\<forall>xes. xes \<in> list n (err A) \<longrightarrow> coalesce xes \<in> err(list n A)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
(*>*)

lemma lem: "\<And>x xs. x \<squnion>\<^bsub>(#)\<^esub> xs = x#xs"
(*<*) by (simp add: plussub_def) (*>*)

lemma coalesce_eq_OK1_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  (\<forall>zs. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
  apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
(*>*)

lemma coalesce_eq_OK2_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  (\<forall>zs. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<longrightarrow> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
(*>*)

lemma lift2_le_ub:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f); x\<in>A; y\<in>A; x \<squnion>\<^sub>f y = OK z;
      u\<in>A; x \<sqsubseteq>\<^sub>r u; y \<sqsubseteq>\<^sub>r u \<rbrakk> \<Longrightarrow> z \<sqsubseteq>\<^sub>r u"
(*<*)
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
(*>*)

lemma coalesce_eq_OK_ub_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  (\<forall>zs us. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] us \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] us
           \<and> us \<in> list n A \<longrightarrow> zs [\<sqsubseteq>\<^bsub>r\<^esub>] us))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
 apply (blast intro: lift2_le_ub)
apply blast
done
(*>*)

lemma lift2_eq_ErrD:
  "\<lbrakk> x \<squnion>\<^sub>f y = Err; semilat(err A, Err.le r, lift2 f); x\<in>A; y\<in>A \<rbrakk>
  \<Longrightarrow> \<not>(\<exists>u\<in>A. x \<sqsubseteq>\<^sub>r u \<and> y \<sqsubseteq>\<^sub>r u)"
(*<*) by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1]) (*>*)

lemma coalesce_eq_Err_D [rule_format]:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f) \<rbrakk>
  \<Longrightarrow> \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
      coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = Err \<longrightarrow>
      \<not>(\<exists>zs \<in> list n A. xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
 apply (blast dest: lift2_eq_ErrD)
done
(*>*)

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> err A)"
(*<*)
apply (unfold closed_def)
apply (simp add: err_def')
done
(*>*)

lemma closed_map2_list [rule_format]:
  "closed (err A) (lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  map2 f xs ys \<in> list n (err A))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
(*>*)

lemma err_semilat_sup:
  "err_semilat (A,r,f) \<Longrightarrow>
  err_semilat (list n A, Listn.le r, sup f)"
(*<*)
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
 apply (drule Semilat.orderI [OF Semilat.intro])
 apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
(*>*)

lemma err_semilat_upto_esl:
  "\<And>L. err_semilat L \<Longrightarrow> err_semilat(upto_esl m L)"
(*<*)
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
                dest: lesub_list_impl_same_size
                simp add: plussub_def Listn.sup_def)
done
(*>*)

end


(*by Lammich and Ammer*)
theory VEBT_List_Assn
imports
  "Separation_Logic_Imperative_HOL/Sep_Main"
  "HOL-Library.Rewrite"

begin

subsection "Lists"

fun list_assn :: "('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> 'a list \<Rightarrow> 'c list \<Rightarrow> assn" where
  "list_assn P [] [] = emp"
| "list_assn P (a#as) (c#cs) = P a c * list_assn P as cs"
| "list_assn _ _ _ = false"

lemma list_assn_aux_simps[simp]:
  "list_assn P [] l' = (\<up>(l'=[]))"
  "list_assn P l [] = (\<up>(l=[]))"
   apply (cases l')
    apply simp
   apply simp
  apply (cases l)
   apply simp
  apply simp
  done

lemma list_assn_aux_append[simp]:
  "length l1=length l1' \<Longrightarrow>
    list_assn P (l1@l2) (l1'@l2')
    = list_assn P l1 l1' * list_assn P l2 l2'"
  apply (induct rule: list_induct2)
   apply simp
  apply (simp add: star_assoc)
  done

lemma list_assn_aux_ineq_len: "length l \<noteq> length li \<Longrightarrow> list_assn A l li = false"
proof (induction l arbitrary: li)
  case (Cons x l li) thus ?case by (cases li; auto)
qed simp

lemma list_assn_aux_append2[simp]:
  assumes "length l2=length l2'"
  shows "list_assn P (l1@l2) (l1'@l2')
    = list_assn P l1 l1' * list_assn P l2 l2'"
  apply (cases "length l1 = length l1'")
   apply (erule list_assn_aux_append)
  apply (simp add: list_assn_aux_ineq_len assms)
  done

lemma list_assn_simps[simp]:
  "(list_assn P) [] [] = emp"
  "(list_assn P) (a#as) (c#cs) = P a c * (list_assn P) as cs"
  "(list_assn P) (a#as) [] = false"
  "(list_assn P) [] (c#cs) = false"
     apply simp_all
  done

lemma list_assn_mono:
  "\<lbrakk>\<And>x x'. P x x'\<Longrightarrow>\<^sub>AP' x x'\<rbrakk> \<Longrightarrow> list_assn P l l' \<Longrightarrow>\<^sub>A list_assn P' l l'"
  apply (induct P l l' rule: list_assn.induct)
  by (auto intro: ent_star_mono)

lemma list_assn_cong[fundef_cong]:
  assumes "xs=xs'" "xsi=xsi'"
  assumes "\<And>x xi. x\<in>set xs' \<Longrightarrow> xi\<in>set xsi' \<Longrightarrow> A x xi = A' x xi"
  shows "list_assn A xs xsi = list_assn A' xs' xsi'"
  using assms
  apply (induct A\<equiv>A xs' xsi' arbitrary: xs xsi rule: list_assn.induct)
     apply simp_all
  done

term prod_list

definition "listI_assn I A xs xsi \<equiv>
    \<up>(length xsi=length xs \<and> I\<subseteq>{0..<length xs})
  * Finite_Set.fold (\<lambda>i a. a * A (xs!i) (xsi!i)) 1 I"

lemmas comp_fun_commute_fold_insert =
  comp_fun_commute_on.fold_insert[where S=UNIV, folded comp_fun_commute_def', simplified]

lemma aux: "Finite_Set.fold (\<lambda>i aa. aa * P ((a # as) ! i) ((c # cs) ! i)) emp {0..<Suc (length as)}
  = P a c * Finite_Set.fold (\<lambda>i aa. aa * P (as ! i) (cs ! i)) emp {0..<length as}"
proof -
  have 1: "{0..<Suc (length as)} = insert 0 {1..<Suc (length as)}" by auto

  have 2: "{Suc 0..<Suc (Suc n)} = insert (Suc n) {Suc 0 ..< Suc n}" for n by auto
  have 3: "{0..<Suc n} = insert n {0..<n}" for n by auto

  have A: "
    Finite_Set.fold P emp {Suc 0..<Suc n}
    = Finite_Set.fold Q emp {0..<n}"
    if "\<forall>i x. P (Suc i) x = Q i x"
      and "comp_fun_commute P"
      and "comp_fun_commute Q"
    for P Q n
    using that
    apply (induction n arbitrary: a)
    subgoal by simp
    thm comp_fun_commute_on.fold_insert
    apply (simp add: comp_fun_commute_fold_insert)
    apply (subst 2)
    apply (subst 3)
    apply (simp add: comp_fun_commute_fold_insert)
    done
  show ?thesis
    apply (simp add: 1)
    apply (subst comp_fun_commute_fold_insert)
    subgoal
      apply unfold_locales
      apply (auto simp: fun_eq_iff algebra_simps)
      done
    subgoal by simp
    subgoal by simp
    apply simp
    apply (rewrite at "\<hole> = _*_" mult.commute)
    apply (rule arg_cong[where f="\<lambda>x. P _ _ * x"])
    apply (rule A)
    subgoal by auto
    subgoal
      apply unfold_locales
      apply (auto simp: fun_eq_iff algebra_simps)
      done
    subgoal
      apply unfold_locales
      apply (auto simp: fun_eq_iff algebra_simps)
      done
    done
qed

lemma list_assn_conv_idx: "list_assn A xs xsi = listI_assn {0..<length xs} A xs xsi"
  apply (induction A xs xsi rule: list_assn.induct)
     apply (auto simp: listI_assn_def aux)
  done

lemma listI_assn_conv: "n=length xs \<Longrightarrow> listI_assn {0..<n} A xs xsi = list_assn A xs xsi"
  by (simp add: list_assn_conv_idx)

lemma listI_assn_conv': "n=length xs \<Longrightarrow> listI_assn {0..<n} A xs xsi *F  = list_assn A xs xsi* F"
  by (simp add: list_assn_conv_idx)

lemma listI_assn_finite[simp]: "\<not>finite I \<Longrightarrow> listI_assn I A xs xsi = false"
  using subset_eq_atLeast0_lessThan_finite by (auto simp: listI_assn_def)

find_theorems Finite_Set.fold name: cong

lemma mult_fun_commute: "comp_fun_commute (\<lambda>i (a::assn). a * f i)"
  apply unfold_locales
  apply (auto simp: fun_eq_iff mult_ac)
  done

lemma listI_assn_weak_cong:
  assumes I: "I=I'" "A=A'" "length xs=length xs'" "length xsi=length xsi'"
  assumes A: "\<And>i. \<lbrakk>i\<in>I; i<length xs; length xs=length xsi \<rbrakk>
    \<Longrightarrow> xs!i = xs'!i \<and> xsi!i = xsi'!i"
  shows "listI_assn I A xs xsi = listI_assn I' A' xs' xsi'"
  unfolding listI_assn_def
  apply (simp add: I)
  apply (cases "length xsi' = length xs' \<and> I' \<subseteq> {0..<length xs'}"; simp only:; simp)
  apply (rule Finite_Set.fold_cong[where S=UNIV, folded comp_fun_commute_def'])
       apply (simp_all add: mult_fun_commute)
  subgoal by (meson subset_eq_atLeast0_lessThan_finite)
  subgoal using A by (auto simp: fun_eq_iff I)
  done

lemma listI_assn_cong:
  assumes I: "I=I'" "length xs=length xs'" "length xsi=length xsi'"
  assumes A: "\<And>i. \<lbrakk>i\<in>I; i<length xs; length xs=length xsi \<rbrakk>
    \<Longrightarrow> xs!i = xs'!i \<and> xsi!i = xsi'!i
      \<and> A (xs!i) (xsi!i) = A' (xs'!i) (xsi'!i)"
  shows "listI_assn I A xs xsi = listI_assn I' A' xs' xsi'"
  unfolding listI_assn_def
  apply (simp add: I)
  apply (cases "length xsi' = length xs' \<and> I' \<subseteq> {0..<length xs'}"; simp only:; simp)
  apply (rule Finite_Set.fold_cong[where S=UNIV, folded comp_fun_commute_def'])
       apply (simp_all add: mult_fun_commute)
  subgoal by (meson subset_eq_atLeast0_lessThan_finite)
  subgoal using A by (fastforce simp: fun_eq_iff I)
  done

lemma listI_assn_insert: "i\<notin>I \<Longrightarrow> i<length xs \<Longrightarrow>
       listI_assn (insert i I) A xs xsi = A (xs!i) (xsi!i) * listI_assn I A xs xsi"
  apply (cases "finite I"; simp?)
  unfolding listI_assn_def
  apply (subst comp_fun_commute_fold_insert)
  subgoal
    apply unfold_locales
    apply (auto simp: fun_eq_iff algebra_simps)
    done
  subgoal by simp
  subgoal by simp
  subgoal by (auto simp: algebra_simps)
  done

lemma listI_assn_extract:
  assumes "i\<in>I" "i<length xs"
  shows "listI_assn I A xs xsi = A (xs!i) (xsi!i) * listI_assn (I-{i}) A xs xsi"
proof -
  have 1: "I = insert i (I-{i})" using assms by auto
  show ?thesis
    apply (subst 1)
    apply (subst listI_assn_insert)
    using assms by auto
qed

lemma listI_assn_reinsert:
  assumes "P \<Longrightarrow>\<^sub>A A (xs!i) (xsi!i) * listI_assn (I-{i}) A xs xsi * F"
  assumes "i<length xs" "i\<in>I"
  assumes "listI_assn I A xs xsi * F \<Longrightarrow>\<^sub>A Q"
  shows "P \<Longrightarrow>\<^sub>A Q"
proof -
  show ?thesis
    apply (rule ent_trans[OF assms(1)])
    apply (subst listI_assn_extract[symmetric])
    subgoal by fact
    subgoal by fact
    subgoal by fact
    done
qed

lemma listI_assn_reinsert_upd:
  fixes xs xsi :: "_ list"
  assumes "P \<Longrightarrow>\<^sub>A A x xi * listI_assn (I-{i}) A xs xsi * F"
  assumes "i<length xs" "i\<in>I"
  assumes "listI_assn I A (xs[i:=x]) (xsi[i:=xi]) * F \<Longrightarrow>\<^sub>A Q"
  shows "P \<Longrightarrow>\<^sub>A Q"
proof (cases "length xs = length xsi")
  case True
  have 1: "listI_assn (I-{i}) A xs xsi = listI_assn (I-{i}) A (xs[i:=x]) (xsi[i:=xi])"
    by (rule listI_assn_cong) auto

  have 2: "A x xi = A ((xs[i:=x])!i) ((xsi[i:=xi])!i)" using \<open>i<length xs\<close> True by auto

  from assms[unfolded 1 2] show ?thesis
    apply (rule_tac listI_assn_reinsert)
       apply assumption
      apply simp_all
    done

next
  case False
  with assms(1) have "P \<Longrightarrow>\<^sub>A false"
    by (simp add: listI_assn_def)
  thus ?thesis using ent_false_iff entailsI by blast
qed

lemma listI_assn_reinsert':
  assumes "P \<Longrightarrow>\<^sub>A A (xs!i) (xsi!i) * listI_assn (I-{i}) A xs xsi * F"
  assumes "i<length xs" "i\<in>I"
  assumes "<listI_assn I A xs xsi * F>c<Q>"
  shows "
c<Q>"
proof -
  show ?thesis
    apply (rule cons_pre_rule[OF assms(1)])
    apply (subst listI_assn_extract[symmetric])
    subgoal by fact
    subgoal by fact
    subgoal by fact
    done
qed

lemma listI_assn_reinsert_upd':
  fixes xs xsi :: "_ list"
  assumes "P \<Longrightarrow>\<^sub>A A x xi * listI_assn (I-{i}) A xs xsi * F"
  assumes "i<length xs" "i\<in>I"
  assumes "<listI_assn I A (xs[i:=x]) (xsi[i:=xi]) * F> c <Q>"
  shows "
 c <Q>"
  by (meson assms(1) assms(2) assms(3) assms(4) cons_pre_rule ent_refl listI_assn_reinsert_upd)

lemma subst_not_in:
  assumes "i\<notin>I " " i<length xs "
  shows "listI_assn I A (xs[i:=x1]) (xsi[i := x2]) = listI_assn I A xs xsi"
  apply (rule listI_assn_cong)
  using assms
  by (auto simp add: nth_list_update')

lemma listI_assn_subst:
  assumes "i\<notin>I "" i<length xs "
  shows "listI_assn (insert i I) A (xs[i:=x1]) (xsi[i := x2]) = A x1 x2 * listI_assn I A xs xsi"
  by (smt (z3) assms(1) assms(2) length_list_update listI_assn_def listI_assn_insert nth_list_update_eq pure_false star_false_left star_false_right subst_not_in)

lemma extract_pre_list_assn_lengthD: "h \<Turnstile> list_assn A xs xsi \<Longrightarrow> length xsi = length xs"
  by (metis list_assn_aux_ineq_len mod_false)

method unwrap_idx for i ::nat =
  (rewrite in "<\<hole>>_<_>" list_assn_conv_idx),
  (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i="i"]),
  (simp split: if_splits; fail),
  (simp split: if_splits; fail)

method wrap_idx uses R =
  (rule R),
  frame_inference,
  (simp split: if_splits; fail),
  (simp split: if_splits; fail),
  (subst listI_assn_conv, (simp; fail))

method extract_pre_pure uses dest =
  (rule hoare_triple_preI | drule asm_rl[of "_\<Turnstile>_"]),
  (determ \<open>elim mod_starE dest[elim_format]\<close>)?,
  ((determ \<open>thin_tac "_ \<Turnstile> _"\<close>)+)?,
  (simp (no_asm) only: triv_forall_equality)?

lemma rule_at_index:
  assumes
    1:"P \<Longrightarrow>\<^sub>A list_assn A xs xsi * F" and
    2[simp]:"i < length xs" and
    3:"<A (xs ! i) (xsi ! i)  *
    listI_assn ({0..<length xs}- {i}) A xs xsi * F> c <Q'>" and
    4: "\<And> r. Q' r \<Longrightarrow>\<^sub>A A (xs ! i) (xsi ! i)  *
   listI_assn ({0..<length xs}- {i}) A xs xsi* F' r"
  shows
      "
c <\<lambda> r. list_assn A xs xsi * F' r> "
  apply(rule cons_pre_rule[OF 1])
  apply(unwrap_idx i)
  apply(rule cons_post_rule)
  apply(rule 3)
  apply(rule ent_trans[OF 4])
  apply(wrap_idx R: listI_assn_reinsert_upd)
  apply simp
  done

end


theory Tree_Demo
imports Main
begin

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

lemma "Leaf ~= Node l x r"
apply auto
done

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Leaf = Leaf" |
"mirror (Node l x r) = Node (mirror r) x (mirror l)"

value "mirror(Node (Node Leaf a Leaf) b t)"

lemma mirror_mirror[simp]: "mirror(mirror t) = t"
apply(induction t)
apply auto
done

text \<open>An example of fun: beyond one equation per constructor\<close>

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a [] = []" |
"sep a [x] = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

value "sep a [x,y,z]"

end


theory T139
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T144
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


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

datatype Sign = Pos | Neg

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Integer" where
"toInteger (Pos) y = P y"
| "toInteger (Neg) (Z) = P Z"
| "toInteger (Neg) (S z) = N z"

fun sign :: "Integer => Sign" where
"sign (P y) = Pos"
| "sign (N z) = Neg"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

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

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

fun opposite :: "Sign => Sign" where
"opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
"timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun absVal :: "Integer => Nat" where
"absVal (P n) = n"
| "absVal (N m) = plus (S Z) m"

fun times :: "Integer => Integer => Integer" where
"times x y =
   toInteger
     (timesSign (sign x) (sign y)) (times2 (absVal x) (absVal y))"

theorem property0 :
  "((times x y) = (times y x))"
  oops

end


theory Lzip_literates
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

datatype ('a, 'b) Pair2 = Pair2 'a 'b

primcorec lzip :: "'a Llist \<Rightarrow> 'b Llist \<Rightarrow> (('a, 'b) Pair2) Llist"
where
  "lnull xs \<or> lnull ys \<Longrightarrow> lnull (lzip xs ys)"
| "lhd (lzip xs ys) = (Pair2 (lhd xs) (lhd ys))"
| "ltl (lzip xs ys) = lzip (ltl xs) (ltl ys)"

primcorec literates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
  where "literates f x = LCons x (literates f (f x))"

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

theorem lzip_literates:
  "lzip (literates f x) (literates g y) = literates (map_prod2 f g) (Pair2 x y)"
by hipster_coinduct_sledgehammer
end


(*  File:       Condorcet_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Condorcet Module\<close>

theory Condorcet_Module
  imports "Component_Types/Elimination_Module"
begin

text \<open>
  This is the Condorcet module used by the Condorcet (voting) rule. The
  Condorcet rule is a voting rule that implements the Condorcet criterion,
  i.e., it elects the Condorcet winner if it exists, otherwise a tie remains
  between all alternatives. The module implemented herein only rejects the
  alternatives not elected by the voting rule, and defers the alternatives that
  would be elected by the full voting rule.
\<close>

subsection \<open>Definition\<close>

fun condorcet_score :: "'a Evaluation_Function" where
  "condorcet_score x A p =
    (if (condorcet_winner A p x) then 1 else 0)"

fun condorcet :: "'a Electoral_Module" where
  "condorcet A p = (max_eliminator condorcet_score) A p"

subsection \<open>Property\<close>

(* Condorcet score is Condorcet rating. *)
theorem condorcet_score_is_condorcet_rating: "condorcet_rating condorcet_score"
proof (unfold condorcet_rating_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    l :: "'a"
  assume
    c_win: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w: "l \<noteq> w"
  have "\<not> condorcet_winner A p l"
    using c_win l_neq_w cond_winner_unique
    by (metis (no_types))
  thus "condorcet_score l A p < condorcet_score w A p"
    using c_win
    by simp
qed

theorem condorcet_is_dcc: "defer_condorcet_consistency condorcet"
proof (unfold defer_condorcet_consistency_def electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    finA: "finite A" and
    profA: "profile A p"
  have "well_formed A (max_eliminator condorcet_score A p)"
    using finA profA max_elim_sound
    unfolding electoral_module_def
    by metis
  thus "well_formed A (condorcet A p)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cwin_w: "condorcet_winner A p w" and
    finA: "finite A"
  have max_cscore_dcc:
    "defer_condorcet_consistency (max_eliminator condorcet_score)"
    using cr_eval_imp_dcc_max_elim
    by (simp add: condorcet_score_is_condorcet_rating)
  have
    "max_eliminator condorcet_score A p =
  ({},
  A - defer (max_eliminator condorcet_score) A p,
  {a \<in> A. condorcet_winner A p a})"
    using cwin_w finA max_cscore_dcc
    unfolding defer_condorcet_consistency_def
    by (metis (no_types))
  thus
    "condorcet A p =
      ({},
       A - defer condorcet A p,
       {d \<in> A. condorcet_winner A p d})"
    by simp
qed

end


theory More_Asymptotics
  imports
   "Imperative_HOL_Time.Asymptotics_1D"
   "HOL-Real_Asymp.Real_Asymp"
begin

(* by Manuel Eberl *)
lemma dlog[asym_bound]:  "(\<lambda>x. real (Discrete.log x)) \<in> \<Theta>(\<lambda>x. ln (real x))"
proof -
  have "(\<lambda>x. real (Discrete.log x))  \<in> \<Theta>(\<lambda>n. real (nat \<lfloor>log 2 (real n)\<rfloor>))"
    by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of 0]])
       (auto simp: Discrete.log_altdef)
  also have "(\<lambda>n. real (nat \<lfloor>log 2 (real n)\<rfloor>)) \<in> \<Theta>(\<lambda>x. ln (real x))"
    by real_asymp
  finally show ?thesis .
qed

end


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

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

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

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

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
"reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun ordered :: "int list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((z <= y2) & (ordered (cons2 y2 xs)))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 y =
   (case splitAt ((op div) (length y) 3) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
by pat_completeness auto

theorem property0 :
  "ordered (stoogesort xs)"
  oops

end


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

datatype Sign = Pos | Neg

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Integer" where
  "toInteger (Pos) y = P y"
| "toInteger (Neg) (Z) = P Z"
| "toInteger (Neg) (S z) = N z"

fun sign :: "Integer => Sign" where
  "sign (P y) = Pos"
| "sign (N z) = Neg"

fun pred :: "Nat => Nat" where
  "pred (S y) = y"

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

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

fun opposite :: "Sign => Sign" where
  "opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
  "timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

definition(*fun*) one :: "Integer" where
  "one = P (S Z)"

fun absVal :: "Integer => Nat" where
  "absVal (P n) = n"
| "absVal (N m) = plus (S Z) m"

fun times :: "Integer => Integer => Integer" where
  "times x y =
   toInteger
     (timesSign (sign x) (sign y)) (times2 (absVal x) (absVal y))"

theorem property0 :
  "(x = (times one x))"
  oops

end


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

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

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

theory Integer_Nits
imports Main
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

datatype tree = Null | Node nat tree tree

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

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

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

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

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

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

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

end


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

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

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(int list) list => int list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "int list => int list" where
  "msortbu x = mergingbu (map (% (y :: int) => cons2 y (nil2)) x)"

theorem property0 :
  "ordered (msortbu xs)"
  oops

end


(*  Title:      HOL/UNITY/Lift_prog.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge

lift_prog, etc: replication of components and arrays of processes.
*)

section\<open>Replication of Components\<close>

theory Lift_prog imports Rename begin

definition insert_map :: "[nat, 'b, nat=>'b] => (nat=>'b)" where
    "insert_map i z f k == if k<i then f k
                           else if k=i then z
                           else f(k - 1)"

definition delete_map :: "[nat, nat=>'b] => (nat=>'b)" where
    "delete_map i g k == if k<i then g k else g (Suc k)"

definition lift_map :: "[nat, 'b * ((nat=>'b) * 'c)] => (nat=>'b) * 'c" where
    "lift_map i == %(s,(f,uu)). (insert_map i s f, uu)"

definition drop_map :: "[nat, (nat=>'b) * 'c] => 'b * ((nat=>'b) * 'c)" where
    "drop_map i == %(g, uu). (g i, (delete_map i g, uu))"

definition lift_set :: "[nat, ('b * ((nat=>'b) * 'c)) set] => ((nat=>'b) * 'c) set" where
    "lift_set i A == lift_map i ` A"

definition lift :: "[nat, ('b * ((nat=>'b) * 'c)) program] => ((nat=>'b) * 'c) program" where
    "lift i == rename (lift_map i)"

  (*simplifies the expression of specifications*)
definition sub :: "['a, 'a=>'b] => 'b" where
    "sub == %i f. f i"

declare insert_map_def [simp] delete_map_def [simp]

lemma insert_map_inverse: "delete_map i (insert_map i x f) = f"
by (rule ext, simp)

lemma insert_map_delete_map_eq: "(insert_map i x (delete_map i g)) = g(i:=x)"
apply (rule ext)
apply (auto split: nat_diff_split)
done

subsection\<open>Injectiveness proof\<close>

lemma insert_map_inject1: "(insert_map i x f) = (insert_map i y g) ==> x=y"
by (drule_tac x = i in fun_cong, simp)

lemma insert_map_inject2: "(insert_map i x f) = (insert_map i y g) ==> f=g"
apply (drule_tac f = "delete_map i" in arg_cong)
apply (simp add: insert_map_inverse)
done

lemma insert_map_inject':
     "(insert_map i x f) = (insert_map i y g) ==> x=y & f=g"
by (blast dest: insert_map_inject1 insert_map_inject2)

lemmas insert_map_inject = insert_map_inject' [THEN conjE, elim!]

(*The general case: we don't assume i=i'*)
lemma lift_map_eq_iff [iff]:
     "(lift_map i (s,(f,uu)) = lift_map i' (s',(f',uu')))
      = (uu = uu' & insert_map i s f = insert_map i' s' f')"
by (unfold lift_map_def, auto)

(*The !!s allows the automatic splitting of the bound variable*)
lemma drop_map_lift_map_eq [simp]: "!!s. drop_map i (lift_map i s) = s"
apply (unfold lift_map_def drop_map_def)
apply (force intro: insert_map_inverse)
done

lemma inj_lift_map: "inj (lift_map i)"
apply (unfold lift_map_def)
apply (rule inj_onI, auto)
done

subsection\<open>Surjectiveness proof\<close>

lemma lift_map_drop_map_eq [simp]: "!!s. lift_map i (drop_map i s) = s"
apply (unfold lift_map_def drop_map_def)
apply (force simp add: insert_map_delete_map_eq)
done

lemma drop_map_inject [dest!]: "(drop_map i s) = (drop_map i s') ==> s=s'"
by (drule_tac f = "lift_map i" in arg_cong, simp)

lemma surj_lift_map: "surj (lift_map i)"
apply (rule surjI)
apply (rule lift_map_drop_map_eq)
done

lemma bij_lift_map [iff]: "bij (lift_map i)"
by (simp add: bij_def inj_lift_map surj_lift_map)

lemma inv_lift_map_eq [simp]: "inv (lift_map i) = drop_map i"
by (rule inv_equality, auto)

lemma inv_drop_map_eq [simp]: "inv (drop_map i) = lift_map i"
by (rule inv_equality, auto)

lemma bij_drop_map [iff]: "bij (drop_map i)"
by (simp del: inv_lift_map_eq add: inv_lift_map_eq [symmetric] bij_imp_bij_inv)

(*sub's main property!*)
lemma sub_apply [simp]: "sub i f = f i"
by (simp add: sub_def)

lemma all_total_lift: "all_total F ==> all_total (lift i F)"
by (simp add: lift_def rename_def Extend.all_total_extend)

lemma insert_map_upd_same: "(insert_map i t f)(i := s) = insert_map i s f"
by (rule ext, auto)

lemma insert_map_upd:
     "(insert_map j t f)(i := s) =
      (if i=j then insert_map i s f
       else if i<j then insert_map j t (f(i:=s))
       else insert_map j t (f(i - Suc 0 := s)))"
apply (rule ext)
apply (simp split: nat_diff_split)
 txt\<open>This simplification is VERY slow\<close>
done

lemma insert_map_eq_diff:
     "[| insert_map i s f = insert_map j t g;  i\<noteq>j |]
      ==> \<exists>g'. insert_map i s' f = insert_map j t g'"
apply (subst insert_map_upd_same [symmetric])
apply (erule ssubst)
apply (simp only: insert_map_upd if_False split: if_split, blast)
done

lemma lift_map_eq_diff:
     "[| lift_map i (s,(f,uu)) = lift_map j (t,(g,vv));  i\<noteq>j |]
      ==> \<exists>g'. lift_map i (s',(f,uu)) = lift_map j (t,(g',vv))"
apply (unfold lift_map_def, auto)
apply (blast dest: insert_map_eq_diff)
done

subsection\<open>The Operator \<^term>\<open>lift_set\<close>\<close>

lemma lift_set_empty [simp]: "lift_set i {} = {}"
by (unfold lift_set_def, auto)

lemma lift_set_iff: "(lift_map i x \<in> lift_set i A) = (x \<in> A)"
apply (unfold lift_set_def)
apply (rule inj_lift_map [THEN inj_image_mem_iff])
done

(*Do we really need both this one and its predecessor?*)
lemma lift_set_iff2 [iff]:
     "((f,uu) \<in> lift_set i A) = ((f i, (delete_map i f, uu)) \<in> A)"
by (simp add: lift_set_def mem_rename_set_iff drop_map_def)

lemma lift_set_mono: "A \<subseteq> B ==> lift_set i A \<subseteq> lift_set i B"
apply (unfold lift_set_def)
apply (erule image_mono)
done

lemma lift_set_Un_distrib: "lift_set i (A \<union> B) = lift_set i A \<union> lift_set i B"
by (simp add: lift_set_def image_Un)

lemma lift_set_Diff_distrib: "lift_set i (A-B) = lift_set i A - lift_set i B"
apply (unfold lift_set_def)
apply (rule inj_lift_map [THEN image_set_diff])
done

subsection\<open>The Lattice Operations\<close>

lemma bij_lift [iff]: "bij (lift i)"
by (simp add: lift_def)

lemma lift_SKIP [simp]: "lift i SKIP = SKIP"
by (simp add: lift_def)

lemma lift_Join [simp]: "lift i (F \<squnion> G) = lift i F \<squnion> lift i G"
by (simp add: lift_def)

lemma lift_JN [simp]: "lift j (JOIN I F) = (\<Squnion>i \<in> I. lift j (F i))"
by (simp add: lift_def)

subsection\<open>Safety: constrains, stable, invariant\<close>

lemma lift_constrains:
     "(lift i F \<in> (lift_set i A) co (lift_set i B)) = (F \<in> A co B)"
by (simp add: lift_def lift_set_def rename_constrains)

lemma lift_stable:
     "(lift i F \<in> stable (lift_set i A)) = (F \<in> stable A)"
by (simp add: lift_def lift_set_def rename_stable)

lemma lift_invariant:
     "(lift i F \<in> invariant (lift_set i A)) = (F \<in> invariant A)"
by (simp add: lift_def lift_set_def rename_invariant)

lemma lift_Constrains:
     "(lift i F \<in> (lift_set i A) Co (lift_set i B)) = (F \<in> A Co B)"
by (simp add: lift_def lift_set_def rename_Constrains)

lemma lift_Stable:
     "(lift i F \<in> Stable (lift_set i A)) = (F \<in> Stable A)"
by (simp add: lift_def lift_set_def rename_Stable)

lemma lift_Always:
     "(lift i F \<in> Always (lift_set i A)) = (F \<in> Always A)"
by (simp add: lift_def lift_set_def rename_Always)

subsection\<open>Progress: transient, ensures\<close>

lemma lift_transient:
     "(lift i F \<in> transient (lift_set i A)) = (F \<in> transient A)"
by (simp add: lift_def lift_set_def rename_transient)

lemma lift_ensures:
     "(lift i F \<in> (lift_set i A) ensures (lift_set i B)) =
      (F \<in> A ensures B)"
by (simp add: lift_def lift_set_def rename_ensures)

lemma lift_leadsTo:
     "(lift i F \<in> (lift_set i A) leadsTo (lift_set i B)) =
      (F \<in> A leadsTo B)"
by (simp add: lift_def lift_set_def rename_leadsTo)

lemma lift_LeadsTo:
     "(lift i F \<in> (lift_set i A) LeadsTo (lift_set i B)) =
      (F \<in> A LeadsTo B)"
by (simp add: lift_def lift_set_def rename_LeadsTo)

(** guarantees **)

lemma lift_lift_guarantees_eq:
     "(lift i F \<in> (lift i ` X) guarantees (lift i ` Y)) =
      (F \<in> X guarantees Y)"
apply (unfold lift_def)
apply (subst bij_lift_map [THEN rename_rename_guarantees_eq, symmetric])
apply (simp add: o_def)
done

lemma lift_guarantees_eq_lift_inv:
     "(lift i F \<in> X guarantees Y) =
      (F \<in> (rename (drop_map i) ` X) guarantees (rename (drop_map i) ` Y))"
by (simp add: bij_lift_map [THEN rename_guarantees_eq_rename_inv] lift_def)

(*To preserve snd means that the second component is there just to allow
  guarantees properties to be stated.  Converse fails, for lift i F can
  change function components other than i*)
lemma lift_preserves_snd_I: "F \<in> preserves snd ==> lift i F \<in> preserves snd"
apply (drule_tac w1=snd in subset_preserves_o [THEN subsetD])
apply (simp add: lift_def rename_preserves)
apply (simp add: lift_map_def o_def split_def)
done

lemma delete_map_eqE':
     "(delete_map i g) = (delete_map i g') ==> \<exists>x. g = g'(i:=x)"
apply (drule_tac f = "insert_map i (g i) " in arg_cong)
apply (simp add: insert_map_delete_map_eq)
apply (erule exI)
done

lemmas delete_map_eqE = delete_map_eqE' [THEN exE, elim!]

lemma delete_map_neq_apply:
     "[| delete_map j g = delete_map j g';  i\<noteq>j |] ==> g i = g' i"
by force

(*A set of the form (A \<times> UNIV) ignores the second (dummy) state component*)

lemma vimage_o_fst_eq [simp]: "(f o fst) -` A = (f-`A) \<times> UNIV"
by auto

lemma vimage_sub_eq_lift_set [simp]:
     "(sub i -`A) \<times> UNIV = lift_set i (A \<times> UNIV)"
by auto

lemma mem_lift_act_iff [iff]:
     "((s,s') \<in> extend_act (%(x,u::unit). lift_map i x) act) =
      ((drop_map i s, drop_map i s') \<in> act)"
apply (unfold extend_act_def, auto)
apply (rule bexI, auto)
done

lemma preserves_snd_lift_stable:
     "[| F \<in> preserves snd;  i\<noteq>j |]
      ==> lift j F \<in> stable (lift_set i (A \<times> UNIV))"
apply (auto simp add: lift_def lift_set_def stable_def constrains_def
                      rename_def extend_def mem_rename_set_iff)
apply (auto dest!: preserves_imp_eq simp add: lift_map_def drop_map_def)
apply (drule_tac x = i in fun_cong, auto)
done

(*If i\<noteq>j then lift j F  does nothing to lift_set i, and the
  premise ensures A \<subseteq> B.*)
lemma constrains_imp_lift_constrains:
    "[| F i \<in> (A \<times> UNIV) co (B \<times> UNIV);
        F j \<in> preserves snd |]
     ==> lift j (F j) \<in> (lift_set i (A \<times> UNIV)) co (lift_set i (B \<times> UNIV))"
apply (cases "i=j")
apply (simp add: lift_def lift_set_def rename_constrains)
apply (erule preserves_snd_lift_stable[THEN stableD, THEN constrains_weaken_R],
       assumption)
apply (erule constrains_imp_subset [THEN lift_set_mono])
done

(*USELESS??*)
lemma lift_map_image_Times:
     "lift_map i ` (A \<times> UNIV) =
      (\<Union>s \<in> A. \<Union>f. {insert_map i s f}) \<times> UNIV"
apply (auto intro!: bexI image_eqI simp add: lift_map_def)
apply (rule split_conv [symmetric])
done

lemma lift_preserves_eq:
     "(lift i F \<in> preserves v) = (F \<in> preserves (v o lift_map i))"
by (simp add: lift_def rename_preserves)

(*A useful rewrite.  If o, sub have been rewritten out already then can also
  use it as   rewrite_rule [sub_def, o_def] lift_preserves_sub*)
lemma lift_preserves_sub:
     "F \<in> preserves snd
      ==> lift i F \<in> preserves (v o sub j o fst) =
          (if i=j then F \<in> preserves (v o fst) else True)"
apply (drule subset_preserves_o [THEN subsetD])
apply (simp add: lift_preserves_eq o_def)
apply (auto cong del: if_weak_cong
       simp add: lift_map_def eq_commute split_def o_def)
done

subsection\<open>Lemmas to Handle Function Composition (o) More Consistently\<close>

(*Lets us prove one version of a theorem and store others*)
lemma o_equiv_assoc: "f o g = h ==> f' o f o g = f' o h"
by (simp add: fun_eq_iff o_def)

lemma o_equiv_apply: "f o g = h ==> \<forall>x. f(g x) = h x"
by (simp add: fun_eq_iff o_def)

lemma fst_o_lift_map: "sub i o fst o lift_map i = fst"
apply (rule ext)
apply (auto simp add: o_def lift_map_def sub_def)
done

lemma snd_o_lift_map: "snd o lift_map i = snd o snd"
apply (rule ext)
apply (auto simp add: o_def lift_map_def)
done

subsection\<open>More lemmas about extend and project\<close>

text\<open>They could be moved to theory Extend or Project\<close>

lemma extend_act_extend_act:
     "extend_act h' (extend_act h act) =
      extend_act (%(x,(y,y')). h'(h(x,y),y')) act"
apply (auto elim!: rev_bexI simp add: extend_act_def, blast)
done

lemma project_act_project_act:
     "project_act h (project_act h' act) =
      project_act (%(x,(y,y')). h'(h(x,y),y')) act"
by (auto elim!: rev_bexI simp add: project_act_def)

lemma project_act_extend_act:
     "project_act h (extend_act h' act) =
        {(x,x'). \<exists>s s' y y' z. (s,s') \<in> act &
                 h(x,y) = h'(s,z) & h(x',y') = h'(s',z)}"
by (simp add: extend_act_def project_act_def, blast)

subsection\<open>OK and "lift"\<close>

lemma act_in_UNION_preserves_fst:
     "act \<subseteq> {(x,x'). fst x = fst x'} ==> act \<in> \<Union>(Acts ` (preserves fst))"
apply (rule_tac a = "mk_program (UNIV,{act},UNIV) " in UN_I)
apply (auto simp add: preserves_def stable_def constrains_def)
done

lemma UNION_OK_lift_I:
     "[| \<forall>i \<in> I. F i \<in> preserves snd;
         \<forall>i \<in> I. \<Union>(Acts ` (preserves fst)) \<subseteq> AllowedActs (F i) |]
      ==> OK I (%i. lift i (F i))"
apply (auto simp add: OK_def lift_def rename_def Extend.Acts_extend)
apply (simp add: Extend.AllowedActs_extend project_act_extend_act)
apply (rename_tac "act")
apply (subgoal_tac
       "{(x, x'). \<exists>s f u s' f' u'.
                    ((s, f, u), s', f', u') \<in> act &
                    lift_map j x = lift_map i (s, f, u) &
                    lift_map j x' = lift_map i (s', f', u') }
                \<subseteq> { (x,x') . fst x = fst x'}")
apply (blast intro: act_in_UNION_preserves_fst, clarify)
apply (drule_tac x = j in fun_cong)+
apply (drule_tac x = i in bspec, assumption)
apply (frule preserves_imp_eq, auto)
done

lemma OK_lift_I:
     "[| \<forall>i \<in> I. F i \<in> preserves snd;
         \<forall>i \<in> I. preserves fst \<subseteq> Allowed (F i) |]
      ==> OK I (%i. lift i (F i))"
by (simp add: safety_prop_AllowedActs_iff_Allowed UNION_OK_lift_I)

lemma Allowed_lift [simp]: "Allowed (lift i F) = lift i ` (Allowed F)"
by (simp add: lift_def)

lemma lift_image_preserves:
     "lift i ` preserves v = preserves (v o drop_map i)"
by (simp add: rename_image_preserves lift_def)

end


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

section\<open>Zorn's Lemma\<close>

theory Zorn imports OrderArith AC Inductive begin

text\<open>Based upon the unpublished article ``Towards the Mechanization of the
Proofs of Some Classical Theorems of Set Theory,'' by Abrial and Laffitte.\<close>

definition
  Subset_rel :: "i=>i"  where
   "Subset_rel(A) == {z \<in> A*A . \<exists>x y. z=<x,y> & x<=y & x\<noteq>y}"

definition
  chain      :: "i=>i"  where
   "chain(A)      == {F \<in> Pow(A). \<forall>X\<in>F. \<forall>Y\<in>F. X<=Y | Y<=X}"

definition
  super      :: "[i,i]=>i"  where
   "super(A,c)    == {d \<in> chain(A). c<=d & c\<noteq>d}"

definition
  maxchain   :: "i=>i"  where
   "maxchain(A)   == {c \<in> chain(A). super(A,c)=0}"

definition
  increasing :: "i=>i"  where
    "increasing(A) == {f \<in> Pow(A)->Pow(A). \<forall>x. x<=A \<longrightarrow> x<=f`x}"

text\<open>Lemma for the inductive definition below\<close>
lemma Union_in_Pow: "Y \<in> Pow(Pow(A)) ==> \<Union>(Y) \<in> Pow(A)"
by blast

text\<open>We could make the inductive definition conditional on
    \<^term>\<open>next \<in> increasing(S)\<close>
    but instead we make this a side-condition of an introduction rule.  Thus
    the induction rule lets us assume that condition!  Many inductive proofs
    are therefore unconditional.\<close>
consts
  "TFin" :: "[i,i]=>i"

inductive
  domains       "TFin(S,next)" \<subseteq> "Pow(S)"
  intros
    nextI:       "[| x \<in> TFin(S,next);  next \<in> increasing(S) |]
                  ==> next`x \<in> TFin(S,next)"

    Pow_UnionI: "Y \<in> Pow(TFin(S,next)) ==> \<Union>(Y) \<in> TFin(S,next)"

  monos         Pow_mono
  con_defs      increasing_def
  type_intros   CollectD1 [THEN apply_funtype] Union_in_Pow

subsection\<open>Mathematical Preamble\<close>

lemma Union_lemma0: "(\<forall>x\<in>C. x<=A | B<=x) ==> \<Union>(C)<=A | B<=\<Union>(C)"
by blast

lemma Inter_lemma0:
     "[| c \<in> C; \<forall>x\<in>C. A<=x | x<=B |] ==> A \<subseteq> \<Inter>(C) | \<Inter>(C) \<subseteq> B"
by blast

subsection\<open>The Transfinite Construction\<close>

lemma increasingD1: "f \<in> increasing(A) ==> f \<in> Pow(A)->Pow(A)"
apply (unfold increasing_def)
apply (erule CollectD1)
done

lemma increasingD2: "[| f \<in> increasing(A); x<=A |] ==> x \<subseteq> f`x"
by (unfold increasing_def, blast)

lemmas TFin_UnionI = PowI [THEN TFin.Pow_UnionI]

lemmas TFin_is_subset = TFin.dom_subset [THEN subsetD, THEN PowD]

text\<open>Structural induction on \<^term>\<open>TFin(S,next)\<close>\<close>
lemma TFin_induct:
  "[| n \<in> TFin(S,next);
      !!x. [| x \<in> TFin(S,next);  P(x);  next \<in> increasing(S) |] ==> P(next`x);
      !!Y. [| Y \<subseteq> TFin(S,next);  \<forall>y\<in>Y. P(y) |] ==> P(\<Union>(Y))
   |] ==> P(n)"
by (erule TFin.induct, blast+)

subsection\<open>Some Properties of the Transfinite Construction\<close>

lemmas increasing_trans = subset_trans [OF _ increasingD2,
                                        OF _ _ TFin_is_subset]

text\<open>Lemma 1 of section 3.1\<close>
lemma TFin_linear_lemma1:
     "[| n \<in> TFin(S,next);  m \<in> TFin(S,next);
         \<forall>x \<in> TFin(S,next) . x<=m \<longrightarrow> x=m | next`x<=m |]
      ==> n<=m | next`m<=n"
apply (erule TFin_induct)
apply (erule_tac [2] Union_lemma0) (*or just Blast_tac*)
(*downgrade subsetI from intro! to intro*)
apply (blast dest: increasing_trans)
done

text\<open>Lemma 2 of section 3.2.  Interesting in its own right!
  Requires \<^term>\<open>next \<in> increasing(S)\<close> in the second induction step.\<close>
lemma TFin_linear_lemma2:
    "[| m \<in> TFin(S,next);  next \<in> increasing(S) |]
     ==> \<forall>n \<in> TFin(S,next). n<=m \<longrightarrow> n=m | next`n \<subseteq> m"
apply (erule TFin_induct)
apply (rule impI [THEN ballI])
txt\<open>case split using \<open>TFin_linear_lemma1\<close>\<close>
apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
       assumption+)
apply (blast del: subsetI
             intro: increasing_trans subsetI, blast)
txt\<open>second induction step\<close>
apply (rule impI [THEN ballI])
apply (rule Union_lemma0 [THEN disjE])
apply (erule_tac [3] disjI2)
prefer 2 apply blast
apply (rule ballI)
apply (drule bspec, assumption)
apply (drule subsetD, assumption)
apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
       assumption+, blast)
apply (erule increasingD2 [THEN subset_trans, THEN disjI1])
apply (blast dest: TFin_is_subset)+
done

text\<open>a more convenient form for Lemma 2\<close>
lemma TFin_subsetD:
     "[| n<=m;  m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> n=m | next`n \<subseteq> m"
by (blast dest: TFin_linear_lemma2 [rule_format])

text\<open>Consequences from section 3.3 -- Property 3.2, the ordering is total\<close>
lemma TFin_subset_linear:
     "[| m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> n \<subseteq> m | m<=n"
apply (rule disjE)
apply (rule TFin_linear_lemma1 [OF _ _TFin_linear_lemma2])
apply (assumption+, erule disjI2)
apply (blast del: subsetI
             intro: subsetI increasingD2 [THEN subset_trans] TFin_is_subset)
done

text\<open>Lemma 3 of section 3.3\<close>
lemma equal_next_upper:
     "[| n \<in> TFin(S,next);  m \<in> TFin(S,next);  m = next`m |] ==> n \<subseteq> m"
apply (erule TFin_induct)
apply (drule TFin_subsetD)
apply (assumption+, force, blast)
done

text\<open>Property 3.3 of section 3.3\<close>
lemma equal_next_Union:
     "[| m \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> m = next`m <-> m = \<Union>(TFin(S,next))"
apply (rule iffI)
apply (rule Union_upper [THEN equalityI])
apply (rule_tac [2] equal_next_upper [THEN Union_least])
apply (assumption+)
apply (erule ssubst)
apply (rule increasingD2 [THEN equalityI], assumption)
apply (blast del: subsetI
             intro: subsetI TFin_UnionI TFin.nextI TFin_is_subset)+
done

subsection\<open>Hausdorff's Theorem: Every Set Contains a Maximal Chain\<close>

text\<open>NOTE: We assume the partial ordering is \<open>\<subseteq>\<close>, the subset
relation!\<close>

text\<open>* Defining the "next" operation for Hausdorff's Theorem *\<close>

lemma chain_subset_Pow: "chain(A) \<subseteq> Pow(A)"
apply (unfold chain_def)
apply (rule Collect_subset)
done

lemma super_subset_chain: "super(A,c) \<subseteq> chain(A)"
apply (unfold super_def)
apply (rule Collect_subset)
done

lemma maxchain_subset_chain: "maxchain(A) \<subseteq> chain(A)"
apply (unfold maxchain_def)
apply (rule Collect_subset)
done

lemma choice_super:
     "[| ch \<in> (\<Prod>X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S) |]
      ==> ch ` super(S,X) \<in> super(S,X)"
apply (erule apply_type)
apply (unfold super_def maxchain_def, blast)
done

lemma choice_not_equals:
     "[| ch \<in> (\<Prod>X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S) |]
      ==> ch ` super(S,X) \<noteq> X"
apply (rule notI)
apply (drule choice_super, assumption, assumption)
apply (simp add: super_def)
done

text\<open>This justifies Definition 4.4\<close>
lemma Hausdorff_next_exists:
     "ch \<in> (\<Prod>X \<in> Pow(chain(S))-{0}. X) ==>
      \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                   next`X = if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X)"
apply (rule_tac x="\<lambda>X\<in>Pow(S).
                   if X \<in> chain(S) - maxchain(S) then ch ` super(S, X) else X"
       in bexI)
apply force
apply (unfold increasing_def)
apply (rule CollectI)
apply (rule lam_type)
apply (simp (no_asm_simp))
apply (blast dest: super_subset_chain [THEN subsetD]
                   chain_subset_Pow [THEN subsetD] choice_super)
txt\<open>Now, verify that it increases\<close>
apply (simp (no_asm_simp) add: Pow_iff subset_refl)
apply safe
apply (drule choice_super)
apply (assumption+)
apply (simp add: super_def, blast)
done

text\<open>Lemma 4\<close>
lemma TFin_chain_lemma4:
     "[| c \<in> TFin(S,next);
         ch \<in> (\<Prod>X \<in> Pow(chain(S))-{0}. X);
         next \<in> increasing(S);
         \<forall>X \<in> Pow(S). next`X =
                          if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X) |]
     ==> c \<in> chain(S)"
apply (erule TFin_induct)
apply (simp (no_asm_simp) add: chain_subset_Pow [THEN subsetD, THEN PowD]
            choice_super [THEN super_subset_chain [THEN subsetD]])
apply (unfold chain_def)
apply (rule CollectI, blast, safe)
apply (rule_tac m1=B and n1=Ba in TFin_subset_linear [THEN disjE], fast+)
      txt\<open>\<open>Blast_tac's\<close> slow\<close>
done

theorem Hausdorff: "\<exists>c. c \<in> maxchain(S)"
apply (rule AC_Pi_Pow [THEN exE])
apply (rule Hausdorff_next_exists [THEN bexE], assumption)
apply (rename_tac ch "next")
apply (subgoal_tac "\<Union>(TFin (S,next)) \<in> chain (S) ")
prefer 2
 apply (blast intro!: TFin_chain_lemma4 subset_refl [THEN TFin_UnionI])
apply (rule_tac x = "\<Union>(TFin (S,next))" in exI)
apply (rule classical)
apply (subgoal_tac "next ` Union(TFin (S,next)) = \<Union>(TFin (S,next))")
apply (rule_tac [2] equal_next_Union [THEN iffD2, symmetric])
apply (rule_tac [2] subset_refl [THEN TFin_UnionI])
prefer 2 apply assumption
apply (rule_tac [2] refl)
apply (simp add: subset_refl [THEN TFin_UnionI,
                              THEN TFin.dom_subset [THEN subsetD, THEN PowD]])
apply (erule choice_not_equals [THEN notE])
apply (assumption+)
done

subsection\<open>Zorn's Lemma: If All Chains in S Have Upper Bounds In S,
       then S contains a Maximal Element\<close>

text\<open>Used in the proof of Zorn's Lemma\<close>
lemma chain_extend:
    "[| c \<in> chain(A);  z \<in> A;  \<forall>x \<in> c. x<=z |] ==> cons(z,c) \<in> chain(A)"
by (unfold chain_def, blast)

lemma Zorn: "\<forall>c \<in> chain(S). \<Union>(c) \<in> S ==> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
apply (rule Hausdorff [THEN exE])
apply (simp add: maxchain_def)
apply (rename_tac c)
apply (rule_tac x = "\<Union>(c)" in bexI)
prefer 2 apply blast
apply safe
apply (rename_tac z)
apply (rule classical)
apply (subgoal_tac "cons (z,c) \<in> super (S,c) ")
apply (blast elim: equalityE)
apply (unfold super_def, safe)
apply (fast elim: chain_extend)
apply (fast elim: equalityE)
done

text \<open>Alternative version of Zorn's Lemma\<close>

theorem Zorn2:
  "\<forall>c \<in> chain(S). \<exists>y \<in> S. \<forall>x \<in> c. x \<subseteq> y ==> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
apply (cut_tac Hausdorff maxchain_subset_chain)
apply (erule exE)
apply (drule subsetD, assumption)
apply (drule bspec, assumption, erule bexE)
apply (rule_tac x = y in bexI)
  prefer 2 apply assumption
apply clarify
apply rule apply assumption
apply rule
apply (rule ccontr)
apply (frule_tac z=z in chain_extend)
  apply (assumption, blast)
apply (unfold maxchain_def super_def)
apply (blast elim!: equalityCE)
done

subsection\<open>Zermelo's Theorem: Every Set can be Well-Ordered\<close>

text\<open>Lemma 5\<close>
lemma TFin_well_lemma5:
     "[| n \<in> TFin(S,next);  Z \<subseteq> TFin(S,next);  z:Z;  ~ \<Inter>(Z) \<in> Z |]
      ==> \<forall>m \<in> Z. n \<subseteq> m"
apply (erule TFin_induct)
prefer 2 apply blast txt\<open>second induction step is easy\<close>
apply (rule ballI)
apply (rule bspec [THEN TFin_subsetD, THEN disjE], auto)
apply (subgoal_tac "m = \<Inter>(Z) ")
apply blast+
done

text\<open>Well-ordering of \<^term>\<open>TFin(S,next)\<close>\<close>
lemma well_ord_TFin_lemma: "[| Z \<subseteq> TFin(S,next);  z \<in> Z |] ==> \<Inter>(Z) \<in> Z"
apply (rule classical)
apply (subgoal_tac "Z = {\<Union>(TFin (S,next))}")
apply (simp (no_asm_simp) add: Inter_singleton)
apply (erule equal_singleton)
apply (rule Union_upper [THEN equalityI])
apply (rule_tac [2] subset_refl [THEN TFin_UnionI, THEN TFin_well_lemma5, THEN bspec], blast+)
done

text\<open>This theorem just packages the previous result\<close>
lemma well_ord_TFin:
     "next \<in> increasing(S)
      ==> well_ord(TFin(S,next), Subset_rel(TFin(S,next)))"
apply (rule well_ordI)
apply (unfold Subset_rel_def linear_def)
txt\<open>Prove the well-foundedness goal\<close>
apply (rule wf_onI)
apply (frule well_ord_TFin_lemma, assumption)
apply (drule_tac x = "\<Inter>(Z) " in bspec, assumption)
apply blast
txt\<open>Now prove the linearity goal\<close>
apply (intro ballI)
apply (case_tac "x=y")
 apply blast
txt\<open>The \<^term>\<open>x\<noteq>y\<close> case remains\<close>
apply (rule_tac n1=x and m1=y in TFin_subset_linear [THEN disjE],
       assumption+, blast+)
done

text\<open>* Defining the "next" operation for Zermelo's Theorem *\<close>

lemma choice_Diff:
     "[| ch \<in> (\<Prod>X \<in> Pow(S) - {0}. X);  X \<subseteq> S;  X\<noteq>S |] ==> ch ` (S-X) \<in> S-X"
apply (erule apply_type)
apply (blast elim!: equalityE)
done

text\<open>This justifies Definition 6.1\<close>
lemma Zermelo_next_exists:
     "ch \<in> (\<Prod>X \<in> Pow(S)-{0}. X) ==>
           \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                      next`X = (if X=S then S else cons(ch`(S-X), X))"
apply (rule_tac x="\<lambda>X\<in>Pow(S). if X=S then S else cons(ch`(S-X), X)"
       in bexI)
apply force
apply (unfold increasing_def)
apply (rule CollectI)
apply (rule lam_type)
txt\<open>Type checking is surprisingly hard!\<close>
apply (simp (no_asm_simp) add: Pow_iff cons_subset_iff subset_refl)
apply (blast intro!: choice_Diff [THEN DiffD1])
txt\<open>Verify that it increases\<close>
apply (intro allI impI)
apply (simp add: Pow_iff subset_consI subset_refl)
done

text\<open>The construction of the injection\<close>
lemma choice_imp_injection:
     "[| ch \<in> (\<Prod>X \<in> Pow(S)-{0}. X);
         next \<in> increasing(S);
         \<forall>X \<in> Pow(S). next`X = if(X=S, S, cons(ch`(S-X), X)) |]
      ==> (\<lambda> x \<in> S. \<Union>({y \<in> TFin(S,next). x \<notin> y}))
               \<in> inj(S, TFin(S,next) - {S})"
apply (rule_tac d = "%y. ch` (S-y) " in lam_injective)
apply (rule DiffI)
apply (rule Collect_subset [THEN TFin_UnionI])
apply (blast intro!: Collect_subset [THEN TFin_UnionI] elim: equalityE)
apply (subgoal_tac "x \<notin> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
prefer 2 apply (blast elim: equalityE)
apply (subgoal_tac "\<Union>({y \<in> TFin (S,next) . x \<notin> y}) \<noteq> S")
prefer 2 apply (blast elim: equalityE)
txt\<open>For proving \<open>x \<in> next`\<Union>(...)\<close>.
  Abrial and Laffitte's justification appears to be faulty.\<close>
apply (subgoal_tac "~ next ` Union({y \<in> TFin (S,next) . x \<notin> y})
                    \<subseteq> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2
 apply (simp del: Union_iff
             add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset]
             Pow_iff cons_subset_iff subset_refl choice_Diff [THEN DiffD2])
apply (subgoal_tac "x \<in> next ` Union({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2
 apply (blast intro!: Collect_subset [THEN TFin_UnionI] TFin.nextI)
txt\<open>End of the lemmas!\<close>
apply (simp add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset])
done

text\<open>The wellordering theorem\<close>
theorem AC_well_ord: "\<exists>r. well_ord(S,r)"
apply (rule AC_Pi_Pow [THEN exE])
apply (rule Zermelo_next_exists [THEN bexE], assumption)
apply (rule exI)
apply (rule well_ord_rvimage)
apply (erule_tac [2] well_ord_TFin)
apply (rule choice_imp_injection [THEN inj_weaken_type], blast+)
done

subsection \<open>Zorn's Lemma for Partial Orders\<close>

text \<open>Reimported from HOL by Clemens Ballarin.\<close>

definition Chain :: "i => i" where
  "Chain(r) = {A \<in> Pow(field(r)). \<forall>a\<in>A. \<forall>b\<in>A. <a, b> \<in> r | <b, a> \<in> r}"

lemma mono_Chain:
  "r \<subseteq> s ==> Chain(r) \<subseteq> Chain(s)"
  unfolding Chain_def
  by blast

theorem Zorn_po:
  assumes po: "Partial_order(r)"
    and u: "\<forall>C\<in>Chain(r). \<exists>u\<in>field(r). \<forall>a\<in>C. <a, u> \<in> r"
  shows "\<exists>m\<in>field(r). \<forall>a\<in>field(r). <m, a> \<in> r \<longrightarrow> a = m"
proof -
  have "Preorder(r)" using po by (simp add: partial_order_on_def)
  \<comment> \<open>Mirror r in the set of subsets below (wrt r) elements of A (?).\<close>
  let ?B = "\<lambda>x\<in>field(r). r -`` {x}" let ?S = "?B `` field(r)"
  have "\<forall>C\<in>chain(?S). \<exists>U\<in>?S. \<forall>A\<in>C. A \<subseteq> U"
  proof (clarsimp simp: chain_def Subset_rel_def bex_image_simp)
    fix C
    assume 1: "C \<subseteq> ?S" and 2: "\<forall>A\<in>C. \<forall>B\<in>C. A \<subseteq> B | B \<subseteq> A"
    let ?A = "{x \<in> field(r). \<exists>M\<in>C. M = ?B`x}"
    have "C = ?B `` ?A" using 1
      apply (auto simp: image_def)
      apply rule
      apply rule
      apply (drule subsetD) apply assumption
      apply (erule CollectE)
      apply rule apply assumption
      apply (erule bexE)
      apply rule prefer 2 apply assumption
      apply rule
      apply (erule lamE) apply simp
      apply assumption

      apply (thin_tac "C \<subseteq> X" for X)
      apply (fast elim: lamE)
      done
    have "?A \<in> Chain(r)"
    proof (simp add: Chain_def subsetI, intro conjI ballI impI)
      fix a b
      assume "a \<in> field(r)" "r -`` {a} \<in> C" "b \<in> field(r)" "r -`` {b} \<in> C"
      hence "r -`` {a} \<subseteq> r -`` {b} | r -`` {b} \<subseteq> r -`` {a}" using 2 by auto
      then show "<a, b> \<in> r | <b, a> \<in> r"
        using \<open>Preorder(r)\<close> \<open>a \<in> field(r)\<close> \<open>b \<in> field(r)\<close>
        by (simp add: subset_vimage1_vimage1_iff)
    qed
    then obtain u where uA: "u \<in> field(r)" "\<forall>a\<in>?A. <a, u> \<in> r"
      using u
      apply auto
      apply (drule bspec) apply assumption
      apply auto
      done
    have "\<forall>A\<in>C. A \<subseteq> r -`` {u}"
    proof (auto intro!: vimageI)
      fix a B
      assume aB: "B \<in> C" "a \<in> B"
      with 1 obtain x where "x \<in> field(r)" "B = r -`` {x}"
        apply -
        apply (drule subsetD) apply assumption
        apply (erule imageE)
        apply (erule lamE)
        apply simp
        done
      then show "<a, u> \<in> r" using uA aB \<open>Preorder(r)\<close>
        by (auto simp: preorder_on_def refl_def) (blast dest: trans_onD)+
    qed
    then show "\<exists>U\<in>field(r). \<forall>A\<in>C. A \<subseteq> r -`` {U}"
      using \<open>u \<in> field(r)\<close> ..
  qed
  from Zorn2 [OF this]
  obtain m B where "m \<in> field(r)" "B = r -`` {m}"
    "\<forall>x\<in>field(r). B \<subseteq> r -`` {x} \<longrightarrow> B = r -`` {x}"
    by (auto elim!: lamE simp: ball_image_simp)
  then have "\<forall>a\<in>field(r). <m, a> \<in> r \<longrightarrow> a = m"
    using po \<open>Preorder(r)\<close> \<open>m \<in> field(r)\<close>
    by (auto simp: subset_vimage1_vimage1_iff Partial_order_eq_vimage1_vimage1_iff)
  then show ?thesis using \<open>m \<in> field(r)\<close> by blast
qed

end