theory proof_insert
  imports
  LLRB_SET
  LLRB_IMP
begin

subsection \<open>proof of bst_insert\<close>

lemma bst_paint: "inorder(paint c t) = inorder t"
  by(induct t)
  auto

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

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

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

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

theorem bst_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
  by(auto simp: insert_def bst_ins bst_paint)

subsection \<open>proof of invh_insert\<close>

lemma f1:
  "bheight t2 = 0 \<Longrightarrow> bheight (rightredB \<langle>\<rangle> a t2) = Suc 0"
  apply (induct t2)
  apply auto
  by (metis (full_types) rightredB.simps(2) Suc_eq_plus1 add_is_0 bheight.simps(1) bheight.simps(2) color.exhaust zero_neq_one)

lemma f2:
  "Suc (bheight v) = bheight t2 \<Longrightarrow> bheight (rightredB (B v vc vb) a t2) = Suc (bheight t2)"
  apply (induct t2)
  apply auto
  by (metis (full_types) Suc_eq_plus1 bheight.simps(2) color.exhaust rightredB.simps(1))

lemma bheight_rightredB:
  "bheight l = bheight r \<Longrightarrow> bheight (rightredB l a r) = Suc (bheight l)"
  apply(induct l a r rule: baliL.induct)
  apply auto
  apply (simp add: f1)
  apply (simp add: f2)
  apply (smt (verit, del_insts) One_nat_def add_0 bheight.simps(1) bheight.simps(2) color.exhaust f2 rightredB.simps(5))
  apply (smt (verit) One_nat_def add.commute add_0 add_Suc_shift bheight.simps(2) color.exhaust f2 rightredB.simps(5))
  apply (simp add: f2)
  apply (metis (full_types) Suc_eq_plus1 bheight.simps(2) color.exhaust f2 rightredB.simps(5))
  apply (metis (full_types) Suc_eq_plus1 bheight.simps(2) color.exhaust f2 rightredB.simps(5))
  by (simp add: f2)

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

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

lemma invh_rightredB:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (rightredB l a r)"
  by(cases "(l,a,r)"rule: rightredB.cases)
  auto

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

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

lemma invh_bheight_rightredB:
  "\<lbrakk> invh l;  invh r;  bheight l  = bheight r \<rbrakk> \<Longrightarrow> invh (rightredB l a r) \<and> bheight (rightredB l a r) = Suc (bheight r)"
  apply (induct l a r rule: rightredB.induct)
  by simp+

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

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

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

theorem invh_insert: "llrb t \<Longrightarrow> invh (insert x t)"
  by (auto simp: insert_def invh_ins invh_paint llrb_def)

subsection \<open>proof of invc_insert\<close>

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

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

abbreviation invc2 :: "'a llrb \<Rightarrow> bool" where
"invc2 t \<equiv> invc(paint Black t)"

lemma invc2I: "invc t \<Longrightarrow> invc2 t"
  apply(cases t rule: search_tree2_cases)
  apply simp+
  using neq_Black by blast

lemma color_rightredB:"color (rightredB l a r) = Black"
  apply (induct l a r rule: rightredB.induct)
  by auto

lemma invc_rightredB:"invc l \<Longrightarrow> invc r \<Longrightarrow> invc (rightredB l a r)"
  apply (induct l a r rule: rightredB.induct)
  by auto

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

fun ins_right_red :: "'a llrb \<Rightarrow> 'a llrb" where
"ins_right_red (Node l (a, Red) r) = (if(color l = Black \<and> color r = Red \<and> invc r \<and> invc3 l) then rightredB l a r else  (Node l (a, Black) r))" |
"ins_right_red Leaf = Leaf"|
"ins_right_red (B v vc vb) = (B v vc vb)"

abbreviation invc4 :: "'a llrb   \<Rightarrow> bool" where
"invc4 t  \<equiv> invc(ins_right_red t)"

fun invc_red :: "'a llrb \<Rightarrow> bool" where
"invc_red Leaf = True" |
"invc_red (Node l (a,c) r) = (invc4 (Node l (a,c) r) \<and> invc l \<and> invc r)"

lemma invc4I:"invc t \<Longrightarrow> invc4 t"
  apply(cases t rule: search_tree2_cases)
  apply simp
  by (metis (full_types) ins_right_red.simps(1) ins_right_red.simps(3) invc.simps(2) neq_Black)

lemma invc_redI:"invc t \<Longrightarrow> invc_red t"
  apply(cases t rule: search_tree2_cases)
  apply simp
  by (metis (full_types) ins_right_red.simps(1) ins_right_red.simps(3) invc.simps(2) invc_red.simps(2) neq_Black)

lemma invc_baliR1: "\<lbrakk>invc l; invc_red r\<rbrakk> \<Longrightarrow> invc_red (baliR l a r)"
  apply (induct l a r rule: baliR.induct)
  by (auto simp: invc_redI invc_rightredB)

lemma invc_baliR2: "\<lbrakk>invc l; invc_red r\<rbrakk> \<Longrightarrow> invc (baliR l a r)"
  apply (induct l a r rule: baliR.induct)
  apply auto
  by (auto simp: invc_rightredB color_rightredB)

lemma invc_baliR3: "\<lbrakk>invc_red l; invc r\<rbrakk> \<Longrightarrow> invc_red (baliL l a r)"
  apply (induct l a r rule: baliL.induct)
  by(auto simp:  invc_redI invc_rightredB)

lemma invc_baliR4: "\<lbrakk>invc_red l; invc r\<rbrakk> \<Longrightarrow> invc (baliL l a r)"
  apply (induct l a r rule: baliL.induct)
  by(auto simp:  invc_rightredB color_rightredB)

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

lemma invc3I: "invc t \<Longrightarrow> invc3 t"
  apply(cases t rule: search_tree2_cases)
  by simp+

lemma invc_ins: "invc t \<longrightarrow> invc_red (ins x t) \<and> (color t = Black \<longrightarrow> invc (ins x t))"
  apply(induct x t rule: ins.induct)
  by(auto simp: invc_baliR1 invc_baliR2 invc3I invc_baliR3 invc_baliR4 invc_rightredB)

lemma invc2_ins:"invc t \<and> invh t \<and> color t = Black \<Longrightarrow> invc2 (ins x t)"
  by (simp add: invc2I invc_ins)

theorem invc_insert: "llrb t \<Longrightarrow> invc (insert x t)"
  by(simp add: llrb_def insert_def invc2_ins)

subsection \<open>proof of insert\<close>

theorem llrb_insert: "llrb t \<Longrightarrow> llrb (insert x t)"
  by(metis invc_insert invh_insert llrb_def color_paint_Black insert_def)

end


section "Idle Proofs"

theory Idle_Proof
  imports Idle Stack_Proof
begin

lemma push_list [simp]: "list (push x idle) = x # list idle"
  by(induction idle arbitrary: x) auto

lemma pop_list [simp]: "\<lbrakk>\<not> is_empty idle; pop idle = (x, idle')\<rbrakk> \<Longrightarrow> x # list idle' = list idle"
  by(induction idle arbitrary: x)(auto simp: list_not_empty)

lemma pop_list_tl [simp]:
    "\<lbrakk>\<not> is_empty idle; pop idle = (x, idle')\<rbrakk> \<Longrightarrow> x # (tl (list idle)) = list idle"
  by(induction idle arbitrary: x) (auto simp: list_not_empty)

lemma pop_list_tl' [simp]: "\<lbrakk>pop idle = (x, idle')\<rbrakk> \<Longrightarrow> list idle' = tl (list idle)"
  by(induction idle arbitrary: x)(auto simp: drop_Suc)

lemma size_push [simp]: "size (push x idle) = Suc (size idle)"
  by(induction idle arbitrary: x) auto

lemma size_pop [simp]: "\<lbrakk>\<not>is_empty idle; pop idle = (x, idle')\<rbrakk> \<Longrightarrow> Suc (size idle') = size idle"
  by(induction idle arbitrary: x)(auto simp: size_not_empty)

lemma size_pop_sub: "\<lbrakk>pop idle = (x, idle')\<rbrakk> \<Longrightarrow> size idle' = size idle - 1"
  by(induction idle arbitrary: x) auto

lemma invar_push: "invar idle \<Longrightarrow> invar (push x idle)"
  by(induction x idle rule: push.induct) auto

lemma invar_pop: "\<lbrakk>\<not> is_empty idle; invar idle; pop idle = (x, idle')\<rbrakk> \<Longrightarrow> invar idle'"
  by(induction idle arbitrary: x rule: pop.induct) auto

lemma size_empty: "size idle = 0 \<longleftrightarrow> is_empty (idle :: 'a idle)"
  by(induction idle)(auto simp: size_empty)

lemma size_not_empty: "0 < size idle \<longleftrightarrow> \<not>is_empty (idle :: 'a idle)"
  by(induction idle)(auto simp: size_not_empty)

lemma size_empty_2 [simp]: "\<lbrakk>\<not>is_empty (idle :: 'a idle); 0 = size idle\<rbrakk> \<Longrightarrow> False"
  by (simp add: size_empty)

lemma size_not_empty_2 [simp]: "\<lbrakk>is_empty (idle :: 'a idle); 0 < size idle\<rbrakk> \<Longrightarrow> False"
  by (simp add: size_not_empty)

lemma list_empty: "list idle = [] \<longleftrightarrow> is_empty idle"
  by(induction idle)(simp add: list_empty)

lemma list_not_empty: "list idle  \<noteq> [] \<longleftrightarrow> \<not> is_empty idle"
  by(induction idle)(simp add: list_not_empty)

lemma list_empty_2 [simp]: "\<lbrakk>list idle = []; \<not>is_empty (idle :: 'a idle)\<rbrakk> \<Longrightarrow> False"
  using list_empty by blast

lemma list_not_empty_2 [simp]: "\<lbrakk>list idle \<noteq> []; is_empty (idle :: 'a idle)\<rbrakk> \<Longrightarrow> False"
  using list_not_empty by blast

lemma list_empty_size: "list idle = [] \<longleftrightarrow> 0 = size idle"
  by (simp add: list_empty size_empty)

lemma list_not_empty_size: "list idle \<noteq> [] \<longleftrightarrow> 0 < size idle"
  by (simp add: list_empty_size)

lemma list_empty_size_2 [simp]: "\<lbrakk>list idle \<noteq> []; 0 = size idle\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty size_empty)

lemma list_not_empty_size_2 [simp]: "\<lbrakk>list idle = []; 0 < size idle\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty_size)

end


(*
  File: Structure.thy
  Author: Bohua Zhan

  Definition of mathematical structures. Structures are represented as
  partial functions from natural numbers, with each field given an unique
  natural number index.
*)

theory Structure
  imports Graph
begin

definition Struct :: "i \<Rightarrow> i" where [rewrite]:
  "Struct(S) = S"

lemma not_mem_cons: "x \<noteq> a \<Longrightarrow> x \<notin> S \<Longrightarrow> x \<notin> cons(a,S)" by auto2
lemma mem_cons_head: "x \<in> cons(x,S)" by auto2
lemma mem_cons_tail: "x \<in> S \<Longrightarrow> x \<in> cons(y,S)" by auto2
lemma forall_single: "(\<forall>x\<in>{a}. P(x)) \<longleftrightarrow> P(a)" by auto2
lemma forall_cons: "(\<forall>x\<in>cons(a,X). P(x)) \<longleftrightarrow> (P(a) \<and> (\<forall>x\<in>X. P(x)))" by auto2

ML_file "structure.ML"

section \<open>Components of a structure\<close>

definition "source_name = \<emptyset>"
definition "target_name = succ(\<emptyset>)"
definition "graph_name = succ(succ(\<emptyset>))"

definition "source(S) = graph_eval(S, source_name)"
definition "target(S) = graph_eval(S, target_name)"
definition "graph(S) = graph_eval(S, graph_name)"

setup {* add_field_data (@{term source_name}, @{term source}) *}
setup {* add_field_data (@{term target_name}, @{term target}) *}
setup {* add_field_data (@{term graph_name}, @{term graph}) *}

section \<open>Evaluation function: shared by families and functions\<close>

definition feval :: "i \<Rightarrow> i \<Rightarrow> i" (infixl "`" 90) where [rewrite]:
  "f ` x = graph_eval(graph(f),x)"
setup {* register_wellform_data ("f ` x", ["x \<in> source(f)"]) *}
setup {* add_prfstep_check_req ("f ` x", "x \<in> source(f)") *}

section \<open>Families\<close>

(* Predicate for families. *)
definition is_family :: "i \<Rightarrow> o" where [rewrite]:
  "is_family(F) \<longleftrightarrow> is_func_graph(F,{source_name,graph_name}) \<and> is_func_graph(graph(F),source(F))"

(* Constructor for families. *)
definition Tup :: "i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> i" where [rewrite]:
  "Tup(I,f) = Struct({\<langle>source_name, I\<rangle>, \<langle>graph_name, {\<langle>a, f(a)\<rangle>. a \<in> I}\<rangle>})"

lemma TupD: "is_family(Tup(I,f)) \<and> source(Tup(I,f)) = I"
@proof
  @let "G = {\<langle>a, f(a)\<rangle>. a \<in> I}"
  @have "is_graph(G)"
  @have "\<forall>x. x \<in> gr_source(G) \<longleftrightarrow> x \<in> I" @with
    @case "x \<in> gr_source(G)" @with @obtain y where "\<langle>x,y\<rangle> \<in> G" @end
    @case "x \<in> I" @with @have "\<langle>x, f(x)\<rangle> \<in> G" @end
  @end
  @have "is_func_graph(G,I)"
@qed
setup {* add_forward_prfstep_cond @{thm TupD} [with_term "Tup(?I,?f)"] *}

(* Evaluation for families. *)
lemma Tup_eval [rewrite]: "a \<in> source(Tup(I,f)) \<Longrightarrow> Tup(I,f) ` a = f(a)" by auto2

(* Equality on families. *)
lemma family_eq [backward]:
  "is_family(f) \<Longrightarrow> is_family(g) \<Longrightarrow> source(f) = source(g) \<Longrightarrow> \<forall>a\<in>source(f). f`a = g`a \<Longrightarrow> f = g"
@proof @have "\<forall>a\<in>source(f). graph_eval(graph(f),a) = graph_eval(graph(g),a)" @qed
setup {* del_prfstep_thm @{thm Tup_def} *}

