theory demo
  imports Main
begin

fun remove:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
"remove x [] = []" |
"remove x (y#ys) = (if x=y then (remove x ys) else y#(remove x ys))"

value "remove (2::int) [1, 2, 3]"

lemma "\<not>(List.member (remove element list) element)"
  apply (induct list)
  apply auto
  qed

lemma count_remove:  "(length l) = (length (remove e l)) + (count_list l e)"
  apply (induct l)
  by auto

lemma "(length (remove e l)) = (length l) \<longrightarrow> \<not> (List.member l e)"
  apply (induct l)
   apply (simp add: member_rec(2))
   apply auto
  apply (metis count_remove impossible_Cons le_add_same_cancel1 length_Cons zero_le)
  apply (metis Suc_n_not_le_n count_remove le_add_same_cancel1 zero_le)
  by (simp add: member_rec(1))

end


section\<open>Option to List and Option to Set\<close>
theory Option_Helpers
imports Main
begin

text\<open>Those are just syntactic helpers.\<close>

definition option2set :: "'a option \<Rightarrow> 'a set" where
  "option2set n \<equiv> (case n of None \<Rightarrow> {} | Some s \<Rightarrow> {s})"

definition option2list :: "'a option \<Rightarrow> 'a list" where
  "option2list n \<equiv> (case n of None \<Rightarrow> [] | Some s \<Rightarrow> [s])"

lemma set_option2list[simp]: "set (option2list k) = option2set k"
  unfolding option2list_def option2set_def by (simp split: option.splits)

lemma option2list_simps[simp]: "option2list (Some x) = [x]" "option2list (None) = []"
  unfolding option2list_def option.simps by(fact refl)+

lemma option2set_None: "option2set None = {}"
  by(simp add: option2set_def)

lemma option2list_map: "option2list (map_option f n) = map f (option2list n)"
  by(simp add: option2list_def split: option.split)

lemma option2set_map: "option2set (map_option f n) = f ` option2set n"
  by(simp add: option2set_def split: option.split)

end


section \<open>Multiset Interface\<close>
theory IICF_Multiset
imports "../../Sepref"
begin

subsection \<open>Additions to Multiset Theory\<close>
lemma rel_mset_Plus_gen:
  assumes "rel_mset A m m'"
  assumes "rel_mset A n n'"
  shows "rel_mset A (m+n) (m'+n')"
  using assms
  by induction (auto simp: algebra_simps dest: rel_mset_Plus)

lemma rel_mset_single:
  assumes "A x y"
  shows "rel_mset A {#x#} {#y#}"
  unfolding rel_mset_def
  apply (rule exI[where x="[x]"])
  apply (rule exI[where x="[y]"])
  using assms by auto

lemma rel_mset_Minus:
  assumes BIU: "bi_unique A"
  shows "\<lbrakk> rel_mset A m n; A x y \<rbrakk> \<Longrightarrow> rel_mset A (m-{#x#}) (n-{#y#})"
  unfolding rel_mset_def
proof clarsimp
  fix ml nl
  assume A: "A x y"
  assume R: "list_all2 A ml nl"
  show "\<exists>ml'. mset ml' = mset ml - {#x#} \<and>
                 (\<exists>nl'. mset nl' = mset nl - {#y#} \<and> list_all2 A ml' nl')"
  proof (cases "x\<in>set ml")
    case False
    have "y \<notin> set nl" using A R
      apply (auto simp: in_set_conv_decomp list_all2_append2 list_all2_Cons2)
      using False BIU[unfolded bi_unique_alt_def]
      apply (auto dest: left_uniqueD)
      done
    with False R show ?thesis by (auto simp: diff_single_trivial in_multiset_in_set)
  next
    case True
    then obtain ml1 ml2 where [simp]: "ml=ml1@x#ml2" by (auto simp: in_set_conv_decomp)
    then obtain nl1 nl2 where [simp]: "nl=nl1@y#nl2"
      and LA: "list_all2 A ml1 nl1" "list_all2 A ml2 nl2"
      using A R
      apply (auto simp: in_set_conv_decomp list_all2_append1 list_all2_Cons1)
      using BIU[unfolded bi_unique_alt_def]
      apply (auto dest: right_uniqueD)
      done
    have
      "mset (ml1@ml2) = mset ml - {#x#}"
      "mset (nl1@nl2) = mset nl - {#y#}"
      using R
      by (auto simp: algebra_simps add_implies_diff union_assoc)
    moreover have "list_all2 A (ml1@ml2) (nl1@nl2)"
      by (rule list_all2_appendI) fact+
    ultimately show ?thesis by blast
  qed
qed

lemma rel_mset_Minus_gen:
  assumes BIU: "bi_unique A"
  assumes "rel_mset A m m'"
  assumes "rel_mset A n n'"
  shows "rel_mset A (m-n) (m'-n')"
  using assms(3,2)
  apply (induction R\<equiv>A _ _ rule: rel_mset_induct)
  apply (auto dest: rel_mset_Minus[OF BIU] simp: algebra_simps)
  done

lemma pcr_count:
  assumes "bi_unique A"
  shows "rel_fun (rel_mset A) (rel_fun A (=)) count count"
  apply (intro rel_funI)
  unfolding rel_mset_def
  apply clarsimp
  subgoal for x y xs ys
    apply (rotate_tac,induction xs ys rule: list_all2_induct)
    using assms
    by (auto simp: bi_unique_alt_def left_uniqueD right_uniqueD)
  done

subsection \<open>Parametricity Setup\<close>
definition [to_relAPP]: "mset_rel A \<equiv> p2rel (rel_mset (rel2p A))"

lemma rel2p_mset[rel2p]: "rel2p (\<langle>A\<rangle>mset_rel) = rel_mset (rel2p A)"
  by (simp add: mset_rel_def)

lemma p2re_mset[p2rel]: "p2rel (rel_mset A) = \<langle>p2rel A\<rangle>mset_rel"
  by (simp add: mset_rel_def)

lemma mset_rel_empty[simp]:
  "(a,{#})\<in>\<langle>A\<rangle>mset_rel \<longleftrightarrow> a={#}"
  "({#},b)\<in>\<langle>A\<rangle>mset_rel \<longleftrightarrow> b={#}"
  by (auto simp: mset_rel_def p2rel_def rel_mset_def)

lemma param_mset_empty[param]: "({#},{#}) \<in> \<langle>A\<rangle>mset_rel"
  unfolding mset_rel_def
  apply (simp add: p2rel_def)
  by (rule rel_mset_Zero)

lemma param_mset_Plus[param]: "((+),(+))\<in>\<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel"
  apply (rule rel2pD)
  apply (simp add: rel2p)
  apply (intro rel_funI)
  by (rule rel_mset_Plus_gen)

(*lemma param_mset_single[param]:
  "(Multiset.single,Multiset.single) \<in> A \<rightarrow> \<langle>A\<rangle>mset_rel"
  apply (rule rel2pD)
  apply (simp add: rel2p)
  apply (intro rel_funI)
  by (rule rel_mset_single)*)

lemma param_mset_add[param]: "(add_mset, add_mset) \<in> A \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel"
  apply (rule rel2pD)
  apply (simp add: rel2p)
  apply (intro rel_funI)
  by (rule rel_mset_Plus)

lemma param_mset_minus[param]: "\<lbrakk>single_valued A; single_valued (A\<inverse>)\<rbrakk>
  \<Longrightarrow> ((-), (-)) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel"
  apply (rule rel2pD)
  apply (simp add: rel2p)
  apply (intro rel_funI)
  apply (rule rel_mset_Minus_gen)
  subgoal apply (unfold IS_LEFT_UNIQUE_def[symmetric])
    by (simp add: prop2p bi_unique_alt_def)
  apply (simp; fail)
  apply (simp; fail)
  done

lemma param_count[param]: "\<lbrakk>single_valued A; single_valued (A\<inverse>)\<rbrakk> \<Longrightarrow> (count,count)\<in>\<langle>A\<rangle>mset_rel \<rightarrow> A \<rightarrow> nat_rel"
  apply (rule rel2pD)
  apply (simp add: prop2p rel2p)
  apply (rule pcr_count)
  apply (simp add: bi_unique_alt_def)
  done

lemma param_set_mset[param]:
  shows "(set_mset, set_mset) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>set_rel"
  apply (rule rel2pD; simp add: rel2p)
  by (rule multiset.set_transfer)

definition [simp]: "mset_is_empty m \<equiv> m = {#}"

lemma mset_is_empty_param[param]: "(mset_is_empty,mset_is_empty) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> bool_rel"
  unfolding mset_rel_def mset_is_empty_def[abs_def]
  by (auto simp: p2rel_def rel_mset_def intro: nres_relI)

subsection \<open>Operations\<close>
  sepref_decl_op mset_empty: "{#}" :: "\<langle>A\<rangle>mset_rel" .

  sepref_decl_op mset_is_empty: "\<lambda>m. m={#}" :: "\<langle>A\<rangle>mset_rel \<rightarrow> bool_rel"
    unfolding mset_is_empty_def[symmetric]
    apply (rule frefI)
    by parametricity

  (*sepref_decl_op mset_single: "\<lambda>m. {#m#}" :: "A \<rightarrow> \<langle>A\<rangle>mset_rel" .*)

  sepref_decl_op mset_insert: "add_mset" :: "A \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel" .

  sepref_decl_op mset_delete: "\<lambda>x m. m - {#x#}" :: "A \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel"
    where "single_valued A" "single_valued (A\<inverse>)" .

  sepref_decl_op mset_plus: "(+)::_ multiset \<Rightarrow> _" :: "\<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel" .
  sepref_decl_op mset_minus: "(-)::_ multiset \<Rightarrow> _" :: "\<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>mset_rel"
    where "single_valued A" "single_valued (A\<inverse>)" .

  sepref_decl_op mset_contains: "(\<in>#)" :: "A \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> bool_rel"
    where "single_valued A" "single_valued (A\<inverse>)" .

  sepref_decl_op mset_count: "\<lambda>x y. count y x" :: "A \<rightarrow> \<langle>A\<rangle>mset_rel \<rightarrow> nat_rel"
    where "single_valued A" "single_valued (A\<inverse>)" .

  sepref_decl_op mset_pick: "\<lambda>m. SPEC (\<lambda>(x,m'). m = {#x#} + m')" ::
    "[\<lambda>m. m\<noteq>{#}]\<^sub>f \<langle>A\<rangle>mset_rel \<rightarrow> A \<times>\<^sub>r \<langle>A\<rangle>mset_rel"
    unfolding mset_is_empty_def[symmetric]
    apply (intro frefI nres_relI)
    apply (refine_vcg SPEC_refine)
    apply1 (rule ccontr; clarsimp)
    applyS (metis msed_rel_invL rel2p_def rel2p_mset union_ac(2))
    applyS parametricity
    done

subsection \<open>Patterns\<close>

lemma [def_pat_rules]:
  "(+) $b$(add_mset$x${#}) \<equiv> op_mset_insert$x$b"
  "(+) $(add_mset$x${#})$b \<equiv> op_mset_insert$x$b"
  "(-) $b$(add_mset$x${#}) \<equiv> op_mset_delete$x$b"
  "(<) $0$(count$a$x) \<equiv> op_mset_contains$x$a"
  "(\<in>) $x$(set_mset$a) \<equiv> op_mset_contains$x$a"
  by (auto intro!: eq_reflection simp: algebra_simps)

locale mset_custom_empty =
  fixes rel empty and op_custom_empty :: "'a multiset"
  assumes customize_hnr_aux: "(uncurry0 empty,uncurry0 (RETURN (op_mset_empty::'a multiset))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a rel"
  assumes op_custom_empty_def: "op_custom_empty = op_mset_empty"
begin
  sepref_register op_custom_empty :: "'ax multiset"

  lemma fold_custom_empty:
    "{#} = op_custom_empty"
    "op_mset_empty = op_custom_empty"
    "mop_mset_empty = RETURN op_custom_empty"
    unfolding op_custom_empty_def by simp_all

  lemmas custom_hnr[sepref_fr_rules] = customize_hnr_aux[folded op_custom_empty_def]
end

end


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

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

theory Listn
imports Err
begin

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

definition le :: "'a ord \<Rightarrow> ('a list)ord" where
"le r == list_all2 (%x y. x <=_r y)"

abbreviation
  lesublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
       ("(_ /<=[_] _)" [50, 0, 51] 50)
  where "x <=[r] y == x <=_(le r) y"

abbreviation
  lesssublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
       ("(_ /<[_] _)" [50, 0, 51] 50)
  where "x <[r] y == x <_(le r) y"

definition map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
"map2 f == (%xs ys. map (case_prod f) (zip xs ys))"

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

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

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

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

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

lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list:
  "xs <=[r] ys == Listn.le r xs ys"
  by (simp add: lesub_def)

lemma Nil_le_conv [iff]:
  "([] <=[r] ys) = (ys = [])"
apply (unfold lesub_def Listn.le_def)
apply simp
done

lemma Cons_notle_Nil [iff]:
  "~ x#xs <=[r] []"
apply (unfold lesub_def Listn.le_def)
apply simp
done

lemma Cons_le_Cons [iff]:
  "x#xs <=[r] y#ys = (x <=_r y & xs <=[r] ys)"
apply (unfold lesub_def Listn.le_def)
apply simp
done

lemma Cons_less_Conss [simp]:
  "order r \<Longrightarrow>
  x#xs <_(Listn.le r) y#ys =
  (x <_r y & xs <=[r] ys  |  x = y & xs <_(Listn.le r) ys)"
apply (unfold lesssub_def)
apply blast
done

lemma list_update_le_cong:
  "\<lbrakk> i<size xs; xs <=[r] ys; x <=_r y \<rbrakk> \<Longrightarrow> xs[i:=x] <=[r] ys[i:=y]"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_conv_all_nth nth_list_update)
done

lemma le_listD:
  "\<lbrakk> xs <=[r] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p <=_r ys!p"
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_conv_all_nth)
done

