theory Submission
  imports Defs
begin

inductive
  hoare :: "assn \<Rightarrow> assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile>{(1_)}/ ({(1_)}/ (_)/ {(1_)})" 50)
where
Skip: "\<turnstile>{I} {P} SKIP {P}"  |
Assign:  "\<turnstile>{I} {\<lambda>s. P(s[a/x])} x::=a {P}"  |
Seq: "\<lbrakk> \<turnstile>{I} {P} c\<^sub>1 {Q};  \<turnstile>{I} {Q} c\<^sub>2 {R} \<rbrakk>
      \<Longrightarrow> \<turnstile>{I} {P} c\<^sub>1;;c\<^sub>2 {R}"  |
If: "\<lbrakk> \<turnstile>{I} {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile>{I} {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
     \<Longrightarrow> \<turnstile>{I} {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |
conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile>{I} {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
        \<Longrightarrow> \<turnstile>{I} {P'} c {Q'}" |
While: "\<turnstile>{P} {\<lambda>s. P s \<and> bval b s} c {\<lambda>s. P s} \<Longrightarrow>
        \<turnstile>{I} {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"  |
Continue: "\<turnstile>{I} {I} CONTINUE {P}"
\<comment> \<open>Add your cases here\<close>

lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If

lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile>{I} {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

lemma While':
assumes "\<turnstile>{P} {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile>{I} {P} WHILE b DO c {Q}"
by(rule weaken_post[OF While[OF assms(1)] assms(2)])

definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn \<Rightarrow> assn"  where
  "wp c I Q = (\<lambda>s. \<forall>f t. (c,s) \<Rightarrow> (f, t)  \<longrightarrow>  (if f then I t else Q t))"

lemma wp_SKIP[simp]: "wp SKIP I Q = Q"
by (rule ext) (auto simp: wp_def)

lemma wp_Ass[simp]: "wp (x::=a) I Q = (\<lambda>s. Q(s[a/x]))"
by (rule ext) (auto simp: wp_def)

lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) I Q = wp c\<^sub>1 I (wp c\<^sub>2 I Q)"
by (rule ext) (auto simp: wp_def)

lemma wp_If[simp]:
 "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) I Q =
 (\<lambda>s. if bval b s then wp c\<^sub>1 I Q s else wp c\<^sub>2 I Q s)"
by (rule ext) (auto simp: wp_def)

lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
  wp (WHILE b DO c) I Q s = wp c (wp (WHILE b DO c) I Q) (wp (WHILE b DO c) I Q) s"
using WhileTrue wp_def by auto

lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) I Q s = Q s"
  using WhileFalse wp_def by auto

lemma wp_Continue[simp]: "wp (CONTINUE) I Q = I"
  using wp_def by auto

lemma wp_is_pre: "\<turnstile>{I} {wp c I Q} c {Q}"
proof(induction c arbitrary: I Q)
  case If thus ?case
    by (smt (z3) conseq hoare.If wp_If)
next
  case (While b c)
  let ?w = "WHILE b DO c"
  show "\<turnstile>{I} {wp ?w I Q} ?w {Q}"
  proof(rule While')
    show "\<turnstile>{wp ?w I Q} {\<lambda>s. wp ?w I Q s \<and> bval b s} c {wp ?w I Q}"
    proof(rule strengthen_pre[OF _ While.IH])
      show "\<forall>s. wp ?w I Q s \<and> bval b s \<longrightarrow> wp c (wp ?w I Q) (wp ?w I Q) s" by auto
    qed
    show "\<forall>s. wp ?w I Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
  qed
next case CONTINUE show ?case by (simp add: hoare.Continue)
qed auto

lemma hoare_complete: assumes "\<Turnstile> {P}c{Q}"
  shows "\<turnstile>{Q} {P}c{Q}"
proof(rule strengthen_pre)
  show "\<forall>s. P s \<longrightarrow> wp c Q Q s" using assms
    by (auto simp: hoare_valid_def wp_def)
  show "\<turnstile>{Q} {wp c Q Q} c {Q}" by(rule wp_is_pre)
qed

theorem hoare_sound_complete: "\<turnstile>{Q} {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
  by (metis hoare_complete hoare_sound hoare_valid\<^sub>c_def hoare_valid_def)

end


theory nthpower
imports FreeGroupMain Cancellation  UniversalProperty
begin

lemma cancels_transfer:
assumes "i > 0"
 and "cancels_to_1_at i (a#b#x) (a#y)"
 and "b \<noteq> inverse a"
shows "cancels_to_1_at (i - 1) (b#x) y"
  using assms
 proof(cases x)
   case Nil
   with assms show ?thesis unfolding cancels_to_1_at_def cancel_at_def by force
 next
   case (Cons c list)
   have i:"i - 1 \<ge> 0" by auto
   moreover then have "1 + (i - 1) < length (b # x)" using assms unfolding cancels_to_1_at_def
     by simp
   moreover then have "inverse ((b # x) ! (i - 1)) = (b # x) ! (1 + (i - 1))"
     using i  assms unfolding cancels_to_1_at_def cancel_at_def by simp
   moreover then have "y = take (i - 1) (b # x) @ drop (2 + (i - 1)) (b # x)"
     using i assms Cons unfolding cancels_to_1_at_def cancel_at_def
     by (metis One_nat_def Suc_pred append_Cons drop_Suc_Cons drop_drop gr_implies_not_zero list.sel(3) take_Cons')
   ultimately show ?thesis  unfolding cancels_to_1_at_def cancel_at_def by argo
 qed

lemma non_reduced_words_cancel:
  "\<not>(reduced wrd) \<longleftrightarrow> (\<exists>x. cancels_to_1 wrd x)"
proof
  assume asm:"\<not> (reduced wrd)"
  show "(\<exists>x. cancels_to_1 wrd x)"
    using asm
  proof(induction wrd rule:reduced.induct)
  case (3 g h wrd)
  then show ?case
  proof(cases "inverse g = h")
    case True
    then have "cancels_to_1_at 0 (g#h#wrd) wrd" using  Cons
        unfolding  cancels_to_1_at_def[of 0 "g#h#wrd" wrd]
        unfolding cancel_at_def take.simps(1) by simp
    then show ?thesis unfolding cancels_to_1_def by blast
  next
    case False
    then have "g \<noteq> inverse h" using False
      by (metis inverse_of_inverse)
    then obtain x i where "cancels_to_1_at i (h#wrd) x" using 3 unfolding cancels_to_1_def by fastforce
    then have "cancels_to_1_at (i+1) (g#h#wrd) (g#x)" unfolding cancels_to_1_at_def
      by (metis Suc_eq_plus1 add.assoc add_less_cancel_left append.simps(2) cancel_at_def drop_Suc_Cons length_Cons nth_Cons_Suc plus_1_eq_Suc take_Suc_Cons zero_le)
    then show ?thesis using cancels_transfer unfolding cancels_to_1_def by blast
  qed
  qed (auto)+
next
  assume asm:"\<exists>x. cancels_to_1 wrd x"
  show "\<not>(reduced wrd)"
    using asm
  proof(induction wrd rule:reduced.induct)
    case 1
    then show ?case unfolding cancels_to_1_def cancels_to_1_at_def by simp
  next
    case (2 g)
    then show ?case unfolding cancels_to_1_def cancels_to_1_at_def by simp
  next
    case (3 g h wrd)
    then show ?case
    proof(cases "g = inverse h")
      case False
      then have False':"h \<noteq> inverse g"
        using inverse_of_inverse by blast
      obtain x i where x_i:"cancels_to_1_at i (g#h#wrd) x"  using 3(2) unfolding cancels_to_1_def
        by fast
      then have i:"i > 0" using False
        by (metis cancels_to_1_at_def gr0I inverse_of_inverse nth_Cons_0 nth_Cons_Suc plus_1_eq_Suc)
      obtain y where y:"x = g # y"
        using x_i i  unfolding cancels_to_1_at_def
        cancel_at_def
        by (simp add: take_Cons')
      then have "cancels_to_1_at (i - 1) (h#wrd) y" using x_i cancels_transfer[of i g h wrd y] False'
        i by fastforce
      then have "\<not>(reduced (h#wrd))" using 3(1)[OF False] unfolding cancels_to_1_def by fast
      then show ?thesis by simp
    qed(auto)
  qed
qed

lemma not_reduced_sublist:
  assumes "\<not> (reduced ys)"
  shows "\<not> (reduced (xs@ys))"
  using assms
proof(induction xs rule:reduced.induct)
  case (2 g)
  then show ?case
    by (metis append_Cons append_Nil list.exhaust reduced.simps(1) reduced.simps(3))
next
  case (3 g h wrd)
  then show ?case by (cases "g = inverse h", simp, simp add:3)
qed (simp)

lemma reduced_reverse:
  assumes "reduced (xs@[x])"
      and "reduced (y#ys)"
      and "x \<noteq> inverse y"
    shows "reduced (xs@[x]@(y#ys))"
proof(rule ccontr)
  assume asm:"\<not> (reduced (xs@[x]@(y#ys)))"
  then obtain wrd where wrd:"cancels_to_1 (xs@[x]@(y#ys)) wrd"
    using  non_reduced_words_cancel by blast
  then obtain i where i:"cancels_to_1_at i (xs@[x]@(y#ys)) wrd"
    unfolding cancels_to_1_def by blast
  then show False
  proof(cases "i < length (xs)")
    case True
    hence "((xs@[x]) ! i) =  (xs@[x]@(y#ys))!i" using i unfolding cancels_to_1_at_def
      by (simp add: nth_append)
    moreover have "(xs @[x])! (i+ 1) =  (xs@[x]@(y#ys))!(i+1)"  using i unfolding cancels_to_1_at_def
      by (metis True append_Cons discrete le_neq_implies_less nth_append nth_append_length)
    ultimately have "inverse ((xs@[x])!i) = (xs@[x])!(i+1)" using  i True unfolding cancels_to_1_at_def
      by (metis Suc_eq_plus1  plus_1_eq_Suc)
    then have  inv:"((xs@[x])!i) = inverse ((xs@[x])!(i+1))" using inverse_of_inverse by metis
    then have "drop i (xs@[x]) = ((xs@[x])!i)#((xs@[x])!(i+1))#(drop (i + 2) (xs@[x]))"
      using True
      by (metis Cons_nth_drop_Suc Suc_eq_plus1 add_Suc_right discrete le_imp_less_Suc length_append_singleton less_imp_le_nat nat_1_add_1)
    then have nr_drop_i: "\<not> reduced (drop i (xs@[x]))"
      using inv
      by simp
    moreover have "(xs@[x]) = (take i (xs@[x]))@(drop i (xs@[x]))"
      using True by simp
    then have "\<not> reduced (xs@[x])" using nr_drop_i not_reduced_sublist by metis
    then show ?thesis using assms(1) by argo
  next
    case False
    then have i_len:"i \<ge> length xs" by auto
    then show ?thesis
    proof(cases "i = length xs")
      case True
      hence "x =  (xs@[x]@(y#ys))!i" using i unfolding cancels_to_1_at_def
       by (simp add: nth_append)
      moreover have "y =  (xs@[x]@(y#ys))!(i+1)"  using i unfolding cancels_to_1_at_def
       by (metis One_nat_def True length_Cons list.size(3) nth_append_length nth_append_length_plus)
      ultimately have "inverse x = y" using  i True unfolding cancels_to_1_at_def
       by (metis Suc_eq_plus1  plus_1_eq_Suc)
      then have  inv:"x = inverse y" using inverse_of_inverse by metis
      then show False using assms(3) by argo
    next
      case False
      define j where "j = i - length xs - 1"
      have i_len:"i > length xs" using i_len False by linarith
      hence "([y]@ys) !(i - length xs - 1) =  (xs@[x]@(y#ys))!i" using i unfolding cancels_to_1_at_def
        by (metis (no_types, hide_lams) add.commute add_less_le_mono append.assoc append.simps(1) append_Cons diff_diff_eq discrete length_append_singleton nat_less_le nth_append plus_1_eq_Suc)
      moreover have "([y]@ys)! (i - length xs) =  (xs@[x]@(y#ys))!(i+1)"  using i i_len
        unfolding cancels_to_1_at_def
        by (smt (z3) Nat.le_imp_diff_is_add add_diff_cancel_left' append_Cons append_self_conv2 diff_commute diff_is_0_eq' diffs0_imp_equal le_add1 nat_less_le nth_Cons' nth_append)
      ultimately have "inverse (([y]@ys)!j) = ([y]@ys)!(j+1)" using  i False  unfolding cancels_to_1_at_def
      j_def
        by (metis One_nat_def Suc_eq_plus1 Suc_pred i_len plus_1_eq_Suc zero_less_diff)
     then have  inv:"(([y]@ys)!j) = inverse (([y]@ys)!(j+1))" using inverse_of_inverse by metis
    then have "drop j ([y]@ys) = (([y]@ys)!j)#(([y]@ys)!(j+1))#(drop (j + 2) ([y]@ys))"
      using False i unfolding j_def cancels_to_1_at_def
      by (smt (verit, ccfv_threshold) Cons_nth_drop_Suc add.commute add_Suc_right add_lessD1 add_less_cancel_left discrete i_len le_add_diff_inverse length_Cons length_append linorder_not_less nat_1_add_1 plus_1_eq_Suc)
    then have nr_drop_i: "\<not> reduced (drop j ([y]@ys))"
      using inv
      by simp
    moreover have "([y]@ys) = (take j ([y]@ys))@(drop j ([y]@ys))"
      using False unfolding j_def by simp
    then have "\<not> reduced ([y]@ys)" using nr_drop_i not_reduced_sublist by metis
    then show ?thesis using assms(2) by force
    qed
  qed
qed

lemma reduced_wordinverses:
  assumes "reduced x"
  shows "reduced (wordinverse x)"
  using assms
proof(induction x rule: reduced.induct)
  case 1
  then show ?case by auto
next
  case (2 g)
then show ?case by simp
next
  case (3 g h wrd)
  then have "reduced (wordinverse (h#wrd))"by force
  then have "reduced ((wordinverse wrd)@[inverse h])" by fastforce
  moreover have "reduced ((inverse g)#[])" by auto
  moreover have "inverse h \<noteq> inverse (inverse g)" using inverse_of_inverse 3(2)
    by (metis reduced.simps(3))
  ultimately show ?case using reduced_reverse by fastforce
qed

(* Use reflection somewhere
To prove the following, do the following:
use uncylce
  a. show that first and last elements are the same
  b. show that reduced by knocking off first and last letters is still reduced
  c. do a case analysis for off and even words. *)

lemma eq_wordinv_imp:
  assumes "xs = wordinverse xs"
   "reduced xs"
  shows "xs = []"
proof(cases xs)
  case (Cons y ys)
  then show ?thesis
  proof(cases "even (length xs)")
    case True
    obtain n where n:"length xs = 2*n" using True by auto
    then have "xs ! (n-1) = inverse (xs! n)" using True Cons
         assms(1) wordinverse_redef2[of xs]
      by (smt (z3) One_nat_def Suc_pred add_diff_cancel_right' discrete length_greater_0_conv length_rev less_add_same_cancel2 less_imp_le_nat list.simps(3) mult_2 neq0_conv nth_map rev_nth)
    then have "cancels_to_1  xs ((take (n-1) xs)@(drop (n+1) xs))"
      unfolding cancels_to_1_def cancels_to_1_at_def using n Cons
      by (metis Cons_nth_drop_Suc One_nat_def Suc_eq_plus1 add_lessD1 assms(2) discrete id_take_nth_drop le_add_diff_inverse2 length_greater_0_conv less_add_same_cancel2 list.simps(3) mult_2 nat_0_less_mult_iff not_reduced_sublist reduced.simps(3))
    then have "\<not> (reduced xs)" using non_reduced_words_cancel by auto
    then show ?thesis using assms(2) by blast
  next
    case False
    obtain n where n:"length xs = 2*n + 1" using Cons False by auto
    then have "xs ! n = inverse (xs ! n)" using  Cons
         assms(1) wordinverse_redef2[of xs]
      by (metis (no_types, lifting) Suc_eq_plus1 add_diff_cancel_right' combine_common_factor discrete le_add2 length_rev mult.left_neutral nth_map one_add_one rev_nth)
    then have " True = False"
      apply (cases "snd (xs!n)")
      apply(simp)
      apply (metis inverse.simps(1) prod.collapse snd_conv)
      by (metis inverse.simps(2) sndI surjective_pairing)
    then show ?thesis using Cons by simp
  qed
qed (auto)

lemma red_repelem:
  assumes "w \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
  shows "\<exists>x \<in> w. reduced x \<and> ((reln_tuple \<langle>S\<rangle>)`` {x} = w)"
proof-
  obtain c where c: "w = (reln_tuple \<langle>S\<rangle>) `` {c}" by (meson assms quotientE)
  then have cs: "c \<in> \<langle>S\<rangle>" using assms by (metis proj_def proj_in_iff reln_equiv)
  obtain rc where rc: "rc = (iter (length c) reduce c)" by simp
  then have "reduced rc" by (simp add: reduced_iter_length)
  then have "c ~ rc" using rc cancels_imp_rel iter_cancels_to by auto
  moreover then have "rc \<in> \<langle>S\<rangle>" using cs rc using cancels_to_preserves iter_cancels_to by blast
  ultimately have crc: "(c, rc) \<in> reln_tuple \<langle>S\<rangle>" using cs reln_tuple_def by auto
  then have "((reln_tuple \<langle>S\<rangle>)`` {rc} = w)"using c by (smt (verit, ccfv_SIG) equiv_class_eq_iff reln_equiv)
  moreover then have "rc \<in> w" using c crc by simp
  ultimately show ?thesis using \<open>reduced rc\<close> by auto
qed

lemma(in group) not_eq_id:
  assumes  "x \<in> carrier (freegroup S)"
    and "x \<noteq> \<one>\<^bsub>(freegroup S)\<^esub>"
  shows "[] \<notin> x"
  using assms unfolding freegroup_def reln_tuple_def quotient_def
  apply (simp)
proof(rule ccontr)
  assume " \<not> [] \<notin> x"
  then have in_x:"[] \<in> x" by auto
  moreover have in_S:"[] \<in> \<langle>S\<rangle>"  unfolding freewords_on_def
    by (simp add: words_on.empty)
  obtain xa where xa:"x = {y. xa ~ y \<and> y \<in> \<langle>S\<rangle>}" "xa \<in>  \<langle>S\<rangle>"
    using assms unfolding freegroup_def reln_tuple_def quotient_def
    by (simp, blast)
  then have eq_xa:" xa ~ []" using in_x in_S by simp
  then have "x = \<one>\<^bsub>(freegroup S)\<^esub>"
    unfolding freegroup_def reln_tuple_def quotient_def apply (simp)
  proof
    {fix a
     assume asm:"a \<in> x"
     then have a_prop:"xa ~ a" "a \<in> \<langle>S\<rangle>" using xa by simp+
     then have "a ~ []" using eq_xa
       using reln.sym reln.trans by blast
     then have "a \<in> {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>}"
       using in_S a_prop(2) reln.sym by force}
   then show " x \<subseteq> {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>}" by blast
 next
    {fix a
     assume asm:"a \<in> {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>}"
     then have a_prop:"[] ~ a" "a \<in> \<langle>S\<rangle>" using xa by simp+
     then have "a ~ xa" using eq_xa
       using reln.sym reln.trans by blast
     then have "a \<in> x"
       using in_S a_prop(2) xa reln.sym by force}
   then show " {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>} \<subseteq> x" by blast
 qed
  then show False using assms(2) by simp
qed

(* reln_imp_cancels *)
lemma(in group)
  assumes "x \<in> carrier (freegroup S)" "x \<noteq> \<one>\<^bsub>(freegroup S)\<^esub>"
  shows "x \<noteq> inv\<^bsub>(freegroup S)\<^esub> x"
proof
  assume asm:"x = inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> x"
  obtain g where g:"x =  (reln_tuple \<langle>S\<rangle>) `` {g}" "g \<in> \<langle>S\<rangle>" "reduced g"
    using assms red_repelem unfolding freegroup_def reln_tuple_def apply simp
    by auto
  moreover have g_inv:"inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> x = (reln_tuple \<langle>S\<rangle>) `` {wordinverse g}"
    using wordinverse_inv[OF assms(1) g(1)] .
  moreover have red_g_inv:"reduced (wordinverse g)"
    using assms(1) g(1,3) wordinverse_inv
    by (simp add:  reduced_wordinverses)
  have " g \<in> (reln_tuple \<langle>S\<rangle>) `` {g}" using asm g(1,2)
    unfolding reln_tuple_def Image_def apply(simp)
    by auto
  moreover then  have "g \<in> (reln_tuple \<langle>S\<rangle>) `` {wordinverse g}"
    using asm g_inv g g(2) by auto
  then have "wordinverse g ~ g"  using g(1) unfolding reln_tuple_def Image_def
    by simp
  then have "g ~ wordinverse g" using reln.simps by auto
  then have "cancels_eq g (wordinverse g)" using reln_imp_cancels by auto
  then have "g = wordinverse g" using g(3) red_g_inv reduced_cancel_eq by auto
  then have "g = []" using eq_wordinv_imp g(3) red_g_inv by blast
  show False using assms not_eq_id g
    using \<open>g = []\<close> \<open>g \<in> reln_tuple \<langle>S\<rangle> `` {wordinverse g}\<close> by auto
qed

end


(*  Title:      HOL/Groebner_Basis.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section {* Groebner bases *}

theory Groebner_Basis
imports Semiring_Normalization Parity
begin

subsection {* Groebner Bases *}

lemmas bool_simps = simp_thms(1-34) -- {* FIXME move to @{theory HOL} *}

lemma nnf_simps: -- {* FIXME shadows fact binding in @{theory HOL} *}
  "(\<not>(P \<and> Q)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)"
  "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
  "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
  by blast+

lemma dnf:
  "(P & (Q | R)) = ((P&Q) | (P&R))"
  "((Q | R) & P) = ((Q&P) | (R&P))"
  "(P \<and> Q) = (Q \<and> P)"
  "(P \<or> Q) = (Q \<or> P)"
  by blast+

lemmas weak_dnf_simps = dnf bool_simps

lemma PFalse:
    "P \<equiv> False \<Longrightarrow> \<not> P"
    "\<not> P \<Longrightarrow> (P \<equiv> False)"
  by auto

named_theorems algebra "pre-simplification rules for algebraic methods"
ML_file "Tools/groebner.ML"

method_setup algebra = {*
  let
    fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
    val addN = "add"
    val delN = "del"
    val any_keyword = keyword addN || keyword delN
    val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat;
  in
    Scan.optional (keyword addN |-- thms) [] --
     Scan.optional (keyword delN |-- thms) [] >>
    (fn (add_ths, del_ths) => fn ctxt =>
      SIMPLE_METHOD' (Groebner.algebra_tac add_ths del_ths ctxt))
  end
*} "solve polynomial equations over (semi)rings and ideal membership problems using Groebner bases"

declare dvd_def[algebra]
declare dvd_eq_mod_eq_0[symmetric, algebra]
declare mod_div_trivial[algebra]
declare mod_mod_trivial[algebra]
declare div_by_0[algebra]
declare mod_by_0[algebra]
declare zmod_zdiv_equality[symmetric,algebra]
declare div_mod_equality2[symmetric, algebra]
declare div_minus_minus[algebra]
declare mod_minus_minus[algebra]
declare div_minus_right[algebra]
declare mod_minus_right[algebra]
declare div_0[algebra]
declare mod_0[algebra]
declare mod_by_1[algebra]
declare div_by_1[algebra]
declare mod_minus1_right[algebra]
declare div_minus1_right[algebra]
declare mod_mult_self2_is_0[algebra]
declare mod_mult_self1_is_0[algebra]
declare zmod_eq_0_iff[algebra]
declare dvd_0_left_iff[algebra]
declare zdvd1_eq[algebra]
declare zmod_eq_dvd_iff[algebra]
declare nat_mod_eq_iff[algebra]

context semiring_parity
begin

declare even_times_iff [algebra]
declare even_power [algebra]

end

context ring_parity
begin

declare even_minus [algebra]

end

declare even_Suc [algebra]
declare even_diff_nat [algebra]

end


(*  Title:      HOL/Library/Cancellation.thy
    Author:     Mathias Fleury, MPII
    Copyright   2017

This theory defines cancelation simprocs that work on cancel_comm_monoid_add and support the simplification of an operation
that repeats the additions.
*)

theory Cancellation
imports Main
begin

named_theorems cancelation_simproc_pre \<open>These theorems are here to normalise the term. Special
  handling of constructors should be here. Remark that only the simproc @{term NO_MATCH} is also
  included.\<close>

named_theorems cancelation_simproc_post \<open>These theorems are here to normalise the term, after the
  cancelation simproc. Normalisation of \<open>iterate_add\<close> back to the normale representation
  should be put here.\<close>

named_theorems cancelation_simproc_eq_elim \<open>These theorems are here to help deriving contradiction
  (e.g., \<open>Suc _ = 0\<close>).\<close>

definition iterate_add :: \<open>nat \<Rightarrow> 'a::cancel_comm_monoid_add \<Rightarrow> 'a\<close> where
  \<open>iterate_add n a = (((+) a) ^^ n) 0\<close>

lemma iterate_add_simps[simp]:
  \<open>iterate_add 0 a = 0\<close>
  \<open>iterate_add (Suc n) a = a + iterate_add n a\<close>
  unfolding iterate_add_def by auto

lemma iterate_add_empty[simp]: \<open>iterate_add n 0 = 0\<close>
  unfolding iterate_add_def by (induction n) auto

lemma iterate_add_distrib[simp]: \<open>iterate_add (m+n) a = iterate_add m a + iterate_add n a\<close>
  by (induction n) (auto simp: ac_simps)

lemma iterate_add_Numeral1: \<open>iterate_add n Numeral1 = of_nat n\<close>
  by (induction n) auto

lemma iterate_add_1: \<open>iterate_add n 1 = of_nat n\<close>
  using iterate_add_Numeral1 by auto

lemma iterate_add_eq_add_iff1:
  \<open>i \<le> j \<Longrightarrow> (iterate_add j u + m = iterate_add i u + n) = (iterate_add (j - i) u + m = n)\<close>
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_eq_add_iff2:
   \<open>i \<le> j \<Longrightarrow> (iterate_add i u + m = iterate_add j u + n) = (m = iterate_add (j - i) u + n)\<close>
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_less_iff1:
  "j \<le> (i::nat) \<Longrightarrow> (iterate_add i (u:: 'a :: {cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) + m < iterate_add j u + n) = (iterate_add (i-j) u + m < n)"
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_less_iff2:
  "i \<le> (j::nat) \<Longrightarrow> (iterate_add i (u:: 'a :: {cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) + m < iterate_add j u + n) = (m <iterate_add (j - i) u + n)"
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_less_eq_iff1:
  "j \<le> (i::nat) \<Longrightarrow> (iterate_add i (u:: 'a :: {cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) + m \<le> iterate_add j u + n) = (iterate_add (i-j) u + m \<le> n)"
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_less_eq_iff2:
  "i \<le> (j::nat) \<Longrightarrow> (iterate_add i (u:: 'a :: {cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) + m \<le> iterate_add j u + n) = (m \<le> iterate_add (j - i) u + n)"
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_add_eq1:
  "j \<le> (i::nat) \<Longrightarrow> ((iterate_add i u + m) - (iterate_add j u + n)) = ((iterate_add (i-j) u + m) - n)"
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

lemma iterate_add_diff_add_eq2:
  "i \<le> (j::nat) \<Longrightarrow> ((iterate_add i u + m) - (iterate_add j u + n)) = (m - (iterate_add (j-i) u + n))"
  by (auto dest!: le_Suc_ex add_right_imp_eq simp: ab_semigroup_add_class.add_ac(1))

subsection \<open>Simproc Set-Up\<close>

ML_file \<open>Cancellation/cancel.ML\<close>
ML_file \<open>Cancellation/cancel_data.ML\<close>
ML_file \<open>Cancellation/cancel_simprocs.ML\<close>

end


(*
    File:        Nth.thy
    Time-stamp:  <2020-06-22T03:46:28Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory Nth imports ZF_aux ZF.List begin

definition mapnth :: "[[i, i]=>i, i]=>i" where
  "mapnth(f, l) == rec(length(l), [],
                       %n r. r @ [f(n, nth(n, l))])"

lemma UN_succ:
    "(UN z: succ(n). f(z)) = (UN z: n. f(z)) Un f(n)"
apply (rule Un_commute [THEN [2] trans])
apply simp
done

lemmas nth_over_length_lemma = nth_eq_0
lemmas nth_type2 = nth_type

lemma nth_type1:
    "[| n: nat; l: list(A) |] ==> nth(n, l): A Un {0}"
apply (rule_tac i="n" and j="length(l)" in Ord_linear_lt)
apply (erule nat_into_Ord)
apply (rule nat_into_Ord)
apply (rule length_type, assumption)
apply (frule nth_type, assumption)
apply (erule UnI1)
apply (frule nth_eq_0, assumption)
apply (rule le_eqI)
apply (erule sym)
apply (erule nat_into_Ord)
apply blast
apply (frule nth_eq_0, assumption)
apply (erule leI)
apply blast
done

lemma nthlemma_0:
  "(UN y: A. 0) = 0"
	"Collect(0, P) = 0"
  "{x: A . False} = 0"
	"{x: A . True} = A"
by blast+

lemmas nthlemma = nat_ltI ball_mem_nat_in_nat
  (* nth_Cons nth_0 nth_empty *) UN_succ (* UN_0 UN_constant *)
  Un_assoc[THEN sym] (* lt_nat_in_nat mem_nat_in_nat *)
  nthlemma_0
(* declare nat_ltI [TC] *)

declare lt_nat_in_nat [TC]
declare mem_nat_in_nat [TC]

declare nthlemma [simp]
declare nat_bquant_succ1 [simp del]
declare nat_bquant_succ2 [simp]

lemma nth_app_right:
    assumes major: "l: list(A)"
    and prem: "x < length(l)"
    shows "nth(x, l@m) = nth(x, l)"
apply (rule prem [THEN ltD, THEN rev_bspec])
apply (rule major [THEN list.induct])
apply simp_all
done

lemma nth_app_left:
    "l: list(A) ==> nth(length(l), l @ Cons(x, m)) = x"
apply (erule list.induct)
apply simp_all
done

lemma nth_app_left2 [rule_format]:
  "l: list(A) ==> ALL n: nat. length(l) \<le> n -->
              nth(n, l@m) = nth(n #- length(l), m)"
apply (erule list.induct)
apply simp_all
apply (intro ballI impI)
apply (erule natE)
apply simp_all
done

lemma nth_convert_list_type:
  assumes major: "l: list(B)"
  and prem: "ALL z: length(l). nth(z, l): A"
  shows "l: list(A)"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN list.induct])
apply simp_all
done

lemma nth_map:
  assumes major: "l: list(A)"
  and prem: "n < length(l)"
  shows "nth(n, map(f, l)) = f(nth(n, l))"
apply (rule prem [THEN ltD, THEN rev_bspec])
apply (rule major [THEN list.induct])
apply simp_all
done

lemma nth_inj:
  assumes major: "ALL z: length(l). nth(z, m) = nth(z, l)"
      and prem: "length(m) = length(l)"
      and l_list: "l: list(A)"
      and m_list: "m: list(B)"
    shows "m = l"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule m_list [THEN rev_bspec])
apply (rule l_list [THEN list.induct])
apply simp_all
apply clarify
apply (erule_tac a="x" in list.cases)
apply simp_all
apply blast
done

declare nat_bquant_succ1 [simp]
declare nat_bquant_succ2 [simp del]

lemma nth_existence_lemma:
  assumes major: "ALL z:n. f(z): A"
  and sub: "n: nat"
  shows "EX l: list(A). length(l) = n & (ALL z: n. nth(z, l) = f(z))"
apply (rule major [THEN rev_mp])
apply (rule sub [THEN nat_induct])
apply simp_all
apply clarify
apply (rule_tac x="l@[f(length(l))]" in bexI)
apply (simp_all add: nth_append)
apply blast
done

(** mapnth **)
lemma mapnth_Nil:
    "mapnth(f, []) = []"
apply (unfold mapnth_def)
apply simp
done

lemma mapnth_lemma:
    "n: nat ==>
       Cons(f(0, a), rec(n, [], %x r. r @ [f(succ(x), nth(x, l))])) =
          rec(n, [], %x r. r @ [f(x, nth(x, Cons(a, l)))])@
                      [f(n, nth(n, Cons(a, l)))]"
apply (erule nat_induct)
apply simp
apply (simp del: app_Cons add: app_Cons [THEN sym])
done

lemma mapnth_Cons:
    "l: list(A) ==>
      mapnth(f, Cons(a, l)) = Cons(f(0, a), mapnth(%x. f(succ(x)), l))"
apply (unfold mapnth_def)
apply (rule mapnth_lemma [THEN sym, THEN [2] trans])
apply simp_all
done

lemma mapnth_Cons2:
  "[| length(l): nat |] ==>
    mapnth(f, Cons(a, l)) = Cons(f(0, a), mapnth(%x. f(succ(x)), l))"
apply (unfold mapnth_def)
apply (rule mapnth_lemma [THEN sym, THEN [2] trans])
apply simp_all
done

lemma rec_nth_app_right [rule_format]:
    "[| n: nat; l: list(A) |] ==> n \<le> length(l) -->
        rec(n, [], %n r. r @ [f(n, nth(n, l@m))]) =
        rec(n, [], %n r. r @ [f(n, nth(n, l))])"
apply (erule nat_induct)
apply (simp_all add: nth_app_right leI)
done

lemma mapnth_type:
  assumes prem1: "l: list(A)"
  and prem2: "!! n x. [| n: nat; x: A |] ==> f(n, x): B"
  shows "mapnth(f, l): list(B)"
apply (unfold mapnth_def)
apply (rule prem1 [THEN list_append_induct])
apply simp
apply (simp add: rec_nth_app_right)
apply (erule app_type)
apply (rule list.intros)
apply (rule prem2)
apply simp_all
done

lemma mapnth_app_last:
  "l: list(A) ==>
      mapnth(f, l@[a]) = mapnth(f, l) @ [f(length(l), a)]"
apply (unfold mapnth_def)
apply (drule_tac B="list(cons(a, A))" in rev_subsetD)
apply (rule list_mono)
apply blast
apply (simp add: rec_nth_app_right)
apply (simp add: nth_app_left2)
done

lemma mapnth_type2:
  "l: list(A) ==> mapnth(f, l): list({f(n, x). <n,x>: nat*A})"
apply (rule mapnth_type, assumption)
apply (rule_tac P="%y. y:{f(n, x). <n,x>: nat*A}"
         and b="f(n,x)" and a="split(f, <n, x>)" in ssubst)
apply simp_all
apply blast
done

lemma length_mapnth:
    "l: list(A) ==> length(mapnth(f, l)) = length(l)"
apply (erule list_append_induct)
apply (frule_tac [2] f="f" in mapnth_type2)
apply (simp_all add: mapnth_Nil mapnth_app_last)
apply (subst length_app, assumption)
apply (rule list.intros)
apply (rule_tac b="f(length(y), x)" in ssubst)
apply (rule_tac [2] RepFunI)
apply (rule_tac [2] a="length(y)" and b="x" in SigmaI)
apply simp_all
done

lemma nth_mapnth:
  assumes major: "l: list(A)"
  and prem: "n < length(l)"
  shows "nth(n, mapnth(f, l)) = f(n, nth(n, l))"
apply (rule prem [THEN ltD, THEN rev_bspec])
apply (rule major [THEN list_append_induct])
apply (simp_all add: mapnth_app_last)
apply (frule_tac f="f" in mapnth_type2)
apply (frule_tac f="f" in length_mapnth)
apply safe
apply (simp_all add: nth_app_left nth_app_right nth_app_left2)
done

lemma map_mapnth:
  "l: list(A) ==> map(f, mapnth(g, l)) = mapnth(%x r. f(g(x, r)), l)"
apply (frule_tac f="g" in mapnth_type2)
apply (rule nth_inj)
prefer 4 apply (rule map_type2, assumption)
prefer 3 apply (rule mapnth_type2, assumption)
apply (simp_all add: length_mapnth nth_map nth_mapnth)
done

lemma mapnth_map:
  "l: list(A) ==> mapnth(f, map(g, l)) = mapnth(%x r. f(x, g(r)), l)"
apply (frule_tac h="g" in map_type2)
apply (rule nth_inj)
prefer 4 apply (erule mapnth_type2)
prefer 3 apply (erule mapnth_type2)
apply (simp_all add: length_mapnth nth_map nth_mapnth)
done

lemma mapnth_mapnth:
  "l: list(A) ==> mapnth(f, mapnth(g, l)) = mapnth(%x r. f(x, g(x, r)), l)"
apply (frule_tac f="g" in mapnth_type2)
apply (rule nth_inj)
prefer 4 apply (erule mapnth_type2)
prefer 3 apply (erule mapnth_type2)
apply (simp_all add: length_mapnth nth_mapnth)
done

(** nth_0E **)
lemma nth_0E_lemma:
    "l: list(A) ==> ALL a. 0 < length(l) --> nth(0, l) = a
       --> (EX m: list(A). a: A & l = Cons(a, m))"
apply (erule list.cases)
apply simp_all
done

lemma nth_0E:
  assumes major: "nth(0, l) = a"
  and l_list: "l: list(A)"
  and l_len: "0 < length(l)"
  and prem: "!!m. [| a: A; m: list(A); l = Cons(a, m) |] ==> P"
  shows "P"
apply (rule l_list [THEN nth_0E_lemma,
                     THEN spec, THEN mp, THEN mp, THEN bexE])
apply (erule_tac [3] conjE)
apply (rule_tac [3] prem)
apply ((rule major l_len) | assumption)+
done

lemma length_0E:
  assumes major: "length(l) = 0"
  and l_list: "l: list(A)"
  and prem: "l = [] ==> P"
  shows "P"
apply (rule l_list [THEN list.cases])
apply (erule prem)
apply (insert major)
apply simp
done

declare mapnth_type2 [TC]
declare mapnth_type [TC]

lemmas nth_ss_lemmas = mapnth_Nil mapnth_Cons2
   add_0_right (* add_succ_right length_app app_right_Nil *)
   nth_app_right nth_app_left Cons_iff

declare nth_ss_lemmas [simp]

end


(*  Title:      HOL/HOLCF/LowerPD.thy
    Author:     Brian Huffman
*)

section {* Lower powerdomain *}

theory LowerPD
imports Compact_Basis
begin

subsection {* Basis preorder *}

definition
  lower_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<flat>" 50) where
  "lower_le = (\<lambda>u v. \<forall>x\<in>Rep_pd_basis u. \<exists>y\<in>Rep_pd_basis v. x \<sqsubseteq> y)"

lemma lower_le_refl [simp]: "t \<le>\<flat> t"
unfolding lower_le_def by fast

lemma lower_le_trans: "\<lbrakk>t \<le>\<flat> u; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> t \<le>\<flat> v"
unfolding lower_le_def
apply (rule ballI)
apply (drule (1) bspec, erule bexE)
apply (drule (1) bspec, erule bexE)
apply (erule rev_bexI)
apply (erule (1) below_trans)
done

interpretation lower_le: preorder lower_le
by (rule preorder.intro, rule lower_le_refl, rule lower_le_trans)

lemma lower_le_minimal [simp]: "PDUnit compact_bot \<le>\<flat> t"
unfolding lower_le_def Rep_PDUnit
by (simp, rule Rep_pd_basis_nonempty [folded ex_in_conv])

lemma PDUnit_lower_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<flat> PDUnit y"
unfolding lower_le_def Rep_PDUnit by fast

lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
unfolding lower_le_def Rep_PDPlus by fast

lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
unfolding lower_le_def Rep_PDPlus by fast

lemma lower_le_PDUnit_PDUnit_iff [simp]:
  "(PDUnit a \<le>\<flat> PDUnit b) = (a \<sqsubseteq> b)"
unfolding lower_le_def Rep_PDUnit by fast

lemma lower_le_PDUnit_PDPlus_iff:
  "(PDUnit a \<le>\<flat> PDPlus t u) = (PDUnit a \<le>\<flat> t \<or> PDUnit a \<le>\<flat> u)"
unfolding lower_le_def Rep_PDPlus Rep_PDUnit by fast

lemma lower_le_PDPlus_iff: "(PDPlus t u \<le>\<flat> v) = (t \<le>\<flat> v \<and> u \<le>\<flat> v)"
unfolding lower_le_def Rep_PDPlus by fast

lemma lower_le_induct [induct set: lower_le]:
  assumes le: "t \<le>\<flat> u"
  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
  assumes 2: "\<And>t u a. P (PDUnit a) t \<Longrightarrow> P (PDUnit a) (PDPlus t u)"
  assumes 3: "\<And>t u v. \<lbrakk>P t v; P u v\<rbrakk> \<Longrightarrow> P (PDPlus t u) v"
  shows "P t u"
using le
apply (induct t arbitrary: u rule: pd_basis_induct)
apply (erule rev_mp)
apply (induct_tac u rule: pd_basis_induct)
apply (simp add: 1)
apply (simp add: lower_le_PDUnit_PDPlus_iff)
apply (simp add: 2)
apply (subst PDPlus_commute)
apply (simp add: 2)
apply (simp add: lower_le_PDPlus_iff 3)
done

subsection {* Type definition *}

typedef 'a lower_pd =
  "{S::'a pd_basis set. lower_le.ideal S}"
by (rule lower_le.ex_ideal)

type_notation (xsymbols) lower_pd ("('(_')\<flat>)")

instantiation lower_pd :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_lower_pd x \<subseteq> Rep_lower_pd y"

instance ..
end

instance lower_pd :: (bifinite) po
using type_definition_lower_pd below_lower_pd_def
by (rule lower_le.typedef_ideal_po)

instance lower_pd :: (bifinite) cpo
using type_definition_lower_pd below_lower_pd_def
by (rule lower_le.typedef_ideal_cpo)

definition
  lower_principal :: "'a pd_basis \<Rightarrow> 'a lower_pd" where
  "lower_principal t = Abs_lower_pd {u. u \<le>\<flat> t}"

interpretation lower_pd:
  ideal_completion lower_le lower_principal Rep_lower_pd
using type_definition_lower_pd below_lower_pd_def
using lower_principal_def pd_basis_countable
by (rule lower_le.typedef_ideal_completion)

text {* Lower powerdomain is pointed *}

lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
by (induct ys rule: lower_pd.principal_induct, simp, simp)

instance lower_pd :: (bifinite) pcpo
by intro_classes (fast intro: lower_pd_minimal)

lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
by (rule lower_pd_minimal [THEN bottomI, symmetric])

subsection {* Monadic unit and plus *}

definition
  lower_unit :: "'a \<rightarrow> 'a lower_pd" where
  "lower_unit = compact_basis.extension (\<lambda>a. lower_principal (PDUnit a))"

definition
  lower_plus :: "'a lower_pd \<rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd" where
  "lower_plus = lower_pd.extension (\<lambda>t. lower_pd.extension (\<lambda>u.
      lower_principal (PDPlus t u)))"

abbreviation
  lower_add :: "'a lower_pd \<Rightarrow> 'a lower_pd \<Rightarrow> 'a lower_pd"
    (infixl "\<union>\<flat>" 65) where
  "xs \<union>\<flat> ys == lower_plus\<cdot>xs\<cdot>ys"

syntax
  "_lower_pd" :: "args \<Rightarrow> logic" ("{_}\<flat>")

translations
  "{x,xs}\<flat>" == "{x}\<flat> \<union>\<flat> {xs}\<flat>"
  "{x}\<flat>" == "CONST lower_unit\<cdot>x"

lemma lower_unit_Rep_compact_basis [simp]:
  "{Rep_compact_basis a}\<flat> = lower_principal (PDUnit a)"
unfolding lower_unit_def
by (simp add: compact_basis.extension_principal PDUnit_lower_mono)

lemma lower_plus_principal [simp]:
  "lower_principal t \<union>\<flat> lower_principal u = lower_principal (PDPlus t u)"
unfolding lower_plus_def
by (simp add: lower_pd.extension_principal
    lower_pd.extension_mono PDPlus_lower_mono)

interpretation lower_add: semilattice lower_add proof
  fix xs ys zs :: "'a lower_pd"
  show "(xs \<union>\<flat> ys) \<union>\<flat> zs = xs \<union>\<flat> (ys \<union>\<flat> zs)"
    apply (induct xs rule: lower_pd.principal_induct, simp)
    apply (induct ys rule: lower_pd.principal_induct, simp)
    apply (induct zs rule: lower_pd.principal_induct, simp)
    apply (simp add: PDPlus_assoc)
    done
  show "xs \<union>\<flat> ys = ys \<union>\<flat> xs"
    apply (induct xs rule: lower_pd.principal_induct, simp)
    apply (induct ys rule: lower_pd.principal_induct, simp)
    apply (simp add: PDPlus_commute)
    done
  show "xs \<union>\<flat> xs = xs"
    apply (induct xs rule: lower_pd.principal_induct, simp)
    apply (simp add: PDPlus_absorb)
    done
qed

lemmas lower_plus_assoc = lower_add.assoc
lemmas lower_plus_commute = lower_add.commute
lemmas lower_plus_absorb = lower_add.idem
lemmas lower_plus_left_commute = lower_add.left_commute
lemmas lower_plus_left_absorb = lower_add.left_idem

text {* Useful for @{text "simp add: lower_plus_ac"} *}
lemmas lower_plus_ac =
  lower_plus_assoc lower_plus_commute lower_plus_left_commute

text {* Useful for @{text "simp only: lower_plus_aci"} *}
lemmas lower_plus_aci =
  lower_plus_ac lower_plus_absorb lower_plus_left_absorb

lemma lower_plus_below1: "xs \<sqsubseteq> xs \<union>\<flat> ys"
apply (induct xs rule: lower_pd.principal_induct, simp)
apply (induct ys rule: lower_pd.principal_induct, simp)
apply (simp add: PDPlus_lower_le)
done

lemma lower_plus_below2: "ys \<sqsubseteq> xs \<union>\<flat> ys"
by (subst lower_plus_commute, rule lower_plus_below1)

lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<union>\<flat> ys \<sqsubseteq> zs"
apply (subst lower_plus_absorb [of zs, symmetric])
apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
done

lemma lower_plus_below_iff [simp]:
  "xs \<union>\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
apply safe
apply (erule below_trans [OF lower_plus_below1])
apply (erule below_trans [OF lower_plus_below2])
apply (erule (1) lower_plus_least)
done

lemma lower_unit_below_plus_iff [simp]:
  "{x}\<flat> \<sqsubseteq> ys \<union>\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct ys rule: lower_pd.principal_induct, simp)
apply (induct zs rule: lower_pd.principal_induct, simp)
apply (simp add: lower_le_PDUnit_PDPlus_iff)
done

lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct y rule: compact_basis.principal_induct, simp)
apply simp
done

lemmas lower_pd_below_simps =
  lower_unit_below_iff
  lower_plus_below_iff
  lower_unit_below_plus_iff

lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
by (simp add: po_eq_conv)

lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
using lower_unit_Rep_compact_basis [of compact_bot]
by (simp add: inst_lower_pd_pcpo)

lemma lower_unit_bottom_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)

lemma lower_plus_bottom_iff [simp]:
  "xs \<union>\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
apply safe
apply (rule bottomI, erule subst, rule lower_plus_below1)
apply (rule bottomI, erule subst, rule lower_plus_below2)
apply (rule lower_plus_absorb)
done

lemma lower_plus_strict1 [simp]: "\<bottom> \<union>\<flat> ys = ys"
apply (rule below_antisym [OF _ lower_plus_below2])
apply (simp add: lower_plus_least)
done

lemma lower_plus_strict2 [simp]: "xs \<union>\<flat> \<bottom> = xs"
apply (rule below_antisym [OF _ lower_plus_below1])
apply (simp add: lower_plus_least)
done

lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
by (auto dest!: compact_basis.compact_imp_principal)

lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
apply (safe elim!: compact_lower_unit)
apply (simp only: compact_def lower_unit_below_iff [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
done

lemma compact_lower_plus [simp]:
  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs \<union>\<flat> ys)"
by (auto dest!: lower_pd.compact_imp_principal)

subsection {* Induction rules *}

lemma lower_pd_induct1:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<flat>"
  assumes insert:
    "\<And>x ys. \<lbrakk>P {x}\<flat>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<flat> \<union>\<flat> ys)"
  shows "P (xs::'a lower_pd)"
apply (induct xs rule: lower_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct1)
apply (simp only: lower_unit_Rep_compact_basis [symmetric])
apply (rule unit)
apply (simp only: lower_unit_Rep_compact_basis [symmetric]
                  lower_plus_principal [symmetric])
apply (erule insert [OF unit])
done

lemma lower_pd_induct
  [case_names adm lower_unit lower_plus, induct type: lower_pd]:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<flat>"
  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs \<union>\<flat> ys)"
  shows "P (xs::'a lower_pd)"
apply (induct xs rule: lower_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct)
apply (simp only: lower_unit_Rep_compact_basis [symmetric] unit)
apply (simp only: lower_plus_principal [symmetric] plus)
done

subsection {* Monadic bind *}

definition
  lower_bind_basis ::
  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
  "lower_bind_basis = fold_pd
    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
    (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<flat> y\<cdot>f)"

lemma ACI_lower_bind:
  "semilattice (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<flat> y\<cdot>f)"
apply unfold_locales
apply (simp add: lower_plus_assoc)
apply (simp add: lower_plus_commute)
apply (simp add: eta_cfun)
done

lemma lower_bind_basis_simps [simp]:
  "lower_bind_basis (PDUnit a) =
    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
  "lower_bind_basis (PDPlus t u) =
    (\<Lambda> f. lower_bind_basis t\<cdot>f \<union>\<flat> lower_bind_basis u\<cdot>f)"
unfolding lower_bind_basis_def
apply -
apply (rule fold_pd_PDUnit [OF ACI_lower_bind])
apply (rule fold_pd_PDPlus [OF ACI_lower_bind])
done

lemma lower_bind_basis_mono:
  "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
unfolding cfun_below_iff
apply (erule lower_le_induct, safe)
apply (simp add: monofun_cfun)
apply (simp add: rev_below_trans [OF lower_plus_below1])
apply simp
done

definition
  lower_bind :: "'a lower_pd \<rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
  "lower_bind = lower_pd.extension lower_bind_basis"

syntax
  "_lower_bind" :: "[logic, logic, logic] \<Rightarrow> logic"
    ("(3\<Union>\<flat>_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>\<flat>x\<in>xs. e" == "CONST lower_bind\<cdot>xs\<cdot>(\<Lambda> x. e)"

lemma lower_bind_principal [simp]:
  "lower_bind\<cdot>(lower_principal t) = lower_bind_basis t"
unfolding lower_bind_def
apply (rule lower_pd.extension_principal)
apply (erule lower_bind_basis_mono)
done

lemma lower_bind_unit [simp]:
  "lower_bind\<cdot>{x}\<flat>\<cdot>f = f\<cdot>x"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma lower_bind_plus [simp]:
  "lower_bind\<cdot>(xs \<union>\<flat> ys)\<cdot>f = lower_bind\<cdot>xs\<cdot>f \<union>\<flat> lower_bind\<cdot>ys\<cdot>f"
by (induct xs rule: lower_pd.principal_induct, simp,
    induct ys rule: lower_pd.principal_induct, simp, simp)

lemma lower_bind_strict [simp]: "lower_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)

lemma lower_bind_bind:
  "lower_bind\<cdot>(lower_bind\<cdot>xs\<cdot>f)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_bind\<cdot>(f\<cdot>x)\<cdot>g)"
by (induct xs, simp_all)

subsection {* Map *}

definition
  lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
  "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"

lemma lower_map_unit [simp]:
  "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
unfolding lower_map_def by simp

lemma lower_map_plus [simp]:
  "lower_map\<cdot>f\<cdot>(xs \<union>\<flat> ys) = lower_map\<cdot>f\<cdot>xs \<union>\<flat> lower_map\<cdot>f\<cdot>ys"
unfolding lower_map_def by simp

lemma lower_map_bottom [simp]: "lower_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<flat>"
unfolding lower_map_def by simp

lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
by (induct xs rule: lower_pd_induct, simp_all)

lemma lower_map_ID: "lower_map\<cdot>ID = ID"
by (simp add: cfun_eq_iff ID_def lower_map_ident)

lemma lower_map_map:
  "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
by (induct xs rule: lower_pd_induct, simp_all)

lemma lower_bind_map:
  "lower_bind\<cdot>(lower_map\<cdot>f\<cdot>xs)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. g\<cdot>(f\<cdot>x))"
by (simp add: lower_map_def lower_bind_bind)

lemma lower_map_bind:
  "lower_map\<cdot>f\<cdot>(lower_bind\<cdot>xs\<cdot>g) = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_map\<cdot>f\<cdot>(g\<cdot>x))"
by (simp add: lower_map_def lower_bind_bind)

lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
apply default
apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
apply (induct_tac y rule: lower_pd_induct)
apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff)
done

lemma deflation_lower_map: "deflation d \<Longrightarrow> deflation (lower_map\<cdot>d)"
apply default
apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem)
apply (induct_tac x rule: lower_pd_induct)
apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff)
done

(* FIXME: long proof! *)
lemma finite_deflation_lower_map:
  assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  have "deflation d" by fact
  thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  hence *: "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
    apply (rule rev_finite_subset)
    apply clarsimp
    apply (induct_tac xs rule: lower_pd.principal_induct)
    apply (simp add: adm_mem_finite *)
    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
    apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
    apply simp
    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDUnit)
    apply (rule range_eqI)
    apply (erule sym)
    apply (rule exI)
    apply (rule Abs_compact_basis_inverse [symmetric])
    apply (simp add: d.compact)
    apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDPlus)
    done
  thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
    by (rule finite_range_imp_finite_fixes)