(* Pi space is the space of families with values in specified sets.
   Need to use Sigma(I,B) to construct the set. *)
definition Pi :: "[i, i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "Pi(I,B) = {Struct({\<langle>source_name, I\<rangle>, \<langle>graph_name, P\<rangle>}). P \<in> {f \<in> Pow(Sigma(I,B)). is_func_graph(f,I)}}"

lemma Pi_iff [rewrite]:
  "f \<in> Pi(I,B) \<longleftrightarrow> (\<exists>P. P \<in> Pow(Sigma(I,B)) \<and> is_func_graph(P,I) \<and> f = Struct({\<langle>source_name, I\<rangle>, \<langle>graph_name, P\<rangle>}))" by auto2
setup {* del_prfstep_thm @{thm Pi_def} *}

lemma Pi_memI [backward]:
  "is_family(f) \<Longrightarrow> source(f) = I \<Longrightarrow> \<forall>a\<in>I. f`a\<in>B(a) \<Longrightarrow> f \<in> Pi(I,B)"
@proof @have "graph(f) \<in> Pow(Sigma(I,B))" @qed

lemma Pi_is_family [forward]: "f \<in> Pi(I,B) \<Longrightarrow> is_family(f) \<and> source(f) = I" by auto2
lemma Pi_memD [typing]: "a \<in> source(f) \<Longrightarrow> f \<in> Pi(I,B) \<Longrightarrow> f`a \<in> B(a)" by auto2

(* Restriction of a family to a subset of the source *)
definition proj_set :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "proj_set(f,J) = Tup(J, \<lambda>a. f`a)"
setup {* register_wellform_data ("proj_set(f,J)", ["J \<subseteq> source(f)"]) *}
setup {* add_prfstep_check_req ("proj_set(f,J)", "J \<subseteq> source(f)") *}

lemma proj_set_is_family:
  "is_family(f) \<Longrightarrow> is_family(proj_set(f,J)) \<and> source(proj_set(f,J)) = J" by auto2
setup {* add_forward_prfstep_cond @{thm proj_set_is_family} [with_term "proj_set(?f,?J)"] *}

lemma proj_set_eval [rewrite]:
  "a \<in> source(proj_set(f,J)) \<Longrightarrow> proj_set(f,J) ` a = f`a" by auto2

setup {* fold del_prfstep_thm [@{thm is_family_def}, @{thm Pi_iff}, @{thm proj_set_def}] *}

section \<open>Functions\<close>

(* A function is a relation where every element in the source corresponds
   to exactly one value in the target. *)
definition is_function :: "i \<Rightarrow> o" where [rewrite]:
  "is_function(f) \<longleftrightarrow> graph(f) \<in> func_graphs(source(f),target(f))"

definition func_form :: "i \<Rightarrow> o" where [rewrite]:
  "func_form(f) \<longleftrightarrow> is_function(f) \<and> is_func_graph(f,{source_name, target_name, graph_name})"

lemma is_function_from_form [forward]: "func_form(f) \<Longrightarrow> is_function(f)" by auto2

(* The set of functions *)
definition function_space :: "i \<Rightarrow> i \<Rightarrow> i" (infixr "\<rightarrow>" 60)  where [rewrite]:
  "A \<rightarrow> B = {Struct({\<langle>source_name,A\<rangle>, \<langle>target_name,B\<rangle>, \<langle>graph_name,G\<rangle>}). G\<in>func_graphs(A,B)}"

lemma function_spaceD [forward]:
  "f \<in> A \<rightarrow> B \<Longrightarrow> func_form(f) \<and> source(f) = A \<and> target(f) = B" by auto2

lemma function_spaceI [typing]:
  "func_form(f) \<Longrightarrow> f \<in> source(f) \<rightarrow> target(f)" by auto2

(* Constructor for functions *)
definition Fun :: "[i, i, i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "Fun(A,B,b) = Struct({\<langle>source_name,A\<rangle>, \<langle>target_name,B\<rangle>, \<langle>graph_name, {p\<in>A\<times>B. snd(p) = b(fst(p))}\<rangle>})"
setup {* add_prfstep_check_req ("Fun(A,B,b)", "Fun(A,B,b) \<in> A \<rightarrow> B") *}

lemma lambda_is_function [backward]:
  "\<forall>x\<in>A. f(x)\<in>B \<Longrightarrow> Fun(A,B,f) \<in> A \<rightarrow> B"
@proof
  @let "G = {p\<in>A\<times>B. snd(p) = f(fst(p))}"
  @have "is_graph(G)"
  @have "\<forall>x. x \<in> gr_source(G) \<longleftrightarrow> x \<in> A" @with
    @case "x \<in> gr_source(G)" @with @obtain y where "\<langle>x,y\<rangle> \<in> G" @end
    @case "x \<in> A" @with @have "\<langle>x, f(x)\<rangle> \<in> G" @end
  @end
  @have "G \<in> func_graphs(A,B)"
@qed

(* Function evaluation *)
lemma beta [rewrite]:
  "F = Fun(A,B,f) \<Longrightarrow> x \<in> source(F) \<Longrightarrow> is_function(F) \<Longrightarrow> F`x = f(x)" by auto2

lemma feval_in_range [typing]:
  "is_function(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f`x \<in> target(f)" by auto2

(* Equality between functions *)
lemma function_eq [backward]:
  "func_form(f) \<Longrightarrow> func_form(g) \<Longrightarrow> source(f) = source(g) \<Longrightarrow> target(f) = target(g) \<Longrightarrow>
   \<forall>x\<in>source(f). f`x = g`x \<Longrightarrow> f = g"
@proof @have "\<forall>a\<in>source(f). graph_eval(graph(f),a) = graph_eval(graph(g),a)" @qed
setup {* fold del_prfstep_thm [
  @{thm is_function_def}, @{thm Fun_def}, @{thm func_form_def}, @{thm function_space_def}, @{thm feval_def}] *}
setup {* add_rewrite_rule_back @{thm feval_def} *}

(* A small exercise *)
lemma lam_eq_self: "f \<in> A \<rightarrow> B \<Longrightarrow> f = Fun(A,B, \<lambda>x. f`x)" by auto2

section \<open>Carrier of a structure\<close>

(* Underlying set of a structure. *)
definition "carrier_name = \<emptyset>"
definition "carrier(S) = graph_eval(S, carrier_name)"
setup {* add_field_data (@{term carrier_name}, @{term carrier}) *}

setup {* add_property_field_const @{term carrier} *}

abbreviation mem_carrier :: "[i, i] \<Rightarrow> o" (infix "\<in>." 50) where
  "x \<in>. S \<equiv> x \<in> carrier(S)"

abbreviation Ball_carrier :: "[i, i \<Rightarrow> o] \<Rightarrow> o" where "Ball_carrier(S, P) \<equiv> Ball(carrier(S), P)"
abbreviation Bex_carrier :: "[i, i \<Rightarrow> o] \<Rightarrow> o" where "Bex_carrier(S, P) \<equiv> Bex(carrier(S), P)"
abbreviation Collect_carrier :: "[i, i \<Rightarrow> o] \<Rightarrow> i" where "Collect_carrier(S, P) \<equiv> Collect(carrier(S), P)"
abbreviation RepFun_carrier :: "[i, i \<Rightarrow> i] \<Rightarrow> i" where "RepFun_carrier(S, f) \<equiv> RepFun(carrier(S), f)"
abbreviation UnionS_carrier :: "[i, i \<Rightarrow> i] \<Rightarrow> i" where "UnionS_carrier(S, X) \<equiv> UnionS(carrier(S), X)"
abbreviation InterS_carrier :: "[i, i \<Rightarrow> i] \<Rightarrow> i" where "InterS_carrier(S, X) \<equiv> InterS(carrier(S), X)"

syntax
  "_Ball_carrier" :: "[pttrn, i, o] \<Rightarrow> o"  ("(3\<forall>_\<in>._./ _)" 10)
  "_Bex_carrier" :: "[pttrn, i, o] \<Rightarrow> o"  ("(3\<exists>_\<in>._./ _)" 10)
  "_Collect_carrier" :: "[pttrn, i, o] \<Rightarrow> i"  ("(1{_ \<in>. _ ./ _})")
  "_RepFun_carrier" :: "[i, pttrn, i] => i"  ("(1{_ ./ _ \<in>. _})" [51,0,51])
  "_UNION_carrier" :: "[pttrn, i, i] => i"  ("(3\<Union>_\<in>._./ _)" 10)
  "_INTER_carrier" :: "[pttrn, i, i] => i"  ("(3\<Inter>_\<in>._./ _)" 10)
translations
  "\<forall>x\<in>.S. P" \<rightleftharpoons> "CONST Ball_carrier(S, \<lambda>x. P)"
  "\<exists>x\<in>.S. P" \<rightleftharpoons> "CONST Bex_carrier(S, \<lambda>x. P)"
  "{x\<in>.S. P}" \<rightleftharpoons> "CONST Collect_carrier(S, \<lambda>x. P)"
  "{b. x\<in>.S}" \<rightleftharpoons> "CONST RepFun_carrier(S, \<lambda>x. b)"
  "\<Union>a\<in>.I. X" == "CONST UnionS_carrier(I, \<lambda>a. X)"
  "\<Inter>a\<in>.I. X" == "CONST InterS_carrier(I, \<lambda>a. X)"

section \<open>Order structures\<close>

definition "order_graph_name = succ(succ(\<emptyset>))"
definition "order_graph(S) = graph_eval(S, order_graph_name)"

setup {* add_field_data (@{term order_graph_name}, @{term order_graph}) *}

(* Evaluation of order *)
definition le :: "[i, i, i] \<Rightarrow> o" where [rewrite_bidir]:
  "le(R,x,y) \<longleftrightarrow> \<langle>x,y\<rangle> \<in> order_graph(R)"
abbreviation le_notation ("(_/ \<le>\<^sub>_ _)" [51,51,51] 50) where "x \<le>\<^sub>R y \<equiv> le(R,x,y)"
setup {* register_wellform_data ("x \<le>\<^sub>R y", ["x \<in>. R", "y \<in>. R"]) *}

abbreviation (input) ge :: "[i, i, i] \<Rightarrow> o" ("(_/ \<ge>\<^sub>_ _)" [51,51,51] 50) where
  "x \<ge>\<^sub>R y \<equiv> y \<le>\<^sub>R x"

(* General result on evaluation of le. *)
lemma le_eval_gen [rewrite]:
  "order_graph(R) = rel_graph(carrier(R),r) \<Longrightarrow> x \<le>\<^sub>R y \<longleftrightarrow> (x \<in>. R \<and> y \<in>. R \<and> r(x,y))" by auto2

(* General predicate on order. *)
definition raworder :: "i \<Rightarrow> o" where [rewrite]:
  "raworder(R) \<longleftrightarrow> order_graph(R) \<in> Pow(carrier(R)\<times>carrier(R))"

lemma raworderD [forward]:
  "raworder(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> x \<in>. R \<and> y \<in>. R"
  "raworder(R) \<Longrightarrow> is_graph(order_graph(R))" by auto2+
setup {* del_prfstep_thm_eqforward @{thm raworder_def} *}

(* Strict predicate on order. *)
definition ord_form :: "i \<Rightarrow> o" where [rewrite]:
  "ord_form(R) \<longleftrightarrow> raworder(R) \<and> is_func_graph(R,{carrier_name,order_graph_name})"

lemma ord_form_to_raw [forward]: "ord_form(R) \<Longrightarrow> raworder(R)" by auto2

(* Space of all order structures on S *)
definition raworder_space :: "i \<Rightarrow> i" where [rewrite]:
  "raworder_space(S) = {Struct({\<langle>carrier_name,S\<rangle>, \<langle>order_graph_name,G\<rangle>}). G\<in>Pow(S\<times>S)}"

lemma raworder_spaceD [forward]:
  "R \<in> raworder_space(S) \<Longrightarrow> ord_form(R) \<and> carrier(R) = S" by auto2

lemma raworder_spaceI [resolve]:
  "ord_form(R) \<Longrightarrow> R \<in> raworder_space(carrier(R))"
@proof @have "R = Struct({\<langle>carrier_name,carrier(R)\<rangle>, \<langle>order_graph_name,order_graph(R)\<rangle>})" @qed

(* Constructor for ordering *)
definition Order :: "i \<Rightarrow> (i \<Rightarrow> i \<Rightarrow> o) \<Rightarrow> i" where [rewrite]:
  "Order(S,R) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>order_graph_name,rel_graph(S,R)\<rangle>})"

lemma Order_is_raworder [typing]: "Order(S,R) \<in> raworder_space(S)" by auto2

lemma Order_eval [rewrite]:
  "le(Order(S,R),x,y) \<longleftrightarrow> (x \<in> S \<and> y \<in> S \<and> R(x,y))" by auto2

(* Equality on ordering *)
definition eq_str_order :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_order(G,H) \<longleftrightarrow> (raworder(G) \<and> raworder(H) \<and> carrier(G) = carrier(H) \<and> (\<forall>x\<in>.G. \<forall>y\<in>.G. x \<le>\<^sub>G y \<longleftrightarrow> x \<le>\<^sub>H y))"

lemma eq_str_orderD1 [forward]: "eq_str_order(G,H) \<Longrightarrow> raworder(G) \<and> raworder(H) \<and> carrier(G) = carrier(H)" by auto2
lemma eq_str_orderD2 [rewrite]: "eq_str_order(G,H) \<Longrightarrow> x \<le>\<^sub>G y \<longleftrightarrow> x \<le>\<^sub>H y" by auto2
lemma eq_str_orderD2' [rewrite]: "eq_str_order(G,H) \<Longrightarrow> order_graph(G) = order_graph(H)" by auto2
lemma eq_str_order_sym [forward]: "eq_str_order(G,H) \<Longrightarrow> eq_str_order(H,G)" by auto2
setup {* del_prfstep_thm_eqforward @{thm eq_str_order_def} *}

lemma order_eq [backward]:
  "ord_form(R) \<Longrightarrow> ord_form(S) \<Longrightarrow> eq_str_order(R,S) \<Longrightarrow> R = S" by auto2

setup {* fold del_prfstep_thm [@{thm ord_form_def}, @{thm raworder_space_def}, @{thm Order_def}, @{thm le_def}] *}
setup {* add_rewrite_rule_back @{thm le_def} *}

end


(*==========================================================================*)
(* Proofs of Properties about Floating Point Arithmetic.                    *)
(*==========================================================================*)

