header {* \isaheader{Miscellanneous Lemmas and Tools} *}
theory Refine_Misc
imports
  "../Automatic_Refinement/Automatic_Refinement"
begin

subsection {* ML-level stuff *}

ML {*

structure Refine_Misc = struct
  (* Fail if goal index out of bounds. *)
  (* Use IF_EXGOAL instead!
  fun wrap_nogoals tac i st = if nprems_of st < i then
    no_tac st
  else
    tac i st;*)

  (********************)
  (* Monotonicity Prover *)
  (********************)

    structure refine_mono = Named_Thms
      ( val name = @{binding refine_mono}
        val description = "Refinement Framework: " ^
          "Monotonicity rules" )

    (*structure refine_mono_trigger = Named_Thms
      ( val name = @{binding refine_mono_trigger}
        val description = "Refinement Framework: " ^
          "Triggering rules for monotonicity prover" )
    *)

    (* Monotonicity prover: Solve by removing function arguments *)
    fun solve_le_tac ctxt = SOLVED' (REPEAT_ALL_NEW (
      Method.assm_tac ctxt ORELSE' fo_rtac @{thm le_funD} ctxt));

    (* Monotonicity prover. TODO: A related thing is in the
      partial_function package, can we reuse (parts of) that?
    *)
    fun mono_prover_tac ctxt = REPEAT_ALL_NEW (FIRST' [
      Method.assm_tac ctxt,
      match_tac (refine_mono.get ctxt),
      solve_le_tac ctxt
    ]);

    fun untriggered_mono_tac ctxt = mono_prover_tac ctxt
      THEN_ALL_NEW (TRY o Tagged_Solver.solve_tac ctxt)

    val declare_mono_triggers =
      Tagged_Solver.add_triggers "Refine_Misc.refine_mono"
      (* TODO: Hack, how to get correct naming? *)

    val setup = refine_mono.setup
    val decl_setup =
      Tagged_Solver.declare_solver
        @{thms monoI monotoneI[of "op \<le>" "op \<le>"]} @{binding refine_mono}
        "Autoref: Monotonicity prover"
        mono_prover_tac
end;
*}

setup Refine_Misc.setup
declaration Refine_Misc.decl_setup

method_setup refine_mono =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (
    Refine_Misc.untriggered_mono_tac ctxt
  )) *}
  "Refinement framework: Monotonicity prover"

text {* Basic configuration for monotonicity prover: *}
lemmas [refine_mono] = monoI monotoneI[of "op \<le>" "op \<le>"]
lemmas [refine_mono] = TrueI le_funI order_refl

lemma case_prod_mono[refine_mono]:
  "\<lbrakk>\<And>a b. p=(a,b) \<Longrightarrow> f a b \<le> f' a b\<rbrakk> \<Longrightarrow> case_prod f p \<le> case_prod f' p"
  by (auto split: prod.split)

lemma case_option_mono[refine_mono]:
  assumes "fn \<le> fn'"
  assumes "\<And>v. x=Some v \<Longrightarrow> fs v \<le> fs' v"
  shows "case_option fn fs x \<le> case_option fn' fs' x"
  using assms by (auto split: option.split)

lemma case_list_mono[refine_mono]:
  assumes "fn \<le> fn'"
  assumes "\<And>x xs. l=x#xs \<Longrightarrow> fc x xs \<le> fc' x xs"
  shows "case_list fn fc l \<le> case_list fn' fc' l"
  using assms by (auto split: list.split)

lemma if_mono[refine_mono]:
  assumes "b \<Longrightarrow> m1 \<le> m1'"
  assumes "\<not>b \<Longrightarrow> m2 \<le> m2'"
  shows "(if b then m1 else m2) \<le> (if b then m1' else m2')"
  using assms by auto

lemma let_mono[refine_mono]:
  "f x \<le> f' x' \<Longrightarrow> Let x f \<le> Let x' f'" by auto

subsection {* Uncategorized Lemmas *}
lemma all_nat_split_at: "\<forall>i::'a::linorder<k. P i \<Longrightarrow> P k \<Longrightarrow> \<forall>i>k. P i
  \<Longrightarrow> \<forall>i. P i"
  by (metis linorder_neq_iff)

subsection {* Well-Foundedness *}

lemma wf_no_infinite_down_chainI:
  assumes "\<And>f. \<lbrakk>\<And>i. (f (Suc i), f i)\<in>r\<rbrakk> \<Longrightarrow> False"
  shows "wf r"
  by (metis assms wf_iff_no_infinite_down_chain)