qed

subsection {* Lower powerdomain is bifinite *}

lemma approx_chain_lower_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. lower_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP lower_map_ID finite_deflation_lower_map)

instance lower_pd :: (bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_lower_map)
qed

subsection {* Join *}

definition
  lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
  "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"

lemma lower_join_unit [simp]:
  "lower_join\<cdot>{xs}\<flat> = xs"
unfolding lower_join_def by simp

lemma lower_join_plus [simp]:
  "lower_join\<cdot>(xss \<union>\<flat> yss) = lower_join\<cdot>xss \<union>\<flat> lower_join\<cdot>yss"
unfolding lower_join_def by simp

lemma lower_join_bottom [simp]: "lower_join\<cdot>\<bottom> = \<bottom>"
unfolding lower_join_def by simp

lemma lower_join_map_unit:
  "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
by (induct xs rule: lower_pd_induct, simp_all)

lemma lower_join_map_join:
  "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
by (induct xsss rule: lower_pd_induct, simp_all)

lemma lower_join_map_map:
  "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
   lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
by (induct xss rule: lower_pd_induct, simp_all)

end


theory packrat_unambigPackrat
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Tok = X | Y | Z
  datatype B2 = SB "B2" | ZB
  datatype A2 = SA "A2" | ZA
  datatype S = A "A2" | B "B2"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun linA :: "A2 => Tok list" where
  "linA (SA a) =
     append (append (Cons2 X (Nil2)) (linA a)) (Cons2 Y (Nil2))"
  | "linA (ZA) = Cons2 X (Cons2 Z (Cons2 Y (Nil2)))"
  fun linB :: "B2 => Tok list" where
  "linB (SB b) =
     append
       (append (Cons2 X (Nil2)) (linB b)) (Cons2 Y (Cons2 Y (Nil2)))"
  | "linB (ZB) = Cons2 X (Cons2 Z (Cons2 Y (Cons2 Y (Nil2))))"
  fun linS :: "S => Tok list" where
  "linS (A a) = linA a"
  | "linS (B b) = linB b"
  (*hipster append linA linB linS*)
  theorem x0 :
    "!! (u :: S) (v :: S) . ((linS u) = (linS v)) ==> (u = v)"
    oops