(* Author: Lei Yu, University of Cambridge *)

theory FloatProperty imports IEEE begin

section{* Proofs of Properties about Floating Point Arithmetic *}

lemmas float_defs = Finite_def Infinity_def Iszero_def Isnan_def Val_def Sign_def
                    Isnormal_def Isdenormal_def Fraction_def Exponent_def float_format_def
                    Plus_zero_def Minus_zero_def

subsection{*Theorems derived from definitions*}

lemma sign: "\<And>a. sign a = fst a"
by auto

lemma exponent: "\<And>a. exponent a = fst (snd a)"
by auto

lemma fraction: "\<And>a. fraction a = snd (snd a)"
by auto

lemma is_valid: "\<And>x a. is_valid x a = ((sign a < (2::nat)) \<and> (exponent a < 2^(expwidth x))
                        \<and> (fraction a < 2^(fracwidth x)))"
by (auto simp: is_valid_def emax_def)

lemma is_valid_defloat: "is_valid float_format (Rep_float a)"
  by (cases a) (simp add: Abs_float_inverse)

lemma float_cases: "Isnan a \<or> Infinity a \<or> Isnormal a \<or> Isdenormal a \<or> Iszero a"
  by (cases a) (auto simp: Abs_float_inverse emax_def is_nan_def float_defs
                  is_infinity_def is_normal_def is_denormal_def is_zero_def is_valid_def)

lemma float_cases_finite: "Isnan a \<or> Infinity a \<or> Finite a"
by (cases a) (auto simp: Abs_float_inverse emax_def is_nan_def float_defs
                is_infinity_def is_normal_def is_denormal_def is_zero_def is_valid_def)

lemma float_zero1: "Iszero Plus_zero"
  by (auto simp: float_defs Abs_float_inverse is_zero_def is_valid_def)

lemma float_zero2: "Iszero Minus_zero"
  by (auto simp: float_defs Abs_float_inverse is_zero_def is_valid_def)

lemma is_valid_special: "is_valid x (minus_infinity x)"
                        "is_valid x (plus_infinity x)"
                        "is_valid x (topfloat x)"
                        "is_valid x (bottomfloat x)"
                        "is_valid x (plus_zero x)"
                        "is_valid x (minus_zero x)"
  by (auto simp: emax_def is_valid_def minus_infinity_def plus_infinity_def topfloat_def bottomfloat_def)

lemma sign_0_1: "is_valid x a \<Longrightarrow> sign a < 2"
  by (auto simp: is_valid_def)

(*The types of floating-point numbers are mutually distinct*)
lemma float_distinct: "\<not>(Isnan a \<and> Infinity a)"
                      "\<not>(Isnan a \<and> Isnormal a)"
                      "\<not>(Isnan a \<and> Isdenormal a)"
                      "\<not>(Isnan a \<and> Iszero a)"
                      "\<not>(Infinity a \<and> Isnormal a)"
                      "\<not>(Infinity a \<and> Isdenormal a)"
                      "\<not>(Infinity a \<and> Iszero a)"
                      "\<not>(Isnormal a \<and> Isdenormal a)"
                      "\<not>(Isdenormal a \<and> Iszero a)"
by (auto simp: emax_def float_defs is_nan_def is_infinity_def is_normal_def is_denormal_def is_zero_def)

lemma float_distinct_finite: "\<not>(Isnan a \<and> Finite a)" "\<not>(Infinity a \<and> Finite a)"
  by (auto simp: emax_def float_defs is_nan_def is_infinity_def is_normal_def is_denormal_def is_zero_def)

lemma finite_infinity: "Finite a \<Longrightarrow> \<not> (Infinity a)"
  by (auto simp: emax_def float_defs is_infinity_def is_normal_def is_denormal_def is_zero_def)

(* For every real number, the floating-point numbers closest to it always exist. *)
lemma is_closest_exists:
  fixes v::"representation \<Rightarrow> real" and s::"representation set"
  assumes finite: "finite s"
  assumes non_empty: "s \<noteq> {}"
  shows  "\<exists> a. is_closest v s x a"
using finite non_empty
proof (induct s rule: finite_induct)
  case empty thus ?case by simp
next
  case (insert z s) show ?case
  proof (cases "s = {}")
    case True
    then have "is_closest v (insert z s) x z" by (auto simp: is_closest_def)
      then show ?thesis by metis
  next
    case False
    then obtain a where a: "is_closest v s x a" using insert.hyps by metis
    then show ?thesis
    proof (cases "\<bar>v a - x\<bar>" "\<bar>v z - x\<bar>" rule: le_cases)
      case le then show ?thesis
        by (metis insert_iff a is_closest_def)
    next
      case ge
      have "\<forall>b. b \<in> s \<longrightarrow> \<bar>v a - x\<bar> \<le> \<bar>v b - x\<bar>"
        by (metis a is_closest_def)
      then have "\<forall>b. b \<in> (insert z s) \<longrightarrow> \<bar>v z - x\<bar> \<le> \<bar>v b - x\<bar>"
        by (metis eq_iff ge insert_iff order.trans)
      then show ?thesis using is_closest_def a
        by (metis insertI1)
    qed
  qed
qed

lemma closest_is_everything:
  fixes v::"representation \<Rightarrow> real" and s::"representation set"
  assumes finite: "finite s"
  assumes non_empty: "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x) \<and>
         ((\<exists> b. is_closest v s x b \<and> p b) \<longrightarrow> p (closest v p s x))"
unfolding closest_def
by (rule someI_ex) (metis assms is_closest_exists [of s v x])

lemma closest_in_set:
  fixes v::"representation \<Rightarrow> real"
  assumes "finite s"  "s \<noteq> {}"
  shows "(closest v p s x) \<in> s"
  by (metis assms closest_is_everything is_closest_def)

lemma closest_is_closest:
  fixes v::"representation \<Rightarrow> real"
  assumes "finite s"  "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x)"
by (metis closest_is_everything assms)

lemma float_first_cross:
  "{a::representation. fst a < m \<and> fst (snd a) < n \<and> snd (snd a) < p} =
   image (\<lambda> ((x::nat), (y, z)). (x, y, z)) ({x. x < m} \<times> {y. y < n} \<times> {z. z < p})"
  by auto

lemma finite_r3: "finite {a :: representation. fst a < m \<and> fst (snd a) < n \<and> snd (snd a) < p}"
  by (auto simp: float_first_cross)

lemma is_valid_finite: "finite {a. is_valid x a}"
  by (auto simp: finite_r3 sign exponent fraction is_valid_def)

lemma is_finite_subset: "{a :: representation. is_finite x a} \<subseteq> {a. is_valid x a} "
  by (auto simp: is_finite_def)

lemma match_float_finite:
  assumes "{a :: representation. is_finite x a} \<subseteq> {a. is_valid x a}"
  shows "finite {a. is_finite x a}"
by (metis assms finite_subset is_valid_finite)

lemma is_finite_finite: "finite {a :: representation. is_finite x a}"
  by (metis is_finite_subset match_float_finite)

lemma is_valid_nonempty: "{a::representation. is_valid x a} \<noteq> {}"
  by (metis Collect_empty_eq is_valid_special(2))

lemma is_finite_closest:
  fixes v::"representation \<Rightarrow> real"
  shows "is_finite f (closest v p {a. is_finite f a} x)"
  by (metis closest_in_set is_finite_finite is_finite_nonempty mem_Collect_eq)

lemma is_valid_closest:
  fixes v::"representation \<Rightarrow> real"
  shows "is_valid f (closest v p {a. is_finite f a} x)"
by (metis is_finite_closest is_finite_def)

lemma is_valid_round: "is_valid f (round f To_nearest x)"
proof -
  have "is_valid f (minus_infinity f)"
       "is_valid f (plus_infinity f)"
       "is_valid f (closest (valof f) (\<lambda>a. even (fraction a)) {a. is_finite f a} x)"
    using is_valid_special is_valid_closest by auto
  then have "is_valid f (round f To_nearest x)" by auto
  thus ?thesis by auto
qed

lemma zerosign_valid:
  assumes "is_valid x a"
  shows "is_valid x (zerosign x s a)"
using is_valid_special by (metis assms zerosign_def)

lemma defloat_float_zerosign_round:
       "Rep_float(Abs_float (zerosign float_format s (round float_format To_nearest x))) =
        zerosign float_format s (round float_format To_nearest x)"
  by (metis is_valid_round mem_Collect_eq zerosign_valid Abs_float_inverse)

subsection{*Properties about ordering and bounding*}

(*Lifting of non-exceptional comparisons*)
lemma float_lt [simp]:
  assumes "Finite a" "Finite b"
  shows "(a < b \<longleftrightarrow> Val a < Val b)"
proof
  assume "Val a < Val b"
  moreover have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms by (auto simp: finite_nan finite_infinity)
  ultimately have "fcompare float_format (Rep_float a) (Rep_float b) = Lt"
    by (auto simp add: Infinity_def Isnan_def Val_def fcompare_def)
  then show "a < b" by (auto simp: less_float_def)
next
  assume "a < b"
  then have lt: "fcompare float_format (Rep_float a) (Rep_float b) = Lt"
    by (simp add: less_float_def)
  have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms by (auto simp: finite_nan finite_infinity)
  then show "Val a < Val b"
    using lt assms
    by (simp add: fcompare_def Isnan_def Infinity_def Val_def split: split_if_asm)
qed

lemma float_eq [simp]:
  assumes "Finite a" "Finite b"
  shows "(a \<doteq> b) \<longleftrightarrow> (Val a = Val b)"
proof
  assume "Val a = Val b"
  have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms float_distinct_finite by auto
  then have "fcompare float_format (Rep_float a) (Rep_float b) = Eq"
    using `Val a = Val b`
    by (auto simp add: Infinity_def Isnan_def Val_def fcompare_def)
  then show "a \<doteq> b" by (auto simp: float_eq_def)
next
  assume "a \<doteq> b"
  then have eq: "fcompare float_format (Rep_float a) (Rep_float b) = Eq"
    by (simp add: float_eq_def)
  have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms float_distinct_finite by auto
  then show "Val a = Val b"
    using eq assms
    by (simp add: fcompare_def Isnan_def Infinity_def Val_def split: split_if_asm)
qed

lemma float_le [simp]:
  assumes "Finite a" "Finite b"
  shows "(a \<le> b) \<longleftrightarrow> (Val a \<le> Val b)"
proof -
  have "(a \<le> b) \<longleftrightarrow>  a < b \<or> a \<doteq> b"
    by (auto simp add: less_eq_float_def less_float_def float_eq_def)
  then show ?thesis
    by (auto simp add: assms)
qed

(*Reflexivity of equality for non-NaNs*)
lemma float_eq_refl [simp]: "(a \<doteq> a) \<longleftrightarrow> \<not>(Isnan a)"
  by (auto simp add: Infinity_def Isnan_def Val_def fcompare_def float_eq_def)

(*Properties about Ordering*)
lemma float_lt_trans: "\<lbrakk>Finite a; Finite b; Finite c; a < b; b < c\<rbrakk> \<Longrightarrow> a < c"
  by (auto simp: le_trans)

lemma float_le_less_trans: "\<lbrakk>Finite a; Finite b; Finite c; a \<le> b; b < c\<rbrakk> \<Longrightarrow> a < c"
  by (auto simp: le_trans)

lemma float_le_trans: "\<lbrakk>Finite a; Finite b; Finite c; a \<le> b; b \<le> c\<rbrakk> \<Longrightarrow> a \<le> c"
  by (auto simp: le_trans)

lemma float_le_neg: "Finite a \<Longrightarrow> Finite b \<Longrightarrow> \<not>(a < b) \<longleftrightarrow> b \<le> a"
  by auto

(*Properties about bounding*)
lemma float_le_infinity [simp]: "\<not> Isnan a \<Longrightarrow> a \<le> Plus_infinity"
  by (auto simp: Isnan_def fcompare_def is_nan_def is_infinity_def plus_infinity_def Plus_infinity_def
                 less_eq_float_def Abs_float_inverse emax_def is_valid_def)

lemma valof_topfloat: "valof float_format (topfloat float_format) = largest float_format"
  by (simp add: emax_def float_format_def topfloat_def largest_def)

lemma float_frac_le: "Finite a \<Longrightarrow> (Fraction a) \<le> 2^52 - 1"
  by (cases a) (auto simp: Abs_float_inverse float_defs is_valid_def)

lemma float_exp_le: "Finite a \<Longrightarrow> (Exponent a) \<le> 2046"
  by (cases a) (auto simp: emax_def float_defs is_normal_def is_denormal_def is_zero_def)

lemma float_sign_le: "(-1::real)^(Sign a) = 1 \<or> (-1::real)^(Sign a) = -1"
by (metis neg_one_even_power neg_one_odd_power)

lemma exp_less: "(a::nat) \<le> b \<Longrightarrow> (2::real)^a \<le> 2^b"
  by auto

lemma div_less: "(a::'a::linordered_field_inverse_zero) \<le> b \<and> c > 0 \<Longrightarrow> a/c \<le> b/c"
  by (metis divide_le_cancel less_asym)

lemma finite_topfloat: "Finite Topfloat"
by (auto simp: float_defs Topfloat_def topfloat_def Abs_float_inverse emax_def is_normal_def is_valid_def)

lemma valof_eq: "!!r. valof fmt r =
   (if (exponent r = 0)
    then (-1)^sign r * (2 / (2^bias fmt)) * (real (fraction r)/2^(fracwidth fmt))
    else (-1)^sign r * ((2^exponent r) / (2^bias fmt)) * (1 + real (fraction r)/2^fracwidth fmt))"
by auto

lemma float_le_topfloat:
  assumes "Finite a" shows "a \<le> Topfloat"