lemma le_list_refl:
  "\<forall>x. x <=_r x \<Longrightarrow> xs <=[r] xs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done

lemma le_list_trans:
  "\<lbrakk> order r; xs <=[r] ys; ys <=[r] zs \<rbrakk> \<Longrightarrow> xs <=[r] zs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply clarify
apply simp
apply (blast intro: order_trans)
done

lemma le_list_antisym:
  "\<lbrakk> order r; xs <=[r] ys; ys <=[r] xs \<rbrakk> \<Longrightarrow> xs = ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (rule nth_equalityI)
 apply blast
apply clarify
apply simp
apply (blast intro: order_antisym)
done

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

lemma lesub_list_impl_same_size [simp]:
  "xs <=[r] ys \<Longrightarrow> size ys = size xs"
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_conv_all_nth)
done

lemma lesssub_list_impl_same_size:
  "xs <_(Listn.le r) ys \<Longrightarrow> size ys = size xs"
apply (unfold lesssub_def)
apply auto
done

lemma le_list_appendI:
  "\<And>b c d. a <=[r] b \<Longrightarrow> c <=[r] d \<Longrightarrow> a@c <=[r] b@d"
apply (induct a)
 apply simp
apply (case_tac b)
apply auto
done

lemma le_listI:
  "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> a!n <=_r b!n) \<Longrightarrow> a <=[r] b"
  apply (unfold lesub_def Listn.le_def)
  apply (simp add: list_all2_conv_all_nth)
  done

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

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

lemma less_lengthI:
  "\<lbrakk> xs \<in> list n A; p < n \<rbrakk> \<Longrightarrow> p < length xs"
  by simp

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

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

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

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

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

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

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

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

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

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

lemma plus_list_Nil [simp]:
  "[] +[f] xs = []"
apply (unfold plussub_def map2_def)
apply simp
done

lemma plus_list_Cons [simp]:
  "(x#xs) +[f] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x +_f y)#(xs +[f] ys))"
  by (simp add: plussub_def map2_def split: list.split)

lemma length_plus_list [rule_format, simp]:
  "\<forall>ys. length(xs +[f] ys) = min(length xs) (length ys)"
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done

lemma nth_plus_list [rule_format, simp]:
  "\<forall>xs ys i. length xs = n \<longrightarrow> length ys = n \<longrightarrow> i<n \<longrightarrow>
  (xs +[f] ys)!i = (xs!i) +_f (ys!i)"
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done

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

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

lemma (in Semilat) plus_list_lub [rule_format]:
shows "\<forall>xs ys zs. set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> set zs <= A
  \<longrightarrow> size xs = n & size ys = n \<longrightarrow>
  xs <=[r] zs & ys <=[r] zs \<longrightarrow> xs +[f] ys <=[r] zs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done

lemma (in Semilat) list_update_incr [rule_format]:
 "x\<in> A \<Longrightarrow> set xs <= A \<longrightarrow>
  (\<forall>i. i<size xs \<longrightarrow> xs <=[r] xs[i := x +_f xs!i])"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done

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

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

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

lemma Listn_sl: "\<And>L. semilat L \<Longrightarrow> semilat (Listn.sl n L)"
 by(simp add: Listn_sl_aux split_tupled_all)

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

lemma lem: "\<And>x xs. x +_(#) xs = x#xs"
  by (simp add: plussub_def)

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

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

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

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

lemma lift2_eq_ErrD:
  "\<lbrakk> x +_f y = Err; semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A \<rbrakk>
  \<Longrightarrow> ~(\<exists>u\<in> A. x <=_r u & y <=_r u)"
  by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1])

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

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (\<forall>x\<in> A. \<forall>y\<in> A. x +_f y \<in> err A)"
apply (unfold closed_def)
apply (simp add: err_def)
done

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

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

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

end


section \<open>Maps\<close>

theory Maps
imports Sequence_Zip
begin

  section \<open>Basics\<close>

  lemma fun_upd_None[simp]:
    assumes "p \<notin> dom f"
    shows "f (p := None) = f"
    using assms by auto

  (* TODO: this is a strictly stronger version of finite_set_of_finite_maps, move to library *)
  lemma finite_set_of_finite_maps':
    assumes "finite A" "finite B"
    shows "finite {m. dom m \<subseteq> A \<and> ran m \<subseteq> B}"
  proof -
    have "{m. dom m \<subseteq> A \<and> ran m \<subseteq> B} = (\<Union> \<A> \<in> Pow A. {m. dom m = \<A> \<and> ran m \<subseteq> B})" by auto
    also have "finite \<dots>" using finite_subset assms by (auto intro: finite_set_of_finite_maps)
    finally show ?thesis by this
  qed

  lemma fold_map_of:
    assumes "distinct xs"
    shows "fold (\<lambda> x (k, m). (Suc k, m (x \<mapsto> k))) xs (k, m) =
      (k + length xs, m ++ map_of (xs || [k ..< k + length xs]))"
  using assms
  proof (induct xs arbitrary: k m)
    case Nil
    show ?case by simp
  next
    case (Cons x xs)
    have "fold (\<lambda> x (k, m). (Suc k, m (x \<mapsto> k))) (x # xs) (k, m) =
      (Suc k + length xs, (m ++ map_of (xs || [Suc k ..< Suc k + length xs])) (x \<mapsto> k))"
      using Cons by (fastforce simp add: map_add_upd_left)
    also have "\<dots> = (k + length (x # xs), m ++ map_of (x # xs || [k ..< k + length (x # xs)]))"
      by (simp add: upt_rec)
    finally show ?case by this
  qed

  subsection \<open>Expanding set functions to sets of functions\<close>

  definition expand :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b) set" where
    "expand f = {g. \<forall> x. g x \<in> f x}"

  lemma expand_update[simp]:
    assumes "f x \<noteq> {}"
    shows "expand (f (x := S)) = (\<Union> y \<in> S. (\<lambda> g. g (x := y)) ` expand f)"
  unfolding expand_def
  proof (intro equalityI subsetI)
    fix g
    assume 1: "g \<in> {g. \<forall> y. g y \<in> (f (x := S)) y}"
    have 2: "g x \<in> S" "\<And> y. x \<noteq> y \<Longrightarrow> g y \<in> f y" using 1 by (auto split: if_splits)
    obtain y where 3: "y \<in> f x" using assms by auto
    show "g \<in> (\<Union> y \<in> S. (\<lambda> g. g (x := y)) ` {g. \<forall> x. g x \<in> f x})"
    proof (intro UN_I image_eqI)
      show "g x \<in> S" using 2(1) by this
      show "g (x := y) \<in> {g. \<forall> x. g x \<in> f x}" using 2 3 by auto
      show "g = g (x := y, x := g x)" by simp
    qed
  next
    fix g
    assume 1: "g \<in> (\<Union> y \<in> S. (\<lambda> g. g (x := y)) ` {g. \<forall> x. g x \<in> f x})"
    show "g \<in> {g. \<forall> y. g y \<in> (f (x := S)) y}" using 1 by auto
  qed

  subsection \<open>Expanding set maps into sets of maps\<close>

  definition expand_map :: "('a \<rightharpoonup> 'b set) \<Rightarrow> ('a \<rightharpoonup> 'b) set" where
    "expand_map f \<equiv> expand (case_option {None} (image Some) \<circ> f)"

  lemma expand_map_alt_def: "expand_map f =
    {g. dom g = dom f \<and> (\<forall> x S y. f x = Some S \<longrightarrow> g x = Some y \<longrightarrow> y \<in> S)}"
    unfolding expand_map_def expand_def by (auto split: option.splits) (force+)

  lemma expand_map_dom:
    assumes "g \<in> expand_map f"
    shows "dom g = dom f"
    using assms unfolding expand_map_def expand_def by (auto split: option.splits)

  lemma expand_map_empty[simp]: "expand_map Map.empty = {Map.empty}" unfolding expand_map_def expand_def by auto
  lemma expand_map_update[simp]:
    "expand_map (f (x \<mapsto> S)) = (\<Union> y \<in> S. (\<lambda> g. g (x \<mapsto> y)) ` expand_map (f (x := None)))"
  proof -
    let ?m = "case_option {None} (image Some)"
    have 1: "((?m \<circ> f) (x := {None})) x \<noteq> {}" by simp
    have "expand_map (f (x := Some S)) = expand_map (f (x := None, x := Some S))" by simp
    also have "\<dots> = expand ((?m \<circ> f) (x := {None}, x := ?m (Some S)))"
      unfolding expand_map_def fun_upd_comp by simp
    also have "\<dots> = (\<Union> y \<in> ?m (Some S). (\<lambda> g. g (x := y)) ` expand ((?m \<circ> f) (x := {None})))"
      using expand_update 1 by this
    also have "\<dots> = (\<Union> y \<in> S. (\<lambda> g. g (x \<mapsto> y)) ` expand_map (f (x := None)))"
      unfolding expand_map_def fun_upd_comp by simp
    finally show ?thesis by this
  qed