end


(* Title:    HOL/Partial_Function.thy
   Author:   Alexander Krauss, TU Muenchen
*)

section \<open>Partial Function Definitions\<close>

theory Partial_Function
  imports Complete_Partial_Order Option
  keywords "partial_function" :: thy_defn
begin

named_theorems partial_function_mono "monotonicity rules for partial function definitions"
ML_file \<open>Tools/Function/partial_function.ML\<close>

lemma (in ccpo) in_chain_finite:
  assumes "Complete_Partial_Order.chain (\<le>) A" "finite A" "A \<noteq> {}"
  shows "\<Squnion>A \<in> A"
using assms(2,1,3)
proof induction
  case empty thus ?case by simp
next
  case (insert x A)
  note chain = \<open>Complete_Partial_Order.chain (\<le>) (insert x A)\<close>
  show ?case
  proof(cases "A = {}")
    case True thus ?thesis by simp
  next
    case False
    from chain have chain': "Complete_Partial_Order.chain (\<le>) A"
      by(rule chain_subset) blast
    hence "\<Squnion>A \<in> A" using False by(rule insert.IH)
    show ?thesis
    proof(cases "x \<le> \<Squnion>A")
      case True
      have "\<Squnion>(insert x A) \<le> \<Squnion>A" using chain
        by(rule ccpo_Sup_least)(auto simp add: True intro: ccpo_Sup_upper[OF chain'])
      hence "\<Squnion>(insert x A) = \<Squnion>A"
        by(rule antisym)(blast intro: ccpo_Sup_upper[OF chain] ccpo_Sup_least[OF chain'])
      with \<open>\<Squnion>A \<in> A\<close> show ?thesis by simp
    next
      case False
      with chainD[OF chain, of x "\<Squnion>A"] \<open>\<Squnion>A \<in> A\<close>
      have "\<Squnion>(insert x A) = x"
        by(auto intro: antisym ccpo_Sup_least[OF chain] order_trans[OF ccpo_Sup_upper[OF chain']] ccpo_Sup_upper[OF chain])
      thus ?thesis by simp
    qed
  qed
qed

lemma (in ccpo) admissible_chfin:
  "(\<forall>S. Complete_Partial_Order.chain (\<le>) S \<longrightarrow> finite S)
  \<Longrightarrow> ccpo.admissible Sup (\<le>) P"
using in_chain_finite by (blast intro: ccpo.admissibleI)

subsection \<open>Axiomatic setup\<close>

text \<open>This techical locale constains the requirements for function
  definitions with ccpo fixed points.\<close>

definition "fun_ord ord f g \<longleftrightarrow> (\<forall>x. ord (f x) (g x))"
definition "fun_lub L A = (\<lambda>x. L {y. \<exists>f\<in>A. y = f x})"
definition "img_ord f ord = (\<lambda>x y. ord (f x) (f y))"
definition "img_lub f g Lub = (\<lambda>A. g (Lub (f ` A)))"

lemma chain_fun:
  assumes A: "chain (fun_ord ord) A"
  shows "chain ord {y. \<exists>f\<in>A. y = f a}" (is "chain ord ?C")
proof (rule chainI)
  fix x y assume "x \<in> ?C" "y \<in> ?C"
  then obtain f g where fg: "f \<in> A" "g \<in> A"
    and [simp]: "x = f a" "y = g a" by blast
  from chainD[OF A fg]
  show "ord x y \<or> ord y x" unfolding fun_ord_def by auto
qed

lemma call_mono[partial_function_mono]: "monotone (fun_ord ord) ord (\<lambda>f. f t)"
by (rule monotoneI) (auto simp: fun_ord_def)

lemma let_mono[partial_function_mono]:
  "(\<And>x. monotone orda ordb (\<lambda>f. b f x))
  \<Longrightarrow> monotone orda ordb (\<lambda>f. Let t (b f))"
by (simp add: Let_def)

lemma if_mono[partial_function_mono]: "monotone orda ordb F
\<Longrightarrow> monotone orda ordb G
\<Longrightarrow> monotone orda ordb (\<lambda>f. if c then F f else G f)"
unfolding monotone_def by simp

definition "mk_less R = (\<lambda>x y. R x y \<and> \<not> R y x)"

locale partial_function_definitions =
  fixes leq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes lub :: "'a set \<Rightarrow> 'a"
  assumes leq_refl: "leq x x"
  assumes leq_trans: "leq x y \<Longrightarrow> leq y z \<Longrightarrow> leq x z"
  assumes leq_antisym: "leq x y \<Longrightarrow> leq y x \<Longrightarrow> x = y"
  assumes lub_upper: "chain leq A \<Longrightarrow> x \<in> A \<Longrightarrow> leq x (lub A)"
  assumes lub_least: "chain leq A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> leq x z) \<Longrightarrow> leq (lub A) z"

lemma partial_function_lift:
  assumes "partial_function_definitions ord lb"
  shows "partial_function_definitions (fun_ord ord) (fun_lub lb)" (is "partial_function_definitions ?ordf ?lubf")
proof -
  interpret partial_function_definitions ord lb by fact

  show ?thesis
  proof
    fix x show "?ordf x x"
      unfolding fun_ord_def by (auto simp: leq_refl)
  next
    fix x y z assume "?ordf x y" "?ordf y z"
    thus "?ordf x z" unfolding fun_ord_def
      by (force dest: leq_trans)
  next
    fix x y assume "?ordf x y" "?ordf y x"
    thus "x = y" unfolding fun_ord_def
      by (force intro!: dest: leq_antisym)
  next
    fix A f assume f: "f \<in> A" and A: "chain ?ordf A"
    thus "?ordf f (?lubf A)"
      unfolding fun_lub_def fun_ord_def
      by (blast intro: lub_upper chain_fun[OF A] f)
  next
    fix A :: "('b \<Rightarrow> 'a) set" and g :: "'b \<Rightarrow> 'a"
    assume A: "chain ?ordf A" and g: "\<And>f. f \<in> A \<Longrightarrow> ?ordf f g"
    show "?ordf (?lubf A) g" unfolding fun_lub_def fun_ord_def
      by (blast intro: lub_least chain_fun[OF A] dest: g[unfolded fun_ord_def])
   qed
qed

lemma ccpo: assumes "partial_function_definitions ord lb"
  shows "class.ccpo lb ord (mk_less ord)"
using assms unfolding partial_function_definitions_def mk_less_def
by unfold_locales blast+

lemma partial_function_image:
  assumes "partial_function_definitions ord Lub"
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  assumes inv: "\<And>x. f (g x) = x"
  shows "partial_function_definitions (img_ord f ord) (img_lub f g Lub)"
proof -
  let ?iord = "img_ord f ord"
  let ?ilub = "img_lub f g Lub"

  interpret partial_function_definitions ord Lub by fact
  show ?thesis
  proof
    fix A x assume "chain ?iord A" "x \<in> A"
    then have "chain ord (f ` A)" "f x \<in> f ` A"
      by (auto simp: img_ord_def intro: chainI dest: chainD)
    thus "?iord x (?ilub A)"
      unfolding inv img_lub_def img_ord_def by (rule lub_upper)
  next
    fix A x assume "chain ?iord A"
      and 1: "\<And>z. z \<in> A \<Longrightarrow> ?iord z x"
    then have "chain ord (f ` A)"
      by (auto simp: img_ord_def intro: chainI dest: chainD)
    thus "?iord (?ilub A) x"
      unfolding inv img_lub_def img_ord_def
      by (rule lub_least) (auto dest: 1[unfolded img_ord_def])
  qed (auto simp: img_ord_def intro: leq_refl dest: leq_trans leq_antisym inj)
qed

context partial_function_definitions
begin

abbreviation "le_fun \<equiv> fun_ord leq"
abbreviation "lub_fun \<equiv> fun_lub lub"
abbreviation "fixp_fun \<equiv> ccpo.fixp lub_fun le_fun"
abbreviation "mono_body \<equiv> monotone le_fun leq"
abbreviation "admissible \<equiv> ccpo.admissible lub_fun le_fun"

text \<open>Interpret manually, to avoid flooding everything with facts about
  orders\<close>

lemma ccpo: "class.ccpo lub_fun le_fun (mk_less le_fun)"
apply (rule ccpo)
apply (rule partial_function_lift)
apply (rule partial_function_definitions_axioms)
done

text \<open>The crucial fixed-point theorem\<close>

lemma mono_body_fixp:
  "(\<And>x. mono_body (\<lambda>f. F f x)) \<Longrightarrow> fixp_fun F = F (fixp_fun F)"
by (rule ccpo.fixp_unfold[OF ccpo]) (auto simp: monotone_def fun_ord_def)

text \<open>Version with curry/uncurry combinators, to be used by package\<close>

lemma fixp_rule_uc:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a" and
    C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
  assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
  assumes inverse: "\<And>f. C (U f) = f"
  shows "f = F f"
proof -
  have "f = C (fixp_fun (\<lambda>f. U (F (C f))))" by (simp add: eq)
  also have "... = C (U (F (C (fixp_fun (\<lambda>f. U (F (C f)))))))"
    by (subst mono_body_fixp[of "%f. U (F (C f))", OF mono]) (rule refl)
  also have "... = F (C (fixp_fun (\<lambda>f. U (F (C f)))))" by (rule inverse)
  also have "... = F f" by (simp add: eq)
  finally show "f = F f" .
qed

text \<open>Fixpoint induction rule\<close>

lemma fixp_induct_uc:
  fixes F :: "'c \<Rightarrow> 'c"
    and U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a"
    and C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
    and P :: "('b \<Rightarrow> 'a) \<Rightarrow> bool"
  assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
    and eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
    and inverse: "\<And>f. U (C f) = f"
    and adm: "ccpo.admissible lub_fun le_fun P"
    and bot: "P (\<lambda>_. lub {})"
    and step: "\<And>f. P (U f) \<Longrightarrow> P (U (F f))"
  shows "P (U f)"
unfolding eq inverse
apply (rule ccpo.fixp_induct[OF ccpo adm])
apply (insert mono, auto simp: monotone_def fun_ord_def bot fun_lub_def)[2]
apply (rule_tac f5="C x" in step)
apply (simp add: inverse)
done

text \<open>Rules for \<^term>\<open>mono_body\<close>:\<close>

lemma const_mono[partial_function_mono]: "monotone ord leq (\<lambda>f. c)"
by (rule monotoneI) (rule leq_refl)

end

subsection \<open>Flat interpretation: tailrec and option\<close>

definition
  "flat_ord b x y \<longleftrightarrow> x = b \<or> x = y"

definition
  "flat_lub b A = (if A \<subseteq> {b} then b else (THE x. x \<in> A - {b}))"

lemma flat_interpretation:
  "partial_function_definitions (flat_ord b) (flat_lub b)"
proof
  fix A x assume 1: "chain (flat_ord b) A" "x \<in> A"
  show "flat_ord b x (flat_lub b A)"
  proof cases
    assume "x = b"
    thus ?thesis by (simp add: flat_ord_def)
  next
    assume "x \<noteq> b"
    with 1 have "A - {b} = {x}"
      by (auto elim: chainE simp: flat_ord_def)
    then have "flat_lub b A = x"
      by (auto simp: flat_lub_def)
    thus ?thesis by (auto simp: flat_ord_def)
  qed
next
  fix A z assume A: "chain (flat_ord b) A"
    and z: "\<And>x. x \<in> A \<Longrightarrow> flat_ord b x z"
  show "flat_ord b (flat_lub b A) z"
  proof cases
    assume "A \<subseteq> {b}"
    thus ?thesis
      by (auto simp: flat_lub_def flat_ord_def)
  next
    assume nb: "\<not> A \<subseteq> {b}"
    then obtain y where y: "y \<in> A" "y \<noteq> b" by auto
    with A have "A - {b} = {y}"
      by (auto elim: chainE simp: flat_ord_def)
    with nb have "flat_lub b A = y"
      by (auto simp: flat_lub_def)
    with z y show ?thesis by auto
  qed
qed (auto simp: flat_ord_def)

lemma flat_ordI: "(x \<noteq> a \<Longrightarrow> x = y) \<Longrightarrow> flat_ord a x y"
by(auto simp add: flat_ord_def)

lemma flat_ord_antisym: "\<lbrakk> flat_ord a x y; flat_ord a y x \<rbrakk> \<Longrightarrow> x = y"
by(auto simp add: flat_ord_def)

lemma antisymp_flat_ord: "antisymp (flat_ord a)"
by(rule antisympI)(auto dest: flat_ord_antisym)

interpretation tailrec:
  partial_function_definitions "flat_ord undefined" "flat_lub undefined"
  rewrites "flat_lub undefined {} \<equiv> undefined"
by (rule flat_interpretation)(simp add: flat_lub_def)

interpretation option:
  partial_function_definitions "flat_ord None" "flat_lub None"
  rewrites "flat_lub None {} \<equiv> None"
by (rule flat_interpretation)(simp add: flat_lub_def)

abbreviation "tailrec_ord \<equiv> flat_ord undefined"
abbreviation "mono_tailrec \<equiv> monotone (fun_ord tailrec_ord) tailrec_ord"

lemma tailrec_admissible:
  "ccpo.admissible (fun_lub (flat_lub c)) (fun_ord (flat_ord c))
     (\<lambda>a. \<forall>x. a x \<noteq> c \<longrightarrow> P x (a x))"
proof(intro ccpo.admissibleI strip)
  fix A x
  assume chain: "Complete_Partial_Order.chain (fun_ord (flat_ord c)) A"
    and P [rule_format]: "\<forall>f\<in>A. \<forall>x. f x \<noteq> c \<longrightarrow> P x (f x)"
    and defined: "fun_lub (flat_lub c) A x \<noteq> c"
  from defined obtain f where f: "f \<in> A" "f x \<noteq> c"
    by(auto simp add: fun_lub_def flat_lub_def split: if_split_asm)
  hence "P x (f x)" by(rule P)
  moreover from chain f have "\<forall>f' \<in> A. f' x = c \<or> f' x = f x"
    by(auto 4 4 simp add: Complete_Partial_Order.chain_def flat_ord_def fun_ord_def)
  hence "fun_lub (flat_lub c) A x = f x"
    using f by(auto simp add: fun_lub_def flat_lub_def)
  ultimately show "P x (fun_lub (flat_lub c) A x)" by simp
qed

lemma fixp_induct_tailrec:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a" and
    C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> 'a \<Rightarrow> bool" and
    x :: "'b"
  assumes mono: "\<And>x. monotone (fun_ord (flat_ord c)) (flat_ord c) (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub c)) (fun_ord (flat_ord c)) (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x y. (\<And>x y. U f x = y \<Longrightarrow> y \<noteq> c \<Longrightarrow> P x y) \<Longrightarrow> U (F f) x = y \<Longrightarrow> y \<noteq> c \<Longrightarrow> P x y"
  assumes result: "U f x = y"
  assumes defined: "y \<noteq> c"
  shows "P x y"
proof -
  have "\<forall>x y. U f x = y \<longrightarrow> y \<noteq> c \<longrightarrow> P x y"
    by(rule partial_function_definitions.fixp_induct_uc[OF flat_interpretation, of _ U F C, OF mono eq inverse2])
      (auto intro: step tailrec_admissible simp add: fun_lub_def flat_lub_def)
  thus ?thesis using result defined by blast
qed

lemma admissible_image:
  assumes pfun: "partial_function_definitions le lub"
  assumes adm: "ccpo.admissible lub le (P \<circ> g)"
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  assumes inv: "\<And>x. f (g x) = x"
  shows "ccpo.admissible (img_lub f g lub) (img_ord f le) P"
proof (rule ccpo.admissibleI)
  fix A assume "chain (img_ord f le) A"
  then have ch': "chain le (f ` A)"
    by (auto simp: img_ord_def intro: chainI dest: chainD)
  assume "A \<noteq> {}"
  assume P_A: "\<forall>x\<in>A. P x"
  have "(P \<circ> g) (lub (f ` A))" using adm ch'
  proof (rule ccpo.admissibleD)
    fix x assume "x \<in> f ` A"
    with P_A show "(P \<circ> g) x" by (auto simp: inj[OF inv])
  qed(simp add: \<open>A \<noteq> {}\<close>)
  thus "P (img_lub f g lub A)" unfolding img_lub_def by simp
qed

lemma admissible_fun:
  assumes pfun: "partial_function_definitions le lub"
  assumes adm: "\<And>x. ccpo.admissible lub le (Q x)"
  shows "ccpo.admissible  (fun_lub lub) (fun_ord le) (\<lambda>f. \<forall>x. Q x (f x))"
proof (rule ccpo.admissibleI)
  fix A :: "('b \<Rightarrow> 'a) set"
  assume Q: "\<forall>f\<in>A. \<forall>x. Q x (f x)"
  assume ch: "chain (fun_ord le) A"
  assume "A \<noteq> {}"
  hence non_empty: "\<And>a. {y. \<exists>f\<in>A. y = f a} \<noteq> {}" by auto
  show "\<forall>x. Q x (fun_lub lub A x)"
    unfolding fun_lub_def
    by (rule allI, rule ccpo.admissibleD[OF adm chain_fun[OF ch] non_empty])
      (auto simp: Q)
qed

abbreviation "option_ord \<equiv> flat_ord None"
abbreviation "mono_option \<equiv> monotone (fun_ord option_ord) option_ord"

lemma bind_mono[partial_function_mono]:
assumes mf: "mono_option B" and mg: "\<And>y. mono_option (\<lambda>f. C y f)"
shows "mono_option (\<lambda>f. Option.bind (B f) (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b option" assume fg: "fun_ord option_ord f g"
  with mf
  have "option_ord (B f) (B g)" by (rule monotoneD[of _ _ _ f g])
  then have "option_ord (Option.bind (B f) (\<lambda>y. C y f)) (Option.bind (B g) (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg
  have "\<And>y'. option_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "option_ord (Option.bind (B g) (\<lambda>y'. C y' f)) (Option.bind (B g) (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (option.leq_trans)
  show "option_ord (Option.bind (B f) (\<lambda>y. C y f)) (Option.bind (B g) (\<lambda>y'. C y' g))" .
qed

lemma flat_lub_in_chain:
  assumes ch: "chain (flat_ord b) A "
  assumes lub: "flat_lub b A = a"
  shows "a = b \<or> a \<in> A"
proof (cases "A \<subseteq> {b}")
  case True
  then have "flat_lub b A = b" unfolding flat_lub_def by simp
  with lub show ?thesis by simp
next
  case False
  then obtain c where "c \<in> A" and "c \<noteq> b" by auto
  { fix z assume "z \<in> A"
    from chainD[OF ch \<open>c \<in> A\<close> this] have "z = c \<or> z = b"
      unfolding flat_ord_def using \<open>c \<noteq> b\<close> by auto }
  with False have "A - {b} = {c}" by auto
  with False have "flat_lub b A = c" by (auto simp: flat_lub_def)
  with \<open>c \<in> A\<close> lub show ?thesis by simp
qed

lemma option_admissible: "option.admissible (%(f::'a \<Rightarrow> 'b option).
  (\<forall>x y. f x = Some y \<longrightarrow> P x y))"
proof (rule ccpo.admissibleI)
  fix A :: "('a \<Rightarrow> 'b option) set"
  assume ch: "chain option.le_fun A"
    and IH: "\<forall>f\<in>A. \<forall>x y. f x = Some y \<longrightarrow> P x y"
  from ch have ch': "\<And>x. chain option_ord {y. \<exists>f\<in>A. y = f x}" by (rule chain_fun)
  show "\<forall>x y. option.lub_fun A x = Some y \<longrightarrow> P x y"
  proof (intro allI impI)
    fix x y assume "option.lub_fun A x = Some y"
    from flat_lub_in_chain[OF ch' this[unfolded fun_lub_def]]
    have "Some y \<in> {y. \<exists>f\<in>A. y = f x}" by simp
    then have "\<exists>f\<in>A. f x = Some y" by auto
    with IH show "P x y" by auto
  qed
qed

lemma fixp_induct_option:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a option" and
    C :: "('b \<Rightarrow> 'a option) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>x. mono_option (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub None)) (fun_ord option_ord) (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x y. (\<And>x y. U f x = Some y \<Longrightarrow> P x y) \<Longrightarrow> U (F f) x = Some y \<Longrightarrow> P x y"
  assumes defined: "U f x = Some y"
  shows "P x y"
  using step defined option.fixp_induct_uc[of U F C, OF mono eq inverse2 option_admissible]
  unfolding fun_lub_def flat_lub_def by(auto 9 2)

declaration \<open>Partial_Function.init "tailrec" \<^term>\<open>tailrec.fixp_fun\<close>
  \<^term>\<open>tailrec.mono_body\<close> @{thm tailrec.fixp_rule_uc} @{thm tailrec.fixp_induct_uc}
  (SOME @{thm fixp_induct_tailrec[where c = undefined]})\<close>

declaration \<open>Partial_Function.init "option" \<^term>\<open>option.fixp_fun\<close>
  \<^term>\<open>option.mono_body\<close> @{thm option.fixp_rule_uc} @{thm option.fixp_induct_uc}
  (SOME @{thm fixp_induct_option})\<close>

hide_const (open) chain

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Surjections from A to B up to a Permutation on A and B\<close>

theory Twelvefold_Way_Entry12
imports Twelvefold_Way_Entry9 Twelvefold_Way_Entry10
begin

subsection \<open>Properties for Bijections\<close>

lemma size_eq_card_implies_surj_on:
  assumes "finite A" "finite B"
  assumes "size N = card B"
  assumes "f \<in> functions_of A B N"
  shows   "f ` A = B"
proof -
  from \<open>f \<in> functions_of A B N\<close> have "f \<in> A \<rightarrow>\<^sub>E B" and
    "N = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))"
    unfolding functions_of_def by auto
  from this \<open>size N = card B\<close> have "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card B" by simp
  from this \<open>finite B\<close> \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> show "f ` A = B"
    using card_eq_implies_surjective_on by blast
qed

lemma surj_on_implies_size_eq_card:
  assumes "finite A" "finite B"
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B"
  assumes "univ (\<lambda>f. f ` A = B) F"
  shows "size (number_partition_of A B F) = card B"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = domain_and_range_permutation A B `` {f}" using quotientE by blast
  have "number_partition_of A B F = univ (\<lambda>f. image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))) F"
    unfolding number_partition_of_def ..
  also have "\<dots> =  univ (\<lambda>f. image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))) (domain_and_range_permutation A B `` {f})"
    unfolding F_eq ..
  also have "\<dots> = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))"
    using \<open>finite B\<close> equiv_domain_and_range_permutation multiset_of_partition_cards_respects_domain_and_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  finally have eq: "number_partition_of A B F = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))" .
  from iffD1[OF univ_commute', OF equiv_domain_and_range_permutation, OF surjective_respects_domain_and_range_permutation, OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>]
    assms(4) have "f ` A = B" by (simp add: F_eq)
  have "size (number_partition_of A B F) = size (image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})))"
    unfolding eq ..
  also have "\<dots> = card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})" by simp
  also from \<open>f ` A = B\<close> have "\<dots> = card B"
    using surjective_on_implies_card_eq by auto
  finally show ?thesis .
qed

lemma functions_of_is_surj_on:
  assumes "finite A" "finite B"
  assumes "number_partition (card A) N" "size N = card B"
  shows "univ (\<lambda>f. f ` A = B) (functions_of A B N)"
proof -
  have "functions_of A B N \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B"
    using functions_of \<open>finite A\<close> \<open>finite B\<close> \<open>number_partition (card A) N \<close> \<open>size N = card B\<close>
    by fastforce
  from this obtain f where eq_f: "functions_of A B N = domain_and_range_permutation A B `` {f}" and "f \<in> A \<rightarrow>\<^sub>E B"
    using quotientE by blast
  from eq_f have "f \<in> functions_of A B N"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> equiv_domain_and_range_permutation equiv_class_self by fastforce
  have "f ` A = B"
    using \<open>f \<in> functions_of A B N\<close> assms size_eq_card_implies_surj_on by blast
  from this show ?thesis
    unfolding eq_f using equiv_domain_and_range_permutation surjective_respects_domain_and_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') assumption+
qed

subsection \<open>Bijections\<close>

lemma bij_betw_number_partition_of:
   assumes "finite A" "finite B"
  shows "bij_betw (number_partition_of A B) ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B) {N. number_partition (card A) N \<and> size N = card B}"
proof (rule bij_betw_byWitness[where f'="functions_of A B"])
  have quotient_eq: "{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B). univ (\<lambda>f. f ` A = B) F}"
    using equiv_domain_and_range_permutation[of A B] surjective_respects_domain_and_range_permutation[of A B] by (simp only: univ_preserves_predicate)
  show "\<forall>F\<in>{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B.
       functions_of A B (number_partition_of A B F) = F"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp only: quotient_eq functions_of_number_partition_of)
  show "\<forall>N\<in>{N. number_partition (card A) N  \<and> size N = card B}. number_partition_of A B (functions_of A B N) = N"
    using \<open>finite A\<close> \<open>finite B\<close> by (simp add: number_partition_of_functions_of)
  show "number_partition_of A B ` ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B)
    \<subseteq> {N. number_partition (card A) N  \<and> size N = card B}"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq number_partition_of surj_on_implies_size_eq_card)
  show "functions_of A B ` {N. number_partition (card A) N \<and> size N = card B}
    \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq intro: functions_of functions_of_is_surj_on)
qed

lemma bij_betw_functions_of:
   assumes "finite A" "finite B"
  shows "bij_betw (functions_of A B) {N. number_partition (card A) N \<and> size N = card B} ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B)"
proof (rule bij_betw_byWitness[where f'="number_partition_of A B"])
  have quotient_eq: "{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B). univ (\<lambda>f. f ` A = B) F}"
    using equiv_domain_and_range_permutation[of A B] surjective_respects_domain_and_range_permutation[of A B] by (simp only: univ_preserves_predicate)
  show "\<forall>F\<in>{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B.
       functions_of A B (number_partition_of A B F) = F"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp only: quotient_eq functions_of_number_partition_of)
  show "\<forall>N\<in>{N. number_partition (card A) N  \<and> size N = card B}. number_partition_of A B (functions_of A B N) = N"
    using \<open>finite A\<close> \<open>finite B\<close> by (simp add: number_partition_of_functions_of)
  show "number_partition_of A B ` ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B)
    \<subseteq> {N. number_partition (card A) N  \<and> size N = card B}"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq number_partition_of surj_on_implies_size_eq_card)
  show "functions_of A B ` {N. number_partition (card A) N \<and> size N = card B}
    \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq intro: functions_of functions_of_is_surj_on)
qed

subsection \<open>Cardinality\<close>

lemma card_surjective_functions_domain_and_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B) = Partition (card A) (card B)"
proof -
  have "bij_betw (number_partition_of A B) ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B) {N. number_partition (card A) N \<and> size N = card B}"
     using \<open>finite A\<close> \<open>finite B\<close> by (rule bij_betw_number_partition_of)
  from this have "card ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B) = card {N. number_partition (card A) N \<and> size N = card B}"
    by (rule bij_betw_same_card)
  also have "card {N. number_partition (card A) N \<and> size N = card B} = Partition (card A) (card B)"
    by (rule card_partitions_with_k_parts)
  finally show ?thesis .
qed

end