proof -
  have vt: "valof float_format (topfloat float_format) =
        ((2^2046) / (2^bias float_format)) * (1 + (2^52 - 1)/2^fracwidth float_format)"
    by (auto simp: emax_def float_format_def topfloat_def)
  have frale: "(Fraction a) \<le> 2^52 - 1" by (rule float_frac_le [OF assms])
  moreover have exple: "(Exponent a) \<le> 2046" using assms by (rule float_exp_le)
  ultimately have "Fraction a/2^(fracwidth float_format) \<le> (2^52 - 1)/2^(fracwidth float_format)"
    by (auto simp: float_format_def)
  then have "(2 / (2^bias float_format)) * (Fraction a/2^(fracwidth float_format)) \<le>
             (2 / (2^bias float_format)) * ((2^52 - 1)/2^(fracwidth float_format))"
    by (auto simp: float_format_def bias_def)
  then have ineq: "0 < 1 + Fraction a/2^fracwidth float_format"
          "(1 + Fraction a/2^fracwidth float_format) \<le> 1 + (2^52 - 1)/2^fracwidth float_format"
    by (auto simp: float_format_def bias_def)
  then have "0 < (2::real)^Exponent a / (2^bias float_format)"
    by (metis zero_less_divide_iff zero_less_numeral zero_less_power)
  then have gt0: "0 < (2^Exponent a / 2^bias float_format) * (1 + Fraction a/2^fracwidth float_format)"
    using ineq by (metis zero_less_mult_iff)
  moreover
  have "(2::real)^Exponent a / (2^bias float_format) \<le> (2^2046) / (2^bias float_format)"
    by (metis exple exp_less div_less zero_less_numeral zero_less_power)
  ultimately have
      "(2^Exponent a / 2^bias float_format) * (1 + Fraction a/2^fracwidth float_format) \<le>
       valof float_format (topfloat float_format)"
    by (metis vt ineq divide_zero_left pos_divide_less_eq mult_mono' less_eq_real_def)
  then have "1 * (2^Exponent a / 2^bias float_format) * (1 + Fraction a / 2^fracwidth float_format) \<le>
                valof float_format (topfloat float_format)"
            "-1* (2^Exponent a / 2^bias float_format) * (1 + Fraction a / 2^fracwidth float_format) \<le>
                valof float_format (topfloat float_format)"
    using gt0 by auto
  then have nzexp: --{*nonzero exponent case*}
    "(-1)^(Sign a) * (2^Exponent a / 2^bias float_format) *
     (1 + Fraction a/2^fracwidth float_format) \<le> valof float_format (topfloat float_format)"
    by (metis float_sign_le)
  have "-1* (2 / (2^bias float_format)) * (Fraction a/2^(fracwidth float_format)) \<le> valof float_format (topfloat float_format)"
       "1 * (2 / (2^bias float_format)) * (Fraction a/2^(fracwidth float_format)) \<le> valof float_format (topfloat float_format)"
    using frale vt by (auto simp: float_format_def bias_def)
  then have  --{*zero exponent case*}
      "(-1)^(Sign a)*(2 / (2^bias float_format)) * (Fraction a/2^(fracwidth float_format)) \<le>
         valof float_format (topfloat float_format)"
    by (metis float_sign_le)
  then have "Val a \<le> Val Topfloat"
    using nzexp by (cases a) (auto simp: float_defs Abs_float_inverse Topfloat_def is_valid_special)
  thus ?thesis
    by (metis assms finite_topfloat float_le)
qed

lemma topfloat_eq_largest: "Val Topfloat = largest float_format"
proof -
  have "Val Topfloat = valof float_format (topfloat float_format)"
      by (simp add: Abs_float_inverse Topfloat_def is_valid_special Val_def)
  also have "... = largest float_format"
    by (simp add: emax_def largest_def float_format_def topfloat_def)
  finally show ?thesis .
qed

lemma float_val_le_largest:
  assumes "Finite a"
  shows "Val a \<le> largest float_format"
by (metis assms finite_topfloat float_le float_le_topfloat topfloat_eq_largest)

lemma float_val_lt_threshold:
  assumes "Finite a"
  shows "Val a < threshold float_format"
proof -
  have "Val a \<le> largest float_format"
    by (rule float_val_le_largest [OF assms])
  also have "... < threshold float_format"
    by (auto simp: float_format_def largest_def threshold_def bias_def)
  finally show ?thesis .
qed

subsection{*Algebraic properties about basic arithmetic*}

(*Commutativity of addition*)
lemma
  assumes "Finite a" "Finite b"
    shows float_plus_comm_eq: "a + b = b + a"
      and float_plus_comm: "Finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
proof -
  have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms by (auto simp: finite_nan finite_infinity)
  then show "a + b = b + a"
    by (simp add: float_defs fadd_def plus_float_def add.commute)
  then show "Finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
    by (metis float_eq)
qed

(*Showing --(-- a) = a*)
lemma sign_double_neg [simp]: assumes "is_valid x a" shows "(1 - (1 - sign a)) = sign a"
proof -
  have "sign a < 2" using assms
    by (auto simp: is_valid_def)
  then show "(1 - (1 - sign a)) = sign a" by auto
qed

lemma float_double_neg_eq [simp]:
  assumes "\<not>Isnan a" shows "float_neg (float_neg a) = a"
proof -
  have isv: "is_valid float_format ((1 - (Sign a), Exponent a, Fraction a))"
    by (cases a) (auto simp: float_defs Abs_float_inverse is_valid_def)
  have "float_neg (float_neg a) =
    Abs_float (fneg float_format To_nearest
               (Rep_float (Abs_float (1 - (Sign a), Exponent a, Fraction a))))"
    by (simp add: float_defs float_neg_def fneg_def)
  also have "... =  Abs_float (fneg float_format To_nearest (1 - (Sign a), Exponent a, Fraction a))"
    using isv by (simp add: Abs_float_inverse)
  also have "... = Abs_float (1 - (1 - (Sign a)), Exponent a, Fraction a)"
    by (auto simp: fneg_def)
  also have "... = Abs_float ((Sign a), Exponent a, Fraction a)"
    by (metis Sign_def is_valid_defloat sign_double_neg)
  finally show "float_neg (float_neg a) = a"
    by (simp add: float_defs) (metis Rep_float_inverse exponent.elims fraction.simps sign.simps)
qed

lemma float_double_neg [simp]: "\<not>Isnan a \<Longrightarrow> float_neg (float_neg a) \<doteq> a"
  by auto

(* The floating-point number a falls into the same category as the negation of a *)
lemma neg_zero: "is_zero x a \<longleftrightarrow> is_zero x (fneg x m a)"
  by (auto simp: fneg_def is_zero_def)

lemma float_neg_zero [simp]: "Iszero (float_neg a) = Iszero a"
proof -
  have isv: "is_valid float_format ((1 - (Sign a), Exponent a, Fraction a))"
    by (cases a) (auto simp: float_defs Abs_float_inverse is_valid_def)
  have "Iszero (float_neg a) = Iszero (Abs_float (fneg float_format To_nearest (Rep_float a)))"
    by (auto simp: Iszero_def float_neg_def)
  also have "... = is_zero float_format (fneg float_format To_nearest (Rep_float a))"
    using isv by (auto simp: float_defs Abs_float_inverse fneg_def)
  also have "... = Iszero a" by (metis Iszero_def neg_zero)
  finally show ?thesis
    by metis
qed

lemma neg_infinity [simp]: "is_infinity x (fneg x m a) = is_infinity x a"
  by (auto simp: fneg_def is_infinity_def)

lemma neg_normal [simp]: "is_normal x (fneg x m a) = is_normal x a"
  by (auto simp: fneg_def is_normal_def)

lemma float_neg_normal [simp]: "Isnormal (float_neg a) = Isnormal a"
proof -
  have "is_valid float_format ((1 - (Sign a), Exponent a, Fraction a))"
    by (cases a) (auto simp: float_defs Abs_float_inverse is_valid_def)
  then have "Isnormal (float_neg a) =
             is_normal float_format (fneg float_format To_nearest (Rep_float a))"
     by (auto simp: Abs_float_inverse float_defs fneg_def float_neg_def)
  also have "... = Isnormal a"
    by (metis Isnormal_def neg_normal)
  finally show ?thesis .
qed

lemma neg_denormal [simp]: "is_denormal x (fneg x m a) = is_denormal x a"
  by (auto simp: fneg_def is_denormal_def)

lemma float_neg_denormal [simp]: "Isdenormal (float_neg a) = Isdenormal a"
proof -
  have "is_valid float_format ((1 - (Sign a), Exponent a, Fraction a))"
    by (cases a) (auto simp: float_defs Abs_float_inverse is_valid_def)
  then have "Isdenormal (Abs_float (fneg float_format To_nearest (Rep_float a))) =
             is_denormal float_format (fneg float_format To_nearest (Rep_float a))"
    by (auto simp: float_defs Abs_float_inverse fneg_def)
  also have "... = Isdenormal a"
    by (metis Isdenormal_def neg_denormal)
  finally show ?thesis
    by (simp add: float_neg_def)
qed

lemma neg_valid: "is_valid x a \<Longrightarrow> is_valid x (fneg x m a)"
  by (auto simp: fneg_def is_valid_def)

lemma neg_finite: "is_finite x a \<Longrightarrow> is_finite x (fneg x m a) "
  by (metis is_finite_def neg_denormal neg_normal neg_valid neg_zero)

lemma float_neg_finite: "Finite a \<Longrightarrow> Finite (float_neg a)"
  by (metis Finite_def float_neg_denormal float_neg_normal float_neg_zero)

(* The sign of a and the sign of a's negation is different *)
lemma float_neg_sign: "(Sign a) \<noteq> (Sign (float_neg a))"
proof -
  have "(Sign a) < 2"
    by (metis Sign_def is_valid_defloat sign_0_1)
  moreover have "(Sign a) = 0 \<Longrightarrow> (Sign (float_neg a)) = 1"
    by (cases a) (auto simp: Sign_def fneg_def float_neg_def Abs_float_inverse is_valid_def)
  moreover have "(Sign a) = 1 \<Longrightarrow> (Sign (float_neg a)) = 0"
    by (cases a) (auto simp: Sign_def fneg_def float_neg_def Abs_float_inverse is_valid_def)
  ultimately show ?thesis
    by (metis One_nat_def less_2_cases zero_neq_one)
qed

lemma neg_val:
  assumes "is_finite float_format a"
  shows "valof float_format (fneg float_format m a) = - valof float_format a" (is "?L = ?R")
proof -
  have A: "?L = valof float_format (sign (fneg float_format m a),
               exponent (fneg float_format m a), fraction (fneg float_format m a))"
    by (metis exponent.simps fneg_def fraction.simps sign.simps)
  also have "... = valof float_format (1 - sign a, exponent a, fraction a)"
    by (metis calculation fneg_def)
  finally have Leq: "?L = valof float_format (1 - sign a, exponent a, fraction a)" .
  have C: "sign a = 0 \<longleftrightarrow> 1 - (sign a) = 1" by auto
  have D: "sign a = 1 \<longleftrightarrow> 1 - (sign a) = 0" using sign_0_1 assms
    by (auto simp: is_valid_def is_finite_def)
  then have "valof float_format (0, exponent a, fraction a) =
    -valof float_format (1, exponent a, fraction a)"
    by auto
  then show "?thesis" using A C D Leq
    by (metis diff_0_right exponent.simps fraction.cases fraction.simps
      less_one minus_diff_eq neq0_conv sign.simps zero_less_diff)
qed

lemma float_neg_val:
  assumes "Finite b"
    shows "(Val (float_neg b)) = - (Val b)"
proof -
  have "Val (float_neg b) =
    valof float_format ((Sign (float_neg b)),(Exponent (float_neg b)), (Fraction (float_neg b)))"
    unfolding float_defs
    by (metis PairE exponent.simps fraction.simps sign.simps)
  also have "... = valof float_format ((1 - (Sign b), Exponent b, Fraction b))"
    using float_neg_def fneg_def Abs_float_inverse
    by (cases b) (auto simp: float_defs is_valid_def)
  finally have Vb: "Val (float_neg b) =
                    valof float_format ((1 - (Sign b), Exponent b, Fraction b))" .
  have C: "(Val b) = valof float_format (((Sign b), Exponent b, Fraction b))"
    unfolding float_defs
    by (metis exponent.simps fraction.simps prod.exhaust sign.simps)
  thus ?thesis using assms Vb C
    unfolding Val_def Exponent_def Finite_def Fraction_def Isdenormal_def Isnormal_def Iszero_def Sign_def
    by (metis fneg_def is_finite_def is_valid_defloat neg_val)
qed

(* Showing  a + (-b) = a - b *)
lemma float_neg_add:
   "Finite a \<Longrightarrow> Finite b \<Longrightarrow> Finite (a - b) \<Longrightarrow> Val a + Val (float_neg b) = Val a - Val b"
by (metis comm_ring_1_class.normalizing_ring_rules(2) float_neg_val)

lemma float_plus_minus:
  assumes "Finite a" "Finite b" "Finite (a - b)" shows "(a + float_neg b) \<doteq> (a - b)"
proof -
  have nab: "\<not>(Isnan a)" "\<not>(Isnan (float_neg b))" "\<not>(Infinity a)" "\<not>(Infinity (float_neg  b))"
    using assms
    by (auto simp: finite_nan finite_infinity float_neg_finite)
  have "(a - b) =
        Abs_float (zerosign float_format
                   (if Iszero a \<and> Iszero b \<and> Sign a \<noteq> Sign b then (Sign a) else 0)
                   (round float_format To_nearest (Val a - Val b)))"
        using assms finite_infinity finite_nan
        by (simp add: fsub_def minus_float_def float_defs [symmetric])
  also have "... =
        Abs_float (zerosign float_format
                   (if Iszero a \<and> Iszero (float_neg b) \<and> Sign a = Sign (float_neg b) then Sign a else 0)
                   (round float_format To_nearest (Val a + Val (float_neg b))))"
    using assms
    by (simp add: float_neg_sign1 float_neg_add)
  also have "... = (a + float_neg b)"
    using nab
    by (auto simp: float_defs fadd_def plus_float_def)
  finally show ?thesis using assms
    by (metis float_eq)
qed

lemma bottomfloat_eq_m_largest: "Val Bottomfloat = - largest float_format"
proof -
  have "Val Bottomfloat = valof float_format (bottomfloat float_format)"
      by (simp add: Abs_float_inverse Bottomfloat_def is_valid_special Val_def)
  also have "... = - largest float_format"
    by (simp add: emax_def largest_def float_format_def bottomfloat_def)
  finally show ?thesis .
qed

lemma Bottomfloat_m_Topfloat: "Val Bottomfloat = - Val Topfloat"
  by (metis bottomfloat_eq_m_largest topfloat_eq_largest)

lemma float_val_ge_bottomfloat:  "Finite a \<Longrightarrow> Val a \<ge> Val Bottomfloat"
  by (metis Bottomfloat_m_Topfloat float_neg_finite float_neg_val float_val_le_largest minus_minus
            neg_le_iff_le topfloat_eq_largest)

lemma finite_Bottomfloat: "Finite Bottomfloat"
  by (auto simp: float_defs Bottomfloat_def bottomfloat_def Abs_float_inverse
                 emax_def is_normal_def is_valid_def)

lemma float_ge_bottomfloat: "Finite a \<Longrightarrow> a \<ge> Bottomfloat"
  by (metis finite_Bottomfloat float_le float_val_ge_bottomfloat)

lemma sign_Rep_Topfloat [simp]: "sign (Rep_float Topfloat) = 0"
using is_valid_special
by (auto simp add: Abs_float_inverse Topfloat_def topfloat_def)

lemma exponent_Rep_Topfloat [simp]: "exponent (Rep_float Topfloat) = emax float_format - Suc 0"
using is_valid_special
by (auto simp add: Abs_float_inverse Topfloat_def topfloat_def)

lemma fraction_Rep_Topfloat [simp]: "fraction (Rep_float Topfloat) = 2 ^ fracwidth float_format - Suc 0"
using is_valid_special
by (auto simp add: Abs_float_inverse Topfloat_def topfloat_def)

lemma Bottomfloat_fneg_Topfloat: "Bottomfloat = float_neg Topfloat"
using is_valid_special
by (auto simp add: Abs_float_inject float_neg_def fneg_def Bottomfloat_def bottomfloat_def)

lemma float_val_ge_largest:
  assumes "Finite a"
  shows "Val a \<ge> -largest float_format"
proof -
  have "Val Bottomfloat = valof float_format (bottomfloat float_format)"
    using Bottomfloat_def Abs_float_inverse is_valid_special
    by (metis (full_types) Val_def mem_Collect_eq)
  also have "... = -largest float_format"
    by (auto simp: emax_def bias_def bottomfloat_def float_format_def largest_def)
  finally have "Val Bottomfloat = -largest float_format" .
  thus ?thesis
    using float_val_ge_bottomfloat by (metis assms)
qed

lemma float_val_gt_threshold:
  assumes "Finite a"
  shows "Val a > - threshold float_format"
proof -
  have largest: "Val a \<ge> -largest float_format" using float_val_ge_bottomfloat assms
    by (metis float_val_ge_largest)
  then have "-largest float_format > -(threshold float_format)"
    by (auto simp: bias_def threshold_def float_format_def largest_def)
  then show ?thesis
    by (metis largest less_le_trans)
qed

(* Showing abs (-a) = abs (a) *)
lemma float_abs [simp]: "\<not>Isnan a \<Longrightarrow> float_abs (float_neg a) = float_abs a"
  by (cases a) (auto simp: float_abs_def float_neg_def fneg_def Abs_float_inverse is_valid_def)

lemma neg_zerosign: "fneg x m (zerosign x s a) = zerosign x (1-s) (fneg x m a)"
  by (auto simp: fneg_def zerosign_def is_zero_def is_valid_def)

lemma finite_valid: "is_finite x a \<Longrightarrow> is_valid x a"
  by (cases a) (metis is_finite_def)

end


theory Mergeable imports Pord

begin

(* Mergeable is a complete partial order where for all pairs of elements a and b,
 * bsup a b (written [^ a, b ^]) is guaranteed to exist (it really, really should also
 * be computable, since we use this for code generation)
 *)
class Mergeable =
  Pordc +
  fixes bsup :: "('a :: Pordc) \<Rightarrow> 'a \<Rightarrow> 'a" ("[^ _, _ ^]")
assumes bsup_spec :
  "\<And> a b . is_bsup a b (bsup a b)"

(* Utility lemmas for reasoning directly about [^ a, b ^] rather than the
 * predicate version bsup a b
 *)
lemma bsup_comm :
  fixes a b :: "'a :: Mergeable"
  assumes H : "has_sup {a, b}"
  shows "bsup a b = bsup b a"
proof -
  obtain x where  0 : "is_sup {a, b} x" using H
    by (auto simp add:is_sup_def has_sup_def)
  have 1 : "is_sup {a, b} (bsup a b)" using bsup_sup[OF 0 bsup_spec[of a b]]
    by auto
  hence 3 : "bsup a b = x " using 0 1
    by(auto simp add:is_sup_def is_least_unique)
  from H have 4: "has_sup {b, a}"
    by(auto simp add: has_sup_def elim:is_sup_comm2)
  hence 5: "is_sup {b, a} x" using 0
    by(auto simp add: has_sup_def is_sup_unique elim:is_sup_comm2[of a b x])
  have 6 : "is_sup {b, a} (bsup b a)" using bsup_sup[OF 5 bsup_spec[of b a]]
    by auto

  have 7 : "bsup b a = x" using 5 and 6
    by(auto simp add:is_sup_unique)
  show ?thesis using 7 and 3 by auto
qed

(* Bsup admits a very limited notion of what we might call associativity (but only if we stretch
 * the meaning of the term). This holds in general, regardless of completeness.
 *)
lemma bsup_assoc_fact1 :
  fixes a b c :: "'a :: Mergeable"
  shows "bsup a (bsup b c) = (bsup (bsup a b) (bsup b c))"
proof(-)
  have 0:  "pleq a (bsup a b)" using
        bsup_leq[OF bsup_spec [of "a" "b"]]
    by(simp add:bsup_leq)
  have 1:  "pleq b (bsup b c)" using bsup_leq[OF bsup_spec[of b c]]
    by(auto)
  have 2 : "pleq (bsup a b) (bsup a (bsup b c))"
    using bsup_mono2[OF 1 bsup_spec[of a b] bsup_spec[of a "bsup b c"]] by auto

  have LtoR : "pleq (bsup a (bsup b c)) (bsup (bsup a b) (bsup b c))"
    using bsup_compare1[OF bsup_spec bsup_spec 0 2] by auto

  have RtoL : "pleq (bsup (bsup a b) (bsup b c)) (bsup a (bsup b c))"
    using bsup_compare2[OF bsup_spec bsup_spec 0 2] by auto

  thus ?thesis using leq_antisym[OF LtoR RtoL] by auto
qed

lemma bsup_assoc_fact2 :
  fixes a b c :: "'a :: Mergeable"
  shows "pleq (bsup (bsup a b) c) (bsup (bsup a b) (bsup a c))"
proof(-)
  have 0 : "pleq (bsup a b) (bsup a b)" using leq_refl by auto

  have 1 : "pleq (bsup a b) (bsup (bsup a b) c)" using bsup_leq bsup_spec
    by blast

  have 2 : "pleq (bsup a b) (bsup (bsup a b) (bsup a c))" using bsup_leq bsup_spec
    by blast

  have 3 : "(\<And>bd sd. pleq bd (c) \<Longrightarrow> is_sup {(bsup a b), bd} sd \<Longrightarrow> pleq bd ((bsup a c)))"
  proof(-)
    fix bd sd
    assume Hpleq : "pleq bd (c)"
    assume Hsup : "is_sup {(bsup a b), bd} sd"

    have in1 : "has_sup {(bsup a b), bd}" using Hsup by (auto simp add:has_sup_def)
    have in2 : "pleq (a) ((bsup a b))" using bsup_leq bsup_spec by blast
    have in3 : "has_sup {a, bd}" using leq_completion[OF in2 Hsup] by auto
    then obtain sd' where Hsd : "is_sup {a, bd} sd'"
      by (auto simp add:has_sup_def)

    have in4 : "pleq sd' ((bsup a c))" using Hsd Hpleq bsup_spec[of a c]
      by(auto simp add: is_bsup_def is_least_def is_bub_def)

    have in5 : "pleq bd sd'" using Hsd by (simp add:is_sup_def is_ub_def is_least_def)

    show "pleq bd ((bsup a c))" using leq_trans[OF in5 in4] by auto
  qed

  thus ?thesis using bsup_compare1[OF bsup_spec bsup_spec 0 1 3] by auto
qed

(* If a true supremum exists for a and b (but not necessarily c), we can say a bit
 * more about [^ [^ a, b ^], c ^] etc.
*)

lemma sup_assoc1 :
  fixes a b c :: "'a :: Mergeable"
  assumes Hsup : "has_sup {a, b}"
  shows "bsup (bsup a b) c = bsup (bsup b a) c"
  using bsup_comm[OF Hsup] by auto

lemma sup_assoc_lb1 :
  fixes a b c :: "'a :: Mergeable"
  assumes Hsup : "has_sup {a, b}"
  shows "pleq (bsup (bsup a b) c) (bsup a (bsup b c))"
proof(-)
  have 0 : "bsup (bsup a b) c = bsup (bsup b a) c"
    using bsup_comm[OF Hsup]  by auto

  have 1 : "pleq (bsup (bsup b a) c) (bsup (bsup b a) (bsup b c))"
    using bsup_assoc_fact2 by auto

  have 3 : "bsup (bsup b a) (bsup b c) = bsup (bsup a b) (bsup b c)"
    using bsup_comm[OF Hsup] by auto

  have 4 : "bsup (bsup a b) (bsup b c) = bsup a (bsup b c)"
    using bsup_assoc_fact1[of a b c]
    by auto

  show ?thesis using 0 1 3 4 by auto
qed

lemma sup_assoc_2 :
  fixes a b c :: "'a :: Mergeable"
  assumes Hsup : "has_sup {a, b}"
  shows "pleq (bsup (bsup a b) c) (bsup b (bsup a c))"
proof(-)

  have 1 : "pleq (bsup (bsup a b) c) (bsup (bsup a b) (bsup a c))"
    using bsup_assoc_fact2 by auto

  have 2 : "bsup (bsup a b) (bsup a c) = bsup (bsup b a) (bsup a c)"
    using bsup_comm[OF Hsup] by auto

  have 3 : "bsup (bsup b a) (bsup a c) = bsup b (bsup a c)"
    using bsup_assoc_fact1[of b a c] by auto

  show ?thesis using 1 2 3 by auto

qed

class Mergeableb = Mergeable +
  Pordbc

class Mergeableps = Mergeable +
  Pordpsc

class Mergeablebps = Mergeableb +
  Pordpsc

end


theory Second
  imports Complex_Main
begin

text \<open>
  Second task :

  https://www.imo-official.org/problems/IMO2009SL.pdf , problem A2
------------------------------------------------------------------
  Let a, b, c be positive real numbers such that 1/a + 1/b + 1/c = a + b + c. Prove that:

          1                   1                     1           3
    --------------   +  --------------   +   --------------  \<le> ---
    (2a + b + c)^2      (2b + c + a)^2       (2c + a + b)^2     16
------------------------------------------------------------------
  Idea for solving :

    - using AM_GM_2 and inequality_1  we can transform left side to :
      1/2 * expression

    - expression = fraction_1 * fraction_2 * fraction_3. Using lemmas
      L1, L2, L3 in LF we get that expression \<le> 3/8 and then we have
      left side \<le> 1/2 * 3/8 = 3/16
\<close>

(* AM–GM inequality for two numbers *)
lemma AM_GM_2 [simp]:
  fixes x y :: real
  assumes "x \<ge> 0" "y \<ge> 0"
  shows "(x + y)/ 2 \<ge> sqrt(x*y)"
  using assms
  using arith_geo_mean_sqrt
  by blast

(* Inequality used in first part
    (left side transformation)   *)
lemma inequality_1 [simp]:
  fixes x y z :: real
  assumes "x > 0" "y > 0" "z > 0"
  shows "1/((2*x + y + z)^2) \<le>  1/(4*(x + y)*(x + z))"
proof-

  have "2 * sqrt ((x + y)*(x + z)) \<le> (x + y) + (x + z)"
    using AM_GM_2 [of "x + y" "x + z"]
    using assms(1) assms(2) assms(3)
    by simp
  also have "... = 2*x + y + z"
    by simp
  finally have 1 : "2 * sqrt ((x + y)*(x + z)) \<le> 2*x + y + z"
    by simp

  have "(2*x + y + z)^2 \<ge> (2*sqrt((x + y)*(x + z)))^2"
    using assms(1) assms(2) assms(3)
    using 1
    by (smt (verit, ccfv_SIG) power_mono real_sqrt_ge_0_iff zero_le_mult_iff)
  then have "(2*x + y + z)^2 \<ge> 4*(x + y)*(x + z)"
    using assms(1) assms(2) assms(3)
    by (simp add: distrib_right)
  then have "1/((2*x + y + z)^2) \<le>  1/(4*(x + y)*(x + z))"
    using assms
    by (smt frac_le mult_pos_pos)
  then show ?thesis
    .
qed

(* This inequality will be used in lemma L1
       (before using, we must prove it)     *)
lemma inequality_L1 [simp]:
  fixes x y z :: real
  assumes  "x > 0" "y>0" "z > 0"
  shows "x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y \<ge> 6*x*y*z"
proof-

  have "z*(x - y)^2 + x*(y - z)^2 + y*(z - x)^2 \<ge> 0"
    using assms(1) assms(2) assms(3)
    by simp
  then have "z*(x^2 - 2*x*y + y^2) + x*(y^2 - 2*y*z + z^2) + y*(z^2 - 2*z*x + x^2) \<ge> 0"
    by (simp add: diff_add_eq power2_diff)
  then have "z*x^2 - z*2*x*y + z*y^2 + x*(y^2 - 2*y*z + z^2) + y*(z^2 - 2*z*x + x^2) \<ge> 0"
    by (simp add: diff_le_eq distrib_left right_diff_distrib')
  then have "z*x^2 - z*2*x*y + z*y^2 + x*y^2 - x*2*y*z + x*z^2 + y*(z^2 - 2*z*x + x^2) \<ge> 0"
    by (simp add: diff_le_eq distrib_left right_diff_distrib')
  then have "z*x^2 - z*2*x*y + z*y^2 + x*y^2 - x*2*y*z + x*z^2 + y*z^2 - y*2*z*x + y*x^2 \<ge> 0"
    by (simp add: diff_le_eq distrib_left right_diff_distrib')
  then have "x^2*z - 2*x*y*z + y^2*z + y^2*x - 2*x*y*z + z^2*x + z^2*y - 2*x*y*z + x^2*y \<ge> 0"
    by (simp add: mult.commute)
  then have "x^2*z + y^2*z + y^2*x + z^2*x + z^2*y + x^2*y - 6*x*y*z \<ge> 0"
    by simp
  then show ?thesis
    by simp
qed

(* Key lemma used in final lemma LF *)
lemma L1 [simp]:
 fixes x y z :: real
 assumes  "x > 0" "y>0" "z > 0"
 assumes "x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y \<ge> 6*x*y*z"
 shows "((x + y + z)*(x*y + y*z + z*x))/((x + y)*(y + z)*(z + x)) \<le> 9/8"
proof-

  have "x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y \<ge> 6*x*y*z"
    using assms(4)
    by simp
  then have "(9-8)*(x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y) \<ge> (24-18)*(x*y*z)"
    by simp
  then have "9*(x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y) - 8 *(x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y)
          \<ge> 24*x*y*z - 18*x*y*z"
    by (simp add: mult.commute mult.left_commute)
  then have "9*(x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y) + 18*x*y*z \<ge> 24*x*y*z + 8 *(x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y)"
    by simp
  then have "9*(x^2*y + x^2*z + y^2*x + y^2*z + z^2*x + z^2*y) + 18*x*y*z \<ge> 24*x*y*z + 8*x^2*y + 8*x^2*z + 8*y^2*x + 8*y^2*z + 8*z^2*x + 8*z^2*y"
    by simp
  then have "9*x^2*y + 9*x^2*z + 9*y^2*x + 9*y^2*z + 9*z^2*x + 9*z^2*y + 18*x*y*z \<ge> 24*x*y*z + 8*x^2*y + 8*x^2*z + 8*y^2*x + 8*y^2*z + 8*z^2*x + 8*z^2*y"
    by simp
  then have "9*x^2*y + 9*x^2*z + 9*y^2*x + 9*y^2*z + 9*z^2*x + 9*z^2*y + 18*x*y*z \<ge>  8*x^2*y + 8*x*y*z + 8*x^2*z + 8*y^2*x + 8*y^2*z + 8*x*y*z + 8*x*y*z + 8*z^2*x + 8*z^2*y"
    by simp
  then have "9*x^2*y + 9*x^2*z + 9*y^2*x + 9*y^2*z + 9*z^2*x + 9*z^2*y + 18*x*y*z \<ge> (8*x + 8*y + 8*z)*(x*y + y*z + z*x)"
    by (simp add: add.commute add.left_commute distrib_left mult.commute mult.left_commute power2_eq_square)
  then have "9*x*y*z + 9*x^2*y + 9*x^2*z + 9*y^2*x + 9*y^2*z + 9*z^2*x + 9*z^2*y + 9*x*y*z \<ge> (8*x + 8*y + 8*z)*(x*y + y*z + z*x)"
    by simp
  then have "(9*x + 9*y)*(y*z + y*x + z^2 + z*x) \<ge> (8*x + 8*y + 8*z)*(x*y + y*z + z*x)"
    by (simp add: add.commute add.left_commute distrib_left mult.commute mult.left_commute power2_eq_square)
  then have * : " 9*(x + y)*(y + z)*(z + x) \<ge> 8*(x + y + z)*(x*y + y*z + z*x)"
    by (simp add: add.left_commute distrib_left left_diff_distrib mult.commute mult.left_commute right_diff_distrib power2_eq_square)

  have ** : "(x + y)*(y + z)*(z + x)>0"
    using assms(1) assms(2) assms(3)
    by simp

  have "9*(x + y)*(y + z)*(z + x) \<ge> 8*(x + y + z)*(x*y + y*z + z*x)"
    using *
    using assms(1) assms(2) assms(3)
    by blast
  then have "9/8 * (x + y)*(y + z)*(z + x) \<ge> (x + y + z)*(x*y + y*z + z*x)"
    by linarith
  then have "9/8 * (x + y)*(y + z)*(z + x) \<ge> (x + y + z)*(x*y + y*z + z*x)*((x + y)*(y + z)*(z + x))/((x + y)*(y + z)*(z + x))"
    using assms(1) assms(2) assms(3)
    by simp
  then have "9/8 * ((x + y)*(y + z)*(z + x)) \<ge> ((x + y + z)*(x*y + y*z + z*x)/((x + y)*(y + z)*(z + x)))*(x + y)*(y + z)*(z + x)"
    by (metis (mono_tags, hide_lams) mult.assoc times_divide_eq_left)
  then show "9/8 \<ge> ((x + y + z)*(x*y + y*z + z*x)/((x + y)*(y + z)*(z + x)))"
    using **
    by (metis (no_types, hide_lams) ab_semigroup_mult_class.mult_ac(1) mult_le_cancel_right)
qed

(* Key lemma used in final lemma LF *)
lemma L2 [simp]:
  fixes x y z :: real
  assumes "x > 0" "y > 0" "z > 0"
  assumes "1/x + 1/y + 1/z = x + y + z"
  shows "(x*y + y*z + z*x)/(x*y*z*(x + y + z)) \<le> 1"
proof-
  from assms(4)
  have "x*y*z * (1/x + 1/y + 1/z) = x*y*z * (x + y + z)"
    by simp
  then have "x*y*z*(1/x) + x*y*z*(1/y) + x*y*z*(1/z)  = x*y*z * (x + y + z)"
    by (simp add: distrib_left)
  then have "y*z + x*z + x*y = x*y*z * (x + y + z)"
    using assms(1) assms(2) assms(3)
    by simp
  then have * : "x*y + y*z + z*x = x*y*z * (x + y + z)"
    using assms(1) assms(2) assms(3)
    by (simp add: mult.commute)

  have "(x*y + y*z + z*x)/(x*y*z*(x + y + z)) \<le> 1"
    using *
    by simp
  then show ?thesis
    .
qed

(* This inequality will help us form inequality_L3 *)
lemma inequality_2 [simp]:
  fixes x y z :: real
  assumes "x > 0" "y > 0" "z > 0"
  shows "x^2*y^2 + x^2*z^2 \<ge> 2*x^2*y*z"
proof-
  have "(x^2*y^2 + x^2*z^2)/2 \<ge> sqrt(x^2*y^2 * x^2*z^2)"
    using AM_GM_2[of "x^2*y^2" "x^2*z^2"]
    using assms
    by (simp add: mult.assoc)
  then have "(x^2*y^2 + x^2*z^2) \<ge> 2*sqrt(x^2*y^2 * x^2*z^2)"
    by simp
  then have "(x^2*y^2 + x^2*z^2) \<ge> 2*sqrt(x^4*y^2*z^2)"
    by (smt mult.assoc mult.commute numeral_Bit0 power_add)
  then have "x^2*y^2 + x^2*z^2 \<ge> 2* (root 2 (x^4*y^2*z^2))"
    by (simp add: sqrt_def)
  then have "x^2*y^2 + x^2*z^2 \<ge> 2* (x^2*y*z)"
    by (smt assms(2) assms(3) numeral_Bit0 power2_eq_square power_add real_root_mult real_sqrt_abs sqrt_def zero_le_power2)
  then show ?thesis
    by simp
qed

(* This inequality will be used in lemma L3
       (before using, we must prove it)     *)
lemma inequality_L3 [simp]:
  fixes x y z :: real
  assumes "x > 0" "y > 0" "z > 0"
  shows "x^2*y^2 + y^2*z^2 + z^2*x^2 \<ge> x^2*y*z + x*y^2*z + x*y*z^2"
proof-
  have 1: "y^2*x^2 + y^2*z^2 \<ge> 2*y^2*x*z"
    using assms
    by simp

  have 2: "x^2*y^2  + x^2*z^2 \<ge> 2*x^2*y*z"
    using assms
    by simp

  have 3: "z^2*y^2 + z^2*x^2 \<ge> 2*z^2*y*x"
    using assms
    by simp

  have "y^2*x^2 + y^2*z^2 + x^2*y^2  + x^2*z^2 + z^2*y^2 + z^2*x^2 \<ge>  2*y^2*x*z +  2*x^2*y*z + 2*z^2*y*x"
    using 1 2 3 assms
    by linarith
  then have "2*(y^2*x^2 + y^2*z^2 + x^2*z^2) \<ge> 2 * (y^2*x*z + x^2*y*z + z^2*y*x)"
    using assms
    by (simp add: mult.commute)
  then show ?thesis
    by (simp add: mult.commute)
qed

(* Key lemma used in final lemma LF *)
lemma L3 [simp]:
  fixes x y z :: real
  assumes "x > 0" "y > 0" "z > 0"
  assumes "x^2*y^2 + y^2*z^2 + z^2*x^2 \<ge> x^2*y*z + x*y^2*z + x*y*z^2"
  shows "(x*y*z*(x + y + z))/((x*y + y*z + z*x)^2) \<le> 1/3"
proof-

  from assms(4)
  have "x^2*y^2 + y^2*z^2 + z^2*x^2 \<ge> x*y*z * (x + y + z)"
    by (simp add: \<open>x\<^sup>2 * y * z + x * y\<^sup>2 * z + x * y * z\<^sup>2 \<le> x\<^sup>2 * y\<^sup>2 + y\<^sup>2 * z\<^sup>2 + z\<^sup>2 * x\<^sup>2\<close> add.assoc add.commute add.left_commute add_diff_eq diff_add_eq diff_diff_add diff_diff_eq2 distrib_left mult.commute mult.left_commute power_mult_distrib right_diff_distrib' power2_eq_square)
  then have "x^2*y^2 + y^2*z^2 + z^2*x^2 \<ge> (3-2) * (x*y*z * (x + y + z))"
    by simp
  then have "x^2*y^2 + y^2*z^2 + z^2*x^2 \<ge> 3*x*y*z * (x + y + z) - 2*x*y*z * (x + y + z) "
    by simp
  then have "x^2*y^2 + y^2*z^2 + z^2*x^2 + 2*x*y*z * (x + y + z) \<ge> 3*x*y*z * (x + y + z)"
    by simp
  then have "x^2*y^2 + y^2*z^2 + z^2*x^2 + 2*x^2*y*z + 2*x*y^2*z + 2*x*y*z^2 \<ge> 3*x*y*z * (x + y + z)"
    by (simp add: distrib_right mult.commute power2_eq_square)
  then have * : "(x*y + y*z + z*x)^2 \<ge> 3*x*y*z * (x + y + z)"
    by (simp add: add.left_commute distrib_left left_diff_distrib mult.commute mult.left_commute right_diff_distrib power2_eq_square)

  have "(x*y + y*z + z*x)^2 \<ge> 3*x*y*z * (x + y + z)"
    using assms(1) assms(2) assms(3)
    using *
    by simp
  then have ** : "1/(x*y + y*z + z*x)^2 \<le> 1/(3*x*y*z * (x + y + z))"
    using assms(1) assms(2) assms(3)
    by (smt frac_le mult_pos_pos)

  have "(x*y*z*(x + y + z))/((x*y + y*z + z*x)^2) \<le> x*y*z*(x + y + z) * (1/(x*y + y*z + z*x)^2)"
    by simp
  also have "... \<le> x*y*z*(x + y + z) * (1/(3*x*y*z * (x + y + z)))"
    using **
    by (meson add_nonneg_nonneg assms(1) assms(2) assms(3) less_imp_le mult_left_mono mult_nonneg_nonneg)
  also have "... \<le> x*y*z*(x + y + z)/(3*x*y*z * (x + y + z))"
    by simp
  also have "... \<le> 1/3"
    using assms(1) assms(2) assms(3)
    by simp
  finally show ?thesis
    .
qed

(*        Final lemma
  (showing that expression \<le> 3/8) *)
lemma LF:
  fixes x y z :: real
  assumes "x > 0" "y > 0" "z > 0"
  assumes "1/x + 1/y + 1/z = x + y + z"
  shows "(((x + y + z)*(x*y + y*z + z*x))/((x + y)*(y + z)*(z + x))) * ((x*y + y*z + z*x)/(x*y*z*(x + y + z))) * ((x*y*z*(x + y + z))/((x*y + y*z + z*x)^2)) \<le> 3/8"
proof-

  have 11 : "((x + y + z)*(x*y + y*z + z*x))/((x + y)*(y + z)*(z + x)) > 0"
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos zero_less_divide_iff)

  have 1 : "((x + y + z)*(x*y + y*z + z*x))/((x + y)*(y + z)*(z + x)) \<le> 9/8"
    using assms(1) assms(2) assms(3)
    using L1
    by simp

  have 22 : "(x*y + y*z + z*x)/(x*y*z*(x + y + z)) > 0"
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos zero_less_divide_iff)

  have 2 : "(x*y + y*z + z*x)/(x*y*z*(x + y + z)) \<le> 1"
    using assms(1) assms(2) assms(3) assms(4)
    using L2
    by simp

  have 33 : "((x*y*z*(x + y + z))/((x*y + y*z + z*x)^2)) > 0"
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos zero_less_divide_iff zero_less_power)

  have 3 : "((x*y*z*(x + y + z))/((x*y + y*z + z*x)^2)) \<le> 1/3"
    using assms(1) assms(2) assms(3)
    using L3
    by simp

  have " (((x + y + z)*(x*y + y*z + z*x))/((x + y)*(y + z)*(z + x))) * ((x*y + y*z + z*x)/(x*y*z*(x + y + z))) * ((x*y*z*(x + y + z))/((x*y + y*z + z*x)^2))
       \<le> 9/8 * ((x*y + y*z + z*x)/(x*y*z*(x + y + z))) * ((x*y*z*(x + y + z))/((x*y + y*z + z*x)^2))"
    using 1 22 33
    by (metis mult_le_cancel_right mult_less_0_iff not_square_less_zero)
  also have " ...  \<le> 9/8 * 1 * ((x*y*z*(x + y + z))/((x*y + y*z + z*x)^2))"
    using 1 11 2 33
    by (metis add_mono_thms_linordered_semiring(1) le_add_same_cancel1 less_imp_le mult_le_cancel_right mult_left_mono not_less)
  also have " ... \<le> 9/8 * 1 * 1/3"
    using 3 11 22 33
    using assms(1) assms(2) assms(3)
    by simp
  finally show ?thesis
    by simp
qed

(* Simple inequality *)
lemma inequality_3:
  fixes x :: real
  assumes "x > 0" "x \<le> 3/8"
  shows "1/2 * x \<le> 1/2 * 3/8"
  using assms
  by simp

(* Proof *)
lemma Final :
  fixes a b c :: real
  assumes "a > 0" "b > 0" "c > 0"
  assumes "1/a + 1/b + 1/c = a + b + c"
  shows " (1/(2*a + b + c)^2) + (1/(2*b + c + a)^2) + (1/(2*c + a + b)^2) \<le> 3/16"
proof-

  have 1 : "1/((2*a + b + c)^2) \<le> 1/(4*(a + b)*(a + c))"
    using assms(1) assms(2) assms(3)
    using inequality_1
    by simp

  have 2 : "1/((2*b + c + a)^2) \<le> 1/(4*(b + c)*(b + a))"
    using assms(1) assms(2) assms(3)
    using inequality_1
    by simp

  have 3 : "1/((2*c + a + b)^2) \<le> 1/(4*(c + a)*(c + b))"
    using assms(1) assms(2) assms(3)
    using inequality_1
    by simp

  have "(1/(2*a + b + c)^2) + (1/(2*b + c + a)^2) + (1/(2*c + a + b)^2) \<le>
      1/(4*(a + b)*(a + c)) + 1/(4*(b + c)*(b + a)) + 1/(4*(c + a)*(c + b))"
    using 1 2 3
    by simp
  also have " ... = (b + c)/(4*(a + b)*(a + c)*(b + c)) + (a + c)/(4*(b + c)*(b + a)*(a + c)) + (a + b)/(4*(c + a)*(c + b)*(a + b))"
    using assms(1) assms(2) assms(3)
    by simp
  also have "... = (b + c + c + a + a + b)/(4*(a + b)*(b + c)*(c + a))"
    using assms(1) assms(2) assms(3)
    by (metis (mono_tags, hide_lams) add.commute add.left_commute add_divide_distrib mult.commute mult.left_commute)
  also have "... = (2*(a + b + c))/(4*(a + b)*(b + c)*(c + a))"
    by simp
  also have "... = (2/4)*((a + b + c)/((a + b)*(b + c)*(c + a)))"
    proof -
      have "\<forall>r ra rb. (ra::real) * (rb / r) = rb * ra / r"
        by auto
      then show ?thesis
        by (metis (no_types) divide_divide_eq_left)
    qed
  also have "... = (1/2)*((a + b + c)/((a + b)*(b + c)*(c + a)))"
    by simp
  also have "... = (a + b + c)/(2*(a + b)*(b + c)*(c + a))"
    by simp
  also have "... = (a + b + c)/(2*(a + b)*(b + c)*(c + a)) * 1"
    by simp
  also have "... = (a + b + c)/(2*(a + b)*(b + c)*(c + a)) * (a*b*c) / (a*b*c) "
    using assms(1) assms(2) assms(3)
    by simp
  also have "... = (a + b + c)/(2*(a + b)*(b + c)*(c + a)) * (a*b*c) / (a*b*c) * (a + b + c) / (a + b + c)"
    by simp
  also have "... = (a + b + c)/(2*(a + b)*(b + c)*(c + a)) * (a*b*c) / (a*b*c) * (a + b + c) / (a + b + c) * ((a*b + b*c + c*a)^2) / ((a*b + b*c + c*a)^2) "
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos nonzero_mult_div_cancel_right zero_less_power)
  also have "... = (((a + b + c)*(a*b + b*c + c*a))/(2*(a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a + b + c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2))"
    by (simp add: power2_eq_square)
  also have  "... = 1/2*(((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a + b + c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2))"
    by simp
  finally have start : "(1/(2*a + b + c)^2) + (1/(2*b + c + a)^2) + (1/(2*c + a + b)^2) \<le>
        1/2*(((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a+b+c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2))"
    by simp

  have 11 : "((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a)) > 0"
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos zero_less_divide_iff)

  have 22 : "(a*b + b*c + c*a)/(a*b*c*(a + b + c)) > 0"
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos zero_less_divide_iff)

  have 33 : "((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2)) > 0"
    using assms(1) assms(2) assms(3)
    by (smt mult_pos_pos zero_less_divide_iff zero_less_power)

  have * : "(((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a+b+c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2)) > 0"
    using assms(1) assms(2) assms(3)
    using 11 22 33
    using zero_less_mult_iff
    by blast

  have ** : "(((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a + b + c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2)) \<le> 3/8"
    using assms(1) assms(2) assms(3) assms(4)
    using LF
    by simp

  have finish : "1/2* (((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a + b + c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2)) \<le>
        1/2 * 3/8"
    using *
    using **
    using inequality_3[of "(((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a + b + c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2))"]
    by auto

  have "(1/(2*a + b + c)^2) + (1/(2*b + c + a)^2) + (1/(2*c + a + b)^2) \<le>
          1/2*(((a + b + c)*(a*b + b*c + c*a))/((a + b)*(b + c)*(c + a))) * ((a*b + b*c + c*a)/(a*b*c*(a + b + c))) * ((a*b*c*(a + b + c))/((a*b + b*c + c*a)^2))"
    using start
    by simp
  also have "... \<le> 1/2 * 3/8"
    using finish
    by simp
  finally show ?thesis
    by simp