end


section \<open>Sets of maps\<close>
theory MapSets
imports SetMap Utils
begin

text \<open>
In the section about the finiteness of the argument space, we need the fact that the set of maps from a finite domain to a finite range is finite, and the same for the set-valued maps defined in @{theory "Shivers-CFA.SetMap"}. Both these sets are defined (\<open>maps_over\<close>, \<open>smaps_over\<close>) and the finiteness is shown.
\<close>

definition maps_over :: "'a::type set \<Rightarrow> 'b::type set \<Rightarrow> ('a \<rightharpoonup> 'b) set"
  where "maps_over A B = {m. dom m \<subseteq> A \<and> ran m \<subseteq> B}"

lemma maps_over_empty[simp]:
  "Map.empty \<in> maps_over A B"
unfolding maps_over_def by simp

lemma maps_over_upd:
  assumes "m \<in> maps_over A B"
  and "v \<in> A" and "k \<in> B"
shows "m(v \<mapsto> k) \<in> maps_over A B"
  using assms unfolding maps_over_def
  by (auto dest: subsetD[OF ran_upd])

lemma maps_over_finite[intro]:
  assumes "finite A" and "finite B" shows "finite (maps_over A B)"
proof-
  have inj_map_graph: "inj (\<lambda>f. {(x, y). Some y = f x})"
  proof (induct rule: inj_onI)
    case (1 x y)
    from "1.hyps"(3) have hyp: "\<And> a b. (Some b = x a) \<longleftrightarrow> (Some b = y a)"
      by (simp add: set_eq_iff)
    show ?case
    proof (rule ext)
    fix z show "x z = y z"
      using hyp[of _ z]
      by (cases "x z", cases "y z", auto)
    qed
  qed

  have "(\<lambda>f. {(x, y). Some y = f x}) ` maps_over A B \<subseteq> Pow( A \<times> B )" (is "?graph \<subseteq> _")
    unfolding maps_over_def
    by (auto dest!:subsetD[of _ A] subsetD[of _ B] intro:ranI)
  moreover
  have "finite (Pow( A \<times> B ))" using assms by auto
  ultimately
  have "finite ?graph" by (rule finite_subset)
  thus ?thesis
    by (rule finite_imageD[OF _ subset_inj_on[OF inj_map_graph subset_UNIV]])
qed

definition smaps_over :: "'a::type set \<Rightarrow> 'b::type set \<Rightarrow> ('a \<Rightarrow> 'b set) set"
  where "smaps_over A B = {m. sdom m \<subseteq> A \<and> sran m \<subseteq> B}"

lemma smaps_over_empty[simp]:
  "{}. \<in> smaps_over A B"
unfolding smaps_over_def by simp

lemma smaps_over_singleton:
  assumes "k \<in> A" and "vs \<subseteq> B"
shows "{k := vs}. \<in> smaps_over A B"
  using assms unfolding smaps_over_def
  by(auto dest: subsetD[OF sdom_singleton])

lemma smaps_over_un:
  assumes "m1 \<in> smaps_over A B" and "m2 \<in> smaps_over A B"
  shows "m1 \<union>. m2 \<in> smaps_over A B"
using assms unfolding smaps_over_def
by (auto simp add:smap_union_def)

lemma smaps_over_Union:
  assumes "set ms \<subseteq> smaps_over A B"
  shows "\<Union>.ms \<in> smaps_over A B"
using assms
by (induct ms)(auto intro: smaps_over_un)

lemma smaps_over_im:
 "\<lbrakk> f \<in> m a ; m \<in> smaps_over A B \<rbrakk> \<Longrightarrow> f \<in> B"
unfolding smaps_over_def by (auto simp add:sran_def)

lemma smaps_over_finite[intro]:
  assumes "finite A" and "finite B" shows "finite (smaps_over A B)"
proof-
  have inj_smap_graph: "inj (\<lambda>f. {(x, y). y = f x \<and> y \<noteq> {}})" (is "inj ?gr")
  proof (induct rule: inj_onI)
    case (1 x y)
    from "1.hyps"(3) have hyp: "\<And> a b. (b = x a \<and> b \<noteq> {}) = (b = y a \<and> b \<noteq> {})"
      by -(subst (asm) (3) set_eq_iff, simp)
    show ?case
    proof (rule ext)
    fix z show "x z = y z"
      using hyp[of _ z]
      by (cases "x z \<noteq> {}", cases "y z \<noteq> {}", auto)
    qed
  qed

  have "?gr ` smaps_over A B \<subseteq> Pow( A \<times> Pow  B )" (is "?graph \<subseteq> _")
    unfolding smaps_over_def
    by (auto dest!:subsetD[of _ A] subsetD[of _ "Pow B"] sdom_not_mem intro:sranI)
  moreover
  have "finite (Pow( A \<times> Pow B ))" using assms by auto
  ultimately
  have "finite ?graph" by (rule finite_subset)
  thus ?thesis
    by (rule finite_imageD[OF _ subset_inj_on[OF inj_smap_graph subset_UNIV]])
qed

end


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


theory T13
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. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory week03A_demo imports Main begin

\<comment> \<open> ------------------------------------ \<close>

\<comment> \<open>  {* Quantifier reasoning *} \<close>

\<comment> \<open> {* A successful proof: *} \<close>
lemma "\<forall>a. \<exists>b. a = b"
  apply (rule allI) thm exI
  apply (rule_tac  x=a in exI)
  apply (rule refl)
  done

\<comment> \<open> {* An unsuccessful proof: *} \<close>
lemma "\<exists>y. \<forall>x. x = y"
apply(rule exI)
apply(rule allI) thm refl
apply(rule refl)
oops

\<comment> \<open> {* Intro and elim reasoning: *} \<close>
lemma "\<exists>b. \<forall>a. P a b \<Longrightarrow> \<forall>a. \<exists>b. P a b"
  apply (rule allI)
  apply (erule exE)
  apply (erule_tac x=a in allE)
  apply (rule_tac x=b in  exI)
  apply assumption
  done
 (* the safe rules first! *)
 (* (check what happens if you use unsafe rule too early) *)

\<comment> \<open>  {* Instantiation in more detail: *} \<close>

\<comment> \<open> {* Instantiating allE: *} \<close>
lemma "\<forall>x. P x \<Longrightarrow> P 37"
  thm allE
  apply (erule_tac x="37" in allE )
  apply assumption
  done

\<comment> \<open> {* Instantiating exI: *} \<close>

lemma "\<exists>n. P (f n) \<Longrightarrow> \<exists>m. P m"
  apply (erule exE) thm exI
  apply (rule_tac  x="f n"  in exI)
  apply assumption
  done

\<comment> \<open> {* Instantiation removes ambiguity: *} \<close>
lemma "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
  apply(erule_tac P = "C" and Q="D" in conjE)
(* without instantiation, the wrong one is chosen (first) *)
apply assumption
done

\<comment> \<open>  {* Instantiation with "where" and "of" *} \<close>

thm conjI
thm conjI [of "A" "B"]
thm conjI [where Q = "f x"]

\<comment> \<open>  ---------------------------------------------- \<close>

\<comment> \<open> {* Renaming parameters: *} \<close>

lemma "\<And>x y z. P x y z"
apply(rename_tac a b)
oops

lemma "\<forall>x. P x \<Longrightarrow> \<forall>x. \<forall>x. P x"
  apply (rule allI) thm allI
  apply (rule allI)
  apply (rename_tac y)
  apply (erule_tac x=y in allE)
  apply assumption
  done

\<comment> \<open>  {* Forward reasoning: drule/frule/OF/THEN*} \<close>

lemma "A \<and> B \<Longrightarrow> \<not> \<not> A"
thm conjunct1
apply (drule conjunct1) thm notI
apply (rule notI) thm notE
apply (erule notE)
apply assumption
done

lemma "\<forall>x. P x \<Longrightarrow> P t \<and> P t'"

  apply (frule_tac x="t" in spec)
  apply (drule_tac x="t'" in spec)
  apply (rule conjI)
   apply assumption
  apply assumption
  done

thm dvd_add dvd_refl
thm dvd_add [OF dvd_refl]
thm dvd_add [OF dvd_refl dvd_refl]

\<comment> \<open>  --------------------------------------------- \<close>

\<comment> \<open>  {* Epsilon *} \<close>

lemma "(\<exists>x. P x) = P (SOME x. P x)"
  apply (rule iffI)
  apply (erule exE)
   apply (rule_tac x="x" in someI)
   apply assumption
  apply (rule_tac x="(SOME x. P x)" in exI)
  apply assumption
  done

\<comment> \<open>  {* Automation *} \<close>

lemma "\<forall>x y. P x y \<and> Q x y \<and> R x y"
apply (intro allI conjI)
oops

lemma "\<forall>x y. P x y \<and> Q x y \<and> R x y"
apply clarify
oops

lemma "\<forall>x y. P x y \<and> Q x y \<and> R x y"
apply safe
oops

lemma "\<exists>y. \<forall>x. P x y \<Longrightarrow> \<forall>x. \<exists>y. P x y"
apply blast
done

lemma "\<exists>y. \<forall>x. P x y \<Longrightarrow> \<forall>x. \<exists>y. P x y"
apply fast
done

\<comment> \<open>  --------------------------------------------- \<close>

\<comment> \<open>  {* Exercises *} \<close>

\<comment> \<open>  "Quantifier scope is important:" \<close>
lemma "(\<forall>x. P x \<longrightarrow> Q) = ((\<exists>x. P x) \<longrightarrow> Q)"
  apply(rule iffI)
   apply(rule impI)
   apply(erule exE)
   apply (erule_tac x=x in allE)
   apply (erule mp)
   apply assumption
  apply(rule allI)
  apply (rule impI)
  apply (erule impE)
   apply (rule_tac x=x in exI)
   apply assumption
  apply assumption
  done

\<comment> \<open> {*
   Derive the axiom of choice from the SOME operator (using the rule someI), i.e.
   using only the rules: allI, allE, exI, exE and someI; with only the
   proof methods: rule, erule, rule_tac, erule_tac and assumption, prove:
*} \<close>
thm someI [where P="f" and x="x"]

lemma choice:
  "\<forall>x. \<exists>y. R x y \<Longrightarrow> \<exists>f. \<forall>x. R x (f x)"
  apply (rule exI)
  apply (rule allI)
  apply (erule allE)
  apply (erule exE)
  apply (erule someI)
  done

end


theory HoArithUtils
  imports Main
begin

lemma general_theorem:
  fixes P f and l :: nat
  assumes "(\<forall>p. P p \<and> f p > l \<longrightarrow> (\<exists>p'. P p' \<and> f p' < f p))"
  shows "(\<forall>p. P p \<longrightarrow> (\<exists>p'. P p' \<and> f p' \<le> l))"
proof-
  have "\<forall>p. (n = f p) \<and> P p \<longrightarrow> (\<exists>p'. P p' \<and> f p' \<le> l)" for n
    apply(rule Nat.nat_less_induct[where ?P = "%n. \<forall>p. (n = f p) \<and> P p \<longrightarrow> (\<exists>p'. P p' \<and> f p' \<le> l)"])
    by (metis assms not_less)
  then show ?thesis by auto