text {* This lemma transfers well-foundedness over a simulation relation. *}
lemma sim_wf:
  assumes WF: "wf (S'\<inverse>)"
  assumes STARTR: "(x0,x0')\<in>R"
  assumes SIM: "\<And>s s' t. \<lbrakk> (s,s')\<in>R; (s,t)\<in>S; (x0',s')\<in>S'\<^sup>* \<rbrakk>
    \<Longrightarrow> \<exists>t'. (s',t')\<in>S' \<and> (t,t')\<in>R"
  assumes CLOSED: "Domain S  \<subseteq> S\<^sup>*``{x0}"
  shows "wf (S\<inverse>)"
proof (rule wf_no_infinite_down_chainI, simp)
  txt {*
    Informal proof:
    Assume there is an infinite chain in @{text "S"}.
    Due to the closedness property of @{text "S"}, it can be extended to
    start at @{text x0}.
    Now, we inductively construct an infinite chain in @{text "S'"}, such that
    each element of the new chain is in relation with the corresponding
    element of the original chain:
      The first element is @{text "x0'"}.
      For any element @{text "i+1"}, the simulation property yields the next
      element.
    This chain contradicts well-foundedness of @{text "S'"}.
    *}

  fix f
  assume CHAIN: "\<And>i. (f i, f (Suc i))\<in>S"
  txt {* Extend to start with @{text "x0"} *}
  obtain f' where CHAIN': "\<And>i. (f' i, f' (Suc i))\<in>S" and [simp]: "f' 0 = x0"
  proof -
    {
      fix x
      assume S: "x = f 0"
      from CHAIN have "f 0 \<in> Domain S" by auto
      with CLOSED have "(x0,x)\<in>S\<^sup>*" by (auto simp: S)
      then obtain g k where G0: "g 0 = x0" and X: "x = g k"
        and CH: "(\<forall>i<k. (g i, g (Suc i))\<in>S)"
      proof induct
        case base thus ?case by force
      next
        case (step y z) show ?case proof (rule step.hyps(3))
          fix g k
          assume "g 0 = x0" and "y = g k"
            and "\<forall>i<k. (g i, g (Suc i))\<in>S"
          thus ?case using `(y,z)\<in>S`
            by (rule_tac step.prems[where g="g(Suc k := z)" and k="Suc k"])
              auto
        qed
      qed
      def f'\<equiv>"\<lambda>i. if i<k then g i else f (i-k)"
      have "\<exists>f'. f' 0 = x0 \<and> (\<forall>i. (f' i, f' (Suc i))\<in>S)"
        apply (rule_tac x=f' in exI)
        apply (unfold f'_def)
        apply (rule conjI)
        using S X G0 apply (auto) []
        apply (rule_tac k=k in all_nat_split_at)
        apply (auto)
        apply (simp add: CH)
        apply (subgoal_tac "k = Suc i")
        apply (simp add: S[symmetric] CH X)
        apply simp
        apply (simp add: CHAIN)
        apply (subgoal_tac "Suc i - k = Suc (i-k)")
        using CHAIN apply simp
        apply simp
        done
    }
    then obtain f' where "\<forall>i. (f' i,f' (Suc i))\<in>S" and "f' 0 = x0" by blast
    thus ?thesis by (blast intro!: that)
  qed

  txt {* Construct chain in @{text "S'"}*}
  def g'\<equiv>"rec_nat x0' (\<lambda>i x. SOME x'.
          (x,x')\<in>S' \<and> (f' (Suc i),x')\<in>R \<and> (x0', x')\<in>S'\<^sup>* )"
  {
    fix i
    note [simp] = g'_def
    have "(g' i, g' (Suc i))\<in>S' \<and> (f' (Suc i),g' (Suc i))\<in>R
      \<and> (x0',g' (Suc i))\<in>S'\<^sup>*"
    proof (induct i)
      case 0
      from SIM[OF STARTR] CHAIN'[of 0] obtain t' where
        "(x0',t')\<in>S'" and "(f' (Suc 0),t')\<in>R" by auto
      moreover hence "(x0',t')\<in>S'\<^sup>*" by auto
      ultimately show ?case
        by (auto intro: someI2 simp: STARTR)
    next
      case (Suc i)
      with SIM[OF _ CHAIN'[of "Suc i"]]
      obtain t' where LS: "(g' (Suc i),t')\<in>S'" and "(f' (Suc (Suc i)),t')\<in>R"
        by auto
      moreover from LS Suc have "(x0', t')\<in>S'\<^sup>*" by auto
      ultimately show ?case
        apply simp
        apply (rule_tac a="t'" in someI2)
        apply auto
        done
    qed
  } hence S'CHAIN: "\<forall>i. (g' i, g'(Suc i))\<in>S'" by simp
  txt {* This contradicts well-foundedness *}
  with WF show False
    by (erule_tac wf_no_infinite_down_chainE[where f=g']) simp
qed

text {* Well-founded relation that approximates a finite set from below. *}
definition "finite_psupset S \<equiv> { (Q',Q). Q\<subset>Q' \<and> Q' \<subseteq> S }"
lemma finite_psupset_wf[simp, intro]: "finite S \<Longrightarrow> wf (finite_psupset S)"
  unfolding finite_psupset_def by (blast intro: wf_bounded_supset)

subsection {* Monotonicity and Orderings *}

lemma mono_const[simp, intro!]: "mono (\<lambda>_. c)" by (auto intro: monoI)
lemma mono_if: "\<lbrakk>mono S1; mono S2\<rbrakk> \<Longrightarrow>
  mono (\<lambda>F s. if b s then S1 F s else S2 F s)"
  apply rule
  apply (rule le_funI)
  apply (auto dest: monoD[THEN le_funD])
  done

lemma mono_infI: "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (inf f g)"
  unfolding inf_fun_def
  apply (rule monoI)
  apply (metis inf_mono monoD)
  done

lemma mono_infI':
  "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (\<lambda>x. inf (f x) (g x) :: 'b::lattice)"
  by (rule mono_infI[unfolded inf_fun_def])

lemma mono_infArg:
  fixes f :: "'a::lattice \<Rightarrow> 'b::order"
  shows "mono f \<Longrightarrow> mono (\<lambda>x. f (inf x X))"
  apply (rule monoI)
  apply (erule monoD)
  apply (metis inf_mono order_refl)
  done

lemma mono_Sup:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> Sup (f`S) \<le> f (Sup S)"
  apply (rule Sup_least)
  apply (erule imageE)
  apply simp
  apply (erule monoD)
  apply (erule Sup_upper)
  done

lemma mono_SupI:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  assumes "mono f"
  assumes "S'\<subseteq>f`S"
  shows "Sup S' \<le> f (Sup S)"
  by (metis Sup_subset_mono assms mono_Sup order_trans)

lemma mono_Inf:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> f (Inf S) \<le> Inf (f`S)"
  apply (rule Inf_greatest)
  apply (erule imageE)
  apply simp
  apply (erule monoD)
  apply (erule Inf_lower)
  done

lemma mono_funpow: "mono (f::'a::order \<Rightarrow> 'a) \<Longrightarrow> mono (f^^i)"
  apply (induct i)
  apply (auto intro!: monoI)
  apply (auto dest: monoD)
  done

lemma mono_id[simp, intro!]:
  "mono id"
  "mono (\<lambda>x. x)"
  by (auto intro: monoI)

declare SUP_insert[simp]

lemma (in semilattice_inf) le_infD1:
  "a \<le> inf b c \<Longrightarrow> a \<le> b" by (rule le_infE)
lemma (in semilattice_inf) le_infD2:
  "a \<le> inf b c \<Longrightarrow> a \<le> c" by (rule le_infE)
lemma (in semilattice_inf) inf_leI:
  "\<lbrakk> \<And>x. \<lbrakk> x\<le>a; x\<le>b \<rbrakk> \<Longrightarrow> x\<le>c \<rbrakk> \<Longrightarrow> inf a b \<le> c"
  by (metis inf_le1 inf_le2)

lemma top_Sup: "(top::'a::complete_lattice)\<in>A \<Longrightarrow> Sup A = top"
  by (metis Sup_upper top_le)
lemma bot_Inf: "(bot::'a::complete_lattice)\<in>A \<Longrightarrow> Inf A = bot"
  by (metis Inf_lower le_bot)

lemma mono_compD: "mono f \<Longrightarrow> x\<le>y \<Longrightarrow> f o x \<le> f o y"
  apply (rule le_funI)
  apply (auto dest: monoD le_funD)
  done

subsubsection {* Galois Connections *}
locale galois_connection =
  fixes \<alpha>::"'a::complete_lattice \<Rightarrow> 'b::complete_lattice" and \<gamma>
  assumes galois: "c \<le> \<gamma>(a) \<longleftrightarrow> \<alpha>(c) \<le> a"
begin
  lemma \<alpha>\<gamma>_defl: "\<alpha>(\<gamma>(x)) \<le> x"
  proof -
    have "\<gamma> x \<le> \<gamma> x" by simp
    with galois show "\<alpha>(\<gamma>(x)) \<le> x" by blast
  qed
  lemma \<gamma>\<alpha>_infl: "x \<le> \<gamma>(\<alpha>(x))"
  proof -
    have "\<alpha> x \<le> \<alpha> x" by simp
    with galois show "x \<le> \<gamma>(\<alpha>(x))" by blast
  qed

  lemma \<gamma>_mono: "mono \<gamma>"
    by rule (metis \<alpha>\<gamma>_defl galois inf_absorb1 le_infE)

  lemma dist_\<gamma>[simp]:
    "\<gamma> (inf a b) = inf (\<gamma> a) (\<gamma> b)"
    apply (rule order_antisym)
    apply (rule mono_inf[OF \<gamma>_mono])
    apply (simp add: galois)
    apply (simp add: galois[symmetric])
    done

  lemma dist_\<alpha>[simp]:
    "\<alpha> (sup a b) = sup (\<alpha> a) (\<alpha> b)"
    by (metis (no_types) \<alpha>_mono galois mono_sup order_antisym
      sup_ge1 sup_ge2 sup_least)

end

subsubsection {* Fixed Points *}
lemma mono_lfp_eqI:
  assumes MONO: "mono f"
  assumes FIXP: "f a \<le> a"
  assumes LEAST: "\<And>x. f x = x \<Longrightarrow> a\<le>x"
  shows "lfp f = a"
  apply (rule antisym)
  apply (rule lfp_lowerbound)
  apply (rule FIXP)
  by (metis LEAST MONO lfp_unfold)

lemma mono_gfp_eqI:
  assumes MONO: "mono f"
  assumes FIXP: "a \<le> f a"
  assumes GREATEST: "\<And>x. f x = x \<Longrightarrow> x\<le>a"
  shows "gfp f = a"
  apply (rule antisym)
  apply (metis GREATEST MONO gfp_unfold)
  apply (rule gfp_upperbound)
  apply (rule FIXP)
  done

lemma lfp_le_gfp: "mono f \<Longrightarrow> lfp f \<le> gfp f"
  by (metis gfp_upperbound lfp_lemma3)

lemma lfp_le_gfp': "mono f \<Longrightarrow> lfp f x \<le> gfp f x"
  by (rule le_funD[OF lfp_le_gfp])

subsubsection {* Connecting Complete Lattices and
  Chain-Complete Partial Orders *}
(* Note: Also connected by subclass now. However, we need both directions
  of embedding*)
lemma (in complete_lattice) is_ccpo: "class.ccpo Sup (op \<le>) (op <)"
  apply unfold_locales
  apply (erule Sup_upper)
  apply (erule Sup_least)
  done

lemma (in complete_lattice) is_dual_ccpo: "class.ccpo Inf (op \<ge>) (op >)"
  apply unfold_locales
  apply (rule less_le_not_le)
  apply (rule order_refl)
  apply (erule (1) order_trans)
  apply (erule (1) antisym)
  apply (erule Inf_lower)
  apply (erule Inf_greatest)
  done

lemma ccpo_mono_simp: "monotone (op \<le>) (op \<le>) f \<longleftrightarrow> mono f"
  unfolding monotone_def mono_def by simp
lemma ccpo_monoI: "mono f \<Longrightarrow> monotone (op \<le>) (op \<le>) f"
  by (simp add: ccpo_mono_simp)
lemma ccpo_monoD: "monotone (op \<le>) (op \<le>) f \<Longrightarrow> mono f"
  by (simp add: ccpo_mono_simp)

lemma dual_ccpo_mono_simp: "monotone (op \<ge>) (op \<ge>) f \<longleftrightarrow> mono f"
  unfolding monotone_def mono_def by auto
lemma dual_ccpo_monoI: "mono f \<Longrightarrow> monotone (op \<ge>) (op \<ge>) f"
  by (simp add: dual_ccpo_mono_simp)
lemma dual_ccpo_monoD: "monotone (op \<ge>) (op \<ge>) f \<Longrightarrow> mono f"
  by (simp add: dual_ccpo_mono_simp)

lemma ccpo_lfp_simp: "\<And>f. mono f \<Longrightarrow> ccpo.fixp Sup op \<le> f = lfp f"
  apply (rule antisym)
  defer
  apply (rule lfp_lowerbound)
  apply (drule ccpo.fixp_unfold[OF is_ccpo ccpo_monoI, symmetric])
  apply simp

  apply (rule ccpo.fixp_lowerbound[OF is_ccpo ccpo_monoI], assumption)
  apply (simp add: lfp_unfold[symmetric])
  done

lemma ccpo_gfp_simp: "\<And>f. mono f \<Longrightarrow> ccpo.fixp Inf op \<ge> f = gfp f"
  apply (rule antisym)
  apply (rule gfp_upperbound)
  apply (drule ccpo.fixp_unfold[OF is_dual_ccpo dual_ccpo_monoI, symmetric])
  apply simp

  apply (rule ccpo.fixp_lowerbound[OF is_dual_ccpo dual_ccpo_monoI], assumption)
  apply (simp add: gfp_unfold[symmetric])
  done

abbreviation "chain_admissible P \<equiv> ccpo.admissible Sup op \<le> P"
abbreviation "is_chain \<equiv> Complete_Partial_Order.chain (op \<le>)"
lemmas chain_admissibleI[intro?] = ccpo.admissibleI[where lub=Sup and ord="op \<le>"]

abbreviation "dual_chain_admissible P \<equiv> ccpo.admissible Inf (\<lambda>x y. y\<le>x) P"
abbreviation "is_dual_chain \<equiv> Complete_Partial_Order.chain (\<lambda>x y. y\<le>x)"
lemmas dual_chain_admissibleI[intro?] =
  ccpo.admissibleI[where lub=Inf and ord="(\<lambda>x y. y\<le>x)"]

lemma dual_chain_iff[simp]: "is_dual_chain C = is_chain C"
  unfolding chain_def
  apply auto
  done

lemmas chain_dualI = iffD1[OF dual_chain_iff]
lemmas dual_chainI = iffD2[OF dual_chain_iff]

lemma is_chain_empty[simp, intro!]: "is_chain {}"
  by (rule chainI) auto
lemma is_dual_chain_empty[simp, intro!]: "is_dual_chain {}"
  by (rule dual_chainI) auto

lemma point_chainI: "is_chain M \<Longrightarrow> is_chain ((\<lambda>f. f x)`M)"
  by (auto intro: chainI le_funI dest: chainD le_funD)

text {* We transfer the admissible induction lemmas to complete
  lattices. *}
lemma lfp_cadm_induct:
  "\<lbrakk>chain_admissible P; P (Sup {}); mono f; \<And>x. P x \<Longrightarrow> P (f x)\<rbrakk> \<Longrightarrow> P (lfp f)"
  by (simp only: ccpo_mono_simp[symmetric] ccpo_lfp_simp[symmetric])
     (rule ccpo.fixp_induct[OF is_ccpo])

lemma gfp_cadm_induct:
  "\<lbrakk>dual_chain_admissible P; P (Inf {}); mono f; \<And>x. P x \<Longrightarrow> P (f x)\<rbrakk> \<Longrightarrow> P (gfp f)"
  by (simp only: dual_ccpo_mono_simp[symmetric] ccpo_gfp_simp[symmetric])
     (rule ccpo.fixp_induct[OF is_dual_ccpo])

subsubsection {* Continuity and Kleene Fixed Point Theorem *}
definition "cont f \<equiv> \<forall>C. C\<noteq>{} \<longrightarrow> f (Sup C) = Sup (f`C)"
definition "strict f \<equiv> f bot = bot"
definition "inf_distrib f \<equiv> strict f \<and> cont f"

lemma contI[intro?]: "\<lbrakk>\<And>C. C\<noteq>{} \<Longrightarrow> f (Sup C) = Sup (f`C)\<rbrakk> \<Longrightarrow> cont f"
  unfolding cont_def by auto
lemma contD: "cont f \<Longrightarrow> C\<noteq>{} \<Longrightarrow> f (Sup C) = Sup (f`C)"
  unfolding cont_def by auto
lemma contD': "cont f \<Longrightarrow> C\<noteq>{} \<Longrightarrow> f (Sup C) = SUPREMUM C f"
  using contD by simp

lemma strictD[dest]: "strict f \<Longrightarrow> f bot = bot"
  unfolding strict_def by auto
-- "We only add this lemma to the simpset for functions on the same type.
    Otherwise, the simplifier tries it much too often."
lemma strictD_simp[simp]: "strict f \<Longrightarrow> f (bot::'a::bot) = (bot::'a)"
  unfolding strict_def by auto

lemma strictI[intro?]: "f bot = bot \<Longrightarrow> strict f"
  unfolding strict_def by auto

lemma inf_distribD[simp]:
  "inf_distrib f \<Longrightarrow> strict f"
  "inf_distrib f \<Longrightarrow> cont f"
  unfolding inf_distrib_def by auto

lemma inf_distribI[intro?]: "\<lbrakk>strict f; cont f\<rbrakk> \<Longrightarrow> inf_distrib f"
  unfolding inf_distrib_def by auto

lemma inf_distribD'[simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "inf_distrib f \<Longrightarrow> f (Sup C) = Sup (f`C)"
  apply (cases "C={}")
  apply (auto dest: inf_distribD contD')
  done

lemma inf_distrib_is_mono[simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "inf_distrib f \<Longrightarrow> mono f"
  by simp

text {* Only proven for complete lattices here. Also holds for CCPOs. *}
theorem kleene_lfp:
  fixes f:: "'a::complete_lattice \<Rightarrow> 'a"
  assumes CONT: "cont f"
  shows "lfp f = (SUP i. (f^^i) bot)"
proof (rule antisym)
  let ?K="{ (f^^i) bot | i . True}"
  note MONO=cont_is_mono[OF CONT]
  {
    fix i
    have "(f^^i) bot \<le> lfp f"
      apply (induct i)
      apply simp
      apply simp
      by (metis MONO lfp_unfold monoD)
  } thus "(SUP i. (f^^i) bot) \<le> lfp f" by (blast intro: SUP_least)
next
  show "lfp f \<le> (SUP i. (f^^i) bot)"
    apply (rule lfp_lowerbound)
    unfolding SUP_def
    apply (simp add: contD [OF CONT] del: Sup_image_eq)
    apply (rule Sup_subset_mono)
    apply (auto)
    apply (rule_tac x="Suc i" in range_eqI)
    apply auto
    done
qed

lemma (in galois_connection) dual_inf_dist_\<gamma>: "\<gamma> (Inf C) = Inf (\<gamma>`C)"
  apply (rule antisym)
  apply (rule Inf_greatest)
  apply clarify
  apply (rule monoD[OF \<gamma>_mono])
  apply (rule Inf_lower)
  apply simp

  apply (subst galois)
  apply (rule Inf_greatest)
  apply (subst galois[symmetric])
  apply (rule Inf_lower)
  apply simp
  done

lemma (in galois_connection) inf_dist_\<alpha>: "inf_distrib \<alpha>"
  apply (rule inf_distribI')
  apply (rule antisym)

  apply (subst galois[symmetric])
  apply (rule Sup_least)
  apply (subst galois)
  apply (rule Sup_upper)
  apply simp

  apply (rule Sup_least)
  apply clarify
  apply (rule monoD[OF \<alpha>_mono])
  apply (rule Sup_upper)
  apply simp
  done

subsection {* Maps *}
subsubsection {* Key-Value Set *}

  lemma map_to_set_simps[simp]:
    "map_to_set Map.empty = {}"
    "map_to_set [a\<mapsto>b] = {(a,b)}"
    "map_to_set (m|`K) = map_to_set m \<inter> K\<times>UNIV"
    "map_to_set (m(x:=None)) = map_to_set m - {x}\<times>UNIV"
    "map_to_set (m(x\<mapsto>v)) = map_to_set m - {x}\<times>UNIV \<union> {(x,v)}"
    "map_to_set m \<inter> dom m\<times>UNIV = map_to_set m"
    "m k = Some v \<Longrightarrow> (k,v)\<in>map_to_set m"
    "single_valued (map_to_set m)"
    apply (simp_all)
    by (auto simp: map_to_set_def restrict_map_def split: split_if_asm
      intro: single_valuedI)

  lemma map_to_set_inj:
    "(k,v)\<in>map_to_set m \<Longrightarrow> (k,v')\<in>map_to_set m \<Longrightarrow> v = v'"
    by (auto simp: map_to_set_def)

end


theory Examples
imports Main "HOL-Library.Predicate_Compile_Alternative_Defs"
begin

declare [[values_timeout = 480.0]]

section \<open>Formal Languages\<close>

subsection \<open>General Context Free Grammars\<close>

text \<open>a contribution by Aditi Barthwal\<close>

datatype ('nts,'ts) symbol = NTS 'nts
                            | TS 'ts

datatype ('nts,'ts) rule = rule 'nts "('nts,'ts) symbol list"

type_synonym ('nts,'ts) grammar = "('nts,'ts) rule set * 'nts"

fun rules :: "('nts,'ts) grammar => ('nts,'ts) rule set"
where
  "rules (r, s) = r"

definition derives
where
"derives g = { (lsl,rsl). \<exists>s1 s2 lhs rhs.
                         (s1 @ [NTS lhs] @ s2 = lsl) \<and>
                         (s1 @ rhs @ s2) = rsl \<and>
                         (rule lhs rhs) \<in> fst g }"

definition derivesp ::
  "(('nts, 'ts) rule => bool) * 'nts => ('nts, 'ts) symbol list => ('nts, 'ts) symbol list => bool"
where
  "derivesp g = (\<lambda> lhs rhs. (lhs, rhs) \<in> derives (Collect (fst g), snd g))"

lemma [code_pred_def]:
  "derivesp g = (\<lambda> lsl rsl. \<exists>s1 s2 lhs rhs.
                         (s1 @ [NTS lhs] @ s2 = lsl) \<and>
                         (s1 @ rhs @ s2) = rsl \<and>
                         (fst g) (rule lhs rhs))"
unfolding derivesp_def derives_def by auto

abbreviation "example_grammar ==
({ rule ''S'' [NTS ''A'', NTS ''B''],
   rule ''S'' [TS ''a''],
  rule ''A'' [TS ''b'']}, ''S'')"

definition "example_rules ==
(%x. x = rule ''S'' [NTS ''A'', NTS ''B''] \<or>
   x = rule ''S'' [TS ''a''] \<or>
  x = rule ''A'' [TS ''b''])"

code_pred [inductify, skip_proof] derivesp .

thm derivesp.equation

definition "testp = (% rhs. derivesp (example_rules, ''S'') [NTS ''S''] rhs)"

code_pred (modes: o \<Rightarrow> bool) [inductify] testp .
thm testp.equation

values "{rhs. testp rhs}"

declare rtranclp.intros(1)[code_pred_def] converse_rtranclp_into_rtranclp[code_pred_def]

code_pred [inductify] rtranclp .

definition "test2 = (\<lambda> rhs. rtranclp (derivesp (example_rules, ''S'')) [NTS ''S''] rhs)"

code_pred [inductify, skip_proof] test2 .

values "{rhs. test2 rhs}"

subsection \<open>Some concrete Context Free Grammars\<close>

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

code_pred [inductify] S\<^sub>1p .
code_pred [random_dseq inductify] S\<^sub>1p .
thm S\<^sub>1p.equation
thm S\<^sub>1p.random_dseq_equation

values [random_dseq 5, 5, 5] 5 "{x. S\<^sub>1p x}"

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

code_pred [random_dseq inductify] S\<^sub>2p .
thm S\<^sub>2p.random_dseq_equation
thm A\<^sub>2p.random_dseq_equation
thm B\<^sub>2p.random_dseq_equation

values [random_dseq 5, 5, 5] 10 "{x. S\<^sub>2p x}"

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

code_pred [inductify, skip_proof] S\<^sub>3p .
thm S\<^sub>3p.equation

values 10 "{x. S\<^sub>3p x}"

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

code_pred (expected_modes: o => bool, i => bool) S\<^sub>4p .

hide_const a b

section \<open>Semantics of programming languages\<close>

subsection \<open>IMP\<close>

type_synonym var = nat
type_synonym state = "int list"

datatype com =
  Skip |
  Ass var "state => int" |
  Seq com com |
  IF "state => bool" com com |
  While "state => bool" com

inductive exec :: "com => state => state => bool" where
"exec Skip s s" |
"exec (Ass x e) s (s[x := e(s)])" |
"exec c1 s1 s2 ==> exec c2 s2 s3 ==> exec (Seq c1 c2) s1 s3" |
"b s ==> exec c1 s t ==> exec (IF b c1 c2) s t" |
"~b s ==> exec c2 s t ==> exec (IF b c1 c2) s t" |
"~b s ==> exec (While b c) s s" |
"b s1 ==> exec c s1 s2 ==> exec (While b c) s2 s3 ==> exec (While b c) s1 s3"

code_pred exec .

values "{t. exec
 (While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))))
 [3,5] t}"

subsection \<open>Lambda\<close>

datatype type =
    Atom nat
  | Fun type type    (infixr "\<Rightarrow>" 200)

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs type dB

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = None"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

inductive nth_el' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
where
  "nth_el' (x # xs) 0 x"
| "nth_el' xs i y \<Longrightarrow> nth_el' (x # xs) (Suc i) y"

inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
  where
    Var [intro!]: "nth_el' env x T \<Longrightarrow> env \<turnstile> Var x : T"
  | Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
  | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs T s) k = Abs T (lift s (k + 1))"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (i - 1) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs T t)[s/k] = Abs T (t[lift s 0 / k+1])"

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs T s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"

code_pred (expected_modes: i => i => o => bool, i => i => i => bool) typing .
thm typing.equation

code_pred (modes: i => i => bool,  i => o => bool as reduce') beta .
thm beta.equation

values "{x. App (Abs (Atom 0) (Var 0)) (Var 1) \<rightarrow>\<^sub>\<beta> x}"

definition "reduce t = Predicate.the (reduce' t)"

value "reduce (App (Abs (Atom 0) (Var 0)) (Var 1))"

code_pred [dseq] typing .
code_pred [random_dseq] typing .

values [random_dseq 1,1,5] 10 "{(\<Gamma>, t, T). \<Gamma> \<turnstile> t : T}"

subsection \<open>A minimal example of yet another semantics\<close>

text \<open>thanks to Elke Salecker\<close>

type_synonym vname = nat
type_synonym vvalue = int
type_synonym var_assign = "vname \<Rightarrow> vvalue"  \<comment> \<open>variable assignment\<close>

datatype ir_expr =
  IrConst vvalue
| ObjAddr vname
| Add ir_expr ir_expr

datatype val =
  IntVal  vvalue

record  configuration =
  Env :: var_assign

inductive eval_var ::
  "ir_expr \<Rightarrow> configuration \<Rightarrow> val \<Rightarrow> bool"
where
  irconst: "eval_var (IrConst i) conf (IntVal i)"
| objaddr: "\<lbrakk> Env conf n = i \<rbrakk> \<Longrightarrow> eval_var (ObjAddr n) conf (IntVal i)"
| plus: "\<lbrakk> eval_var l conf (IntVal vl); eval_var r conf (IntVal vr) \<rbrakk> \<Longrightarrow>
    eval_var (Add l r) conf (IntVal (vl+vr))"

code_pred eval_var .
thm eval_var.equation

values "{val. eval_var (Add (IrConst 1) (IrConst 2)) (| Env = (\<lambda>x. 0)|) val}"

subsection \<open>Another semantics\<close>

type_synonym name = nat \<comment> \<open>For simplicity in examples\<close>
type_synonym state' = "name \<Rightarrow> nat"

datatype aexp = N nat | V name | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state' \<Rightarrow> nat" where
"aval (N n) _ = n" |
"aval (V x) st = st x" |
"aval (Plus e\<^sub>1 e\<^sub>2) st = aval e\<^sub>1 st + aval e\<^sub>2 st"

datatype bexp = B bool | Not bexp | And bexp bexp | Less aexp aexp

primrec bval :: "bexp \<Rightarrow> state' \<Rightarrow> bool" where
"bval (B b) _ = b" |
"bval (Not b) st = (\<not> bval b st)" |
"bval (And b1 b2) st = (bval b1 st \<and> bval b2 st)" |
"bval (Less a\<^sub>1 a\<^sub>2) st = (aval a\<^sub>1 st < aval a\<^sub>2 st)"

datatype
  com' = SKIP
      | Assign name aexp         ("_ ::= _" [1000, 61] 61)
      | Semi   com'  com'          ("_; _"  [60, 61] 60)
      | If     bexp com' com'     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com'         ("WHILE _ DO _"  [0, 61] 61)

inductive
  big_step :: "com' * state' \<Rightarrow> state' \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
  Skip:    "(SKIP,s) \<Rightarrow> s"
| Assign:  "(x ::= a,s) \<Rightarrow> s(x := aval a s)"

| Semi:    "(c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2  \<Longrightarrow>  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3  \<Longrightarrow> (c\<^sub>1;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3"

| IfTrue:  "bval b s  \<Longrightarrow>  (c\<^sub>1,s) \<Rightarrow> t  \<Longrightarrow>  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"
| IfFalse: "\<not>bval b s  \<Longrightarrow>  (c\<^sub>2,s) \<Rightarrow> t  \<Longrightarrow>  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"

| WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s"
| WhileTrue:  "bval b s\<^sub>1  \<Longrightarrow>  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2  \<Longrightarrow>  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3
               \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

code_pred big_step .

thm big_step.equation

definition list :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list" where
  "list s n = map s [0 ..< n]"

values [expected "{[42::nat, 43]}"] "{list s 2|s. (SKIP, nth [42, 43]) \<Rightarrow> s}"

subsection \<open>CCS\<close>

text\<open>This example formalizes finite CCS processes without communication or
recursion. For simplicity, labels are natural numbers.\<close>

datatype proc = nil | pre nat proc | or proc proc | par proc proc

inductive step :: "proc \<Rightarrow> nat \<Rightarrow> proc \<Rightarrow> bool" where
"step (pre n p) n p" |
"step p1 a q \<Longrightarrow> step (or p1 p2) a q" |
"step p2 a q \<Longrightarrow> step (or p1 p2) a q" |
"step p1 a q \<Longrightarrow> step (par p1 p2) a (par q p2)" |
"step p2 a q \<Longrightarrow> step (par p1 p2) a (par p1 q)"

code_pred step .

inductive steps where
"steps p [] p" |
"step p a q \<Longrightarrow> steps q as r \<Longrightarrow> steps p (a#as) r"

code_pred steps .

values 3
 "{as . steps (par (or (pre 0 nil) (pre 1 nil)) (pre 2 nil)) as (par nil nil)}"

values 5
 "{as . steps (par (or (pre 0 nil) (pre 1 nil)) (pre 2 nil)) as (par nil nil)}"

values 3 "{(a,q). step (par nil nil) a q}"

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
chapter \<open>Heap instance of Separation Algebra\<close>
theory Sep_Heap_Instance
imports QSL_Misc
begin

paragraph \<open>Summary\<close>

text \<open>We introduce a heap instance for separation algebra.

    We define general assertions in a separation algebra, like
    points to assertions, and an assertion for the empty heap.\<close>

subsection "basic expectations"

type_synonym vars = string
type_synonym val = int
type_synonym stack = "vars \<Rightarrow> val"

type_synonym addrs = int

text \<open>Instead of @{typ \<open>'a option\<close>} we use @{typ "'a tsa_opt"}, as it is defined in
    Sep_Algebra_Add, as int should not be interpreted as typ which is a
  separation_algebra.  \<close>
type_synonym heap = "addrs \<Rightarrow> int tsa_opt"

text \<open>conversion from a heap to a map from addresses to values\<close>
definition map_of_heap :: "heap \<Rightarrow> addrs \<Rightarrow> val option"  where
  "map_of_heap h a = (case h a of ZERO \<Rightarrow> None | TRIV a \<Rightarrow> Some a)"

definition heap_of_map :: "(addrs \<Rightarrow> val option) \<Rightarrow> heap"  where
  "heap_of_map h a = (case h a of None \<Rightarrow> ZERO | Some a \<Rightarrow> TRIV a)"

text \<open>points to assertion (as a boolean!)\<close>
definition ptb :: "(stack \<Rightarrow> addrs) \<Rightarrow> (stack \<Rightarrow> val) \<Rightarrow> stack \<times> heap \<Rightarrow>  bool" where
  "ptb e e' \<equiv> (\<lambda>(s,h). dom (map_of_heap h) = {e s} \<and> h (e s) = TRIV (e' s)  )"

text \<open>points to list assertion (as boolean!)\<close>
definition ptsb :: "(stack \<Rightarrow> addrs) \<Rightarrow> ((stack \<Rightarrow> val) list) \<Rightarrow> stack \<times> heap \<Rightarrow>  bool" where
  "ptsb e es' \<equiv> (\<lambda>(s,h). if dom (map_of_heap h) = {e s..e s + length es'} \<and> (\<forall>x<length es'. h (e s + x) = TRIV ((es' ! x) s))
                         then True else False)"

text \<open>points-to any\<close>

definition ptanyb :: "(stack \<Rightarrow> addrs)  \<Rightarrow> stack \<times> heap \<Rightarrow>  bool" where
  "ptanyb e \<equiv> (\<lambda>(s,h). dom (map_of_heap h) = {e s})"

lemma
  "ptanyb e = (\<lambda>(s,h). \<exists>v. dom (map_of_heap h) = {e s} \<and> h (e s) = TRIV v)"
  unfolding ptanyb_def map_of_heap_def apply(rule ext) apply auto
  by (metis domIff singletonI tsa_opt.collapse tsa_opt.simps(4))

text \<open>empty assertion\<close>
definition empb :: "stack \<times> heap \<Rightarrow> bool" where
  "empb \<equiv> (\<lambda>(s,h). dom (map_of_heap h) = {} )"

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Big sum and product over function bodies\<close>

theory Groups_Big_Fun
imports
  Main
begin

subsection \<open>Abstract product\<close>

locale comm_monoid_fun = comm_monoid
begin

definition G :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a"
where
  expand_set: "G g = comm_monoid_set.F f \<^bold>1 g {a. g a \<noteq> \<^bold>1}"

interpretation F: comm_monoid_set f "\<^bold>1"
  ..

lemma expand_superset:
  assumes "finite A" and "{a. g a \<noteq> \<^bold>1} \<subseteq> A"
  shows "G g = F.F g A"
  apply (simp add: expand_set)
  apply (rule F.same_carrierI [of A])
  apply (simp_all add: assms)
  done

lemma conditionalize:
  assumes "finite A"
  shows "F.F g A = G (\<lambda>a. if a \<in> A then g a else \<^bold>1)"
  using assms
  apply (simp add: expand_set)
  apply (rule F.same_carrierI [of A])
  apply auto
  done

lemma neutral [simp]:
  "G (\<lambda>a. \<^bold>1) = \<^bold>1"
  by (simp add: expand_set)

lemma update [simp]:
  assumes "finite {a. g a \<noteq> \<^bold>1}"
  assumes "g a = \<^bold>1"
  shows "G (g(a := b)) = b \<^bold>* G g"
proof (cases "b = \<^bold>1")
  case True with \<open>g a = \<^bold>1\<close> show ?thesis
    by (simp add: expand_set) (rule F.cong, auto)
next
  case False
  moreover have "{a'. a' \<noteq> a \<longrightarrow> g a' \<noteq> \<^bold>1} = insert a {a. g a \<noteq> \<^bold>1}"
    by auto
  moreover from \<open>g a = \<^bold>1\<close> have "a \<notin> {a. g a \<noteq> \<^bold>1}"
    by simp
  moreover have "F.F (\<lambda>a'. if a' = a then b else g a') {a. g a \<noteq> \<^bold>1} = F.F g {a. g a \<noteq> \<^bold>1}"
    by (rule F.cong) (auto simp add: \<open>g a = \<^bold>1\<close>)
  ultimately show ?thesis using \<open>finite {a. g a \<noteq> \<^bold>1}\<close> by (simp add: expand_set)
qed

lemma infinite [simp]:
  "\<not> finite {a. g a \<noteq> \<^bold>1} \<Longrightarrow> G g = \<^bold>1"
  by (simp add: expand_set)

lemma cong:
  assumes "\<And>a. g a = h a"
  shows "G g = G h"
  using assms by (simp add: expand_set)

lemma strong_cong [cong]:
  assumes "\<And>a. g a = h a"
  shows "G (\<lambda>a. g a) = G (\<lambda>a. h a)"
  using assms by (fact cong)

lemma not_neutral_obtains_not_neutral:
  assumes "G g \<noteq> \<^bold>1"
  obtains a where "g a \<noteq> \<^bold>1"
  using assms by (auto elim: F.not_neutral_contains_not_neutral simp add: expand_set)

lemma reindex_cong:
  assumes "bij l"
  assumes "g \<circ> l = h"
  shows "G g = G h"
proof -
  from assms have unfold: "h = g \<circ> l" by simp
  from \<open>bij l\<close> have "inj l" by (rule bij_is_inj)
  then have "inj_on l {a. h a \<noteq> \<^bold>1}" by (rule subset_inj_on) simp
  moreover from \<open>bij l\<close> have "{a. g a \<noteq> \<^bold>1} = l ` {a. h a \<noteq> \<^bold>1}"
    by (auto simp add: image_Collect unfold elim: bij_pointE)
  moreover have "\<And>x. x \<in> {a. h a \<noteq> \<^bold>1} \<Longrightarrow> g (l x) = h x"
    by (simp add: unfold)
  ultimately have "F.F g {a. g a \<noteq> \<^bold>1} = F.F h {a. h a \<noteq> \<^bold>1}"
    by (rule F.reindex_cong)
  then show ?thesis by (simp add: expand_set)
qed

lemma distrib:
  assumes "finite {a. g a \<noteq> \<^bold>1}" and "finite {a. h a \<noteq> \<^bold>1}"
  shows "G (\<lambda>a. g a \<^bold>* h a) = G g \<^bold>* G h"
proof -
  from assms have "finite ({a. g a \<noteq> \<^bold>1} \<union> {a. h a \<noteq> \<^bold>1})" by simp
  moreover have "{a. g a \<^bold>* h a \<noteq> \<^bold>1} \<subseteq> {a. g a \<noteq> \<^bold>1} \<union> {a. h a \<noteq> \<^bold>1}"
    by auto (drule sym, simp)
  ultimately show ?thesis
    using assms
    by (simp add: expand_superset [of "{a. g a \<noteq> \<^bold>1} \<union> {a. h a \<noteq> \<^bold>1}"] F.distrib)
qed

lemma commute:
  assumes "finite C"
  assumes subset: "{a. \<exists>b. g a b \<noteq> \<^bold>1} \<times> {b. \<exists>a. g a b \<noteq> \<^bold>1} \<subseteq> C" (is "?A \<times> ?B \<subseteq> C")
  shows "G (\<lambda>a. G (g a)) = G (\<lambda>b. G (\<lambda>a. g a b))"
proof -
  from \<open>finite C\<close> subset
    have "finite ({a. \<exists>b. g a b \<noteq> \<^bold>1} \<times> {b. \<exists>a. g a b \<noteq> \<^bold>1})"
    by (rule rev_finite_subset)
  then have fins:
    "finite {b. \<exists>a. g a b \<noteq> \<^bold>1}" "finite {a. \<exists>b. g a b \<noteq> \<^bold>1}"
    by (auto simp add: finite_cartesian_product_iff)
  have subsets: "\<And>a. {b. g a b \<noteq> \<^bold>1} \<subseteq> {b. \<exists>a. g a b \<noteq> \<^bold>1}"
    "\<And>b. {a. g a b \<noteq> \<^bold>1} \<subseteq> {a. \<exists>b. g a b \<noteq> \<^bold>1}"
    "{a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1} \<noteq> \<^bold>1} \<subseteq> {a. \<exists>b. g a b \<noteq> \<^bold>1}"
    "{a. F.F (\<lambda>aa. g aa a) {a. \<exists>b. g a b \<noteq> \<^bold>1} \<noteq> \<^bold>1} \<subseteq> {b. \<exists>a. g a b \<noteq> \<^bold>1}"
    by (auto elim: F.not_neutral_contains_not_neutral)
  from F.commute have
    "F.F (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1}) {a. \<exists>b. g a b \<noteq> \<^bold>1} =
      F.F (\<lambda>b. F.F (\<lambda>a. g a b) {a. \<exists>b. g a b \<noteq> \<^bold>1}) {b. \<exists>a. g a b \<noteq> \<^bold>1}" .
  with subsets fins have "G (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1}) =
    G (\<lambda>b. F.F (\<lambda>a. g a b) {a. \<exists>b. g a b \<noteq> \<^bold>1})"
    by (auto simp add: expand_superset [of "{b. \<exists>a. g a b \<noteq> \<^bold>1}"]
      expand_superset [of "{a. \<exists>b. g a b \<noteq> \<^bold>1}"])
  with subsets fins show ?thesis
    by (auto simp add: expand_superset [of "{b. \<exists>a. g a b \<noteq> \<^bold>1}"]
      expand_superset [of "{a. \<exists>b. g a b \<noteq> \<^bold>1}"])
qed

lemma cartesian_product:
  assumes "finite C"
  assumes subset: "{a. \<exists>b. g a b \<noteq> \<^bold>1} \<times> {b. \<exists>a. g a b \<noteq> \<^bold>1} \<subseteq> C" (is "?A \<times> ?B \<subseteq> C")
  shows "G (\<lambda>a. G (g a)) = G (\<lambda>(a, b). g a b)"
proof -
  from subset \<open>finite C\<close> have fin_prod: "finite (?A \<times> ?B)"
    by (rule finite_subset)
  from fin_prod have "finite ?A" and "finite ?B"
    by (auto simp add: finite_cartesian_product_iff)
  have *: "G (\<lambda>a. G (g a)) =
    (F.F (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1}) {a. \<exists>b. g a b \<noteq> \<^bold>1})"
    apply (subst expand_superset [of "?B"])
    apply (rule \<open>finite ?B\<close>)
    apply auto
    apply (subst expand_superset [of "?A"])
    apply (rule \<open>finite ?A\<close>)
    apply auto
    apply (erule F.not_neutral_contains_not_neutral)
    apply auto
    done
  have "{p. (case p of (a, b) \<Rightarrow> g a b) \<noteq> \<^bold>1} \<subseteq> ?A \<times> ?B"
    by auto
  with subset have **: "{p. (case p of (a, b) \<Rightarrow> g a b) \<noteq> \<^bold>1} \<subseteq> C"
    by blast
  show ?thesis
    apply (simp add: *)
    apply (simp add: F.cartesian_product)
    apply (subst expand_superset [of C])
    apply (rule \<open>finite C\<close>)
    apply (simp_all add: **)
    apply (rule F.same_carrierI [of C])
    apply (rule \<open>finite C\<close>)
    apply (simp_all add: subset)
    apply auto
    done
qed

lemma cartesian_product2:
  assumes fin: "finite D"
  assumes subset: "{(a, b). \<exists>c. g a b c \<noteq> \<^bold>1} \<times> {c. \<exists>a b. g a b c \<noteq> \<^bold>1} \<subseteq> D" (is "?AB \<times> ?C \<subseteq> D")
  shows "G (\<lambda>(a, b). G (g a b)) = G (\<lambda>(a, b, c). g a b c)"
proof -
  have bij: "bij (\<lambda>(a, b, c). ((a, b), c))"
    by (auto intro!: bijI injI simp add: image_def)
  have "{p. \<exists>c. g (fst p) (snd p) c \<noteq> \<^bold>1} \<times> {c. \<exists>p. g (fst p) (snd p) c \<noteq> \<^bold>1} \<subseteq> D"
    by auto (insert subset, blast)
  with fin have "G (\<lambda>p. G (g (fst p) (snd p))) = G (\<lambda>(p, c). g (fst p) (snd p) c)"
    by (rule cartesian_product)
  then have "G (\<lambda>(a, b). G (g a b)) = G (\<lambda>((a, b), c). g a b c)"
    by (auto simp add: split_def)
  also have "G (\<lambda>((a, b), c). g a b c) = G (\<lambda>(a, b, c). g a b c)"
    using bij by (rule reindex_cong [of "\<lambda>(a, b, c). ((a, b), c)"]) (simp add: fun_eq_iff)
  finally show ?thesis .
qed

lemma delta [simp]:
  "G (\<lambda>b. if b = a then g b else \<^bold>1) = g a"
proof -
  have "{b. (if b = a then g b else \<^bold>1) \<noteq> \<^bold>1} \<subseteq> {a}" by auto
  then show ?thesis by (simp add: expand_superset [of "{a}"])
qed

lemma delta' [simp]:
  "G (\<lambda>b. if a = b then g b else \<^bold>1) = g a"
proof -
  have "(\<lambda>b. if a = b then g b else \<^bold>1) = (\<lambda>b. if b = a then g b else \<^bold>1)"
    by (simp add: fun_eq_iff)
  then have "G (\<lambda>b. if a = b then g b else \<^bold>1) = G (\<lambda>b. if b = a then g b else \<^bold>1)"
    by (simp cong del: strong_cong)
  then show ?thesis by simp
qed

end

subsection \<open>Concrete sum\<close>

context comm_monoid_add
begin

sublocale Sum_any: comm_monoid_fun plus 0
  defines Sum_any = Sum_any.G
  rewrites "comm_monoid_set.F plus 0 = sum"
proof -
  show "comm_monoid_fun plus 0" ..
  then interpret Sum_any: comm_monoid_fun plus 0 .
  from sum_def show "comm_monoid_set.F plus 0 = sum" by (auto intro: sym)
qed

end

syntax (ASCII)
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3SUM _. _)" [0, 10] 10)
syntax
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3\<Sum>_. _)" [0, 10] 10)
translations
  "\<Sum>a. b" \<rightleftharpoons> "CONST Sum_any (\<lambda>a. b)"

lemma Sum_any_left_distrib:
  fixes r :: "'a :: semiring_0"
  assumes "finite {a. g a \<noteq> 0}"
  shows "Sum_any g * r = (\<Sum>n. g n * r)"
proof -
  note assms
  moreover have "{a. g a * r \<noteq> 0} \<subseteq> {a. g a \<noteq> 0}" by auto
  ultimately show ?thesis
    by (simp add: sum_distrib_right Sum_any.expand_superset [of "{a. g a \<noteq> 0}"])
qed

lemma Sum_any_right_distrib:
  fixes r :: "'a :: semiring_0"
  assumes "finite {a. g a \<noteq> 0}"
  shows "r * Sum_any g = (\<Sum>n. r * g n)"
proof -
  note assms
  moreover have "{a. r * g a \<noteq> 0} \<subseteq> {a. g a \<noteq> 0}" by auto
  ultimately show ?thesis
    by (simp add: sum_distrib_left Sum_any.expand_superset [of "{a. g a \<noteq> 0}"])
qed

lemma Sum_any_product:
  fixes f g :: "'b \<Rightarrow> 'a::semiring_0"
  assumes "finite {a. f a \<noteq> 0}" and "finite {b. g b \<noteq> 0}"
  shows "Sum_any f * Sum_any g = (\<Sum>a. \<Sum>b. f a * g b)"
proof -
  have subset_f: "{a. (\<Sum>b. f a * g b) \<noteq> 0} \<subseteq> {a. f a \<noteq> 0}"
    by rule (simp, rule, auto)
  moreover have subset_g: "\<And>a. {b. f a * g b \<noteq> 0} \<subseteq> {b. g b \<noteq> 0}"
    by rule (simp, rule, auto)
  ultimately show ?thesis using assms
    by (auto simp add: Sum_any.expand_set [of f] Sum_any.expand_set [of g]
      Sum_any.expand_superset [of "{a. f a \<noteq> 0}"] Sum_any.expand_superset [of "{b. g b \<noteq> 0}"]
      sum_product)
qed

lemma Sum_any_eq_zero_iff [simp]:
  fixes f :: "'a \<Rightarrow> nat"
  assumes "finite {a. f a \<noteq> 0}"
  shows "Sum_any f = 0 \<longleftrightarrow> f = (\<lambda>_. 0)"
  using assms by (simp add: Sum_any.expand_set fun_eq_iff)

subsection \<open>Concrete product\<close>

context comm_monoid_mult
begin

sublocale Prod_any: comm_monoid_fun times 1
  defines Prod_any = Prod_any.G
  rewrites "comm_monoid_set.F times 1 = prod"
proof -
  show "comm_monoid_fun times 1" ..
  then interpret Prod_any: comm_monoid_fun times 1 .
  from prod_def show "comm_monoid_set.F times 1 = prod" by (auto intro: sym)
qed

end

syntax (ASCII)
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3PROD _. _)" [0, 10] 10)
syntax
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3\<Prod>_. _)" [0, 10] 10)
translations
  "\<Prod>a. b" == "CONST Prod_any (\<lambda>a. b)"

lemma Prod_any_zero:
  fixes f :: "'b \<Rightarrow> 'a :: comm_semiring_1"
  assumes "finite {a. f a \<noteq> 1}"
  assumes "f a = 0"
  shows "(\<Prod>a. f a) = 0"
proof -
  from \<open>f a = 0\<close> have "f a \<noteq> 1" by simp
  with \<open>f a = 0\<close> have "\<exists>a. f a \<noteq> 1 \<and> f a = 0" by blast
  with \<open>finite {a. f a \<noteq> 1}\<close> show ?thesis
    by (simp add: Prod_any.expand_set prod_zero)
qed

lemma Prod_any_not_zero:
  fixes f :: "'b \<Rightarrow> 'a :: comm_semiring_1"
  assumes "finite {a. f a \<noteq> 1}"
  assumes "(\<Prod>a. f a) \<noteq> 0"
  shows "f a \<noteq> 0"
  using assms Prod_any_zero [of f] by blast

lemma power_Sum_any:
  assumes "finite {a. f a \<noteq> 0}"
  shows "c ^ (\<Sum>a. f a) = (\<Prod>a. c ^ f a)"
proof -
  have "{a. c ^ f a \<noteq> 1} \<subseteq> {a. f a \<noteq> 0}"
    by (auto intro: ccontr)
  with assms show ?thesis
    by (simp add: Sum_any.expand_set Prod_any.expand_superset power_sum)
qed

end


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

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

theory Partial_Function
imports Complete_Partial_Order Fun_Def_Base Option
keywords "partial_function" :: thy_decl
begin

named_theorems partial_function_mono "monotonicity rules for partial function definitions"
ML_file "Tools/Function/partial_function.ML"

lemma (in ccpo) in_chain_finite:
  assumes "Complete_Partial_Order.chain op \<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 op \<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 op \<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 op \<le> S \<longrightarrow> finite S)
  \<Longrightarrow> ccpo.admissible Sup op \<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 mono_body}:\<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 antisymI)(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 o 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 o g) (lub (f ` A))" using adm ch'
  proof (rule ccpo.admissibleD)
    fix x assume "x \<in> f ` A"
    with P_A show "(P o 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 tailrec.fixp_fun}
  @{term tailrec.mono_body} @{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 option.fixp_fun}
  @{term option.mono_body} @{thm option.fixp_rule_uc} @{thm option.fixp_induct_uc}
  (SOME @{thm fixp_induct_option})\<close>

hide_const (open) chain

end


theory Chapter12_4
imports "HOL-IMP.VCG" "HOL-IMP.Hoare_Examples"
begin

text \<open>
\exercise
Let @{term "asum i"} be the annotated command \texttt{y := 0; W}
where \texttt{W} is defined in Example~12.7. Prove
\<close>
definition asum :: "int \<Rightarrow> acom"where
  "asum i = ''y'' ::= (N 0);;
    {\<lambda>s. s ''y'' + sum (s ''x'') = sum i}
    WHILE Less (N 0) (V ''x'') DO
    (''y'' ::= Plus (V ''y'') (V ''x'');; ''x'' ::= Plus (V ''x'') (N (-1)))"

lemma "\<turnstile> {\<lambda>s. s ''x'' = i} strip(asum i) {\<lambda>s. s ''y'' = sum i}"
  unfolding asum_def
  by (rule vc_sound', auto)

text \<open>
with the help of corollary @{thm[source] vc_sound'}.
\endexercise

\exercise
Solve exercises \ref{exe:Hoare:sumeq} to \ref{exe:Hoare:sqrt} using the VCG:
for every Hoare triple @{prop"\<turnstile> {P} c {Q}"} from one of those exercises
define an annotated version @{text C} of @{text c} and prove
@{prop"\<turnstile> {P} strip C {Q}"} with the help of %Corollary~\ref{cor:vc_sound}
corollary @{thm[source] vc_sound'}.
\<close>

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = (And (Not (Less a1 a2)) (Not (Less a2 a1)))"

lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  unfolding Eq_def by auto

lemma "\<turnstile> {\<lambda>s. s ''x'' = i \<and> 0 \<le> i} strip (
  ''y'' ::= N 0;;
  {\<lambda>s. s ''y'' = sum i - sum (s ''x'') \<and> 0 \<le> s ''x''}
  WHILE Not(Eq (V ''x'') (N 0))
  DO (''y'' ::= Plus (V ''y'') (V ''x'');;
    ''x'' ::= Plus (V ''x'') (N (-1))))
  {\<lambda>s. s ''y'' = sum i}"
  by (rule vc_sound', auto)

lemma "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x} strip (
  {\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x''}
  WHILE Less (N 0) (V ''x'')
  DO (''x'' ::= Plus (V ''x'') (N (-1));;
    ''y'' ::= Plus (V ''y'') (N (-1))))
  {\<lambda>t. t ''y'' = y - x}"
  by (rule vc_sound', auto)

abbreviation cmult :: com where
  "cmult \<equiv> ''z'' ::= N 0;;
    WHILE Less (N 0) (V ''y'') DO (''y'' ::= (Plus (V ''y'') (N (-1)));; ''z'' ::= (Plus (V ''z'') (V ''x'')))"

lemma
  "\<turnstile> {\<lambda>s.  s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} strip (
    ''z'' ::= N 0;;
    {\<lambda>s. s ''x'' = x \<and> s ''z'' = s ''x'' * (y - s ''y'') \<and> 0 \<le> s ''y''}
    WHILE Less (N 0) (V ''y'')
    DO (''y'' ::= (Plus (V ''y'') (N (-1)));;
      ''z'' ::= (Plus (V ''z'') (V ''x''))))
  {\<lambda>t. t ''z'' = x*y}"
  by (rule vc_sound', auto simp add: algebra_simps)

lemma
  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i} strip (
     ''r'' ::= N 0;; ''r2'' ::= N 1;;
     {\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'' + 1)\<^sup>2}
     WHILE (Not (Less (V ''x'') (V ''r2'')))
     DO (''r'' ::= Plus (V ''r'') (N 1);;
            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1))))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
proof (rule vc_sound', auto simp add: algebra_simps)
  fix s :: state
  have "\<And>x::int. 3 + (2 * x + (1 + x)\<^sup>2) = (2 + x)\<^sup>2"
  proof -
    fix x :: int
    have "(1 + x)\<^sup>2 = x\<^sup>2 + 2 * x + 1" by (simp add: power2_sum)
    then have "3 + (2 * x + (1 + x)\<^sup>2) = 3 + (2 * x + (x\<^sup>2 + 2 * x + 1))" by simp
    also have "\<dots> = 4 + 4 * x + x\<^sup>2" by simp
    also have "\<dots> = (2 + x)\<^sup>2" by (simp add: power2_sum)
    finally show "3 + (2 * x + (1 + x)\<^sup>2) = (2 + x)\<^sup>2" .
  qed
  then show "3 + (2 * s ''r'' + (1 + s ''r'')\<^sup>2) = (2 + s ''r'')\<^sup>2" by simp
qed

text \<open>
\endexercise

\exercise
Having two separate functions @{const pre} and @{const vc} is inefficient.
When computing @{const vc} one often needs to compute @{const pre} too,
leading to multiple traversals of many subcommands. Define an optimised function
\<close>
fun prevc :: "acom \<Rightarrow> assn \<Rightarrow> assn \<times> bool" where
  "prevc SKIP Q = (Q, True)" |
  "prevc (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)), True)" |
  "prevc (C\<^sub>1;; C\<^sub>2) Q = (\<lambda>(P', S'). (\<lambda>(P, S). (P, S \<and> S')) (prevc C\<^sub>1 P')) (prevc C\<^sub>2 Q)" |
  "prevc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
    (\<lambda>(P\<^sub>1, S\<^sub>1). (\<lambda>(P\<^sub>2, S\<^sub>2). (\<lambda>s. if bval b s then P\<^sub>1 s else P\<^sub>2 s, S\<^sub>1 \<and> S\<^sub>2) ) (prevc C\<^sub>2 Q)) (prevc C\<^sub>1 Q)" |
  "prevc ({I} WHILE b DO C) Q = (\<lambda>(P, S).
    (I, (\<forall>s.
      (I s \<and> bval b s \<longrightarrow> P s) \<and>
      (I s \<and> \<not> bval b s \<longrightarrow> Q s)) \<and>
      S)) (prevc C I)"

text \<open> that traverses the command only once. Prove \<close>

lemma "prevc C Q = (pre C Q, vc C Q)"
  by (induct C arbitrary: Q) auto

text \<open>
\endexercise

\exercise
Design a VCG that computes post rather than preconditions.
Start by solving Exercise~\ref{exe:fwdassign}. Now modify theory
@{short_theory "VCG"} as follows. Instead of @{const pre} define a function
\<close>

fun post :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
  "post SKIP P = P" |
  "post (x ::= a) P = (\<lambda>s. \<exists> x'. P (s(x := x')) \<and> s x = aval a (s(x := x')))" |
  "post (C\<^sub>1;; C\<^sub>2) P = post C\<^sub>2 (post C\<^sub>1 P)" |
  "post (IF b THEN C\<^sub>1 ELSE C\<^sub>2) P =
  (\<lambda>t. post C\<^sub>1 (\<lambda>s. P s \<and> bval b s) t \<or> post C\<^sub>2 (\<lambda>s. P s \<and> \<not>bval b s) t)" |
  "post ({I} WHILE b DO c) P = (\<lambda>s. I s \<and> \<not>bval b s)"

text \<open>
such that (with the execption of loops) @{term "post C P"} is the strongest
postcondition of @{text C} w.r.t.\ the precondition @{text P} (see also
Exercise~\ref{exe:sp}). Now modify @{const vc} such that is uses
@{const post} instead of @{const pre} and prove its soundness
and completeness.
\<close>

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
  "vc SKIP P = True" |
  "vc (x ::= a) P = True" |
  "vc (C\<^sub>1;; C\<^sub>2) P \<longleftrightarrow> vc C\<^sub>1 P \<and> vc C\<^sub>2 (post C\<^sub>1 P)" |
  "vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) P \<longleftrightarrow> vc C\<^sub>1 (\<lambda>s. P s \<and> bval b s) \<and> vc C\<^sub>2 (\<lambda>s. P s \<and> \<not>bval b s)" |
  "vc ({I} WHILE b DO C) P =
    ((\<forall>s. (post C (\<lambda>s. I s \<and> bval b s) s \<longrightarrow> I s) \<and>
      (P s \<longrightarrow> I s)) \<and>
      vc C (\<lambda>s. I s \<and> bval b s))"

lemma vc_sound: "vc C P \<Longrightarrow> \<turnstile> {P} strip C {post C P}"
proof (induction C arbitrary: P)
  case (Aassign x x2)
  show ?case
  proof (rule strengthen_pre; (simp, rule hoare.Assign)?; simp, intro allI impI)
    fix s :: state
    let ?H = "\<lambda>x'. P (s(x := x')) \<and> aval x2 s = aval x2 (s(x := x'))"
    assume "P s"
    then have "?H (s x)" by auto
    from exI [of ?H, OF this]
    show "\<exists>x'. ?H x'" by simp
  qed
next
  case (Aif b C1 C2)
  show ?case by (simp, rule hoare.If; rule weaken_post; (rule Aif(1) | rule Aif(2))?; insert Aif(3)) auto
next
  case (Awhile I b C)
  let ?c = "strip C"
  show ?case by (simp, rule strengthen_pre; (rule hoare.While, rule weaken_post; (rule Awhile(1))?)?; insert Awhile(2); auto)
qed auto

lemma post_mono: "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> post C P s \<Longrightarrow> post C P' s"
proof (induction C arbitrary: P P' s)
  case (Aassign x1 x2)
  then show ?case by simp metis
next
  case (Aseq C1 C2)
  then show ?case by simp metis
next
  case (Aif b C1 C2)
  let ?PT = "\<lambda>P s. P s \<and> bval b s"
  let ?PF = "\<lambda>P s. P s \<and> \<not>bval b s"
  from Aif(3) have HT: "\<forall>s. ?PT P s \<longrightarrow> ?PT P' s" by simp
  from Aif(3) have HF: "\<forall>s. ?PF P s \<longrightarrow> ?PF P' s" by simp
  from Aif(4) consider (T) "post C1 (?PT P) s" | (F) "post C2 (?PF P) s" by auto
  then show ?case
  proof cases
    case T
    from Aif(1) [OF HT T] show ?thesis by simp
  next
    case F
    from Aif(2) [OF HF F] show ?thesis by simp
  qed
qed auto

lemma vc_antimono: "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> vc C P' \<Longrightarrow> vc C P"
proof(induct C arbitrary: P P')
  case (Aseq C1 C2) thus ?case by simp (metis post_mono)
next
  case (Aif b C1 C2)
  let ?PT = "\<lambda>P s. P s \<and> bval b s"
  let ?PF = "\<lambda>P s. P s \<and> \<not>bval b s"
  from Aif(3) have HT: "\<forall>s. ?PT P s \<longrightarrow> ?PT P' s" by simp
  from Aif(3) have HF: "\<forall>s. ?PF P s \<longrightarrow> ?PF P' s" by simp
  from Aif(1) [OF HT] Aif(2) [OF HF] Aif(4) show ?case by auto
qed simp_all

lemma vc_complete: "\<turnstile> {P} c {Q}
  \<Longrightarrow> \<exists>C. strip C = c \<and> vc C P \<and> (\<forall>s. post C P s \<longrightarrow> Q s)"
  (is "_ \<Longrightarrow> \<exists>C. ?G P c Q C")
proof (induct rule: hoare.induct)
  case (Skip P)
  show ?case (is "\<exists>C. ?C C")
    by (rule exI [of ?C Askip], simp)
next
  case (Assign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof (rule exI [of ?C "Aassign x a"], auto)
    fix s :: state and x'
    assume "s x = aval a (s(x := x'))"
    then have "s(x := aval a (s(x := x'))) = s" by auto
    moreover assume "P (s(x := aval a (s(x := x'))))"
    ultimately show "P s" by simp
  qed
next
  case (Seq P c\<^sub>1 Q c\<^sub>2 R)
  from Seq(4) obtain C\<^sub>2 where IH2: "?G Q c\<^sub>2 R C\<^sub>2" by blast
  from Seq(2) obtain C\<^sub>1 where IH1: "?G P c\<^sub>1 Q C\<^sub>1" by blast
  have "?G P (c\<^sub>1;; c\<^sub>2) R (C\<^sub>1;; C\<^sub>2)"
  proof (intro conjI)
    from IH1 IH2 show "strip (C\<^sub>1;; C\<^sub>2) = c\<^sub>1;; c\<^sub>2" by auto
    from IH1 IH2 show "vc (C\<^sub>1;; C\<^sub>2) P" by (fastforce elim!: post_mono vc_antimono)
    show "\<forall>s. post (C\<^sub>1;; C\<^sub>2) P s \<longrightarrow> R s"
    proof (intro allI)
      fix s
      from IH1 have "post C\<^sub>2 (post C\<^sub>1 P) s \<Longrightarrow> post C\<^sub>2 Q s" by (auto elim!: post_mono)
      with IH2 show "post (C\<^sub>1;; C\<^sub>2) P s \<longrightarrow> R s" by auto
    qed
  qed
  then show ?case by blast
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  from If(2) obtain C\<^sub>1 where IH1: "?G (\<lambda>s. P s \<and> bval b s) c\<^sub>1 Q C\<^sub>1" by blast
  from If(4) obtain C\<^sub>2 where IH2: "?G (\<lambda>s. P s \<and> \<not>bval b s) c\<^sub>2 Q C\<^sub>2" by blast
  from IH1 IH2 have "?G P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q (IF b THEN C\<^sub>1 ELSE C\<^sub>2)" by simp
  then show ?case by blast
next
  case (While P b c)
  from While(2) obtain C where IH: "?G (\<lambda>s. P s \<and> bval b s) c P C" by blast
  then have "?G P (WHILE b DO c) (\<lambda>s. P s \<and> \<not>bval b s) ({P} WHILE b DO C)" by auto
  then show ?case by blast
next
  case (conseq P' P c Q Q')
  from conseq(3) obtain C where HC: "strip C = c" "vc C P" "\<forall>s. post C P s \<longrightarrow> Q s" by blast+
  from conseq(1) HC(2) have "vc C P'" by (simp add: vc_antimono)
  moreover from conseq(1, 4) HC(3) have "\<forall>s. post C P' s \<longrightarrow> Q' s" by (simp add: post_mono vc_antimono)
  ultimately show ?case using HC(1) by auto
qed

text  \<open>
\endexercise
\<close>

end


section \<open>Wetzel's Problem, Solved by Erdös\<close>

text \<open>Martin Aigner and Günter M. Ziegler. Proofs from THE BOOK. (Springer, 2018).
Chapter 19: Sets, functions, and the continuum hypothesis
Theorem 5 (pages 137--8)\<close>

theory Wetzels_Problem imports
  "HOL-Complex_Analysis.Complex_Analysis" "ZFC_in_HOL.General_Cardinals"

begin

definition Wetzel :: "(complex \<Rightarrow> complex) set \<Rightarrow> bool"
  where "Wetzel \<equiv> \<lambda>F. (\<forall>f\<in>F. f analytic_on UNIV) \<and> (\<forall>z. countable((\<lambda>f. f z) ` F))"

subsubsection \<open>When the continuum hypothesis is false\<close>

proposition Erdos_Wetzel_nonCH:
  assumes W: "Wetzel F" and NCH: "C_continuum > \<aleph>1"
  shows "countable F"
proof -
  have "\<exists>z0. gcard ((\<lambda>f. f z0) ` F) \<ge> \<aleph>1" if "uncountable F"
  proof -
    have "gcard F \<ge> \<aleph>1"
      using that uncountable_gcard_ge by force
    then obtain F' where "F' \<subseteq> F" and F': "gcard F' = \<aleph>1"
      by (meson Card_Aleph subset_smaller_gcard)
    then obtain \<phi> where \<phi>: "bij_betw \<phi> (elts \<omega>1) F'"
      by (metis TC_small eqpoll_def gcard_eqpoll)
    define S where "S \<equiv> \<lambda>\<alpha> \<beta>. {z. \<phi> \<alpha> z = \<phi> \<beta> z}"
    have co_S: "gcard (S \<alpha> \<beta>) \<le> \<aleph>0" if "\<alpha> \<in> elts \<beta>" "\<beta> \<in> elts \<omega>1" for \<alpha> \<beta>
    proof -
      have "\<phi> \<alpha> holomorphic_on UNIV" "\<phi> \<beta> holomorphic_on UNIV"
        using W \<open>F' \<subseteq> F\<close> unfolding Wetzel_def
        by (meson Ord_\<omega>1 Ord_trans \<phi> analytic_imp_holomorphic bij_betwE subsetD that)+
      moreover have "\<phi> \<alpha> \<noteq> \<phi> \<beta>"
        by (metis Ord_\<omega>1 Ord_trans \<phi> bij_betw_def inj_on_def mem_not_refl that)
      ultimately have "countable (S \<alpha> \<beta>)"
        using holomorphic_countable_equal_UNIV unfolding S_def by blast
      then show ?thesis
        using countable_imp_g_le_Aleph0 by blast
    qed
    define SS where "SS \<equiv>\<Squnion>\<beta> \<in> elts \<omega>1. \<Squnion>\<alpha> \<in> elts \<beta>. S \<alpha> \<beta>"
    have F'_eq: "F' =  \<phi> ` elts \<omega>1"
      using \<phi> bij_betw_imp_surj_on by auto
    have \<section>: "\<And>\<beta>. \<beta> \<in> elts \<omega>1 \<Longrightarrow> gcard (\<Union>\<alpha>\<in>elts \<beta>. S \<alpha> \<beta>) \<le> \<omega>"
      by (metis Aleph_0 TC_small co_S countable_UN countable_iff_g_le_Aleph0 less_\<omega>1_imp_countable)
    have "gcard SS \<le> gcard ((\<lambda>\<beta>. \<Union>\<alpha>\<in>elts \<beta>. S \<alpha> \<beta>) ` elts \<omega>1) \<otimes> \<aleph>0"
      apply (simp add: SS_def)
      by (metis (no_types, lifting) "\<section>" TC_small gcard_Union_le_cmult imageE)
    also have "\<dots>  \<le> \<aleph>1"
    proof (rule cmult_InfCard_le)
      show "gcard ((\<lambda>\<beta>. \<Union>\<alpha>\<in>elts \<beta>. S \<alpha> \<beta>) ` elts \<omega>1) \<le> \<omega>1"
        using gcard_image_le by fastforce
    qed auto
    finally have "gcard SS \<le> \<aleph>1" .
    with NCH obtain z0 where "z0 \<notin> SS"
      by (metis Complex_gcard UNIV_eq_I less_le_not_le)
    then have "inj_on (\<lambda>x. \<phi> x z0) (elts \<omega>1)"
      apply (simp add: SS_def S_def inj_on_def)
      by (metis Ord_\<omega>1 Ord_in_Ord Ord_linear)
    then have "gcard ((\<lambda>f. f z0) ` F') = \<aleph>1"
      by (smt (verit) F' F'_eq gcard_image imageE inj_on_def)
    then show ?thesis
      by (metis TC_small \<open>F' \<subseteq> F\<close> image_mono subset_imp_gcard_le)
  qed
  with W show ?thesis
    unfolding Wetzel_def by (meson countable uncountable_gcard_ge)
qed

subsubsection \<open>When the continuum hypothesis is true\<close>

lemma Rats_closure_real2: "closure (\<rat>\<times>\<rat>) = (UNIV::real set)\<times>(UNIV::real set)"
  by (simp add: Rats_closure_real closure_Times)

proposition Erdos_Wetzel_CH:
  assumes CH: "C_continuum = \<aleph>1"
  obtains F where "Wetzel F" and "uncountable F"
proof -
  define D where "D \<equiv> {z. Re z \<in> \<rat> \<and> Im z \<in> \<rat>}"
  have Deq: "D = (\<Union>x\<in>\<rat>. \<Union>y\<in>\<rat>. {Complex x y})"
    using complex.collapse by (force simp: D_def)
  with countable_rat have "countable D"
    by blast
  have "infinite D"
    unfolding Deq
    by (intro infinite_disjoint_family_imp_infinite_UNION Rats_infinite) (auto simp: disjoint_family_on_def)
  have "\<exists>w. Re w \<in> \<rat> \<and> Im w \<in> \<rat> \<and> norm (w - z) < e" if "e > 0" for z and e::real
  proof -
    obtain x y where "x\<in>\<rat>" "y\<in>\<rat>" and xy: "dist (x,y) (Re z, Im z) < e"
      using \<open>e > 0\<close> Rats_closure_real2 by (force simp: closure_approachable)
    moreover have "dist (x,y) (Re z, Im z) = norm (Complex x y - z)"
      by (simp add: norm_complex_def norm_prod_def dist_norm)
    ultimately show "\<exists>w. Re w \<in> \<rat> \<and> Im w \<in> \<rat> \<and> norm (w - z) < e"
      by (metis complex.sel)
  qed
  then have cloD: "closure D = UNIV"
    by (auto simp: D_def closure_approachable dist_complex_def)
  obtain \<zeta> where \<zeta>: "bij_betw \<zeta> (elts \<omega>1) (UNIV::complex set)"
    by (metis Complex_gcard TC_small assms eqpoll_def gcard_eqpoll)
  define inD where "inD \<equiv> \<lambda>\<beta> f. (\<forall>\<alpha> \<in> elts \<beta>. f (\<zeta> \<alpha>) \<in> D)"
  define \<Phi> where "\<Phi> \<equiv> \<lambda>\<beta> f. f \<beta> analytic_on UNIV \<and> inD \<beta> (f \<beta>) \<and> inj_on f (elts (succ \<beta>))"
  have ind_step: "\<exists>h. \<Phi> \<gamma> ((restrict f (elts \<gamma>))(\<gamma>:=h))"
    if \<gamma>: "\<gamma> \<in> elts \<omega>1" and "\<forall>\<beta> \<in> elts \<gamma>. \<Phi> \<beta> f" for \<gamma> f
  proof -
    have f: "\<forall>\<beta> \<in> elts \<gamma>. f \<beta> analytic_on UNIV \<and> inD \<beta> (f \<beta>)"
      using that by (auto simp: \<Phi>_def)
    have inj: "inj_on f (elts \<gamma>)"
      using that by (simp add: \<Phi>_def inj_on_def) (meson Ord_\<omega>1 Ord_in_Ord Ord_linear)
    obtain h where "h analytic_on UNIV" "inD \<gamma> h" "(\<forall>\<beta> \<in> elts \<gamma>. h \<noteq> f \<beta>)"
    proof (cases "finite (elts \<gamma>)")
      case True
      then obtain \<eta> where \<eta>: "bij_betw \<eta> {..<card (elts \<gamma>)} (elts \<gamma>)"
        using bij_betw_from_nat_into_finite by blast
      define g where "g \<equiv> f o \<eta>"
      define w where "w \<equiv> \<zeta> o \<eta>"
      have gf: "\<forall>i<card (elts \<gamma>). h \<noteq> g i \<Longrightarrow> \<forall>\<beta>\<in>elts \<gamma>. h \<noteq> f \<beta>" for h
        using \<eta> by (auto simp: bij_betw_iff_bijections g_def)
      have **: "\<exists>h. h analytic_on UNIV \<and> (\<forall>i<n. h (w i) \<in> D \<and> h (w i) \<noteq> g i (w i))"
        if "n \<le> card (elts \<gamma>)" for n
        using that
      proof (induction n)
        case 0
        then show ?case
          using analytic_on_const by blast
      next
        case (Suc n)
        then obtain h where "h analytic_on UNIV" and hg: "\<forall>i<n. h(w i) \<in> D \<and> h(w i) \<noteq> g i (w i)"
          using Suc_leD by blast
        define p where "p \<equiv> \<lambda>z. \<Prod>i<n. z - w i"
        have p0: "p z = 0 \<longleftrightarrow> (\<exists>i<n. z = w i)" for z
          unfolding p_def by force
        obtain d where d: "d \<in> D - {g n (w n)}"
          using \<open>infinite D\<close> by (metis ex_in_conv finite.emptyI infinite_remove)
        define h' where "h' \<equiv> \<lambda>z. h z + p z * (d - h (w n)) / p (w n)"
        have h'_eq: "h' (w i) = h (w i)" if "i<n" for i
          using that by (force simp: h'_def p0)
        show ?case
        proof (intro exI strip conjI)
          have nless: "n < card (elts \<gamma>)"
            using Suc.prems Suc_le_eq by blast
          with \<eta> have "\<eta> n \<noteq> \<eta> i" if "i<n" for i
            using that unfolding bij_betw_iff_bijections
            by (metis lessThan_iff less_not_refl order_less_trans)
          with \<zeta> \<eta> \<gamma> have pwn_nonzero: "p (w n) \<noteq> 0"
            apply (clarsimp simp: p0 w_def bij_betw_iff_bijections)
            by (metis Ord_\<omega>1 Ord_trans nless lessThan_iff order_less_trans)
          then show "h' analytic_on UNIV"
            unfolding h'_def p_def by (intro analytic_intros \<open>h analytic_on UNIV\<close>)
          fix i
          assume "i < Suc n"
          then have \<section>: "i < n \<or> i = n"
            by linarith
          then show "h' (w i) \<in> D"
            using h'_eq hg d h'_def pwn_nonzero by force
          show "h' (w i) \<noteq> g i (w i)"
            using \<section> h'_eq hg h'_def d pwn_nonzero by fastforce
        qed
      qed
      show ?thesis
        using ** [OF order_refl] \<eta> that gf
        by (simp add: w_def bij_betw_iff_bijections inD_def) metis
    next
      case False
      then obtain \<eta> where \<eta>: "bij_betw \<eta> (UNIV::nat set) (elts \<gamma>)"
        by (meson \<gamma> countable_infiniteE' less_\<omega>1_imp_countable)
      then have \<eta>_inject [simp]: "\<eta> i = \<eta> j \<longleftrightarrow> i=j" for i j
        by (simp add: bij_betw_imp_inj_on inj_eq)
      define g where "g \<equiv> f o \<eta>"
      define w where "w \<equiv> \<zeta> o \<eta>"
      then have w_inject [simp]: "w i = w j \<longleftrightarrow> i=j" for i j
        by (smt (verit) Ord_\<omega>1 Ord_trans UNIV_I \<eta> \<gamma> \<zeta> bij_betw_iff_bijections comp_apply)
      define p where "p \<equiv> \<lambda>n z. \<Prod>i<n. z - w i"
      define q where "q \<equiv> \<lambda>n. \<Prod>i<n. 1 + norm (w i)"
      define h where "h \<equiv> \<lambda>n \<epsilon> z. \<Sum>i<n. \<epsilon> i * p i z"
      define BALL where "BALL \<equiv> \<lambda>n \<epsilon>. ball (h n \<epsilon> (w n)) (norm (p n (w n)) / (fact n * q n))"
                  \<comment> \<open>The demonimator above is the key to keeping the epsilons small\<close>
      define DD where "DD \<equiv> \<lambda>n \<epsilon>. D \<inter> BALL n \<epsilon> - {g n (w n)}"
      define dd where "dd \<equiv> \<lambda>n \<epsilon>. SOME x. x \<in> DD n \<epsilon>"
      have p0: "p n z = 0 \<longleftrightarrow> (\<exists>i<n. z = w i)" for z n
        unfolding p_def by force
      have [simp]: "p n (w i) = 0" if "i<n" for i n
        using that by (simp add: p0)
      have q_gt0: "0 < q n" for n
        unfolding q_def by (smt (verit) norm_not_less_zero prod_pos)
      have "DD n \<epsilon> \<noteq> {}" for n \<epsilon>
      proof -
        have "r > 0 \<Longrightarrow> infinite (D \<inter> ball z r)" for z r
          by (metis islimpt_UNIV limpt_of_closure islimpt_eq_infinite_ball cloD)
        then have "infinite (D \<inter> BALL n \<epsilon>)" for n \<epsilon>
          by (simp add: BALL_def p0 q_gt0)
        then show ?thesis
          by (metis DD_def finite.emptyI infinite_remove)
      qed
      then have dd_in_DD: "dd n \<epsilon> \<in> DD n \<epsilon>" for n \<epsilon>
        by (simp add: dd_def some_in_eq)

      have h_cong: "h n \<epsilon> = h n \<epsilon>'" if "\<And>i. i<n \<Longrightarrow> \<epsilon> i = \<epsilon>' i" for n \<epsilon> \<epsilon>'
        using that by (simp add: h_def)
      have dd_cong: "dd n \<epsilon> = dd n \<epsilon>'" if "\<And>i. i<n \<Longrightarrow> \<epsilon> i = \<epsilon>' i" for n \<epsilon> \<epsilon>'
        using that by (metis dd_def DD_def BALL_def h_cong)
      have [simp]: "h n (cut \<epsilon> less_than n) = h n \<epsilon>" for n \<epsilon>
        by (meson cut_apply h_cong less_than_iff)
      have [simp]: "dd n (cut \<epsilon> less_than n) = dd n \<epsilon>" for n \<epsilon>
        by (meson cut_apply dd_cong less_than_iff)

      define coeff where "coeff \<equiv> wfrec less_than (\<lambda>\<epsilon> n. (dd n \<epsilon> - h n \<epsilon> (w n)) / p n (w n))"
      have coeff_eq: "coeff n = (dd n coeff - h n coeff (w n)) / p n (w n)" for n
        by (simp add: def_wfrec [OF coeff_def])

      have norm_coeff: "norm (coeff n) < 1 / (fact n * q n)" for n
        using dd_in_DD [of n coeff]
        by (simp add: q_gt0 coeff_eq DD_def BALL_def dist_norm norm_minus_commute norm_divide divide_simps)
      have norm_p_bound: "norm (p n z') \<le> q n * (1 + norm z) ^ n"
          if "dist z z' \<le> 1" for n z z'
      proof (induction n)
        case 0
        then show ?case
          by (auto simp: p_def q_def)
      next
        case (Suc n)
        have "norm z' - norm z \<le> 1"
          by (smt (verit) dist_norm norm_triangle_ineq3 that)
        then have \<section>: "norm (z' - w n) \<le> (1 + norm (w n)) * (1 + norm z)"
          by (simp add: mult.commute add_mono distrib_left norm_triangle_le_diff)
        have "norm (p n z') * norm (z' - w n) \<le> (q n * (1 + norm z) ^ n) * norm (z' - w n)"
          by (metis Suc mult.commute mult_left_mono norm_ge_zero)
        also have "\<dots> \<le> (q n * (1 + norm z) ^ n) * (1 + norm (w n)) * ((1 + norm z))"
          by (smt (verit) "\<section>" Suc mult.assoc mult_left_mono norm_ge_zero)
        also have "\<dots> \<le> q n * (1 + norm (w n)) * ((1 + norm z) * (1 + norm z) ^ n)"
          by auto
        finally show ?case
          by (auto simp: p_def q_def norm_mult simp del: fact_Suc)
      qed

      show ?thesis
      proof
        define hh where "hh \<equiv> \<lambda>z. suminf (\<lambda>i. coeff i * p i z)"
        have "hh holomorphic_on UNIV"
        proof (rule holomorphic_uniform_sequence)
          fix n   \<comment>\<open>Many thanks to Manuel Eberl for suggesting these approach\<close>
          show "h n coeff holomorphic_on UNIV"
            unfolding h_def p_def by (intro holomorphic_intros)
        next
          fix z
          have "uniform_limit (cball z 1) (\<lambda>n. h n coeff) hh sequentially"
            unfolding hh_def h_def
          proof (rule Weierstrass_m_test)
            let ?M = "\<lambda>n. (1 + norm z) ^ n / fact n"
            have "\<exists>N. \<forall>n\<ge>N. B \<le> (1 + real n) / (1 + norm z)" for B
            proof
              show "\<forall>n\<ge>nat \<lceil>B * (1 + norm z)\<rceil>. B \<le> (1 + real n) / (1 + norm z)"
                using norm_ge_zero [of z] by (auto simp: divide_simps simp del: norm_ge_zero)
            qed
            then have L: "liminf (\<lambda>n. ereal ((1 + real n) / (1 + norm z))) = \<infinity>"
              by (simp add: Lim_PInfty flip: liminf_PInfty)
            have "\<forall>\<^sub>F n in sequentially. 0 < (1 + cmod z) ^ n / fact n"
              using norm_ge_zero [of z] by (simp del: norm_ge_zero)
            then show "summable ?M"
              by (rule ratio_test_convergence) (auto simp: add_nonneg_eq_0_iff L)
            fix n z'
            assume "z' \<in> cball z 1"
            then have "norm (coeff n * p n z') \<le> norm (coeff n) * q n * (1 + norm z) ^ n"
              by (simp add: mult.assoc mult_mono norm_mult norm_p_bound)
            also have "\<dots> \<le> (1 / fact n) * (1 + norm z) ^ n"
            proof (rule mult_right_mono)
              show "norm (coeff n) * q n \<le> 1 / fact n"
                using q_gt0 norm_coeff [of n] by (simp add: field_simps)
            qed auto
            also have "\<dots> \<le> ?M n"
              by (simp add: divide_simps)
            finally show "norm (coeff n * p n z') \<le> ?M n" .
          qed
          then show "\<exists>d>0. cball z d \<subseteq> UNIV \<and> uniform_limit (cball z d) (\<lambda>n. h n coeff) hh sequentially"
            using zero_less_one by blast
        qed auto
        then show "hh analytic_on UNIV"
          by (simp add: analytic_on_open)
        have hh_eq_dd: "hh (w n) = dd n coeff" for n
        proof -
          have "hh (w n) = h (Suc n) coeff (w n)"
            unfolding hh_def h_def by (intro suminf_finite) auto
          also have "\<dots> = dd n coeff"
            by (induction n) (auto simp add: p0 h_def p_def coeff_eq [of "Suc _"] coeff_eq [of 0])
          finally show ?thesis .
        qed
        then have "hh (w n) \<in> D" for n
          using DD_def dd_in_DD by fastforce
        then show "inD \<gamma> hh"
          unfolding inD_def by (metis \<eta> bij_betw_iff_bijections comp_apply w_def)
        have "hh (w n) \<noteq> f (\<eta> n) (w n)" for n
          using DD_def dd_in_DD g_def hh_eq_dd by auto
        then show "\<forall>\<beta>\<in>elts \<gamma>. hh \<noteq> f \<beta>"
          by (metis \<eta> bij_betw_imp_surj_on imageE)
      qed
    qed
    with f show ?thesis
      using inj by (rule_tac x="h" in exI) (auto simp: \<Phi>_def inj_on_def)
  qed
  define G where "G \<equiv> \<lambda>f \<gamma>. @h. \<Phi> \<gamma> ((restrict f (elts \<gamma>))(\<gamma>:=h))"
  define f where "f \<equiv> transrec G"
  have \<Phi>f: "\<Phi> \<beta> f" if "\<beta> \<in> elts \<omega>1" for \<beta>
    using that
  proof (induction \<beta> rule: eps_induct)
    case (step \<gamma>)
    then have IH: "\<forall>\<beta>\<in>elts \<gamma>. \<Phi> \<beta> f"
      using Ord_\<omega>1 Ord_trans by blast
    have "f \<gamma> = G f \<gamma>"
      by (metis G_def f_def restrict_apply' restrict_ext transrec)
    moreover have "\<Phi> \<gamma> ((restrict f (elts \<gamma>))(\<gamma> := G f \<gamma>))"
      by (metis ind_step[OF step.prems] G_def IH someI)
    ultimately show ?case
      by (metis IH \<Phi>_def elts_succ fun_upd_same fun_upd_triv inj_on_restrict_eq restrict_upd)
  qed
  then have anf: "\<And>\<beta>. \<beta> \<in> elts \<omega>1 \<Longrightarrow> f \<beta> analytic_on UNIV"
    and inD: "\<And>\<alpha> \<beta>. \<lbrakk>\<beta> \<in> elts \<omega>1; \<alpha> \<in> elts \<beta>\<rbrakk> \<Longrightarrow> f \<beta> (\<zeta> \<alpha>) \<in> D"
    using \<Phi>_def inD_def by blast+
  have injf: "inj_on f (elts \<omega>1)"
    using \<Phi>f unfolding inj_on_def \<Phi>_def by (metis Ord_\<omega>1 Ord_in_Ord Ord_linear_le in_succ_iff)
  show ?thesis
  proof
    let ?F = "f ` elts \<omega>1"
    have "countable ((\<lambda>f. f z) ` f ` elts \<omega>1)" for z
    proof -
      obtain \<alpha> where \<alpha>: "\<zeta> \<alpha> = z" "\<alpha> \<in> elts \<omega>1" "Ord \<alpha>"
        by (meson Ord_\<omega>1 Ord_in_Ord UNIV_I \<zeta> bij_betw_iff_bijections)
      let ?B = "elts \<omega>1 - elts (succ \<alpha>)"
      have eq: "elts \<omega>1 = elts (succ \<alpha>) \<union> ?B"
        using \<alpha> by (metis Diff_partition Ord_\<omega>1 OrdmemD less_eq_V_def succ_le_iff)
      have "(\<lambda>f. f z) ` f ` ?B \<subseteq> D"
        using \<alpha> inD by clarsimp (meson Ord_\<omega>1 Ord_in_Ord Ord_linear)
      then have "countable ((\<lambda>f. f z) ` f ` ?B)"
        by (meson \<open>countable D\<close> countable_subset)
      moreover have "countable ((\<lambda>f. f z) ` f ` elts (succ \<alpha>))"
        by (simp add: \<alpha> less_\<omega>1_imp_countable)
      ultimately show ?thesis
        using eq by (metis countable_Un_iff image_Un)
    qed
    then show "Wetzel ?F"
      unfolding Wetzel_def by (blast intro: anf)
    show "uncountable ?F"
      using Ord_\<omega>1 countable_iff_less_\<omega>1 countable_image_inj_eq injf by blast
  qed
qed

theorem Erdos_Wetzel: "C_continuum = \<aleph>1 \<longleftrightarrow> (\<exists>F. Wetzel F \<and> uncountable F)"
  by (metis C_continuum_ge Erdos_Wetzel_CH Erdos_Wetzel_nonCH less_V_def)

text \<open>The originally submitted version of this theory included the development of cardinals
for general Isabelle/HOL sets (as opposed to ZF sets, elements of type V), as well as other
generally useful library material. From March 2022, that material has been moved to
the analysis libraries or to @{theory ZFC_in_HOL.General_Cardinals}, as appropriate.\<close>

end


section \<open>Split Cycle Module\<close>

theory Split_Cycle_Module
  imports "Component_Types/Electoral_Module"
          "Component_Types/Margin_Graph_Creator"
          "Component_Types/Graph_Winner_Finder"
          "../Sequential_Composition"
begin

datatype candidates = A|B|C|D

fun mgWeight::"'a Weight_Function" where
"mgWeight cand P arc = (prefer_count (limit_profile cand P) (fst  arc) (snd arc))
- (prefer_count (limit_profile cand P) (snd arc) (fst arc)) "

fun split_cycle_first_round::"'a Electoral_Module" where
"split_cycle_first_round a p = evaluateGraph(createMarginGraph a p mgWeight)"

fun testProfile::"candidates \<Rightarrow> candidates \<Rightarrow> candidates \<Rightarrow> candidates Profile" where
"testProfile A B C =  [{(A,A),(B,B),(C,C),(A,B),(B,C),(A,C)}]"|
  "testProfile x y z = [{}]"

lemma "profile {} [{}] = True"
 unfolding profile_def all_set_conv_all_nth
  by simp

lemma "split_cycle_first_round {} [{}] = ({},{},{})"
  by auto

lemma "profile {0} [{(0,0)}] = True"
  unfolding profile_def all_set_conv_all_nth
  by simp

lemma "profile {A,B,C} (testProfile A B C)= True"
  unfolding profile_def
            all_set_conv_all_nth
            linear_order_on_def
            partial_order_on_def
            preorder_on_def
            refl_on_def
            trans_def antisym_def
            total_on_def
  by simp

lemma "limit_profile {A,B,C} (testProfile A B C) = testProfile A B C"
  by auto

lemma "above {(A,B)} A = {B}"
  by auto

lemma "win_count (testProfile A B C) A = 2"
  unfolding above_def
  by simp

lemma [simp]:"mgWeight {A,B,C} (testProfile A B C) (A,B) = 1"
  by auto

lemma "createMarginGraph {A,B,C} (testProfile A B C) mgWeight
= \<lparr>verts = {A,B,C}, arcs = {(A,B),(B,C),(A,C)},tail=fst, head=snd\<rparr> "
  apply simp_all
  done

lemma "split_cycle_first_round {A,B,C} [{(A,A),(B,B),(C,C),(A,B),(B,C),(A,C)}] =({A},{C},{B})"
  by auto

end