qed

end


theory ReplicateMultiset imports "~~/src/HOL/Library/Multiset" begin

lemma count_sum: "finite A \<Longrightarrow> count (sum f A) x = sum (\<lambda>y. count (f y) x) A"
  apply(erule finite_induct)
  by auto

theorem sum_replicate_mset: "M = sum (\<lambda>m. replicate_mset (count M m) m) (set_mset M)"
  apply(rule multiset_eqI)
  by (auto simp add: count_sum not_in_iff)

end


theory T59
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. over(x, meet(y, z)) = join(over(x, y), over(x, 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. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory prop_63
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun lt :: "Nat => Nat => bool" where
  "lt x (Z) = False"
  | "lt (Z) (S z) = True"
  | "lt (S x2) (S z) = lt x2 z"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun last :: "Nat list => Nat" where
  "last (Nil2) = Z"
  | "last (Cons2 y (Nil2)) = y"
  | "last (Cons2 y (Cons2 x2 x3)) = last (Cons2 x2 x3)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster lt len last drop *)

(*hipster lt len drop*)
lemma lemma_a []: "lt x2 x2 = False"
by (hipster_induct_schemes lt.simps len.simps)

lemma lemma_aa []: "lt x2 (S x2) = True"
by (hipster_induct_schemes lt.simps len.simps)

lemma lemma_ab []: "lt (S x2) x2 = False"
by (hipster_induct_schemes lt.simps len.simps)

(*hipster_cond lt*)
lemma lemma_ac []: "lt y2 x2 \<Longrightarrow> lt x2 y2 = False"
by (hipster_induct_schemes lt.simps)

lemma lemma_ad []: "lt y2 x2 \<Longrightarrow> lt Z x2 = True"
by (hipster_induct_schemes lt.simps)

lemma lemma_ae []: "lt x2 y2 \<Longrightarrow> lt x2 (S y2) = True"
by (hipster_induct_schemes lt.simps)

lemma lemma_af []: "lt y2 x2 \<Longrightarrow> lt x2 (S y2) = False"
by (hipster_induct_schemes lt.simps)

lemma lemma_ag []: "lt y1 x1 \<and> lt z1 y1 \<Longrightarrow> lt (S Z) x1 = True"
by (hipster_induct_schemes lt.simps Nat.exhaust)

lemma lemma_ah []: "lt z x \<and> lt y z \<Longrightarrow> lt x y = False"
by (hipster_induct_schemes lt.simps Nat.exhaust)

lemma lemma_ai []: "lt z y \<and> lt x z \<Longrightarrow> lt x y = True"
by (hipster_induct_schemes lt.simps Nat.exhaust)

lemma unknown []: "lt z y \<and> lt x z \<Longrightarrow> lt (S x) y = True"
by (hipster_induct_schemes lt.simps Nat.exhaust)

(*hipster lt len last drop*)
lemma lemma_aj []: "drop x1 Nil2 = Nil2"
by (hipster_induct_schemes lt.simps len.simps last.simps drop.simps)

lemma lemma_ak []: "drop (len x2) x2 = Nil2"
by (hipster_induct_schemes lt.simps len.simps last.simps drop.simps)

lemma lemma_al []: "drop (S Z) (drop x2 y2) = drop (S x2) y2"
by (hipster_induct_schemes lt.simps len.simps last.simps drop.simps)

lemma lemma_am []: "drop (len x4) (drop y4 x4) = Nil2"
by (hipster_induct_schemes lt.simps len.simps last.simps drop.simps Nat.exhaust)

lemma unknown []: "drop x (drop y z) = drop y (drop x z)"
oops

lemma unknown []: "drop (S x) (drop y z) = drop (S y) (drop x z)"
oops

(*hipster_cond lt len drop*)
lemma lemma_an []: "lt ya2 x2 \<Longrightarrow> drop x2 (Cons2 y2 z2) = drop x2 (Cons2 xa2 z2)"
by (metis lt.simps drop.simps Nat.exhaust)(*
by (hipster_induct_schemes lt.simps len.simps drop.simps)*)

lemma lemma_ao []: "lt z4 x4 \<Longrightarrow> drop x4 (Cons2 y4 Nil2) = Nil2"
by (metis lt.simps drop.simps Nat.exhaust) (*
by (hipster_induct_schemes lt.simps len.simps drop.simps)*)

fun ltlen :: "Nat \<Rightarrow> 'a list \<Rightarrow> bool" where
  "ltlen n x = lt n (len x)"

(*hipster ltlen*)

(*hipster ltlen drop last len*) (*
lemma lemma_anll []: "ltlen Z (drop x2 y2) = ltlen x2 y2"
by (hipster_induct_schemes ltlen.simps drop.simps last.simps len.simps)

lemma lemma_aoll []: "ltlen (S Z) (drop x2 y2) = ltlen (S x2) y2"
by (hipster_induct_schemes ltlen.simps drop.simps last.simps len.simps)

lemma unknown []: "ltlen x (drop y z) = ltlen y (drop x z)"
oops

lemma unknown []: "ltlen (S x) (drop y z) = ltlen (S y) (drop x z)"
oops

*)

  theorem x0 :
    "(lt n (len xs)) ==> ((last (drop n xs)) = (last xs))"
    by (hipster_induct_schemes lt.simps  last.simps drop.simps Nat.exhaust)
    apply(induction xs arbitrary: n)
    apply(simp_all)
    by (metis len.simps lt.simps last.simps drop.simps Nat.exhaust list.exhaust)

end


theory General_Rewriting
imports Terms_Extras
begin

locale rewriting =
  fixes R :: "'a::term \<Rightarrow> 'a \<Rightarrow> bool"
  assumes R_fun: "R t t' \<Longrightarrow> R (app t u) (app t' u)"
  assumes R_arg: "R u u' \<Longrightarrow> R (app t u) (app t u')"
begin

lemma rt_fun:
  "R\<^sup>*\<^sup>* t t' \<Longrightarrow> R\<^sup>*\<^sup>* (app t u) (app t' u)"
by (induct rule: rtranclp.induct) (auto intro: rtranclp.rtrancl_into_rtrancl R_fun)

lemma rt_arg:
  "R\<^sup>*\<^sup>* u u' \<Longrightarrow> R\<^sup>*\<^sup>* (app t u) (app t u')"
by (induct rule: rtranclp.induct) (auto intro: rtranclp.rtrancl_into_rtrancl R_arg)

lemma rt_comb:
  "R\<^sup>*\<^sup>* t\<^sub>1 u\<^sub>1 \<Longrightarrow> R\<^sup>*\<^sup>* t\<^sub>2 u\<^sub>2 \<Longrightarrow> R\<^sup>*\<^sup>* (app t\<^sub>1 t\<^sub>2) (app u\<^sub>1 u\<^sub>2)"
by (metis rt_fun rt_arg rtranclp_trans)

lemma rt_list_comb:
  assumes "list_all2 R\<^sup>*\<^sup>* ts us" "R\<^sup>*\<^sup>* t u"
  shows "R\<^sup>*\<^sup>* (list_comb t ts) (list_comb u us)"
using assms
by (induction ts us arbitrary: t u rule: list.rel_induct) (auto intro: rt_comb)

end

end


section\<open>Aids to internalize formulas\<close>

theory Internalizations
  imports
    DPow_absolute
    Synthetic_Definition
    Nat_Miscellanea
begin

hide_const (open) Order.pred

definition
  infinity_ax :: "(i \<Rightarrow> o) \<Rightarrow> o" where
  "infinity_ax(M) \<equiv>
      (\<exists>I[M]. (\<exists>z[M]. empty(M,z) \<and> z\<in>I) \<and> (\<forall>y[M]. y\<in>I \<longrightarrow> (\<exists>sy[M]. successor(M,y,sy) \<and> sy\<in>I)))"

definition
  wellfounded_trancl :: "[i=>o,i,i,i] => o" where
  "wellfounded_trancl(M,Z,r,p) \<equiv>
      \<exists>w[M]. \<exists>wx[M]. \<exists>rp[M].
               w \<in> Z & pair(M,w,p,wx) & tran_closure(M,r,rp) & wx \<in> rp"

lemma empty_intf :
  "infinity_ax(M) \<Longrightarrow>
  (\<exists>z[M]. empty(M,z))"
  by (auto simp add: empty_def infinity_ax_def)

lemma Transset_intf :
  "Transset(M) \<Longrightarrow>  y\<in>x \<Longrightarrow> x \<in> M \<Longrightarrow> y \<in> M"
  by (simp add: Transset_def,auto)

definition
  choice_ax :: "(i\<Rightarrow>o) \<Rightarrow> o" where
  "choice_ax(M) \<equiv> \<forall>x[M]. \<exists>a[M]. \<exists>f[M]. ordinal(M,a) \<and> surjection(M,a,x,f)"

lemma (in M_basic) choice_ax_abs :
  "choice_ax(M) \<longleftrightarrow> (\<forall>x[M]. \<exists>a[M]. \<exists>f[M]. Ord(a) \<and> f \<in> surj(a,x))"
  unfolding choice_ax_def
  by simp

txt\<open>Setting up notation for internalized formulas\<close>

abbreviation
  dec10  :: i   ("10") where "10 \<equiv> succ(9)"
abbreviation
  dec11  :: i   ("11") where "11 \<equiv> succ(10)"
abbreviation
  dec12  :: i   ("12") where "12 \<equiv> succ(11)"
abbreviation
  dec13  :: i   ("13") where "13 \<equiv> succ(12)"
abbreviation
  dec14  :: i   ("14") where "14 \<equiv> succ(13)"
abbreviation
  dec15  :: i   ("15") where "15 \<equiv> succ(14)"
abbreviation
  dec16  :: i   ("16") where "16 \<equiv> succ(15)"
abbreviation
  dec17  :: i   ("17") where "17 \<equiv> succ(16)"
abbreviation
  dec18  :: i   ("18") where "18 \<equiv> succ(17)"
abbreviation
  dec19  :: i   ("19") where "19 \<equiv> succ(18)"
abbreviation
  dec20  :: i   ("20") where "20 \<equiv> succ(19)"
abbreviation
  dec21  :: i   ("21") where "21 \<equiv> succ(20)"
abbreviation
  dec22  :: i   ("22") where "22 \<equiv> succ(21)"
abbreviation
  dec23  :: i   ("23") where "23 \<equiv> succ(22)"
abbreviation
  dec24  :: i   ("24") where "24 \<equiv> succ(23)"
abbreviation
  dec25  :: i   ("25") where "25 \<equiv> succ(24)"
abbreviation
  dec26  :: i   ("26") where "26 \<equiv> succ(25)"
abbreviation
  dec27  :: i   ("27") where "27 \<equiv> succ(26)"
abbreviation
  dec28  :: i   ("28") where "28 \<equiv> succ(27)"
abbreviation
  dec29  :: i   ("29") where "29 \<equiv> succ(28)"

notation Member (\<open>\<cdot>_ \<in>/ _\<cdot>\<close>)
notation Equal (\<open>\<cdot>_ =/ _\<cdot>\<close>)
notation Nand (\<open>\<cdot>\<not>'(_ \<and>/ _')\<cdot>\<close>)
notation And (\<open>\<cdot>_ \<and>/ _\<cdot>\<close>)
notation Or (\<open>\<cdot>_ \<or>/ _\<cdot>\<close>)
notation Iff (\<open>\<cdot>_ \<leftrightarrow>/ _\<cdot>\<close>)
notation Implies (\<open>\<cdot>_ \<rightarrow>/ _\<cdot>\<close>)
notation Neg (\<open>\<cdot>\<not>_\<cdot>\<close>)
notation Forall (\<open>'(\<cdot>\<forall>(/_)\<cdot>')\<close>)
notation Exists (\<open>'(\<cdot>\<exists>(/_)\<cdot>')\<close>)