qed

end


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

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

datatype Nat = Z | S "Nat"

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

fun rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) y = y"
| "rotate (S z) (nil2) = nil2"
| "rotate (S z) (cons2 z2 xs1) = rotate z (snoc z2 xs1)"

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

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

theorem property0 :
  "((rotate (length xs) xs) = xs)"
  oops

end


header {* Square Root Upper and Lower Bounds *}

theory Sqrt_Bounds
imports Bounds_Lemmas
        "~~/src/HOL/Library/Sum_of_Squares"

begin

text{*Covers all bounds used in sqrt-upper.ax, sqrt-lower.ax and sqrt-extended.ax.*}

section{*Upper bounds*}

primrec sqrtu :: "[real,nat] \<Rightarrow> real" where
  "sqrtu x 0 = (x+1)/2"
| "sqrtu x (Suc n) = (sqrtu x n + x/sqrtu x n) / 2"

lemma sqrtu_upper: "x \<le> sqrtu x n ^ 2"
using assms
proof (induction n)
  case 0 show ?case
    apply (simp add: power2_eq_square)
    apply (sos "(((A<0 * R<1) + (R<1 * (R<1 * [~1*x + 1]^2))))")
    done
next
  case (Suc n)
  have xy: "\<And>y. \<lbrakk>x \<le> y * y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * (2 * (y * y)) \<le> x * x + y * (y * (y * y))"
    by (sos "(((((A<0 * A<1) * R<1) + ((A<0 * R<1) * (R<1 * [~1*y^2 + x]^2)))) &
                   ((((A<0 * A<1) * R<1) + ((A<0 * R<1) * (R<1 * [~1*y^2 + x]^2)))))")
  show ?case using Suc
    by (auto simp: power2_eq_square algebra_simps divide_simps xy)
qed

lemma sqrtu_numeral:
  "sqrtu x (numeral n) = (sqrtu x (pred_numeral n) + x/sqrtu x (pred_numeral n)) / 2"
  by (simp add: numeral_eq_Suc)

lemma sqrtu_gt_0: "x \<ge> 0 \<Longrightarrow> sqrtu x n > 0"
apply (induct n)
apply (auto simp: field_simps)
by (metis add_strict_increasing2 mult_zero_left not_real_square_gt_zero)

theorem gen_sqrt_upper: "0 \<le> x \<Longrightarrow> sqrt x \<le> sqrtu x n"
using real_sqrt_le_mono [OF sqrtu_upper [of x n]]
by auto (metis abs_of_nonneg dual_order.strict_iff_order sqrtu_gt_0)

lemma sqrt_upper_bound_0:
  assumes "x \<ge> 0" shows "sqrt x \<le> (x+1)/2" (is "_ \<le> ?rhs")
proof -
  have "sqrt x \<le> sqrtu x 0"
    by (metis assms gen_sqrt_upper)
  also have "... = ?rhs"
    by (simp add: divide_simps)
  finally show ?thesis .
qed

lemma sqrt_upper_bound_1:
  assumes "x \<ge> 0" shows "sqrt x \<le> (1/4)*(x^2+6*x+1) / (x+1)" (is "_ \<le> ?rhs")
proof -
  have "sqrt x \<le> sqrtu x 1"
    by (metis assms gen_sqrt_upper)
  also have "... = ?rhs"
    by (simp add: divide_simps) algebra
  finally show ?thesis .
qed

lemma sqrtu_2_eq:
   "sqrtu x 2 = (1/8)*(x^4 + 28*x^3 + 70*x^2 + 28*x + 1) / ((x + 1)*(x^2 + 6*x + 1))"
  by (simp add: sqrtu_numeral divide_simps) algebra

lemma sqrt_upper_bound_2:
  assumes "x \<ge> 0"
    shows "sqrt x \<le> (1/8)*(x^4 + 28*x^3 + 70*x^2 + 28*x + 1) / ((x + 1)*(x^2 + 6*x + 1))"
  by (metis assms gen_sqrt_upper sqrtu_2_eq)

lemma sqrtu_4_eq:
   "x \<ge> 0 \<Longrightarrow>
    sqrtu x 4 = (1/32)*(225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)
             / ((x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))"
  by (simp add: sqrtu_numeral divide_simps add_nonneg_eq_0_iff) algebra

lemma sqrt_upper_bound_4:
  assumes "x \<ge> 0"
    shows "sqrt x \<le> (1/32)*(225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)
             / ((x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))"
  by (metis assms gen_sqrt_upper sqrtu_4_eq)

lemma gen_sqrt_upper_scaled:
  assumes "0 \<le> x" "0 < u"
    shows "sqrt x \<le> sqrtu (x*u^2) n / u"
proof -
  have "sqrt x = sqrt x * sqrt (u^2) / u"
    using assms
    by simp
  also have "... = sqrt (x*u^2) / u"
    by (metis real_sqrt_mult_distrib2)
  also have "... \<le> sqrtu (x*u^2) n / u"
    using assms
    by (simp add: divide_simps) (metis gen_sqrt_upper zero_le_mult_iff zero_le_power2)
  finally show ?thesis .
qed

lemma sqrt_upper_bound_2_small:
  assumes "0 \<le> x"
    shows "sqrt x \<le> (1/32)*(65536*x^4 + 114688*x^3 + 17920*x^2 + 448*x + 1) / ((16*x + 1)*(256*x^2 + 96*x + 1))"
apply (rule order_trans [OF gen_sqrt_upper_scaled [of x 4 2] eq_refl])
using assms
apply (auto simp: sqrtu_2_eq )
apply (simp add: divide_simps)
apply algebra
done

lemma sqrt_upper_bound_2_large:
  assumes "0 \<le> x"
    shows "sqrt x \<le> (1/32)*(65536 + 114688*x + 17920*x^2 + 448*x^3 + x^4) / ((x + 16)*(256 + 96*x + x^2))"
apply (rule order_trans [OF gen_sqrt_upper_scaled [of x "1/4" 2] eq_refl])
using assms
apply (auto simp: sqrtu_2_eq )
apply (simp add: divide_simps)
apply algebra
done

section{*Lower bounds*}

lemma sqrt_lower_bound_id:
  assumes "0 \<le> x" "x \<le> 1"
    shows "x \<le> sqrt x"
proof -
  have "x^2 \<le> x" using assms
    by (metis one_le_numeral power_decreasing power_one_right)
  then show ?thesis
    by (metis real_le_rsqrt)
qed

definition sqrtl :: "[real,nat] \<Rightarrow> real" where
  "sqrtl x n = x/sqrtu x n"

lemma sqrtl_lower: "0 \<le> x \<Longrightarrow> sqrtl x n ^ 2 \<le> x"
  unfolding sqrtl_def using sqrtu_upper [of x n]
  by (auto simp: power2_eq_square divide_simps mult_left_mono)

theorem gen_sqrt_lower:  "0 \<le> x \<Longrightarrow> sqrtl x n \<le> sqrt x"
using real_sqrt_le_mono [OF sqrtl_lower [of x n]]
by auto

lemma sqrt_lower_bound_0:
  assumes "x \<ge> 0" shows "2*x/(x+1) \<le> sqrt x" (is "?lhs \<le> _")
proof -
  have "?lhs = sqrtl x 0"
    by (simp add: sqrtl_def)
  also have "... \<le> sqrt x"
    by (metis assms gen_sqrt_lower)
  finally show ?thesis .
qed

lemma sqrt_lower_bound_1:
  assumes "x \<ge> 0" shows "4*x*(x+1) / (x^2+6*x+1) \<le> sqrt x" (is "?lhs \<le> _")
proof -
  have "?lhs = sqrtl x 1" using assms
    by (simp add: sqrtl_def power_eq_if algebra_simps divide_simps)
  also have "... \<le> sqrt x"
    by (metis assms gen_sqrt_lower)
  finally show ?thesis .
qed

lemma sqrt_lower_bound_2:
  assumes "x \<ge> 0"
    shows "8*x*(x + 1)*(x^2 + 6*x + 1) / (x^4 + 28*x^3 + 70*x^2 + 28*x + 1) \<le> sqrt x"
  by (metis assms sqrtl_2_eq gen_sqrt_lower)

lemma sqrtl_4_eq: "x \<ge> 0 \<Longrightarrow>
  sqrtl x 4
    = (32*x*(x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))
    / (225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)"
  using sqrtu_gt_0 [of x 4]
  by (simp add: sqrtl_def sqrtu_4_eq)

lemma sqrt_lower_bound_4:
  assumes "x \<ge> 0"
    shows "(32*x*(x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))
           / (225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)
           \<le> sqrt x"
  by (metis assms sqrtl_4_eq gen_sqrt_lower)

lemma gen_sqrt_lower_scaled:
  assumes "0 \<le> x" "0 < u"
    shows "sqrtl (x*u^2) n / u \<le> sqrt x"
proof -
  have "sqrtl (x*u^2) n / u \<le> sqrt (x*u^2) / u"
    using assms
    by (simp add: divide_simps) (metis gen_sqrt_lower zero_le_mult_iff zero_le_power2)
  also have "... = sqrt x * sqrt (u^2) / u"
    by (metis real_sqrt_mult_distrib2)
  also have "... = sqrt x"
    using assms
    by simp
  finally show ?thesis .
qed

lemma sqrt_lower_bound_2_small:
  assumes "0 \<le> x"
    shows "32*x*(16*x + 1)*(256*x^2 + 96*x + 1) / (65536*x^4 + 114688*x^3 + 17920*x^2 + 448*x + 1) \<le> sqrt x"
apply (rule order_trans [OF eq_refl gen_sqrt_lower_scaled [of x 4 2]])
using assms
apply (auto simp: sqrtl_2_eq )
apply (simp add: divide_simps)
apply algebra
done

lemma sqrt_lower_bound_2_large:
  assumes "0 \<le> x"
    shows "32*x*(x + 16)*(x^2 + 96*x + 256) / (x^4 + 448*x^3 + 17920*x^2 + 114688*x + 65536) \<le> sqrt x"
apply (rule order_trans [OF eq_refl gen_sqrt_lower_scaled [of x "1/4" 2]])
using assms
apply (auto simp: sqrtl_2_eq)
apply (simp add: divide_simps)
done

end


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

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Plus p q) s) = ((recognise p s) | (recognise q s)))"
  oops

end


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

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

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

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

fun pairs :: "int list => int list => int list" where
"pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
"stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
by pat_completeness auto

fun count :: "'a => 'a list => int" where
"count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

(*fun did not finish the proof*)
function bmerge :: "int list => int list => int list" where
"bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: int list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "int list => int list" where
"bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
by pat_completeness auto

theorem property0 :
  "((count y (bsort xs)) = (count y xs))"
  oops

end


(* Title:      Approximation
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Approximation\<close>

theory Approximation

imports Stone_Kleene_Relation_Algebras.Iterings

begin

nitpick_params [timeout = 600]

class apx =
  fixes apx :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)

class apx_order = apx +
  assumes apx_reflexive: "x \<sqsubseteq> x"
  assumes apx_antisymmetric: "x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> x = y"
  assumes apx_transitive: "x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z"

sublocale apx_order < apx: order where less_eq = apx and less = "\<lambda>x y . x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x"
  apply unfold_locales
  apply simp
  apply (rule apx_reflexive)
  using apx_transitive apply blast
  by (simp add: apx_antisymmetric)

context apx_order
begin

abbreviation the_apx_least_fixpoint    :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<kappa> _" [201] 200)  where "\<kappa>  f \<equiv> apx.the_least_fixpoint f"
abbreviation the_apx_least_prefixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("p\<kappa> _" [201] 200) where "p\<kappa> f \<equiv> apx.the_least_prefixpoint f"

definition is_apx_meet  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"          where "is_apx_meet x y z \<equiv> z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<and> (\<forall>w . w \<sqsubseteq> x \<and> w \<sqsubseteq> y \<longrightarrow> w \<sqsubseteq> z)"
definition has_apx_meet :: "'a \<Rightarrow> 'a \<Rightarrow> bool"                where "has_apx_meet x y \<equiv> \<exists>z . is_apx_meet x y z"
definition the_apx_meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<triangle>" 66) where "x \<triangle> y \<equiv> THE z . is_apx_meet x y z"

lemma apx_meet_unique:
  "has_apx_meet x y \<Longrightarrow> \<exists>!z . is_apx_meet x y z"
  by (meson apx_antisymmetric has_apx_meet_def is_apx_meet_def)

lemma apx_meet:
  assumes "has_apx_meet x y"
    shows "is_apx_meet x y (x \<triangle> y)"
proof -
  have "is_apx_meet x y (THE z . is_apx_meet x y z)"
    by (metis apx_meet_unique assms theI)
  thus ?thesis
    by (simp add: the_apx_meet_def)
qed

lemma apx_greatest_lower_bound:
  "has_apx_meet x y \<Longrightarrow> (w \<sqsubseteq> x \<and> w \<sqsubseteq> y \<longleftrightarrow> w \<sqsubseteq> x \<triangle> y)"
  by (meson apx_meet apx_transitive is_apx_meet_def)

lemma apx_meet_same:
  "is_apx_meet x y z \<Longrightarrow> z = x \<triangle> y"
  using apx_meet apx_meet_unique has_apx_meet_def by blast

lemma apx_meet_char:
  "is_apx_meet x y z \<longleftrightarrow> has_apx_meet x y \<and> z = x \<triangle> y"
  using apx_meet_same has_apx_meet_def by auto

end

class apx_biorder = apx_order + order
begin

lemma mu_below_kappa:
  "has_least_fixpoint f \<Longrightarrow> apx.has_least_fixpoint f \<Longrightarrow> \<mu> f \<le> \<kappa> f"
  using apx.mu_unfold is_least_fixpoint_def least_fixpoint by auto

lemma kappa_below_nu:
  "has_greatest_fixpoint f \<Longrightarrow> apx.has_least_fixpoint f \<Longrightarrow> \<kappa> f \<le> \<nu> f"
  by (meson apx.mu_unfold greatest_fixpoint is_greatest_fixpoint_def)

lemma kappa_apx_below_mu:
  "has_least_fixpoint f \<Longrightarrow> apx.has_least_fixpoint f \<Longrightarrow> \<kappa> f \<sqsubseteq> \<mu> f"
  using apx.is_least_fixpoint_def apx.least_fixpoint mu_unfold by auto

lemma kappa_apx_below_nu:
  "has_greatest_fixpoint f \<Longrightarrow> apx.has_least_fixpoint f \<Longrightarrow> \<kappa> f \<sqsubseteq> \<nu> f"
  by (metis apx.is_least_fixpoint_def apx.least_fixpoint nu_unfold)

end

class apx_semiring = apx_biorder + idempotent_left_semiring + L +
  assumes apx_L_least: "L \<sqsubseteq> x"
  assumes sup_apx_left_isotone: "x \<sqsubseteq> y \<longrightarrow> x \<squnion> z \<sqsubseteq> y \<squnion> z"
  assumes mult_apx_left_isotone: "x \<sqsubseteq> y \<longrightarrow> x * z \<sqsubseteq> y * z"
  assumes mult_apx_right_isotone: "x \<sqsubseteq> y \<longrightarrow> z * x \<sqsubseteq> z * y"
begin

lemma sup_apx_right_isotone:
  "x \<sqsubseteq> y \<Longrightarrow> z \<squnion> x \<sqsubseteq> z \<squnion> y"
  by (simp add: sup_apx_left_isotone sup_commute)

lemma sup_apx_isotone:
  "w \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> w \<squnion> x \<sqsubseteq> y \<squnion> z"
  by (meson apx_transitive sup_apx_left_isotone sup_apx_right_isotone)

lemma mult_apx_isotone:
  "w \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> w * x \<sqsubseteq> y * z"
  by (meson apx_transitive mult_apx_left_isotone mult_apx_right_isotone)

lemma affine_apx_isotone:
  "apx.isotone (\<lambda>x . y * x \<squnion> z)"
  by (simp add: apx.isotone_def mult_apx_right_isotone sup_apx_left_isotone)

end

end


theory MVT_Ex
imports
  "~~/src/HOL/Multivariate_Analysis/Multivariate_Analysis"
  "~~/src/HOL/Decision_Procs/Approximation"
  "../ODE_Auxiliarities"
begin

subsection {* (Counter)Example of Mean Value Theorem in Euclidean Space *}
text {* \label{sec:countermvt} *}

text {* There is no exact analogon of the mean value theorem in the multivariate case! *}

lemma MVT_wrong: assumes
    "\<And>J a u (f::real*real\<Rightarrow>real*real).
      (\<And>x. FDERIV f x :> J x) \<Longrightarrow>
      (\<exists>t\<in>{0<..<1}. f (a + u) - f a = J (a + t *\<^sub>R u) u)"
  shows "False"
proof -
  have "\<And>t::real*real. FDERIV (\<lambda>t. (cos (fst t), sin (fst t))) t :> (\<lambda>h. (- ((fst h) * sin (fst t)), (fst h) * cos (fst t)))"
    by (auto intro!: derivative_eq_intros)
  from assms[OF this, of "(1, 1)" "(1, 1)"] obtain t where t: "0 < t" "t < 1" and
    "cos 1 - cos 2 = sin (1 + t)" "sin 2 - sin 1 = cos (1 + t)"
    by auto
  moreover have "t \<in> {0..0.3} \<longrightarrow> cos (1 + t) > sin 2 - sin 1"
    "t \<in> {0.3..0.7} \<longrightarrow> sin (1 + t) > cos 1 - cos 2"
    "t \<in> {0.7..0.9} \<longrightarrow> cos (1 + t) < sin 2 - sin 1"
    "t \<in> {0.9..1} \<longrightarrow> sin (1 + t) < cos 1 - cos 2"
  by (approximation 80)+
  ultimately show ?thesis by auto
qed

lemma MVT_wrong2: assumes
    "\<And>J a u (f::real*real\<Rightarrow>real*real).
      (\<And>x. FDERIV f x :> J x) \<Longrightarrow>
      (\<exists>x \<in> {a..a+u}. f (a + u) - f a = J x u)"
  shows "False"
proof -
  have "\<And>t::real*real. FDERIV (\<lambda>t. (cos (fst t), sin (fst t))) t :> (\<lambda>h. (- ((fst h) * sin (fst t)), (fst h) * cos (fst t)))"
    by (auto intro!: derivative_eq_intros)
  from assms[OF this, of "(1, 1)" "(1, 1)"] obtain x where x: "1 \<le> x" "x \<le> 2" and
    "cos 2 - cos 1 = - sin x" "sin 2 - sin 1 = cos x"
    by auto
  moreover have
    "x \<in> {1 .. 1.5} \<longrightarrow> cos x > sin 2 - sin 1"
    "x \<in> {1.5 .. 1.6} \<longrightarrow> - sin x < cos 2 - cos 1"
    "x \<in> {1.6 .. 2} \<longrightarrow> cos x < sin 2 - sin 1"
    by (approximation 80)+
  ultimately show ?thesis by auto
qed

lemma MVT_corrected:
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::euclidean_space"
  assumes fderiv: "\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D)"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> a + x *\<^sub>R u \<in> D"
  shows "(\<exists>t\<in>Basis\<rightarrow>{0<..<1}. (f (a + u) - f a) = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i))"
proof -
  {
    fix i::'b
    assume "i \<in> Basis"
    have subset: "((\<lambda>x. a + x *\<^sub>R u) ` {0..1}) \<subseteq> D"
      using line_in by force
    have "\<forall>x\<in> {0 .. 1}. ((\<lambda>b. f (a + b *\<^sub>R u) \<bullet> i) has_derivative (\<lambda>b. b *\<^sub>R J (a + x *\<^sub>R u) u \<bullet> i)) (at x within {0..1})"
      using line_in
      by (auto intro!: derivative_eq_intros
        has_derivative_subset[OF _ subset]
        has_derivative_in_compose[where f="\<lambda>x. a + x *\<^sub>R u"]
        fderiv line_in
        simp add: linear.scaleR[OF has_derivative_linear[OF fderiv]])
    with zero_less_one
    have "\<exists>x\<in>{0<..<1}. f (a + 1 *\<^sub>R u) \<bullet> i - f (a + 0 *\<^sub>R u) \<bullet> i = (1 - 0) *\<^sub>R J (a + x *\<^sub>R u) u \<bullet> i"
      by (rule mvt_simple)
  }
  then obtain t where "\<forall>i\<in>Basis. t i \<in> {0<..<1} \<and> f (a + u) \<bullet> i - f a \<bullet> i = J (a + t i *\<^sub>R u) u \<bullet> i"
    by atomize_elim (force intro!: bchoice)
  hence "t \<in> Basis \<rightarrow> {0<..<1}" "\<And>i. i \<in> Basis \<Longrightarrow> (f (a + u) - f a) \<bullet> i = J (a + t i *\<^sub>R u) u \<bullet> i"
    by (auto simp: inner_diff_left)
  moreover hence "(f (a + u) - f a) = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i)"
    by (intro euclidean_eqI[where 'a='b]) simp
  ultimately show ?thesis by blast
qed

lemma MVT_ivl:
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
  assumes fderiv: "\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D)"
  assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x u \<in> {J0 .. J1}"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> a + x *\<^sub>R u \<in> D"
  shows "f (a + u) - f a \<in> {J0..J1}"
proof -
  from MVT_corrected[OF fderiv line_in] obtain t where
    t: "t\<in>Basis \<rightarrow> {0<..<1}" and
    mvt: "f (a + u) - f a = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i)"
    by auto
  note mvt
  also have "\<dots> \<in> {J0 .. J1}"
  proof -
    have J: "\<And>i. i \<in> Basis \<Longrightarrow> J0 \<le> J (a + t i *\<^sub>R u) u"
            "\<And>i. i \<in> Basis \<Longrightarrow> J (a + t i *\<^sub>R u) u \<le> J1"
      using J_ivl t line_in by (auto simp: Pi_iff)
    show ?thesis
      using J
      unfolding atLeastAtMost_iff eucl_le[where 'a='b]
      by auto
  qed
  finally show ?thesis .
qed

lemma MVT:
  shows
  "\<And>J J0 J1 a u (f::real*real\<Rightarrow>real*real).
    (\<And>x. FDERIV f x :> J x) \<Longrightarrow>
    (\<And>x. J x u \<in> {J0 .. J1}) \<Longrightarrow>
    f (a + u) - f a \<in> {J0 .. J1}"
  by (rule_tac J = J in MVT_ivl[where D=UNIV]) auto