notation subset_fm (\<open>\<cdot>_ \<subseteq>/ _\<cdot>\<close>)
notation succ_fm (\<open>\<cdot>succ'(_') is _\<cdot>\<close>)
notation empty_fm (\<open>\<cdot>_ is empty\<cdot>\<close>)
notation fun_apply_fm (\<open>\<cdot>_`_ is _\<cdot>\<close>)
notation big_union_fm (\<open>\<cdot>\<Union>_ is _\<cdot>\<close>)
notation upair_fm (\<open>\<cdot>{_,_} is _ \<cdot>\<close>)
notation ordinal_fm (\<open>\<cdot>_ is ordinal\<cdot>\<close>)

notation pair_fm (\<open>\<cdot>\<langle>_,_\<rangle> is _ \<cdot>\<close>)
notation composition_fm (\<open>\<cdot>_ \<circ> _ is _ \<cdot>\<close>)
notation domain_fm (\<open>\<cdot>dom'(_') is _ \<cdot>\<close>)
notation range_fm (\<open>\<cdot>ran'(_') is _ \<cdot>\<close>)
notation union_fm (\<open>\<cdot>_ \<union> _ is _ \<cdot>\<close>)
notation image_fm (\<open>\<cdot>_ `` _ is _ \<cdot>\<close>)
notation pre_image_fm (\<open>\<cdot>_ -`` _ is _ \<cdot>\<close>)
notation field_fm (\<open>\<cdot>fld'(_') is _ \<cdot>\<close>)
notation cons_fm (\<open>\<cdot>cons'(_,_') is _ \<cdot>\<close>)
notation number1_fm (\<open>\<cdot>_ is the number one\<cdot>\<close>)
notation function_fm (\<open>\<cdot>_ is funct\<cdot>\<close>)
notation relation_fm (\<open>\<cdot>_ is relat\<cdot>\<close>)
notation restriction_fm (\<open>\<cdot>_ \<restriction> _ is _ \<cdot>\<close>)
notation transset_fm (\<open>\<cdot>_ is transitive\<cdot>\<close>)
notation limit_ordinal_fm (\<open>\<cdot>_ is limit\<cdot>\<close>)
notation finite_ordinal_fm (\<open>\<cdot>_ is finite ord\<cdot>\<close>)
notation omega_fm (\<open>\<cdot>_ is \<omega>\<cdot>\<close>)
notation cartprod_fm (\<open>\<cdot>_ \<times> _ is _\<cdot>\<close>)
notation Memrel_fm (\<open>\<cdot>Memrel'(_') is _\<cdot>\<close>)
notation quasinat_fm (\<open>\<cdot>_ is qnat\<cdot>\<close>)
  (* notation rtran_closure_mem_fm (\<open>\<cdot>{_,_} is _ \<cdot>\<close>)
notation rtran_closure_fm (\<open>\<cdot>{_,_} is _ \<cdot>\<close>)
notation tran_closure_fm (\<open>\<cdot>_ is  \<cdot>\<close>)
notation order_isomorphism_fm (\<open>\<cdot>{_,_} is _ \<cdot>\<close>) *)
notation Inl_fm (\<open>\<cdot>Inl'(_') is _ \<cdot>\<close>)
notation Inr_fm (\<open>\<cdot>Inr'(_') is _ \<cdot>\<close>)
notation pred_set_fm (\<open>\<cdot>_-predecessors of _ are _\<cdot>\<close>)

abbreviation
  fm_typedfun :: "[i,i,i] \<Rightarrow> i" (\<open>\<cdot>_ : _ \<rightarrow> _\<cdot>\<close>) where
  "fm_typedfun(f,A,B) \<equiv> typed_function_fm(A,B,f)"

abbreviation
  fm_surjection :: "[i,i,i] \<Rightarrow> i" (\<open>\<cdot>_ surjects _ to _\<cdot>\<close>) where
  "fm_surjection(f,A,B) \<equiv> surjection_fm(A,B,f)"

abbreviation
  fm_injection :: "[i,i,i] \<Rightarrow> i" (\<open>\<cdot>_ injects _ to _\<cdot>\<close>) where
  "fm_injection(f,A,B) \<equiv> injection_fm(A,B,f)"

abbreviation
  fm_bijection :: "[i,i,i] \<Rightarrow> i" (\<open>\<cdot>_ bijects _ to _\<cdot>\<close>) where
  "fm_bijection(f,A,B) \<equiv> bijection_fm(A,B,f)"

text\<open>We found it useful to have slightly different versions of some
results in ZF-Constructible:\<close>
lemma nth_closed :
  assumes "env\<in>list(A)" "0\<in>A"
  shows "nth(n,env)\<in>A"
  using assms unfolding nth_def by (induct env; simp)

lemma conj_setclass_model_iff_sats [iff_sats]:
  "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> (P \<and> (##A)(x)) \<longleftrightarrow> sats(A, p, env)"
  "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> ((##A)(x) \<and> P) \<longleftrightarrow> sats(A, p, env)"
  using nth_closed[of env A i]
  by auto

lemma conj_mem_model_iff_sats [iff_sats]:
  "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> (P \<and> x \<in> A) \<longleftrightarrow> sats(A, p, env)"
  "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> (x \<in> A \<and> P) \<longleftrightarrow> sats(A, p, env)"
  using nth_closed[of env A i]
  by auto

(* lemma [iff_sats]:
      "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> (x \<in> A \<longleftrightarrow> P) \<longleftrightarrow> sats(A, p, env)"
      "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> (P \<longleftrightarrow> x \<in> A) \<longleftrightarrow> sats(A, p, env)"

      "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A);
       P \<longleftrightarrow> sats(A,p,env); env \<in> list(A) |]
       ==> (x \<in> A \<longrightarrow> P) \<longleftrightarrow> sats(A, p, env)"

  using nth_closed[of env A i]
  by auto *)

lemma mem_model_iff_sats [iff_sats]:
  "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A)|]
       ==> (x\<in>A) \<longleftrightarrow> sats(A, Exists(Equal(0,0)), env)"
  using nth_closed[of env A i]
  by auto

lemma subset_iff_sats[iff_sats]:
  "nth(i, env) = x \<Longrightarrow> nth(j, env) = y \<Longrightarrow> i\<in>nat \<Longrightarrow> j\<in>nat \<Longrightarrow>
   env \<in> list(A) \<Longrightarrow> subset(##A, x, y) \<longleftrightarrow> sats(A, subset_fm(i, j), env)"
  using sats_subset_fm' by simp

lemma not_mem_model_iff_sats [iff_sats]:
  "[| 0 \<in> A; nth(i,env) = x; env \<in> list(A)|]
       ==> (\<forall> x . x \<notin> A) \<longleftrightarrow> sats(A, Neg(Exists(Equal(0,0))), env)"
  by auto

lemma top_iff_sats [iff_sats]:
  "env \<in> list(A) \<Longrightarrow> 0 \<in> A \<Longrightarrow> sats(A, Exists(Equal(0,0)), env)"
  by auto

lemma prefix1_iff_sats[iff_sats]:
  assumes
    "x \<in> nat" "env \<in> list(A)" "0 \<in> A" "a \<in> A"
  shows
    "a = nth(x,env) \<longleftrightarrow> sats(A, Equal(0,x+\<^sub>\<omega>1), Cons(a,env))"
    "nth(x,env) = a \<longleftrightarrow> sats(A, Equal(x+\<^sub>\<omega>1,0), Cons(a,env))"
    "a \<in> nth(x,env) \<longleftrightarrow> sats(A, Member(0,x+\<^sub>\<omega>1), Cons(a,env))"
    "nth(x,env) \<in> a \<longleftrightarrow> sats(A, Member(x+\<^sub>\<omega>1,0), Cons(a,env))"
  using assms nth_closed
  by simp_all

lemma prefix2_iff_sats[iff_sats]:
  assumes
    "x \<in> nat" "env \<in> list(A)" "0 \<in> A" "a \<in> A" "b \<in> A"
  shows
    "b = nth(x,env) \<longleftrightarrow> sats(A, Equal(1,x+\<^sub>\<omega>2), Cons(a,Cons(b,env)))"
    "nth(x,env) = b \<longleftrightarrow> sats(A, Equal(x+\<^sub>\<omega>2,1), Cons(a,Cons(b,env)))"
    "b \<in> nth(x,env) \<longleftrightarrow> sats(A, Member(1,x+\<^sub>\<omega>2), Cons(a,Cons(b,env)))"
    "nth(x,env) \<in> b \<longleftrightarrow> sats(A, Member(x+\<^sub>\<omega>2,1), Cons(a,Cons(b,env)))"
  using assms nth_closed
  by simp_all

lemma prefix3_iff_sats[iff_sats]:
  assumes
    "x \<in> nat" "env \<in> list(A)" "0 \<in> A" "a \<in> A" "b \<in> A" "c \<in> A"
  shows
    "c = nth(x,env) \<longleftrightarrow> sats(A, Equal(2,x+\<^sub>\<omega>3), Cons(a,Cons(b,Cons(c,env))))"
    "nth(x,env) = c \<longleftrightarrow> sats(A, Equal(x+\<^sub>\<omega>3,2), Cons(a,Cons(b,Cons(c,env))))"
    "c \<in> nth(x,env) \<longleftrightarrow> sats(A, Member(2,x+\<^sub>\<omega>3), Cons(a,Cons(b,Cons(c,env))))"
    "nth(x,env) \<in> c \<longleftrightarrow> sats(A, Member(x+\<^sub>\<omega>3,2), Cons(a,Cons(b,Cons(c,env))))"
  using assms nth_closed
  by simp_all

lemmas FOL_sats_iff = sats_Nand_iff sats_Forall_iff sats_Neg_iff sats_And_iff
  sats_Or_iff sats_Implies_iff sats_Iff_iff sats_Exists_iff

lemma nth_ConsI: "\<lbrakk>nth(n,l) = x; n \<in> nat\<rbrakk> \<Longrightarrow> nth(succ(n), Cons(a,l)) = x"
  by simp

lemmas nth_rules = nth_0 nth_ConsI nat_0I nat_succI
lemmas sep_rules = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
  fun_plus_iff_sats successor_iff_sats
  omega_iff_sats FOL_sats_iff Replace_iff_sats

text\<open>Also a different compilation of lemmas (term\<open>sep_rules\<close>) used in formula
 synthesis\<close>
lemmas fm_defs =
  omega_fm_def limit_ordinal_fm_def empty_fm_def typed_function_fm_def
  pair_fm_def upair_fm_def domain_fm_def function_fm_def succ_fm_def
  cons_fm_def fun_apply_fm_def image_fm_def big_union_fm_def union_fm_def
  relation_fm_def composition_fm_def field_fm_def ordinal_fm_def range_fm_def
  transset_fm_def subset_fm_def Replace_fm_def

lemmas formulas_def [fm_definitions] = fm_defs
  is_iterates_fm_def iterates_MH_fm_def is_wfrec_fm_def is_recfun_fm_def is_transrec_fm_def
  is_nat_case_fm_def quasinat_fm_def number1_fm_def ordinal_fm_def finite_ordinal_fm_def
  cartprod_fm_def sum_fm_def Inr_fm_def Inl_fm_def
  formula_functor_fm_def
  Memrel_fm_def transset_fm_def subset_fm_def pre_image_fm_def restriction_fm_def
  list_functor_fm_def tl_fm_def quasilist_fm_def Cons_fm_def Nil_fm_def

lemmas sep_rules' [iff_sats]  = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
  fun_plus_iff_sats omega_iff_sats

lemmas  more_iff_sats [iff_sats] = rtran_closure_iff_sats tran_closure_iff_sats
  is_eclose_iff_sats Inl_iff_sats Inr_iff_sats fun_apply_iff_sats cartprod_iff_sats
  Collect_iff_sats

end


theory Exercise2
  imports Main
begin

inductive palindrome :: "'a list \<Rightarrow> bool" where
pdrmNil:  "palindrome []" |
pdrmSing: "palindrome [x]" |
pdrmRec:  "palindrome xs \<Longrightarrow> palindrome (x # xs @ [x])"

theorem "(palindrome xs) \<Longrightarrow> (rev xs = xs)"
  apply (induction rule: palindrome.induct)
  by simp_all

end


theory T114
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(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. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(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(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T149
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. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(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=8,timeout=86400]
oops
end