lemma MVT_ivl':
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
  assumes fderiv: "(\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D))"
  assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x (a - b) \<in> {J0..J1}"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> b + x *\<^sub>R (a - b) \<in> D"
  shows "f a \<in> {f b + J0..f b + J1}"
proof -
  have "f (b + (a - b)) - f b \<in> {J0 .. J1}"
    apply (rule MVT_ivl[OF fderiv ])
    apply assumption
    apply (rule J_ivl) apply assumption
    using line_in
    apply (auto simp: diff_le_eq le_diff_eq ac_simps)
    done
  thus ?thesis
    by (auto simp: diff_le_eq le_diff_eq ac_simps)
qed

end


(*
  File:     Gaussian_Integers_Pythagorean_Triples.thy
  Author:   Manuel Eberl, TU München

  Application of Gaussian integers to deriving Euclid's formula for primitive Pythagorean triples
*)
subsection \<open>Primitive Pythagorean triples\<close>
theory Gaussian_Integers_Pythagorean_Triples
  imports Gaussian_Integers
begin

text \<open>
  In this section, we derive Euclid's formula for primitive Pythagorean triples using
  Gaussian integers, following Stillwell~\<^cite>\<open>"stillwell"\<close>.
\<close>
definition prim_pyth_triple :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "prim_pyth_triple x y z \<longleftrightarrow> x > 0 \<and> y > 0 \<and> coprime x y \<and> x\<^sup>2 + y\<^sup>2 = z\<^sup>2"

lemma prim_pyth_triple_commute: "prim_pyth_triple x y z \<longleftrightarrow> prim_pyth_triple y x z"
  by (simp add: prim_pyth_triple_def coprime_commute add_ac conj_ac)

lemma prim_pyth_triple_aux:
  fixes u v :: nat
  assumes "v \<le> u"
  shows "(2 * u * v) ^ 2 + (u ^ 2 - v ^ 2) ^ 2 = (u ^ 2 + v ^ 2) ^ 2"
proof -
  have "int ((2 * u * v) ^ 2 + (u ^ 2 - v ^ 2) ^ 2) =
        (2 * int u * int v) ^ 2 + (int u ^ 2 - int v ^ 2) ^ 2"
    using assms by (simp add: of_nat_diff)
  also have "\<dots> = (int u ^ 2 + int v ^ 2) ^ 2"
    by (simp add: power2_eq_square algebra_simps)
  also have "\<dots> = int ((u ^ 2 + v ^ 2) ^ 2)"
    by simp
  finally show ?thesis
    by (simp only: of_nat_eq_iff)
qed

lemma prim_pyth_tripleI1:
  assumes "0 < v" "v < u" "coprime u v" "\<not>(odd u \<and> odd v)"
  shows   "prim_pyth_triple (2 * u * v) (u\<^sup>2 - v\<^sup>2) (u\<^sup>2 + v\<^sup>2)"
proof -
  have "v ^ 2 < u ^ 2"
    using assms by (intro power_strict_mono) auto
  hence "\<not>u ^ 2 < v ^ 2" by linarith

  from assms have "coprime (int u) (int v ^ 2)"
    by auto
  hence "coprime (int u) (int u * int u + (-(int v ^ 2)))"
    unfolding coprime_iff_gcd_eq_1 by (subst gcd_add_mult) auto
  also have "int u * int u + (-(int v ^ 2)) = int (u ^ 2 - v ^ 2)"
    using \<open>v < u\<close> by (simp add: of_nat_diff flip: power2_eq_square)
  finally have coprime1: "coprime u (u ^ 2 - v ^ 2)"
    by auto

  from assms have "coprime (int v) (int u ^ 2)"
    by (auto simp: coprime_commute)
  hence "coprime (int v) ((-int v) * int v + int u ^ 2)"
    unfolding coprime_iff_gcd_eq_1 by (subst gcd_add_mult) auto
  also have "(-int v) * int v + int u ^ 2 = int (u ^ 2 - v ^ 2)"
    using \<open>v < u\<close> by (simp add: of_nat_diff flip: power2_eq_square)
  finally have coprime2: "coprime v (u ^ 2 - v ^ 2)"
    by auto

  have "(2 * u * v) ^ 2 + (u ^ 2 - v ^ 2) ^ 2 = (u ^ 2 + v ^ 2) ^ 2"
    using \<open>v < u\<close> by (intro prim_pyth_triple_aux) auto
  moreover have "coprime (2 * u * v) (u ^ 2 - v ^ 2)"
    using assms \<open>\<not>u ^ 2 < v ^ 2\<close> coprime1 coprime2 by auto
  ultimately show ?thesis using assms \<open>v ^ 2 < u ^ 2\<close>
    by (simp add: prim_pyth_triple_def)
qed

lemma prim_pyth_tripleI2:
  assumes "0 < v" "v < u" "coprime u v" "\<not>(odd u \<and> odd v)"
  shows   "prim_pyth_triple (u\<^sup>2 - v\<^sup>2) (2 * u * v) (u\<^sup>2 + v\<^sup>2)"
  using prim_pyth_tripleI1[OF assms] by (simp add: prim_pyth_triple_commute)

lemma primitive_pythagorean_tripleE_int:
  assumes "z ^ 2 = x ^ 2 + y ^ 2"
  assumes "coprime x y"
  obtains u v :: int
    where "coprime u v" and "\<not>(odd u \<and> odd v)"
      and "x = 2 * u * v \<and> y = u\<^sup>2 - v\<^sup>2  \<or>  x = u\<^sup>2 - v\<^sup>2 \<and> y = 2 * u * v"
proof -
  have "\<not>(even x \<and> even y)"
    using not_coprimeI[of 2 x y] \<open>coprime x y\<close> by auto
  moreover have "\<not>(odd x \<and> odd y)"
  proof safe
    assume "odd x" "odd y"
    hence "[x ^ 2 + y ^ 2 = 1 + 1] (mod 4)"
      by (intro cong_add odd_square_cong_4_int)
    hence "[z ^ 2 = 2] (mod 4)"
      by (simp add: assms)
    moreover have "[z ^ 2 = 0] (mod 4) \<or> [z ^ 2 = 1] (mod 4)"
      using even_square_cong_4_int[of z] odd_square_cong_4_int[of z]
      by (cases "even z") auto
    ultimately show False
      by (auto simp: cong_def)
  qed
  ultimately have "even y \<longleftrightarrow> odd x"
    by blast

  have "even z \<longleftrightarrow> even (z ^ 2)"
    by auto
  also have "even (z ^ 2) \<longleftrightarrow> even (x ^ 2 + y ^ 2)"
    by (subst assms(1)) auto
  finally have "odd z"
    by (cases "even x") (auto simp: \<open>even y \<longleftrightarrow> \<not>even x\<close>)

  define t where "t = of_int x + \<i>\<^sub>\<int> * of_int y"
  from assms have t_mult_cnj: "t * gauss_cnj t = of_int z ^ 2"
    by (simp add: t_def power2_eq_square algebra_simps flip: of_int_mult of_int_add)

  have "gauss_int_norm t = z ^ 2"
    by (simp add: gauss_int_norm_def t_def assms)
  with \<open>coprime x y\<close> and \<open>odd z\<close> have "coprime t (gauss_cnj t)"
    by (intro coprime_self_gauss_cnj)
       (auto simp: t_def gauss_int_norm_def assms(1) [symmetric] even_nat_iff)
  moreover have "is_square (t * gauss_cnj t)"
    by (subst t_mult_cnj) auto
  hence "is_nth_power_upto_unit 2 (t * gauss_cnj t)"
    by (auto intro: is_nth_power_upto_unit_base)
  ultimately have "is_nth_power_upto_unit 2 t"
    by (rule is_nth_power_upto_unit_mult_coprimeD1)
  then obtain a b where ab: "is_unit a" "a * t = b ^ 2"
    by (auto simp: is_nth_power_upto_unit_def is_nth_power_def)
  from ab(1) have "a \<in> {1, -1, \<i>\<^sub>\<int>, -\<i>\<^sub>\<int>}"
    by (auto simp: is_unit_gauss_int_iff)
  then obtain u v :: int where "ReZ t = 2 * u * v \<and> ImZ t = u ^ 2 - v ^ 2 \<or>
                                ImZ t = 2 * u * v \<and> ReZ t = u ^ 2 - v ^ 2"
  proof safe
    assume [simp]: "a = 1"
    have "ReZ t = ReZ b ^ 2 - ImZ b ^ 2" "ImZ t = 2 * ReZ b * ImZ b" using ab(2)
      by (auto simp: gauss_int_eq_iff power2_eq_square)
    thus ?thesis using that by blast
  next
    assume [simp]: "a = -1"
    have "ReZ t = ImZ b ^ 2 - (-ReZ b) ^ 2" "ImZ t = 2 * ImZ b * (-ReZ b)" using ab(2)
      by (auto simp: gauss_int_eq_iff power2_eq_square algebra_simps)
    thus ?thesis using that by blast
  next
    assume [simp]: "a = \<i>\<^sub>\<int>"
    hence "ImZ t = ImZ b ^ 2 - ReZ b ^ 2" "ReZ t = 2 * ImZ b * ReZ b" using ab(2)
      by (auto simp: gauss_int_eq_iff power2_eq_square algebra_simps)
    thus ?thesis using that by blast
  next
    assume [simp]: "a = -\<i>\<^sub>\<int>"
    hence "ImZ t = (-ReZ b) ^ 2 - ImZ b ^ 2" "ReZ t = 2 * (-ReZ b) * ImZ b" using ab(2)
      by (auto simp: gauss_int_eq_iff power2_eq_square algebra_simps)
    thus ?thesis using that by blast
  qed
  also have "ReZ t = x"
    by (simp add: t_def)
  also have "ImZ t = y"
    by (simp add: t_def)
  finally have xy: "x = 2 * u * v \<and> y = u\<^sup>2 - v\<^sup>2 \<or> x = u\<^sup>2 - v\<^sup>2 \<and> y = 2 * u * v"
    by blast

  have not_both_odd: "\<not>(odd u \<and> odd v)"
  proof safe
    assume "odd u" "odd v"
    hence "even x" "even y"
      using xy by auto
    with \<open>coprime x y\<close> show False
      by auto
  qed

  have "coprime u v"
  proof (rule coprimeI)
    fix d assume "d dvd u" "d dvd v"
    hence "d dvd (u\<^sup>2 - v\<^sup>2)" "d dvd 2 * u * v"
      by (auto simp: power2_eq_square)
    with xy have "d dvd x" "d dvd y"
      by auto
    with \<open>coprime x y\<close> show "is_unit d"
      using not_coprimeI by blast
  qed
  with xy not_both_odd show ?thesis
    using that[of u v] by blast
qed

lemma prim_pyth_tripleE:
  assumes "prim_pyth_triple x y z"
  obtains u v :: nat
  where "0 < v" and "v < u" and "coprime u v" and "\<not>(odd u \<and> odd v)" and "z = u\<^sup>2 + v\<^sup>2"
    and "x = 2 * u * v \<and> y = u\<^sup>2 - v\<^sup>2  \<or>  x = u\<^sup>2 - v\<^sup>2 \<and> y = 2 * u * v"
proof -
  have *: "(int z) ^ 2 = (int x) ^ 2 + (int y) ^ 2" "coprime (int x) (int y)"
    using assms by (auto simp flip: of_nat_power of_nat_add simp: prim_pyth_triple_def)
  obtain u v
    where uv: "coprime u v" "\<not>(odd u \<and> odd v)"
              "int x = 2 * u * v \<and> int y = u\<^sup>2 - v\<^sup>2  \<or>  int x = u\<^sup>2 - v\<^sup>2 \<and> int y = 2 * u * v"
    using primitive_pythagorean_tripleE_int[OF *] by metis
  define u' v' where "u' = nat \<bar>u\<bar>" and "v' = nat \<bar>v\<bar>"

  have **: "a = 2 * u' * v'" if "int a = 2 * u * v" for a
  proof -
    from that have "nat \<bar>int a\<bar> = nat \<bar>2 * u * v\<bar>"
      by (simp only: )
    thus "a = 2 * u' * v'"
      by (simp add: u'_def v'_def abs_mult nat_mult_distrib)
  qed
  have ***: "a = u' ^ 2 - v' ^ 2" "v' \<le> u'" if "int a = u ^ 2 - v ^ 2" for a
  proof -
    have "v ^ 2 \<le> v ^ 2 + int a"
      by simp
    also have "\<dots> = u ^ 2"
      using that by simp
    finally have "\<bar>v\<bar> \<le> \<bar>u\<bar>"
      using abs_le_square_iff by blast
    thus "v' \<le> u'"
      by (simp add: v'_def u'_def)

    from that have "u ^ 2 = v ^ 2 + int a"
      by simp
    hence "nat \<bar>u ^ 2\<bar> = nat \<bar>v ^ 2 + int a\<bar>"
      by (simp only: )
    also have "nat \<bar>u ^ 2\<bar> = u' ^ 2"
      by (simp add: u'_def flip: nat_power_eq)
    also have "nat \<bar>v ^ 2 + int a\<bar> = v' ^ 2 + a"
      by (simp add: nat_add_distrib v'_def flip: nat_power_eq)
    finally show "a = u' ^ 2 - v' ^ 2"
      by simp
  qed

  have eq: "x = 2 * u' * v' \<and> y = u'\<^sup>2 - v'\<^sup>2  \<or>  x = u'\<^sup>2 - v'\<^sup>2 \<and> y = 2 * u' * v'" and "v' \<le> u'"
    using uv(3) **[of x] **[of y] ***[of x] ***[of y] by blast+
  moreover have "coprime u' v'"
    using \<open>coprime u v\<close>
    by (auto simp: u'_def v'_def)
  moreover have "\<not>(odd u' \<and> odd v')"
    using uv(2) by (auto simp: u'_def v'_def)
  moreover have "v' \<noteq> u'" "v' > 0"
    using \<open>coprime u' v'\<close> eq assms by (auto simp: prim_pyth_triple_def)
  moreover from this have "v' < u'"
    using \<open>v' \<le> u'\<close> by auto
  moreover have "z = u'\<^sup>2 + v'\<^sup>2"
  proof -
    from assms have "z ^ 2 = x ^ 2 + y ^ 2"
      by (simp add: prim_pyth_triple_def)
    also have "\<dots> = (2 * u' * v') ^ 2 + (u' ^ 2 - v' ^ 2) ^ 2"
      using eq by (auto simp: add_ac)
    also have "\<dots> = (u' ^ 2 + v' ^ 2) ^ 2"
      by (intro prim_pyth_triple_aux) fact
    finally show ?thesis by simp
  qed
  ultimately show ?thesis using that[of v' u'] by metis
qed

theorem prim_pyth_triple_iff:
  "prim_pyth_triple x y z \<longleftrightarrow>
     (\<exists>u v. 0 < v \<and> v < u \<and> coprime u v \<and> \<not>(odd u \<and> odd v) \<and>
            (x = 2 * u * v \<and> y = u\<^sup>2 - v\<^sup>2  \<or>  x = u\<^sup>2 - v\<^sup>2 \<and> y = 2 * u * v) \<and> z = u\<^sup>2 + v\<^sup>2)"
  (is "_ \<longleftrightarrow> ?rhs")
proof
  assume "prim_pyth_triple x y z"
  from prim_pyth_tripleE[OF this] show ?rhs by metis
next
  assume ?rhs
  then obtain u v where uv: "0 < v" "v < u" "coprime u v" "\<not>(odd u \<and> odd v)" "z = u\<^sup>2 + v\<^sup>2" and
                        eq: "x = 2 * u * v \<and> y = u\<^sup>2 - v\<^sup>2  \<or>  x = u\<^sup>2 - v\<^sup>2 \<and> y = 2 * u * v"
    by metis
  thus "prim_pyth_triple x y z"
    using uv prim_pyth_tripleI1[OF uv(1-4)] prim_pyth_tripleI2[OF uv(1-4)] uv(5) eq by auto
qed

end


theory Relations
  imports Finprod
begin

definition (in comm_group) relations :: "'a set \<Rightarrow> ('a \<Rightarrow> int) set" where
  "relations A = {f. finprod G (\<lambda>a. a [^] f a) A = \<one>} \<inter> extensional A"

lemma (in comm_group) rel_in_carr:
  assumes "A \<subseteq> carrier G" "r \<in> relations A"
  shows "(\<lambda>a. a [^] r a) \<in> A \<rightarrow> carrier G"
  by (meson Pi_I assms(1) int_pow_closed subsetD)

lemma (in comm_group) in_relationsI[intro]:
  assumes "finprod G (\<lambda>a. a [^] f a) A = \<one>" "f \<in> extensional A"
  shows "f \<in> relations A"
  unfolding relations_def using assms by blast

lemma (in comm_group) triv_rel:
  "restrict (\<lambda>_. 0::int) A \<in> relations A"
proof
  show "(\<Otimes>a\<in>A. a [^] (\<lambda>_\<in>A. 0::int) a) = \<one>" by(intro finprod_one_eqI, simp)
qed simp

lemma (in comm_group) not_triv_relI:
  assumes "a \<in> A" "f a \<noteq> (0::int)"
  shows "f \<noteq> (\<lambda>_\<in>A. 0::int)"
  using assms by auto

lemma (in comm_group) relations_zero_imp_pow_not_one:
  assumes "a \<in> A" "\<forall>f\<in>(relations A). f a = 0"
  shows "\<forall>z::int \<noteq> 0. a [^] z \<noteq> \<one>"
proof (rule ccontr; safe)
  fix z::int
  assume z: "z \<noteq> 0" "a [^] z = \<one>"
  have "restrict ((\<lambda>x. 0)(a := z)) A \<in> relations A" by(intro in_relationsI finprod_one_eqI, use z in auto)
  thus False using z assms by auto
qed

lemma (in comm_group) relations_zero_imp_ord_zero:
  assumes "a \<in> A" "\<forall>f\<in>(relations A). f a = 0"
  and "a \<in> carrier G"
  shows "ord a = 0"
  using assms relations_zero_imp_pow_not_one[OF assms(1, 2)]
  by (meson finite_cyclic_subgroup_int infinite_cyclic_subgroup_order)

lemma (in comm_group) finprod_relations_triv_harder_better_stronger:
  assumes "A \<subseteq> carrier G" "relations A = {(\<lambda>_\<in>A. 0::int)}"
  shows "\<forall>f \<in> Pi\<^sub>E A (\<lambda>a. generate G {a}). finprod G f A = \<one> \<longrightarrow> (\<forall>a\<in>A. f a = \<one>)"
proof(rule, rule)
  fix f
  assume f: "f \<in> (\<Pi>\<^sub>E a\<in>A. generate G {a})" "finprod G f A = \<one>"
  with generate_pow assms(1) have "\<forall>a\<in>A. \<exists>k::int. f a = a [^] k" by auto
  then obtain r::"'a \<Rightarrow> int" where r: "\<forall>a\<in>A. f a = a [^] r a" by metis
  have "restrict r A \<in> relations A"
  proof(intro in_relationsI)
    have "(\<Otimes>a\<in>A. a [^] restrict r A a) = finprod G f A" by(intro finprod_cong, use assms r in auto)
    thus "(\<Otimes>a\<in>A. a [^] restrict r A a) = \<one>" using f by simp
  qed simp
  with assms(2) have z: "restrict r A = (\<lambda>_\<in>A. 0)" by blast
  have "(restrict r A) a = r a" if "a \<in> A" for a using that by auto
  with r z show "\<forall>a\<in>A. f a = \<one>" by auto
qed

lemma (in comm_group) finprod_relations_triv:
  assumes "A \<subseteq> carrier G" "relations A = {(\<lambda>_\<in>A. 0::int)}"
  shows "\<forall>f \<in> Pi\<^sub>E ((\<lambda>a. generate G {a}) ` A) id. finprod G f ((\<lambda>a. generate G {a}) ` A) = \<one> \<longrightarrow> (\<forall>H\<in> (\<lambda>a. generate G {a}) ` A. f H = \<one>)"
  using assms finprod_relations_triv_harder_better_stronger stronger_PiE_finprod_imp by presburger

lemma (in comm_group) ord_zero_strong_imp_rel_triv:
  assumes "A \<subseteq> carrier G" "\<forall>a \<in> A. ord a = 0"
  and "\<forall>f \<in> Pi\<^sub>E A (\<lambda>a. generate G {a}). finprod G f A = \<one> \<longrightarrow> (\<forall>a\<in>A. f a = \<one>)"
  shows "relations A = {(\<lambda>_\<in>A. 0::int)}"
proof -
  have "\<And>r. r \<in> relations A \<Longrightarrow> r = (\<lambda>_\<in>A. 0::int)"
  proof
    fix r x
    assume r: "r \<in> relations A"
    show "r x = (\<lambda>_\<in>A. 0::int) x"
    proof (cases "x \<in> A")
      case True
      let ?r = "restrict (\<lambda>a. a [^] r a) A"
      have rp: "?r \<in> Pi\<^sub>E A (\<lambda>a. generate G {a})"
      proof -
        have "?r \<in> extensional A" by blast
        moreover have "?r \<in> Pi A (\<lambda>a. generate G {a})"
        proof
          fix a
          assume a: "a \<in> A"
          then have sga: "subgroup (generate G {a}) G" using generate_is_subgroup assms(1) by auto
          show "a [^] r a \<in> generate G {a}" using generate.incl[of a "{a}" G] subgroup_int_pow_closed[OF sga] by simp
        qed
        ultimately show ?thesis unfolding PiE_def by blast
      qed
      have "finprod G ?r A = (\<Otimes>a\<in>A. a [^] r a)" by(intro finprod_cong, use assms(1) in auto)
      with r have "finprod G ?r A = \<one>" unfolding relations_def by simp
      with assms(3) rp have "\<forall>a\<in>A. ?r a = \<one>" by fast
      then have "\<forall>a\<in>A. a [^] r a = \<one>" by simp
      with assms(1, 2) True have "r x = 0" using finite_cyclic_subgroup_int infinite_cyclic_subgroup_order
        by blast
      thus ?thesis using True by simp
    next
      case False
      thus ?thesis using r unfolding relations_def extensional_def by simp
    qed
  qed
  thus ?thesis using triv_rel by blast
qed

lemma (in comm_group) comp_fam_iff_relations_triv:
  assumes "finite gs" "gs \<subseteq> carrier G" "\<forall>g\<in>gs. ord g = 0"
  shows "relations gs = {(\<lambda>_\<in>gs. 0::int)} \<longleftrightarrow> compl_gens gs"
  using triv_finprod_iff_comp_gens[OF assms(1, 2)]
        ord_zero_strong_imp_rel_triv[OF assms(2, 3)]
        finprod_relations_triv_harder_better_stronger[OF assms(2)]
  by blast

end


theory svm
  imports "RLM_stable" "Subgradients"
begin

locale soft_svm =
  fixes H :: "'b::euclidean_space set"
    and D :: "('b \<times> real) pmf"
    and n :: "nat"
    and k :: "real"
  fixes S :: "(nat \<Rightarrow> ('b \<times> real))"
    and \<rho> :: "real"
  assumes nnH: "H \<noteq> {}"
    and  convH: "convex H"
    and n_pos: "n\<ge>1"
    and k_pos : "k>0"
    and rho_pos: "\<rho> > 0"
    and S_in_D: "S \<in> Samples n D"
    and D_bounded : "\<forall>z \<in> D. norm (fst z) \<le> \<rho>"
    and y_abs : "\<forall>z\<in> D. abs (snd z) = 1"
begin
end

sublocale soft_svm \<subseteq> lipschitz_ridge_and_convex_loss H D n hinge_loss k \<rho>
proof unfold_locales
  show "H \<noteq> {}" using nnH by auto
  show "convex H" using convH by auto
  show " \<forall>h\<in>H. \<forall>z\<in>set_pmf D. 0 \<le> hinge_loss h z" using hinge_loss_pos by auto
  show "\<forall>z\<in>set_pmf D. convex_on H (\<lambda>h. hinge_loss h z)" using hinge_loss_convex by auto
  show "1 \<le> n" using n_pos by auto
  show "k>0" using k_pos by auto
  show " 0 < \<rho>" using rho_pos by auto
  show " \<forall>y\<in>set_pmf D. \<rho>-lipschitz_on H (\<lambda>h. hinge_loss h y)"
  proof
    fix y
    assume " y\<in> D"
    then have "abs (snd y) = 1" using y_abs by auto
    then have "(norm (fst y))-lipschitz_on H (\<lambda> z. hinge_loss z y)"
      using abv by auto
    then show "\<rho>-lipschitz_on H (\<lambda> z. hinge_loss z y)" using D_bounded `y\<in>D`
      using lipschitz_on_le by blast
  qed

  show "\<forall> h \<in> H. integrable D (\<lambda> z. hinge_loss h z)"
proof
  fix h
  assume "h\<in>H"
  have "integrable D (\<lambda> z. 0)" by auto
  have "integrable D (\<lambda> z. (1 - (snd z) * inner h (fst z)))"
  proof
    show "integrable D (\<lambda>x. 1)" by auto

    have 6: "integrable D (\<lambda> x. snd x *\<^sub>R fst x)"
    proof -
      have 1:"(\<lambda> x. 1) \<in> borel_measurable D" by auto
      have 2:"\<rho> \<noteq> \<infinity>" by auto
      have "integrable D (\<lambda>x. 1)" by auto
      then have "integral\<^sup>N D (\<lambda> x. 1) < \<infinity>" by simp
      have "AE x in D. norm (snd x *\<^sub>R fst x) \<le> \<rho> * ((\<lambda> x. 1) x)"
        using D_bounded y_abs
        by (simp add: AE_measure_pmf_iff)
      then have 3: "(\<integral>\<^sup>+x. norm (snd x *\<^sub>R fst x) \<partial>D) < \<infinity>" using D_bounded
          nn_integral_mult_bounded_inf[of "(\<lambda> x. 1)" D \<rho> "(\<lambda> x. norm (snd x *\<^sub>R fst x))"] 1 2
        using rho_pos by auto
      have 4:"(\<lambda> x. snd x *\<^sub>R fst x) \<in> borel_measurable D" by auto
      show "integrable D (\<lambda> x. snd x *\<^sub>R fst x)" using 3 4
        using integrableI_bounded by blast
    qed

    have 5: "integrable D (\<lambda>x. (h \<bullet> snd x *\<^sub>R fst x))"
    proof(cases "h=0")
      case True
      then show ?thesis
        by simp
    next
      case False

      then show "integrable D (\<lambda>x. h \<bullet> snd x *\<^sub>R fst x)"
        using integrable_inner_right[of h D "(\<lambda> x. snd x *\<^sub>R fst x)"] 6
          `h \<noteq> 0` by auto
    qed
    have "(\<lambda> x. h \<bullet> snd x *\<^sub>R fst x) = (\<lambda> x.  snd x * (h \<bullet> fst x))"
      by simp
    then show "integrable D (\<lambda>x. snd x * (h \<bullet> fst x))" using 5 by simp
  qed
  then show "integrable D (hinge_loss h)" unfolding hinge_loss.simps
    by auto
qed
qed

context soft_svm
begin
fun soft_svm :: "(nat \<Rightarrow> real)  \<Rightarrow> ('b \<Rightarrow> real)" where
  "soft_svm ksi  = (\<lambda> w. k * norm w^2 + (1/n)* (\<Sum>i\<in>{0..<n}. (ksi i)))"

lemma
  fixes w :: "'b::euclidean_space"
  fixes ksi :: "(nat \<Rightarrow> real)"
  assumes "w\<in>H"
  assumes "\<forall> i\<in>{0..<n}. ksi i \<ge> 0"
  assumes "\<forall>i\<in>{0..<n}. snd (S i) * (inner w (fst (S i))) \<ge> 1 - (ksi i)"
  shows"ridge_mine S k =  (SOME h. is_arg_min (soft_svm ksi) (\<lambda>s. s\<in>H) h)"
proof -

  oops

end


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

datatype Sign = Pos | Neg

datatype Nat = Z | S "Nat"

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

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

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

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

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

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

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

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

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

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

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

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

end


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

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

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

datatype Nat = Z | S "Nat"

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

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

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

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

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

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

function stooge2sort2 :: "Nat list => Nat list"
  and stoogesort2 :: "Nat list => Nat list"
  and stooge2sort1 :: "Nat list => Nat list" where
  "stooge2sort2 y =
   (case
      splitAt (idiv (S (times (S (S Z)) (length y))) (S (S (S Z)))) y
      of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "((stoogesort2 xs) = (isort xs))"
  oops

end


theory Datatype_thru_Codatatype
imports Main
begin

section {* Inductive Datatypes with Nesting through Codatatypes as in Isabelle/HOL *}

text {*
The abstract interface between a datatype and a codatatype through which it is
nested is a set function that returns the elements. This is modeled below by a
@{text subtrees} predicate.
*}

subsection {* Basic Setup *}

hide_const (open) Nil Cons hd tl

text \<open>
This will be called @{text "iota!"} in Nunchaku:
\<close>

definition The_bang :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "The_bang P = (if \<exists>x. P x then The P else Nitpick.unknown)"

definition pred_of_fun :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "pred_of_fun p f x y \<longleftrightarrow> p x \<and> f x = y"

typedecl elem
typedecl tree
typedecl forest

nitpick_params [user_axioms, dont_box, show_all, atoms elem = a b c d e f g h i j k l,
  atoms forest = as bs cs ds es fs gs hs "is" js ks ls,
  atoms tree = aa bb cc dd ee ff gg hh ii jj kk ll]

subsection {* Codatatype Destructors *}

axiomatization
  null :: "forest \<Rightarrow> bool" and
  hd :: "forest \<Rightarrow> tree" and
  tl :: "forest \<Rightarrow> forest"

coinductive bisim :: "forest \<Rightarrow> forest \<Rightarrow> bool" where
  "null xs \<Longrightarrow> null ys \<Longrightarrow> bisim xs ys"
| "\<not> null xs \<Longrightarrow> \<not> null ys \<Longrightarrow> hd xs = hd ys \<Longrightarrow> bisim (tl xs) (tl ys) \<Longrightarrow> bisim xs ys"

text \<open>
@{prop "hd xs = hd ys"} is appropriate, as opposed to lifting @{const bisim}
with the tree relator.
\<close>

axiomatization where
  bisim: "\<And>xs ys. bisim xs ys \<Longrightarrow> xs = ys"

definition
  subtrees :: "forest \<Rightarrow> tree \<Rightarrow> bool"
where
  "subtrees = rtranclp (pred_of_fun (Not \<circ> null) tl) OO pred_of_fun (Not \<circ> null) hd"

subsection {* Datatype Destructors *}

axiomatization
  lab :: "tree \<Rightarrow> elem" and
  sub :: "tree \<Rightarrow> forest"
where
  unique: "\<And>xs ys. lab xs = lab ys \<Longrightarrow> sub xs = sub ys \<Longrightarrow> xs = ys" and
  acyclic: "\<And>xs. \<not> tranclp (pred_of_fun (\<lambda>_. True) sub OO subtrees) xs xs"

nitpick_params [card elem = 3, card forest = 1-5, card tree = 1-5, iter = 1-5, mono]

subsection {* Codatatype Constructors *}

definition
  Nil :: forest
where
  "Nil = The_bang (\<lambda>ys. null ys)"

definition
  Cons :: "tree \<Rightarrow> forest \<Rightarrow> forest"
where
  "Cons x xs = The_bang (\<lambda>ys. \<not> null ys \<and> hd ys = x \<and> tl ys = xs)"

lemma "Nil \<noteq> Cons x xs"
  nitpick[satisfy, expect = genuine]
  nitpick[expect = none]
  sorry

lemma "xs = Nil \<or> xs = Cons (hd xs) (tl xs)"
  nitpick[satisfy, expect = genuine]
  nitpick [expect = none]
  sorry

lemma "xs \<noteq> Cons x xs"
  nitpick [expect = genuine]
  oops

lemma "xs \<noteq> Cons x (Cons y xs)"
  nitpick [expect = genuine]
  oops

lemma "x \<noteq> y \<Longrightarrow> xs \<noteq> Cons x (Cons y xs)"
  nitpick [expect = genuine]
  oops

lemma "xs = ys \<longleftrightarrow> (null xs \<and> null ys) \<or> (\<not> null xs \<and> \<not> null ys \<and> hd xs = hd ys \<and> tl xs = tl ys)"
  nitpick [expect = none]
  sorry

lemma "xs = Cons x ys \<Longrightarrow> ys = Cons x xs \<Longrightarrow> xs = ys"
  nitpick [expect = none]
  nitpick [satisfy, expect = genuine]
  sorry

lemma "xs \<noteq> Nil \<Longrightarrow> xs \<noteq> sub (hd xs)"
  nitpick [expect = none]
  sorry

subsection {* Datatype Constructors *}

definition
  Node :: "elem \<Rightarrow> forest \<Rightarrow> tree"
where
  "Node x xs = The_bang (\<lambda>yy. lab yy = x \<and> sub yy = xs)"

lemma "xx \<noteq> Node x (Cons xx xs)"
  nitpick [expect = none]
  sorry

lemma "xx \<noteq> Node x (Cons (Node y (Cons xx Nil)) Nil)"
  nitpick [expect = none]
  nitpick [satisfy, expect = genuine]
  sorry

lemma "xx = yy \<longleftrightarrow> lab xx = lab yy \<and> sub xx = sub yy"
  nitpick [expect = none]
  sorry

lemma "sub xx \<noteq> Nil \<Longrightarrow> tl (sub xx) \<noteq> sub xx"
  nitpick [expect = genuine]
  oops

lemma "xs = Cons (Node x xs) Nil"
  nitpick [satisfy, expect = none]
  oops

end