(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Probabilistic Guarded Command Language (pGCL)\<close>

theory PGCL
  imports "../Markov_Decision_Process"
begin

subsection \<open>Syntax\<close>

datatype 's pgcl =
    Skip
  | Abort
  | Assign "'s \<Rightarrow> 's"
  | Seq "'s pgcl" "'s pgcl"
  | Par "'s pgcl" "'s pgcl"
  | If "'s \<Rightarrow> bool" "'s pgcl" "'s pgcl"
  | Prob "bool pmf" "'s pgcl" "'s pgcl"
  | While "'s \<Rightarrow> bool" "'s pgcl"

subsection \<open>Denotational Semantics\<close>

primrec wp :: "'s pgcl \<Rightarrow> ('s \<Rightarrow> ennreal) \<Rightarrow> ('s \<Rightarrow> ennreal)" where
  "wp Skip f          = f"
| "wp Abort f         = (\<lambda>_. 0)"
| "wp (Assign u) f    = f \<circ> u"
| "wp (Seq c\<^sub>1 c\<^sub>2) f    = wp c\<^sub>1 (wp c\<^sub>2 f)"
| "wp (If b c\<^sub>1 c\<^sub>2) f   = (\<lambda>s. if b s then wp c\<^sub>1 f s else wp c\<^sub>2 f s)"
| "wp (Par c\<^sub>1 c\<^sub>2) f    = wp c\<^sub>1 f \<sqinter> wp c\<^sub>2 f"
| "wp (Prob p c\<^sub>1 c\<^sub>2) f = (\<lambda>s. pmf p True * wp c\<^sub>1 f s + pmf p False * wp c\<^sub>2 f s)"
| "wp (While b c) f   = lfp (\<lambda>X s. if b s then wp c X s else f s)"

lemma wp_mono: "mono (wp c)"
  by (induction c)
     (auto simp: monotone_def le_fun_def intro: order_trans le_infI1 le_infI2
           intro!: add_mono mult_left_mono lfp_mono[THEN le_funD])

abbreviation det :: "'s pgcl \<Rightarrow> 's \<Rightarrow> ('s pgcl \<times> 's) pmf set" ("\<lless> _, _ \<ggreater>") where
  "det c s \<equiv> {return_pmf (c, s)}"

subsection \<open>Operational Semantics\<close>

fun step :: "('s pgcl \<times> 's) \<Rightarrow> ('s pgcl \<times> 's) pmf set" where
  "step (Skip, s)        = \<lless>Skip, s\<ggreater>"
| "step (Abort, s)       = \<lless>Abort, s\<ggreater>"
| "step (Assign u, s)    = \<lless>Skip, u s\<ggreater>"
| "step (Seq c\<^sub>1 c\<^sub>2, s)    = (map_pmf (\<lambda>(p1', s'). (if p1' = Skip then c\<^sub>2 else Seq p1' c\<^sub>2, s'))) ` step (c\<^sub>1, s)"
| "step (If b c\<^sub>1 c\<^sub>2, s)   = (if b s then \<lless>c\<^sub>1, s\<ggreater> else \<lless>c\<^sub>2, s\<ggreater>)"
| "step (Par c\<^sub>1 c\<^sub>2, s)    = \<lless>c\<^sub>1, s\<ggreater> \<union> \<lless>c\<^sub>2, s\<ggreater>"
| "step (Prob p c\<^sub>1 c\<^sub>2, s) = {map_pmf (\<lambda>b. if b then (c\<^sub>1, s) else (c\<^sub>2, s)) p}"
| "step (While b c, s)   = (if b s then \<lless>Seq c (While b c), s\<ggreater> else \<lless>Skip, s\<ggreater>)"

lemma step_finite: "finite (step x)"
  by (induction x rule: step.induct) simp_all

lemma step_non_empty: "step x \<noteq> {}"
  by (induction x rule: step.induct) simp_all

interpretation step: Markov_Decision_Process step
  proof qed (rule step_non_empty)

definition rF :: "('s \<Rightarrow> ennreal) \<Rightarrow> (('s pgcl \<times> 's) stream \<Rightarrow> ennreal) \<Rightarrow> ('s pgcl \<times> 's) stream \<Rightarrow> ennreal" where
  "rF f F \<omega> = (if fst (shd \<omega>) = Skip then f (snd (shd \<omega>)) else F (stl \<omega>))"

abbreviation r :: "('s \<Rightarrow> ennreal) \<Rightarrow> ('s pgcl \<times> 's) stream \<Rightarrow> ennreal" where
  "r f \<equiv> lfp (rF f)"

lemma continuous_rF: "sup_continuous (rF f)"
  unfolding rF_def[abs_def]
  by (auto simp: sup_continuous_def fun_eq_iff SUP_sup_distrib [symmetric] image_comp
           split: prod.splits pgcl.splits)

lemma mono_rF: "mono (rF f)"
  using continuous_rF by (rule sup_continuous_mono)

lemma r_unfold: "r f \<omega> = (if fst (shd \<omega>) = Skip then f (snd (shd \<omega>)) else r f (stl \<omega>))"
  by (subst lfp_unfold[OF mono_rF]) (simp add: rF_def)

lemma mono_r: "F \<le> G \<Longrightarrow> r F \<omega> \<le> r G \<omega>"
  by (rule le_funD[of _ _ \<omega>], rule lfp_mono)
     (auto intro!: lfp_mono simp: rF_def le_fun_def max.coboundedI2)

lemma measurable_rF:
  assumes F[measurable]: "F \<in> borel_measurable step.St"
  shows "rF f F \<in> borel_measurable step.St"
  unfolding rF_def[abs_def]
  apply measurable
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable []
  apply (rule measurable_compose[OF measurable_stl])
  apply measurable []
  apply (rule predE)
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable
  done

lemma measurable_r[measurable]: "r f \<in> borel_measurable step.St"
  using continuous_rF measurable_rF by (rule borel_measurable_lfp)

lemma mono_r': "mono (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D)"
  by (auto intro!: monoI le_funI INF_mono[OF bexI] nn_integral_mono simp: le_fun_def)

lemma E_inf_r:
  "step.E_inf s (r f) =
    lfp (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) s"
proof -
  have "step.E_inf s (r f) =
    lfp (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) s"
    unfolding rF_def[abs_def]
  proof (rule step.E_inf_lfp[THEN fun_cong])
    let ?F = "\<lambda>t x. (if fst t = Skip then f (snd t) else x)"
    show "(\<lambda>(s, x). ?F s x) \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M borel)"
      apply (simp add: measurable_split_conv split_beta')
      apply (intro borel_measurable_max borel_measurable_const measurable_If predE
         measurable_compose[OF measurable_snd] measurable_compose[OF measurable_fst])
      apply measurable
      done
    show "\<And>s. sup_continuous (?F s)"
      by (auto simp: sup_continuous_def SUP_sup_distrib[symmetric] split: prod.split pgcl.split)
    show "\<And>F cfg. (\<integral>\<^sup>+\<omega>. ?F (state cfg) (F \<omega>) \<partial>step.T cfg) =
      ?F (state cfg) (nn_integral (step.T cfg) F)"
      by (auto simp: split: pgcl.split prod.split)
  qed (rule step_finite)
  then show ?thesis
    by simp
qed

lemma E_inf_r_unfold:
  "step.E_inf s (r f) = (\<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else step.E_inf t (r f)) \<partial>measure_pmf D)"
  unfolding E_inf_r by (simp add: lfp_unfold[OF mono_r'])

lemma E_inf_r_induct[consumes 1, case_names step]:
  assumes "P s y"
  assumes *: "\<And>F s y. P s y \<Longrightarrow>
    (\<And>s y. P s y \<Longrightarrow> F s \<le> y) \<Longrightarrow> (\<And>s. F s \<le> step.E_inf s (r f)) \<Longrightarrow>
    (\<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) \<le> y"
  shows "step.E_inf s (r f) \<le> y"
  using \<open>P s y\<close>
  unfolding E_inf_r
proof (induction arbitrary: s y rule: lfp_ordinal_induct[OF mono_r'[where f=f]])
  case (1 F) with *[of s y F] show ?case
    unfolding le_fun_def E_inf_r[where f=f, symmetric] by simp
qed (auto intro: SUP_least)

lemma E_inf_Skip: "step.E_inf (Skip, s) (r f) = f s"
  by (subst E_inf_r_unfold) simp

lemma E_inf_Seq:
  assumes [simp]: "\<And>x. 0 \<le> f x"
  shows "step.E_inf (Seq a b, s) (r f) = step.E_inf (a, s) (r (\<lambda>s. step.E_inf (b, s) (r f)))"
proof (rule antisym)
  show "step.E_inf (Seq a b, s) (r f) \<le> step.E_inf (a, s) (r (\<lambda>s. step.E_inf (b, s) (r f)))"
  proof (coinduction arbitrary: a s rule: E_inf_r_induct)
    case step then show ?case
      by (rewrite in "_ \<le> \<hole>" E_inf_r_unfold)
         (force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_inf_Skip image_comp)
  qed
  show "step.E_inf (a, s) (r (\<lambda>s. step.E_inf (b, s) (r f))) \<le> step.E_inf (Seq a b, s) (r f)"
  proof (coinduction arbitrary: a s rule: E_inf_r_induct)
    case step then show ?case
      by (rewrite in "_ \<le> \<hole>" E_inf_r_unfold)
         (force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_inf_Skip image_comp)
   qed
qed

lemma E_inf_While:
  "step.E_inf (While g c, s) (r f) =
    lfp (\<lambda>F s. if g s then step.E_inf (c, s) (r F) else f s) s"
proof (rule antisym)
  have E_inf_While_step: "step.E_inf (While g c, s) (r f) =
    (if g s then step.E_inf (c, s) (r (\<lambda>s. step.E_inf (While g c, s) (r f))) else f s)" for f s
    by (rewrite E_inf_r_unfold) (simp add: min_absorb1 E_inf_Seq)

  have "mono (\<lambda>F s. if g s then step.E_inf (c, s) (r F) else f s)" (is "mono ?F")
    by (auto intro!: mono_r step.E_inf_mono simp: mono_def le_fun_def max.coboundedI2)
  then show "lfp ?F s \<le> step.E_inf (While g c, s) (r f)"
  proof (induction arbitrary: s rule: lfp_ordinal_induct[consumes 1])
    case mono then show ?case
      by (rewrite E_inf_While_step) (auto intro!: step.E_inf_mono mono_r le_funI)
  qed (auto intro: SUP_least)

  define w where "w F s = (\<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then if g (snd t) then F (c, snd t) else f (snd t) else F t) \<partial>measure_pmf D)"
    for F s
  have "mono w"
    by (auto simp: w_def mono_def le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono) []

  define d where "d = c"
  define t where "t = Seq d (While g c)"
  then have "(t = While g c \<and> d = c \<and> g s) \<or> t = Seq d (While g c)"
    by auto
  then have "step.E_inf (t, s) (r f) \<le> lfp w (d, s)"
  proof (coinduction arbitrary: t d s rule: E_inf_r_induct)
    case (step F t d s)
    from step(1)
    show ?case
    proof (elim conjE disjE)
      { fix s have "\<not> g s \<Longrightarrow> F (While g c, s) \<le> f s"
          using step(3)[of "(While g c, s)"] by (simp add: E_inf_While_step) }
      note [simp] = this
      assume "t = Seq d (While g c)" then show ?thesis
        by (rewrite lfp_unfold[OF \<open>mono w\<close>])
           (auto simp: max.absorb2 w_def intro!: INF_mono[OF bexI] nn_integral_mono step)
    qed (auto intro!: step)
  qed
  also have "lfp w = lfp (\<lambda>F s. step.E_inf s (r (\<lambda>s. if g s then F (c, s) else f s)))"
    unfolding E_inf_r w_def
    by (rule lfp_lfp[symmetric]) (auto simp: le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono)
  finally have "step.E_inf (While g c, s) (r f) \<le> (if g s then \<dots> (c, s) else f s)"
    unfolding t_def d_def by (rewrite E_inf_r_unfold) simp
  also have "\<dots> = lfp ?F s"
    by (rewrite lfp_rolling[symmetric, of "\<lambda>F s. if g s then F (c, s) else f s"  "\<lambda>F s. step.E_inf s (r F)"])
       (auto simp: mono_def le_fun_def sup_apply[abs_def] if_distrib[of "max 0"] max.coboundedI2 max.absorb2
                intro!: step.E_inf_mono mono_r cong del: if_weak_cong)
  finally show "step.E_inf (While g c, s) (r f) \<le> \<dots>"
    .
qed

subsection \<open>Equate Both Semantics\<close>

lemma E_inf_r_eq_wp: "step.E_inf (c, s) (r f) = wp c f s"
proof (induction c arbitrary: f s)
  case Skip then show ?case
    by (simp add: E_inf_Skip)
next
  case Abort then show ?case
  proof (intro antisym)
    have "lfp (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) \<le>
      (\<lambda>s. if \<exists>t. s = (Abort, t) then 0 else \<top>)"
      by (intro lfp_lowerbound) (auto simp: le_fun_def)
    then show "step.E_inf (Abort, s) (r f) \<le> wp Abort f s"
      by (auto simp: E_inf_r le_fun_def split: if_split_asm)
  qed simp
next
  case Assign then show ?case
    by (rewrite E_inf_r_unfold) (simp add: min_absorb1)
next
  case (If b c1 c2) then show ?case
    by (rewrite E_inf_r_unfold) auto
next
  case (Prob p c1 c2) then show ?case
    apply (rewrite E_inf_r_unfold)
    apply auto
    apply (rewrite nn_integral_measure_pmf_support[of "UNIV::bool set"])
    apply (auto simp: UNIV_bool ac_simps)
    done
next
  case (Par c1 c2) then show ?case
    by (rewrite E_inf_r_unfold) (auto intro: inf.commute)
next
  case (Seq c1 c2) then show ?case
    by (simp add: E_inf_Seq)
next
  case (While g c) then show ?case
    apply (simp add: E_inf_While)
    apply (rewrite While)
    apply auto
    done
qed

end


(*  Title:      Sequents/LK.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Axiom to express monotonicity (a variant of the deduction theorem).  Makes the
link between \<turnstile> and \<Longrightarrow>, needed for instance to prove imp_cong.

Axiom left_cong allows the simplifier to use left-side formulas.  Ideally it
should be derived from lower-level axioms.

CANNOT be added to LK0.thy because modal logic is built upon it, and
various modal rules would become inconsistent.
*)

theory LK
imports LK0
begin

axiomatization where
  monotonic:  "($H \<turnstile> P \<Longrightarrow> $H \<turnstile> Q) \<Longrightarrow> $H, P \<turnstile> Q" and

  left_cong:  "\<lbrakk>P == P';  \<turnstile> P' \<Longrightarrow> ($H \<turnstile> $F) \<equiv> ($H' \<turnstile> $F')\<rbrakk>
               \<Longrightarrow> (P, $H \<turnstile> $F) \<equiv> (P', $H' \<turnstile> $F')"

subsection \<open>Rewrite rules\<close>

lemma conj_simps:
  "\<turnstile> P \<and> True \<longleftrightarrow> P"
  "\<turnstile> True \<and> P \<longleftrightarrow> P"
  "\<turnstile> P \<and> False \<longleftrightarrow> False"
  "\<turnstile> False \<and> P \<longleftrightarrow> False"
  "\<turnstile> P \<and> P \<longleftrightarrow> P"
  "\<turnstile> P \<and> P \<and> Q \<longleftrightarrow> P \<and> Q"
  "\<turnstile> P \<and> \<not> P \<longleftrightarrow> False"
  "\<turnstile> \<not> P \<and> P \<longleftrightarrow> False"
  "\<turnstile> (P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)"
  by (fast add!: subst)+

lemma disj_simps:
  "\<turnstile> P \<or> True \<longleftrightarrow> True"
  "\<turnstile> True \<or> P \<longleftrightarrow> True"
  "\<turnstile> P \<or> False \<longleftrightarrow> P"
  "\<turnstile> False \<or> P \<longleftrightarrow> P"
  "\<turnstile> P \<or> P \<longleftrightarrow> P"
  "\<turnstile> P \<or> P \<or> Q \<longleftrightarrow> P \<or> Q"
  "\<turnstile> (P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)"
  by (fast add!: subst)+

lemma not_simps:
  "\<turnstile> \<not> False \<longleftrightarrow> True"
  "\<turnstile> \<not> True \<longleftrightarrow> False"
  by (fast add!: subst)+

lemma imp_simps:
  "\<turnstile> (P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
  "\<turnstile> (P \<longrightarrow> True) \<longleftrightarrow> True"
  "\<turnstile> (False \<longrightarrow> P) \<longleftrightarrow> True"
  "\<turnstile> (True \<longrightarrow> P) \<longleftrightarrow> P"
  "\<turnstile> (P \<longrightarrow> P) \<longleftrightarrow> True"
  "\<turnstile> (P \<longrightarrow> \<not> P) \<longleftrightarrow> \<not> P"
  by (fast add!: subst)+

lemma iff_simps:
  "\<turnstile> (True \<longleftrightarrow> P) \<longleftrightarrow> P"
  "\<turnstile> (P \<longleftrightarrow> True) \<longleftrightarrow> P"
  "\<turnstile> (P \<longleftrightarrow> P) \<longleftrightarrow> True"
  "\<turnstile> (False \<longleftrightarrow> P) \<longleftrightarrow> \<not> P"
  "\<turnstile> (P \<longleftrightarrow> False) \<longleftrightarrow> \<not> P"
  by (fast add!: subst)+

lemma quant_simps:
  "\<And>P. \<turnstile> (\<forall>x. P) \<longleftrightarrow> P"
  "\<And>P. \<turnstile> (\<forall>x. x = t \<longrightarrow> P(x)) \<longleftrightarrow> P(t)"
  "\<And>P. \<turnstile> (\<forall>x. t = x \<longrightarrow> P(x)) \<longleftrightarrow> P(t)"
  "\<And>P. \<turnstile> (\<exists>x. P) \<longleftrightarrow> P"
  "\<And>P. \<turnstile> (\<exists>x. x = t \<and> P(x)) \<longleftrightarrow> P(t)"
  "\<And>P. \<turnstile> (\<exists>x. t = x \<and> P(x)) \<longleftrightarrow> P(t)"
  by (fast add!: subst)+

subsection \<open>Miniscoping: pushing quantifiers in\<close>

text \<open>
  We do NOT distribute of \<forall> over \<and>, or dually that of \<exists> over \<or>
  Baaz and Leitsch, On Skolemization and Proof Complexity (1994)
  show that this step can increase proof length!
\<close>

text \<open>existential miniscoping\<close>
lemma ex_simps:
  "\<And>P Q. \<turnstile> (\<exists>x. P(x) \<and> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<and> Q"
  "\<And>P Q. \<turnstile> (\<exists>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<exists>x. Q(x))"
  "\<And>P Q. \<turnstile> (\<exists>x. P(x) \<or> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<or> Q"
  "\<And>P Q. \<turnstile> (\<exists>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<exists>x. Q(x))"
  "\<And>P Q. \<turnstile> (\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q"
  "\<And>P Q. \<turnstile> (\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<exists>x. Q(x))"
  by (fast add!: subst)+

text \<open>universal miniscoping\<close>
lemma all_simps:
  "\<And>P Q. \<turnstile> (\<forall>x. P(x) \<and> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<and> Q"
  "\<And>P Q. \<turnstile> (\<forall>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<forall>x. Q(x))"
  "\<And>P Q. \<turnstile> (\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<longrightarrow> Q"
  "\<And>P Q. \<turnstile> (\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<forall>x. Q(x))"
  "\<And>P Q. \<turnstile> (\<forall>x. P(x) \<or> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<or> Q"
  "\<And>P Q. \<turnstile> (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<forall>x. Q(x))"
  by (fast add!: subst)+

text \<open>These are NOT supplied by default!\<close>
lemma distrib_simps:
  "\<turnstile> P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R"
  "\<turnstile> (Q \<or> R) \<and> P \<longleftrightarrow> Q \<and> P \<or> R \<and> P"
  "\<turnstile> (P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)"
  by (fast add!: subst)+

lemma P_iff_F: "\<turnstile> \<not> P \<Longrightarrow> \<turnstile> (P \<longleftrightarrow> False)"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemmas iff_reflection_F = P_iff_F [THEN iff_reflection]

lemma P_iff_T: "\<turnstile> P \<Longrightarrow> \<turnstile> (P \<longleftrightarrow> True)"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemmas iff_reflection_T = P_iff_T [THEN iff_reflection]

lemma LK_extra_simps:
  "\<turnstile> P \<or> \<not> P"
  "\<turnstile> \<not> P \<or> P"
  "\<turnstile> \<not> \<not> P \<longleftrightarrow> P"
  "\<turnstile> (\<not> P \<longrightarrow> P) \<longleftrightarrow> P"
  "\<turnstile> (\<not> P \<longleftrightarrow> \<not> Q) \<longleftrightarrow> (P \<longleftrightarrow> Q)"
  by (fast add!: subst)+

subsection \<open>Named rewrite rules\<close>

lemma conj_commute: "\<turnstile> P \<and> Q \<longleftrightarrow> Q \<and> P"
  and conj_left_commute: "\<turnstile> P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)"
  by (fast add!: subst)+

lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: "\<turnstile> P \<or> Q \<longleftrightarrow> Q \<or> P"
  and disj_left_commute: "\<turnstile> P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)"
  by (fast add!: subst)+

lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: "\<turnstile> P \<and> (Q \<or> R) \<longleftrightarrow> (P \<and> Q \<or> P \<and> R)"
  and conj_disj_distribR: "\<turnstile> (P \<or> Q) \<and> R \<longleftrightarrow> (P \<and> R \<or> Q \<and> R)"

  and disj_conj_distribL: "\<turnstile> P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)"
  and disj_conj_distribR: "\<turnstile> (P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)"

  and imp_conj_distrib: "\<turnstile> (P \<longrightarrow> (Q \<and> R)) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)"
  and imp_conj: "\<turnstile> ((P \<and> Q) \<longrightarrow> R)  \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))"
  and imp_disj: "\<turnstile> (P \<or> Q \<longrightarrow> R)  \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)"

  and imp_disj1: "\<turnstile> (P \<longrightarrow> Q) \<or> R \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)"
  and imp_disj2: "\<turnstile> Q \<or> (P \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)"

  and de_Morgan_disj: "\<turnstile> (\<not> (P \<or> Q)) \<longleftrightarrow> (\<not> P \<and> \<not> Q)"
  and de_Morgan_conj: "\<turnstile> (\<not> (P \<and> Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q)"

  and not_iff: "\<turnstile> \<not> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<longleftrightarrow> \<not> Q)"
  by (fast add!: subst)+

lemma imp_cong:
  assumes p1: "\<turnstile> P \<longleftrightarrow> P'"
    and p2: "\<turnstile> P' \<Longrightarrow> \<turnstile> Q \<longleftrightarrow> Q'"
  shows "\<turnstile> (P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q')"
  apply (lem p1)
  apply safe
   apply (tactic \<open>
     REPEAT (resolve_tac \<^context> @{thms cut} 1 THEN
       DEPTH_SOLVE_1
         (resolve_tac \<^context> [@{thm thinL}, @{thm thinR}, @{thm p2} COMP @{thm monotonic}] 1) THEN
           Cla.safe_tac \<^context> 1)\<close>)
  done

lemma conj_cong:
  assumes p1: "\<turnstile> P \<longleftrightarrow> P'"
    and p2: "\<turnstile> P' \<Longrightarrow> \<turnstile> Q \<longleftrightarrow> Q'"
  shows "\<turnstile> (P \<and> Q) \<longleftrightarrow> (P' \<and> Q')"
  apply (lem p1)
  apply safe
   apply (tactic \<open>
     REPEAT (resolve_tac \<^context> @{thms cut} 1 THEN
       DEPTH_SOLVE_1
         (resolve_tac \<^context> [@{thm thinL}, @{thm thinR}, @{thm p2} COMP @{thm monotonic}] 1) THEN
           Cla.safe_tac \<^context> 1)\<close>)
  done

lemma eq_sym_conv: "\<turnstile> x = y \<longleftrightarrow> y = x"
  by (fast add!: subst)

ML_file \<open>simpdata.ML\<close>
setup \<open>map_theory_simpset (put_simpset LK_ss)\<close>
setup \<open>Simplifier.method_setup []\<close>

text \<open>To create substitution rules\<close>

lemma eq_imp_subst: "\<turnstile> a = b \<Longrightarrow> $H, A(a), $G \<turnstile> $E, A(b), $F"
  by simp

lemma split_if: "\<turnstile> P(if Q then x else y) \<longleftrightarrow> ((Q \<longrightarrow> P(x)) \<and> (\<not> Q \<longrightarrow> P(y)))"
  apply (rule_tac P = Q in cut)
   prefer 2
   apply (simp add: if_P)
  apply (rule_tac P = "\<not> Q" in cut)
   prefer 2
   apply (simp add: if_not_P)
  apply fast
  done

lemma if_cancel: "\<turnstile> (if P then x else x) = x"
  apply (lem split_if)
  apply fast
  done

lemma if_eq_cancel: "\<turnstile> (if x = y then y else x) = x"
  apply (lem split_if)
  apply safe
  apply (rule symL)
  apply (rule basic)
  done

end


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

section \<open>Bell Numbers and Spivey's Generalized Recurrence\<close>

theory Bell_Numbers
imports
  "HOL-Library.FuncSet"
  "HOL-Library.Monad_Syntax"
  "HOL-Combinatorics.Stirling"
  Card_Partitions.Injectivity_Solver
  Card_Partitions.Card_Partitions
begin

subsection \<open>Preliminaries\<close>

subsubsection \<open>Additions to FuncSet\<close>

(* this is clearly to be added to FuncSet *)
lemma extensional_funcset_ext:
  assumes "f \<in> A \<rightarrow>\<^sub>E B" "g \<in> A \<rightarrow>\<^sub>E B"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
  shows "f = g"
using assms by (metis PiE_iff extensionalityI)

subsubsection \<open>Additions for Injectivity Proofs\<close>

lemma inj_on_impl_inj_on_image:
  assumes "inj_on f A"
  assumes "\<And>x. x \<in> X \<Longrightarrow> x \<subseteq> A"
  shows "inj_on ((`) f) X"
using assms by (meson inj_onI inj_on_image_eq_iff)

lemma injectivity_union:
  assumes "A \<union> B = C \<union> D"
  assumes "P A" "P C"
  assumes "Q B" "Q D"
    "\<And>S T. P S \<Longrightarrow> Q T \<Longrightarrow> S \<inter> T = {}"
  shows "A = C \<and> B = D"
using assms Int_Un_distrib Int_commute inf_sup_absorb by blast+

lemma injectivity_image:
  assumes "f ` A = g ` A"
  assumes "\<forall>x\<in>A. invert (f x) = x \<and> invert (g x) = x"
  shows "\<forall>x\<in>A. f x = g x"
using assms by (metis (no_types, lifting) image_iff)

lemma injectivity_image_union:
  assumes "(\<lambda>X. X \<union> F X) ` P = (\<lambda>X. X \<union> G X) ` P'"
  assumes "\<forall>X \<in> P. X \<subseteq> A" "\<forall>X \<in> P'. X \<subseteq> A"
  assumes "\<forall>X \<in> P. \<forall>y\<in>F X. y \<notin> A" "\<forall>X \<in> P'. \<forall>y\<in>G X. y \<notin> A"
  shows "P = P'"
proof
  show "P \<subseteq> P'"
  proof
    fix X
    assume "X \<in> P"
    from assms(1) this obtain X' where "X' \<in> P'" and "X \<union> F X = X' \<union> G X'"
      by (metis imageE image_eqI)
    moreover from assms(2,4) \<open>X \<in> P\<close> have X: "(X \<union> F X) \<inter> A = X" by auto
    moreover from assms(3,5) \<open>X' \<in> P'\<close> have X': "(X' \<union> G X') \<inter> A = X'" by auto
    ultimately have "X = X'" by simp
    from this \<open>X' \<in> P'\<close> show "X \<in> P'" by auto
  qed
next
  show "P' \<subseteq> P"
  proof
    fix X'
    assume "X' \<in> P'"
    from assms(1) this obtain X where "X \<in> P" and "X \<union> F X = X' \<union> G X'"
      by (metis imageE image_eqI)
    moreover from assms(2,4) \<open>X \<in> P\<close> have X: "(X \<union> F X) \<inter> A = X" by auto
    moreover from assms(3,5) \<open>X' \<in> P'\<close> have X': "(X' \<union> G X') \<inter> A = X'" by auto
    ultimately have "X = X'" by simp
    from this \<open>X \<in> P\<close> show "X' \<in> P" by auto
  qed
qed

subsection \<open>Definition of Bell Numbers\<close>

definition Bell :: "nat \<Rightarrow> nat"
where
  "Bell n = card {P. partition_on {0..<n} P}"

lemma Bell_altdef:
  assumes "finite A"
  shows "Bell (card A) = card {P. partition_on A P}"
proof -
  from \<open>finite A\<close> obtain f where bij: "bij_betw f {0..<card A} A"
    using ex_bij_betw_nat_finite by blast
  from this have inj: "inj_on f {0..<card A}"
    using bij_betw_imp_inj_on by blast
  from bij have image_f_eq: "A = f ` {0..<card A}"
    using bij_betw_imp_surj_on by blast
  have "\<forall>x \<in> {P. partition_on {0..<card A} P}. x \<subseteq> Pow {0..<card A}"
    by (auto elim: partition_onE)
  from this inj have "inj_on ((`) ((`) f)) {P. partition_on {0..<card A} P}"
    by (intro inj_on_impl_inj_on_image[of _ "Pow {0..<card A}"]
     inj_on_impl_inj_on_image[of _ "{0..<card A}"]) blast+
  moreover from inj have "(`) ((`) f) ` {P. partition_on {0..<card A} P} = {P. partition_on A P}"
    by (subst image_f_eq, auto elim!: set_of_partition_on_map)
  ultimately have "bij_betw ((`) ((`) f)) {P. partition_on {0..<card A} P} {P. partition_on A P}"
    by (auto intro: bij_betw_imageI)
  from this \<open>finite A\<close> show ?thesis
    unfolding Bell_def
    by (subst bij_betw_iff_card[symmetric]) (auto intro: finitely_many_partition_on)
qed

lemma Bell_0:
  "Bell 0 = 1"
by (auto simp add: Bell_def partition_on_empty)

subsection \<open>Construction of the Partitions\<close>

definition construct_partition_on :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set set set"
where
  "construct_partition_on B C =
    do {
       k  \<leftarrow> {0..card B};
       j  \<leftarrow> {0..card C};
       P  \<leftarrow> {P. partition_on C P \<and> card P = j};
       B' \<leftarrow> {B'. B' \<subseteq> B \<and> card B' = k};
       Q  \<leftarrow> {Q. partition_on B' Q};
       f  \<leftarrow> (B - B') \<rightarrow>\<^sub>E P;
       P'  \<leftarrow> {(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P};
       {P' \<union> Q}
    }"

lemma construct_partition_on:
  assumes "finite B" "finite C"
  assumes "B \<inter> C = {}"
  shows "construct_partition_on B C = {P. partition_on (B \<union> C) P}"
proof (rule set_eqI')
  fix Q'
  assume "Q' \<in> construct_partition_on B C"
  from this obtain j k P P' Q B' f
    where "j \<le> card C"
    and "k \<le> card B"
    and P: "partition_on C P \<and> card P = j"
    and B': "B' \<subseteq> B \<and> card B' = k"
    and Q: "partition_on B' Q"
    and f: "f \<in> B - B' \<rightarrow>\<^sub>E P"
    and P': "P' = (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
    and Q': "Q' = P' \<union> Q"
    unfolding construct_partition_on_def by auto
  from P f have "partition_on (B - B' \<union> C) P'"
    unfolding P' using \<open>B \<inter> C = {}\<close>
    by (intro partition_on_insert_elements) auto
  from this Q have "partition_on ((B - B' \<union> C) \<union> B') Q'"
    unfolding Q' using B' \<open>B \<inter> C = {}\<close> by (auto intro: partition_on_union)
  from this have "partition_on (B \<union> C) Q'"
    using B' by (metis Diff_partition sup.assoc sup.commute)
  from this show "Q' \<in> {P. partition_on (B \<union> C) P}" by auto
next
  fix Q'
  assume Q': "Q' \<in> {Q'. partition_on (B \<union> C) Q'}"
  from Q' have "{} \<notin> Q'" by (auto elim!: partition_onE)
  obtain Q where Q: "Q = ((\<lambda>X. if X \<subseteq> B then X else {}) ` Q') - {{}}" by blast
  obtain P' where P': "P' = ((\<lambda>X. if X \<subseteq> B then {} else X) ` Q') - {{}}" by blast
  from P' Q \<open>{} \<notin> Q'\<close> have Q'_prop: "Q' = P' \<union> Q" by auto
  have P'_nosubset: "\<forall>X \<in> P'. \<not> X \<subseteq> B"
    unfolding P' by auto
  moreover have "\<forall>X \<in> P'. X \<subseteq> B \<union> C"
    using Q' P' by (auto elim: partition_onE)
  ultimately have P'_witness: "\<forall>X \<in> P'. \<exists>x. x \<in> X \<inter> C"
    using \<open>B \<inter> C = {}\<close> by fastforce
  obtain B' where B': "B' = \<Union>Q" by blast
  have Q_prop: "partition_on B' Q"
    using B' Q' Q'_prop partition_on_split2 mem_Collect_eq by blast
  have "\<Union>P' = B - B' \<union> C"
  proof
    have "\<Union>Q' = B \<union> C" "\<forall>X\<in>Q'. \<forall>X'\<in>Q'. X \<noteq> X' \<longrightarrow> X \<inter> X' = {}"
      using Q' unfolding partition_on_def disjoint_def by auto
    from this show "\<Union>P' \<subseteq> B - B' \<union> C"
      unfolding P' B' Q by auto blast
  next
    show "B - B' \<union> C \<subseteq> \<Union>P'"
    proof
      fix x
      assume "x \<in> B - B' \<union> C"
      from this obtain X where X: "x \<in> X" "X \<in> Q'"
        using Q' by (metis Diff_iff Un_iff mem_Collect_eq partition_on_partition_on_unique)
      have "\<forall>X \<in> Q'. X \<subseteq> B \<longrightarrow> X \<subseteq> B'"
        unfolding B' Q by auto
      from this X \<open>x \<in> B - B' \<union> C\<close> have "\<not> X \<subseteq> B"
        using \<open>B \<inter> C = {}\<close> by auto
      from this \<open>X \<in> Q'\<close> have "X \<in> P'" using P' by auto
      from this \<open>x \<in> X\<close> show "x \<in> \<Union>P'" by auto
    qed
  qed
  from this have partition_on_P': "partition_on (B - B' \<union> C) P'"
    using partition_on_split1 Q'_prop Q' mem_Collect_eq by fastforce
  obtain P where P: "P = (\<lambda>X. X \<inter> C) ` P'" by blast
  from P partition_on_P' P'_witness have "partition_on C P"
    using partition_on_intersect_on_elements by auto
  obtain f where f: "f = (\<lambda>x. if x \<in> B - B' then (THE X. x \<in> X \<and> X \<in> P') \<inter> C else undefined)" by blast
  have P'_prop: "P' = (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
  proof
    {
      fix X
      assume "X \<in> P'"
      have X_subset: "X \<subseteq> (B - B') \<union> C"
        using partition_on_P' \<open>X \<in> P'\<close> by (auto elim: partition_onE)
      have "X = X \<inter> C \<union> {x \<in> B - B'. f x = X \<inter> C}"
      proof
        {
          fix x
          assume  "x \<in> X"
          from this X_subset have "x \<in> (B - B') \<union> C" by auto
          from this have "x \<in> X \<inter> C \<union> {xa \<in> B - B'. f xa = X \<inter> C}"
          proof
            assume "x \<in> C"
            from this \<open>x \<in> X\<close> show ?thesis by simp
          next
            assume "x \<in> B - B'"
            from partition_on_P' \<open>x \<in> X\<close> \<open>X \<in> P'\<close> have "(THE X. x \<in> X \<and> X \<in> P') = X"
              by (simp add: partition_on_the_part_eq)
            from \<open>x \<in> B - B'\<close> this show ?thesis unfolding f by auto
          qed
        }
        from this show "X \<subseteq> X \<inter> C \<union> {x \<in> B - B'. f x = X \<inter> C}" by auto
      next
        show "X \<inter> C \<union> {xa \<in> B - B'. f xa = X \<inter> C} \<subseteq> X"
        proof
          fix x
          assume "x \<in> X \<inter> C \<union> {x \<in> B - B'. f x = X \<inter> C}"
          from this show "x \<in> X"
          proof
            assume "x \<in> X \<inter> C"
            from this show ?thesis by simp
          next
            assume x_in: "x \<in> {x \<in> B - B'. f x = X \<inter> C}"
            from this have ex1: "\<exists>!X. x \<in> X \<and> X \<in> P'"
              using partition_on_P' by (auto intro!: partition_on_partition_on_unique)
            from x_in X_subset have eq: "(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C"
              unfolding f by auto
           from P'_nosubset \<open>X \<in> P'\<close> have "\<not> X \<subseteq> B" by simp
           from this have "X \<inter> C \<noteq> {}"
             using X_subset assms(3) by blast
           from this obtain y where y: "y \<in> X \<inter> C" by auto
           from this eq have y_in: "y \<in> (THE X. x \<in> X \<and> X \<in> P') \<inter> C" by simp
           from y y_in have "y \<in> X" "y \<in> (THE X. x \<in> X \<and> X \<in> P')" by auto
           moreover from y have "\<exists>!X. y \<in> X \<and> X \<in> P'"
             using partition_on_P' by (simp add: partition_on_partition_on_unique)
           moreover have "(THE X. x \<in> X \<and> X \<in> P') \<in> P'"
             using ex1 by (rule the1I2) auto
           ultimately have "(THE X. x \<in> X \<and> X \<in> P') = X" using \<open>X \<in> P'\<close> by auto
           from this ex1 show ?thesis by (auto intro: the1I2)
          qed
        qed
      qed
      from \<open>X \<in> P'\<close> this have "X \<in> (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
        unfolding P by simp
    }
    from this show "P' \<subseteq> (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P" ..
  next
    {
      fix x
      assume x_in_image: "x \<in> (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P"
      {
        fix X
        assume "X \<in> P'"
        have "{x \<in> B - B'. f x = X \<inter> C} =  {x \<in> B - B'. x \<in> X}"
        proof -
          {
            fix x
            assume "x \<in> B - B'"
            from this have ex1: "\<exists>!X. x \<in> X \<and> X \<in> P'"
              using partition_on_P' by (auto intro!: partition_on_partition_on_unique)
            from this have in_p: "(THE X. x \<in> X \<and> X \<in> P') \<in> P'"
              and x_in: "x \<in> (THE X. x \<in> X \<and> X \<in> P')"
              by (metis (mono_tags, lifting) theI)+
            have "f x = X \<inter> C \<longleftrightarrow> (THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C"
              using \<open>x \<in> B - B'\<close> unfolding f by auto
            also have "... \<longleftrightarrow> (THE X. x \<in> X \<and> X \<in> P') = X"
            proof
              assume "(THE X. x \<in> X \<and> X \<in> P') = X"
              from this show "(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C" by auto
            next
              assume "(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C"
              have "(THE X. x \<in> X \<and> X \<in> P') \<inter> X \<noteq> {}"
                using P'_witness \<open>(THE X. x \<in> X \<and> X \<in> P') \<inter> C = X \<inter> C\<close> \<open>X \<in> P'\<close> by fastforce
              from this show "(THE X. x \<in> X \<and> X \<in> P') = X"
                using partition_on_P'[unfolded partition_on_def disjoint_def] in_p \<open>X \<in> P'\<close> by metis
            qed
            also have "... \<longleftrightarrow> x \<in> X"
              using ex1 \<open>X \<in> P'\<close> x_in by (auto; metis (no_types, lifting) the_equality)
            finally have "f x = X \<inter> C \<longleftrightarrow> x \<in> X" .
          }
          from this show ?thesis by auto
        qed
        moreover have  "X \<subseteq> B - B' \<union> C"
          using partition_on_P' \<open>X \<in> P'\<close> by (blast elim: partition_onE)
        ultimately have "X \<inter> C \<union> {x \<in> B. x \<notin> B' \<and> f x = X \<inter> C} = X" by auto
      }
      from this x_in_image have "x \<in> P'" unfolding P by auto
    }
    from this show "(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P \<subseteq> P'" ..
  qed
  from partition_on_P' have f_prop: "f \<in> (B - B') \<rightarrow>\<^sub>E P"
    unfolding f P by (auto simp add: partition_on_the_part_mem)
  from Q B' have "B' \<subseteq> B" by auto
  obtain k where k: "k = card B'" by blast
  from \<open>finite B\<close> \<open>B' \<subseteq> B\<close> k have k_prop: "k \<in> {0..card B}" by (simp add: card_mono)
  obtain j where j: "j = card P" by blast
  from j \<open>partition_on C P\<close> have j_prop: "j \<in> {0..card C}"
    by (simp add: assms(2) partition_on_le_set_elements)
  from \<open>partition_on C P\<close> j have P_prop: "partition_on C P \<and> card P = j" by auto
  from k \<open>B' \<subseteq> B\<close> have B'_prop: "B' \<subseteq> B \<and> card B' = k" by auto
  show "Q' \<in> construct_partition_on B C"
    using j_prop k_prop P_prop B'_prop Q_prop P'_prop f_prop Q'_prop
    unfolding construct_partition_on_def
    by (auto simp del: atLeastAtMost_iff) blast
qed

subsection \<open>Injectivity of the Set Construction\<close>

lemma injectivity:
  assumes "B \<inter> C = {}"
  assumes P: "(partition_on C P \<and> card P = j) \<and> (partition_on C P' \<and> card P' = j')"
  assumes B': "(B' \<subseteq> B \<and> card B' = k) \<and> (B'' \<subseteq> B \<and> card B'' = k')"
  assumes Q: "partition_on B' Q \<and> partition_on B'' Q'"
  assumes f: "f \<in> B - B' \<rightarrow>\<^sub>E P \<and> g \<in> B - B'' \<rightarrow>\<^sub>E P'"
  assumes P': "P'' = (\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P \<and>
    P''' = (\<lambda>X. X \<union> {x \<in> B - B''. g x = X}) ` P'"
  assumes eq_result: "P'' \<union> Q = P''' \<union> Q'"
  shows "f = g" and "Q = Q'" and "B' = B''"
    and "P = P'" and "j = j'" and "k = k'"
proof -
  have P_nonempty_sets: "\<forall>X\<in>P. \<exists>c\<in>C. c \<in> X" "\<forall>X\<in>P'. \<exists>c\<in>C. c \<in> X"
    using P by (force elim: partition_onE)+
  have 1: "\<forall>X\<in>P''. \<exists>c\<in>C. c \<in> X" "\<forall>X\<in>P'''. \<exists>c\<in>C. c \<in> X"
    using P' P_nonempty_sets by fastforce+
  have 2: "\<forall>X\<in>Q. \<forall>x\<in>X. x \<notin> C" "\<forall>X\<in>Q'. \<forall>x\<in>X. x \<notin> C"
    using \<open>B \<inter> C = {}\<close> Q B' by (auto elim: partition_onE)
  from eq_result have "P'' = P'''" and "Q = Q'"
    by (auto dest: injectivity_union[OF _ 1 2])
  from this Q show "Q = Q'" and "B' = B''"
    by (auto intro!: partition_on_eq_implies_eq_carrier)
  have subset_C: "\<forall>X\<in>P. X \<subseteq> C" "\<forall>X\<in>P'. X \<subseteq> C"
    using P by (auto elim: partition_onE)
  have eq_image: "(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P = (\<lambda>X. X \<union> {x \<in> B - B''. g x = X}) ` P'"
    using P' \<open>P'' = P'''\<close> by auto
  from this \<open>B \<inter> C = {}\<close>  show "P = P'"
    by (auto dest: injectivity_image_union[OF _ subset_C])
  have eq2: "(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P = (\<lambda>X. X \<union> {x \<in> B - B'. g x = X}) ` P"
    using \<open>P = P'\<close> \<open>B' = B''\<close> eq_image by simp
  from P have P_props: "\<forall>X \<in> P. X \<subseteq> C" "\<forall>X \<in> P. X \<noteq> {}" by (auto elim: partition_onE)
  have invert: "\<forall>X\<in>P. (X \<union> {x \<in> B - B'. f x = X}) \<inter> C = X \<and> (X \<union> {x \<in> B - B'. g x = X}) \<inter> C = X"
    using \<open>B \<inter> C = {}\<close> P_props by auto
  have eq3: "\<forall>X \<in> P. (X \<union> {x \<in> B - B'. f x = X}) = (X \<union> {x \<in> B - B'. g x = X})"
    using injectivity_image[OF eq2 invert] by blast
  have eq4: "\<forall>X \<in> P. {x \<in> B - B'. f x = X} = {x \<in> B - B'. g x = X}"
  proof
    fix X
    assume "X \<in> P"
    from this P have "X \<subseteq> C" by (auto elim: partition_onE)
    have disjoint: "X \<inter> {x \<in> B - B'. f x = X} = {}" "X \<inter> {x \<in> B - B'. g x = X} = {}"
      using \<open>B \<inter> C = {}\<close> \<open>X \<subseteq> C\<close> by auto
    from eq3 \<open>X \<in> P\<close> have "X \<union> {x \<in> B - B'. f x = X} = X \<union> {x \<in> B - B'. g x = X}" by auto
    from this disjoint show "{x \<in> B - B'. f x = X} = {x \<in> B - B'. g x = X}"
      by (auto intro: injectivity_union)
  qed
  from eq4 f have eq5: "\<forall>b\<in>B - B'. f b = g b" by blast
  from eq5 f \<open>B' = B''\<close> \<open>P = P'\<close> show eq6: "f = g" by (auto intro: extensional_funcset_ext)
  from P \<open>P = P'\<close> show "j = j'" by simp
  from B' \<open>B' = B''\<close> show "k = k'" by simp
qed

subsection \<open>The Generalized Bell Recurrence Relation\<close>

theorem Bell_eq:
  "Bell (n + m) = (\<Sum>k\<le>n. \<Sum>j\<le>m. j ^ (n - k) * Stirling m j * (n choose k) * Bell k)"
proof -
  define A where "A = {0..<n + m}"
  define B where "B = {0..<n}"
  define C where "C = {n..<n + m}"
  have "A = B \<union> C" "B \<inter> C = {}" "finite B" "card B = n" "finite C" "card C = m"
    unfolding A_def B_def C_def by auto
  have step1: "Bell (n + m) = card {P. partition_on A P}"
    unfolding Bell_def A_def ..
  from \<open>A = B \<union> C\<close> \<open>B \<inter> C = {}\<close> \<open>finite B\<close> \<open>finite C\<close>
  have step2: "card {P. partition_on A P} = card (construct_partition_on B C)"
    by (simp add: construct_partition_on)
  note injectivity = injectivity[OF \<open>B \<inter> C = {}\<close>]
  let ?expr = "do {
    k  \<leftarrow> {0..card B};
    j  \<leftarrow> {0..card C};
    P  \<leftarrow> {P. partition_on C P \<and> card P = j};
    B' \<leftarrow> {B'. B' \<subseteq> B \<and> card B' = k};
    Q  \<leftarrow> {Q. partition_on B' Q};
    f  \<leftarrow> (B - B') \<rightarrow>\<^sub>E P;
    P'  \<leftarrow> {(\<lambda>X. X \<union> {x \<in> B - B'. f x = X}) ` P};
    {P' \<union> Q}
  }"
  let "?S \<bind> ?comp" = ?expr
  {
    fix k
    assume k: "k \<in> {..card B}"
    let ?expr = "?comp k"
    let "?S \<bind> ?comp" = ?expr
    {
      fix j
      assume "j \<in> {.. card C}"
      let ?expr = "?comp j"
      let "?S \<bind> ?comp" = ?expr
      from \<open>finite C\<close> have "finite ?S"
        by (intro finite_Collect_conjI disjI1 finitely_many_partition_on)
      {
        fix P
        assume P: "P \<in> {P. partition_on C P \<and> card P = j}"
        from this have "partition_on C P" by simp
        let ?expr = "?comp P"
        let "?S \<bind> ?comp" = ?expr
        have "finite P"
         using P \<open>finite C\<close> by (auto intro: finite_elements)
        from \<open>finite B\<close> have "finite ?S" by (auto simp add: finite_subset)
        moreover
        {
          fix B'
          assume B': "B' \<in> {B'. B' \<subseteq> B \<and> card B' = k}"
          from this have "B' \<subseteq> B" by simp
          let ?expr = "?comp B'"
          let "?S \<bind> ?comp" = ?expr
          from \<open>finite B\<close> have "finite B'"
            using B' by (auto simp add: finite_subset)
          from \<open>finite B'\<close> have "finite {Q. partition_on B' Q}"
            by (rule finitely_many_partition_on)
          moreover
          {
            fix Q
            assume Q: "Q \<in> {Q. partition_on B' Q}"
            let ?expr = "?comp Q"
            let "?S \<bind> ?comp" = ?expr
            {
              fix f
              assume "f \<in> B - B' \<rightarrow>\<^sub>E P"
              let ?expr = "?comp f"
              let "?S \<bind> ?comp" = ?expr
              have "disjoint_family_on ?comp ?S"
                by (auto intro: disjoint_family_onI)
              from this have "card ?expr = 1"
                by (simp add: card_bind_constant)
              moreover have "finite ?expr"
                by (simp add: finite_bind)
              ultimately have "finite ?expr \<and> card ?expr = 1" by blast
            }
            moreover have "finite ?S"
              using \<open>finite B\<close> \<open>finite P\<close> by (auto intro: finite_PiE)
            moreover have "disjoint_family_on ?comp ?S"
              using P B' Q
              by (injectivity_solver rule: local.injectivity(1))
            moreover have "card ?S = j ^ (n - k)"
            proof -
              have "card (B - B') = n - k"
                using B' \<open>finite B'\<close> \<open>card B = n\<close>
                by (subst card_Diff_subset) auto
              from this show ?thesis
                using \<open>finite B\<close> P
                by (subst card_PiE) (simp add: prod_constant)+
            qed
            ultimately have "card ?expr = j ^ (n - k)"
              by (simp add: card_bind_constant)
            moreover have "finite ?expr"
              using \<open>finite ?S\<close> \<open>finite {P. partition_on C P \<and> card P = j}\<close>
              by (auto intro!: finite_bind)
            ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k)" by blast
          } note inner = this
          moreover have "card ?S = Bell k"
            using B' \<open>finite B'\<close> by (auto simp add: Bell_altdef[symmetric])
          moreover have "disjoint_family_on ?comp ?S"
            using P B'
            by (injectivity_solver rule: local.injectivity(2))
          ultimately have "card ?expr = j ^ (n - k) * Bell k"
            by (subst card_bind_constant) auto
          moreover have "finite ?expr"
            using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
          ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k) * Bell k" by blast
        } note inner = this
        moreover have "card ?S = n choose k"
          using \<open>card B = n\<close> \<open>finite B\<close> by (simp add: n_subsets)
        moreover have "disjoint_family_on ?comp ?S"
          using P
          by (injectivity_solver rule: local.injectivity(3))
        ultimately have "card ?expr = j ^ (n - k) * (n choose k) * Bell k"
          by (subst card_bind_constant) auto
        moreover have "finite ?expr"
          using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
        ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k) * (n choose k) * Bell k" by blast
      } note inner = this
      moreover note \<open>finite ?S\<close>
      moreover have "card ?S = Stirling m j"
        using \<open>finite C\<close> \<open>card C = m\<close> by (simp add: card_partition_on)
      moreover have "disjoint_family_on ?comp ?S"
        by (injectivity_solver rule: local.injectivity(4))
      ultimately have "card ?expr = j ^ (n - k) * Stirling m j * (n choose k) * Bell k"
        by (subst card_bind_constant) auto
      moreover have "finite ?expr"
        using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
      ultimately have "finite ?expr \<and> card ?expr = j ^ (n - k) * Stirling m j * (n choose k) * Bell k" by blast
    } note inner = this
    moreover have "finite ?S" by simp
    moreover have "disjoint_family_on ?comp ?S"
      by (injectivity_solver rule: local.injectivity(5))
    ultimately have "card ?expr = (\<Sum>j\<le>m. j ^ (n - k) * Stirling m j * (n choose k) * Bell k)" (is "_ = ?formula")
      using \<open>card C = m\<close> by (subst card_bind) (auto intro: sum.cong)
    moreover have "finite ?expr"
      using inner \<open>finite ?S\<close> by (auto intro: finite_bind)
    ultimately have "finite ?expr \<and> card ?expr = ?formula" by blast
  }
  moreover have "finite ?S" by simp
  moreover have "disjoint_family_on ?comp ?S"
    by (injectivity_solver rule: local.injectivity(6))
  ultimately have step3: "card (construct_partition_on B C) = (\<Sum>k\<le>n. \<Sum>j\<le>m. j ^ (n - k) * Stirling m j * (n choose k) * Bell k)"
    unfolding construct_partition_on_def
    using \<open>card B = n\<close> by (subst card_bind) (auto intro: sum.cong)
  from step1 step2 step3 show ?thesis by auto
qed

subsection \<open>Corollaries of the Generalized Bell Recurrence\<close>

corollary Bell_Stirling_eq:
  "Bell m = (\<Sum>j\<le>m. Stirling m j)"
proof -
  have "Bell m = Bell (0 + m)" by simp
  also have "... = (\<Sum>j\<le>m. Stirling m j)"
    unfolding Bell_eq[of 0] by (simp add: Bell_0)
  finally show ?thesis .
qed

corollary Bell_recursive_eq:
  "Bell (n + 1) = (\<Sum>k\<le>n. (n choose k) * Bell k)"
unfolding Bell_eq[of _ 1] by simp

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Last
imports
  HOLCF
  LList
  WorkerWrapper
begin

(*>*)
section\<open>Optimise ``last''.\<close>

text\<open>Andy Gill's solution, mechanised. No fusion, works fine using their rule.\<close>

subsection\<open>The @{term "last"} function.\<close>

fixrec llast :: "'a llist \<rightarrow> 'a"
where
  "llast\<cdot>(x :@ yys) = (case yys of lnil \<Rightarrow> x | y :@ ys \<Rightarrow> llast\<cdot>yys)"

lemma llast_strict[simp]: "llast\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec llast_body :: "('a llist \<rightarrow> 'a) \<rightarrow> 'a llist \<rightarrow> 'a"
where
  "llast_body\<cdot>f\<cdot>(x :@ yys) = (case yys of lnil \<Rightarrow> x | y :@ ys \<Rightarrow> f\<cdot>yys)"

lemma llast_llast_body: "llast = fix\<cdot>llast_body"
  by (rule cfun_eqI, subst llast_def, subst llast_body.unfold, simp)

definition wrap :: "('a \<rightarrow> 'a llist \<rightarrow> 'a) \<rightarrow> ('a llist \<rightarrow> 'a)" where
  "wrap \<equiv> \<Lambda> f (x :@ xs). f\<cdot>x\<cdot>xs"

definition unwrap :: "('a llist \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a llist \<rightarrow> 'a)" where
  "unwrap \<equiv> \<Lambda> f x xs. f\<cdot>(x :@ xs)"

lemma unwrap_strict[simp]: "unwrap\<cdot>\<bottom> = \<bottom>"
  unfolding unwrap_def by ((rule cfun_eqI)+, simp)

lemma wrap_unwrap_ID: "wrap oo unwrap oo llast_body = llast_body"
  unfolding llast_body_def wrap_def unwrap_def
  apply (rule cfun_eqI)+
  apply (case_tac xa)
  apply (simp_all add: fix_const)
  done

definition llast_worker :: "('a \<rightarrow> 'a llist \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> 'a llist \<rightarrow> 'a" where
  "llast_worker \<equiv> \<Lambda> r x yys. case yys of lnil \<Rightarrow> x | y :@ ys \<Rightarrow> r\<cdot>y\<cdot>ys"

definition llast' :: "'a llist \<rightarrow> 'a" where
  "llast' \<equiv> wrap\<cdot>(fix\<cdot>llast_worker)"

lemma llast_worker_llast_body: "llast_worker = unwrap oo llast_body oo wrap"
  unfolding llast_worker_def llast_body_def wrap_def unwrap_def
  apply (rule cfun_eqI)+
  apply (case_tac xb)
  apply (simp_all add: fix_const)
  done

lemma llast'_llast: "llast' = llast" (is "?lhs = ?rhs")
proof -
  have "?rhs = fix\<cdot>llast_body" by (simp only: llast_llast_body)
  also have "\<dots> = wrap\<cdot>(fix\<cdot>(unwrap oo llast_body oo wrap))"
    by (simp only: worker_wrapper_body[OF wrap_unwrap_ID])
  also have "\<dots> = wrap\<cdot>(fix\<cdot>(llast_worker))"
    by (simp only: llast_worker_llast_body)
  also have "... = ?lhs" unfolding llast'_def by simp
  finally show ?thesis by simp
qed

end


(*  Title:      Imperative_Insertion_Sort
    Author:     Christian Sternagel
*)

section \<open>Insertion Sort\<close>

theory Imperative_Insertion_Sort
imports
  Imperative_Loops
  "HOL-Library.Multiset"
begin

subsection \<open>The Algorithm\<close>

abbreviation
  array_update :: "'a::heap array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array Heap" ("(_.'(_') \<leftarrow>/ _)" [1000, 0, 13] 14)
where
  "a.(i) \<leftarrow> x \<equiv> Array.upd i x a"

abbreviation array_nth :: "'a::heap array \<Rightarrow> nat \<Rightarrow> 'a Heap" ("_.'(_')" [1000, 0] 14)
where
  "a.(i) \<equiv> Array.nth a i"

text \<open>
  A definition of insertion sort as given by Cormen et al.\ in \emph{Introduction to Algorithms}.
  Compared to the informal textbook version the variant below is a bit unwieldy due to explicit
  dereferencing of variables on the heap.

  To avoid ambiguities with existing syntax we use OCaml's notation for accessing (@{term "a.(i)"})
  and updating (@{term "a.(i) \<leftarrow> x"}) an array @{term a} at position @{term i}.
\<close>
definition
  "insertion_sort a = do {
    l \<leftarrow> Array.len a;
    for [1 ..< l] (\<lambda>j. do {
      \<comment> \<open>Insert \<open>a[j]\<close> into the sorted subarray \<open>a[1 .. j - 1].\<close>\<close>
      key \<leftarrow> a.(j);
      i \<leftarrow> ref j;
      while (do {
        i' \<leftarrow> ! i;
        if i' > 0 then do {x \<leftarrow> a.(i' - 1); return (x > key)}
        else return False})
      (do {
        i' \<leftarrow> ! i;
        x \<leftarrow> a.(i' - 1);
        a.(i') \<leftarrow> x;
        i := i' - 1
      });
      i' \<leftarrow> ! i;
      a.(i') \<leftarrow> key
    })
  }"

text \<open>
  The following definitions decompose the nested loops of the algorithm into more manageable chunks.
\<close>
definition "shiftr_p a (key::'a::{heap, linorder}) i =
  (do {i' \<leftarrow> ! i; if i' > 0 then do {x \<leftarrow> a.(i' - 1); return (x > key)} else return False})"

definition "shiftr_f a i = do {
  i' \<leftarrow> ! i;
  x \<leftarrow> a.(i' - 1);
  a.(i') \<leftarrow> x;
  i := i' - 1
}"

definition "shiftr a key i = while (shiftr_p a key i) (shiftr_f a i)"

definition "insert_elt a = (\<lambda>j. do {
  key \<leftarrow> a.(j);
  i \<leftarrow> ref j;
  shiftr a key i;
  i' \<leftarrow> ! i;
  a.(i') \<leftarrow> key
})"

definition "sort_upto a = (\<lambda>l. for [1 ..< l] (insert_elt a))"

lemma insertion_sort_alt_def:
  "insertion_sort a = (Array.len a \<bind> sort_upto a)"
  by (simp add: insertion_sort_def sort_upto_def shiftr_def shiftr_p_def shiftr_f_def insert_elt_def)

subsection \<open>Partial Correctness\<close>

lemma effect_shiftr_f:
  assumes "effect (shiftr_f a i) h h' u"
  shows "Ref.get h' i = Ref.get h i - 1 \<and>
    Array.get h' a = list_update (Array.get h a) (Ref.get h i) (Array.get h a ! (Ref.get h i - 1))"
  using assms by (auto simp: shiftr_f_def elim!: effect_elims)

lemma success_shiftr_p:
  "Ref.get h i < Array.length h a \<Longrightarrow> success (shiftr_p a key i) h"
  by (auto simp: success_def shiftr_p_def execute_simps)

interpretation ro_shiftr_p: ro_cond "shiftr_p a key i" for a key i
  by (unfold_locales)
     (auto simp: shiftr_p_def success_def execute_simps execute_bind_case split: option.split, metis effectI effect_nthE)

(*[0 .. j - 1]*)
definition [simp]: "ini h a j = take j (Array.get h a)"
(*[0 .. i - 1]*)
definition [simp]: "left h a i = take (Ref.get h i) (Array.get h a)"
(*[i+1 .. j]*)
definition [simp]: "right h a j i = take (j - Ref.get h i) (drop (Ref.get h i + 1) (Array.get h a))"
(*[0 .. i - 1, i + 1 .. j]*)
definition [simp]: "both h a j i = left h a i @ right h a j i"

lemma effect_shiftr:
  assumes "Ref.get h i = j" (is "?i h = _")
    and "j < Array.length h a"
    and "sorted (take j (Array.get h a))"
    and "effect (while (shiftr_p a key i) (shiftr_f a i)) h h' u"
  shows "Array.length h a = Array.length h' a \<and>
    ?i h' \<le> j \<and>
    mset (list_update (Array.get h a) j key) =
      mset (list_update (Array.get h' a) (?i h') key) \<and>
    ini h a j = both h' a j i \<and>
    sorted (both h' a j i) \<and>
    (\<forall>x \<in> set (right h' a j i). x > key)"
using assms(4, 2)
proof (induction rule: ro_shiftr_p.effect_while_induct)
  case base
  show ?case using assms by auto
next
  case (step h' h'' u)
  from \<open>success (shiftr_p a key i) h'\<close> and \<open>cond (shiftr_p a key i) h'\<close>
    have "?i h' > 0" and
    key: "Array.get h' a ! (?i h' - 1) > key"
    by (auto dest!: ro_shiftr_p.success_cond_effect)
       (auto simp: shiftr_p_def elim!: effect_elims effect_ifE)
  from effect_shiftr_f [OF \<open>effect (shiftr_f a i) h' h'' u\<close>]
    have [simp]: "?i h'' = ?i h' - 1"
    "Array.get h'' a = list_update (Array.get h' a) (?i h') (Array.get h' a ! (?i h' - 1))"
    by auto
  from step have *: "?i h' < length (Array.get h' a)"
    and **: "?i h' - (Suc 0) \<le> ?i h'" "?i h' \<le> length (Array.get h' a)"
    and "?i h' \<le> j"
    and "?i h' < Suc j"
    and IH: "ini h a j = both h' a j i"
    by (auto simp add: Array.length_def)
  have "Array.length h a = Array.length h'' a" using step by (simp add: Array.length_def)
  moreover
  have "?i h'' \<le> j" using step by auto
  moreover
  have "mset (list_update (Array.get h a) j key) =
    mset (list_update (Array.get h'' a) (?i h'') key)"
  proof -
    have "?i h' < length (Array.get h' a)"
      and "?i h' - 1 < length (Array.get h' a)" using * by auto
    then show ?thesis
      using step by (simp add: mset_update ac_simps nth_list_update)
  qed
  moreover
  have "ini h a j = both h'' a j i"
    using \<open>0 < ?i h'\<close> and \<open>?i h' \<le> j\<close> and \<open>?i h' < length (Array.get h' a)\<close> and ** and IH
    by (auto simp: upd_conv_take_nth_drop Suc_diff_le min_absorb1)
       (metis Suc_lessD Suc_pred take_Suc_conv_app_nth)

  moreover
  have "sorted (both h'' a j i)"
    using step and \<open>0 < ?i h'\<close> and \<open>?i h' \<le> j\<close> and \<open>?i h' < length (Array.get h' a)\<close> and **
    by (auto simp: IH upd_conv_take_nth_drop Suc_diff_le min_absorb1)
       (metis Suc_lessD Suc_pred append.simps append_assoc take_Suc_conv_app_nth)
  moreover
  have "\<forall>x \<in> set (right h'' a j i). x > key"
    using step and \<open>0 < ?i h'\<close> and \<open>?i h' < length (Array.get h' a)\<close> and key
    by (auto simp: upd_conv_take_nth_drop Suc_diff_le)
  ultimately show ?case by blast
qed

lemma sorted_take_nth:
  assumes "0 < i" and "i < length xs" and "xs ! (i - 1) \<le> y"
    and "sorted (take i xs)"
  shows "\<forall>x \<in> set (take i xs). x \<le> y"
proof -
  have "take i xs = take (i - 1) xs @ [xs ! (i - 1)]"
    using \<open>0 < i\<close> and \<open>i < length xs\<close>
    by (metis Suc_diff_1 less_imp_diff_less take_Suc_conv_app_nth)
  then show ?thesis
    using \<open>sorted (take i xs)\<close> and \<open>xs ! (i - 1) \<le>y\<close>
    by (auto simp: sorted_append)
qed

lemma effect_for_insert_elt:
  assumes "l \<le> Array.length h a"
    and "1 \<le> l"
    and "effect (for [1 ..< l] (insert_elt a)) h h' u"
  shows "Array.length h a = Array.length h' a \<and>
    sorted (take l (Array.get h' a)) \<and>
    mset (Array.get h a) = mset (Array.get h' a)"
using assms(2-)
proof (induction l h' rule: effect_for_induct)
  case base
  show ?case by (cases "Array.get h a") simp_all
next
  case (step j h' h'' u)
  with assms(1) have "j < Array.length h' a" by auto
  from step have sorted: "sorted (take j (Array.get h' a))" by blast
  from step(3) [unfolded insert_elt_def]
    obtain key and h\<^sub>1 and i and h\<^sub>2 and i'
    where key: "key = Array.get h' a ! j"
      and "effect (ref j) h' h\<^sub>1 i"
      and ref\<^sub>1: "Ref.get h\<^sub>1 i = j"
      and shiftr': "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
      and [simp]: "Ref.get h\<^sub>2 i = i'"
      and [simp]: "h'' = Array.update a i' key h\<^sub>2"
      and "i' < Array.length h\<^sub>2 a"
      by (elim effect_bindE effect_nthE effect_lookupE effect_updE)
         (auto intro: effect_intros, metis effect_refE)

  from \<open>effect (ref j) h' h\<^sub>1 i\<close> have [simp]: "Array.get h\<^sub>1 a = Array.get h' a"
    by (metis array_get_alloc effectE execute_ref option.sel)

  have [simp]: "Array.length h\<^sub>1 a = Array.length h' a" by (simp add: Array.length_def)

  from step and assms(1)
    have "j < Array.length h\<^sub>1 a" "sorted (take j (Array.get h\<^sub>1 a))" by auto
  note shiftr = effect_shiftr [OF ref\<^sub>1 this shiftr' [unfolded shiftr_def], simplified]
  have "i' \<le> j" using shiftr by simp

  have "i' < length (Array.get h\<^sub>2 a)"
    by (metis \<open>i' < Array.length h\<^sub>2 a\<close> length_def)
  have [simp]: "min (Suc j) i' = i'" using \<open>i' \<le> j\<close> by simp
  have [simp]: "min (length (Array.get h\<^sub>2 a)) i' = i'"
    using \<open>i' < length (Array.get h\<^sub>2 a)\<close> by (simp)
  have take_Suc_j: "take (Suc j) (list_update (Array.get h\<^sub>2 a) i' key) =
    take i' (Array.get h\<^sub>2 a) @ key # take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))"
    unfolding upd_conv_take_nth_drop [OF \<open>i' < length (Array.get h\<^sub>2 a)\<close>]
    by (auto) (metis Suc_diff_le \<open>i' \<le> j\<close> take_Suc_Cons)

  have "Array.length h a = Array.length h'' a"
    using shiftr by (auto) (metis step.IH)
  moreover
  have "mset (Array.get h a) = mset (Array.get h'' a)"
    using shiftr and step by (simp add: key)
  moreover
  have "sorted (take (Suc j) (Array.get h'' a))"
  proof -
    from ro_shiftr_p.effect_while_post [OF shiftr' [unfolded shiftr_def]]
      have "i' = 0 \<or> (0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1))"
      by (auto dest!: ro_shiftr_p.success_not_cond_effect)
         (auto elim!: effect_elims simp: shiftr_p_def)
    then show ?thesis
    proof
      assume [simp]: "i' = 0"
      have *: "take (Suc j) (list_update (Array.get h\<^sub>2 a) 0 key) =
        key # take j (drop 1 (Array.get h\<^sub>2 a))"
        by (simp) (metis \<open>i' = 0\<close> append_Nil take_Suc_j diff_zero take_0)
      from sorted and shiftr
        have "sorted (take j (drop 1 (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take j (drop 1 (Array.get h\<^sub>2 a))). key < x" by simp_all
      then have "sorted (key # take j (drop 1 (Array.get h\<^sub>2 a)))"
        by (metis less_imp_le sorted.simps(2))
      then show ?thesis by (simp add: *)
    next
      assume "0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1)"
      moreover
      have "sorted (take i' (Array.get h\<^sub>2 a) @ take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))). key < x"
        using shiftr by auto
      ultimately have "\<forall>x \<in> set (take i' (Array.get h\<^sub>2 a)). x \<le> key"
        using sorted_take_nth [OF _ \<open>i' < length (Array.get h\<^sub>2 a)\<close>, of key]
        by (simp add: sorted_append)
      then show ?thesis
        using shiftr by (auto simp: take_Suc_j sorted_append less_imp_le)
    qed
  qed
  ultimately
  show ?case by blast
qed

lemma effect_insertion_sort:
  assumes "effect (insertion_sort a) h h' u"
  shows "mset (Array.get h a) = mset (Array.get h' a) \<and> sorted (Array.get h' a)"
  using assms
  apply (cases "Array.length h a")
  apply (auto elim!: effect_elims simp: insertion_sort_def Array.length_def)[1]
  unfolding insertion_sort_def
  unfolding shiftr_p_def [symmetric] shiftr_f_def [symmetric]
  unfolding shiftr_def [symmetric] insert_elt_def [symmetric]
  apply (elim effect_elims)
  apply (simp only:)
  apply (subgoal_tac "Suc nat \<le> Array.length h a")
  apply (drule effect_for_insert_elt)
  apply (auto simp: Array.length_def)
done

subsection \<open>Total Correctness\<close>

lemma success_shiftr_f:
  assumes "Ref.get h i < Array.length h a"
  shows "success (shiftr_f a i) h"
  using assms by (auto simp: success_def shiftr_f_def execute_simps)

lemma success_shiftr:
  assumes "Ref.get h i < Array.length h a"
  shows "success (while (shiftr_p a key i) (shiftr_f a i)) h"
proof -
  have "wf (measure (\<lambda>h. Ref.get h i))" by (metis wf_measure)
  then show ?thesis
  proof (induct taking: "\<lambda>h. Ref.get h i < Array.length h a" rule: ro_shiftr_p.success_while_induct)
    case (success_cond h)
    then show ?case by (metis success_shiftr_p)
  next
    case (success_body h)
    then show ?case by (blast intro: success_shiftr_f)
  next
    case (step h h' r)
    then show ?case
      by (auto dest!: effect_shiftr_f ro_shiftr_p.success_cond_effect simp: length_def)
         (auto simp: shiftr_p_def elim!: effect_elims effect_ifE)
  qed fact
qed

lemma effect_shiftr_index:
  assumes "effect (shiftr a key i) h h' u"
  shows "Ref.get h' i \<le> Ref.get h i"
  using assms unfolding shiftr_def
  by (induct h' rule: ro_shiftr_p.effect_while_induct) (auto dest: effect_shiftr_f)

lemma effect_shiftr_length:
  assumes "effect (shiftr a key i) h h' u"
  shows "Array.length h' a = Array.length h a"
  using assms unfolding shiftr_def
  by (induct h' rule: ro_shiftr_p.effect_while_induct) (auto simp: length_def dest: effect_shiftr_f)

lemma success_insert_elt:
  assumes "k < Array.length h a"
  shows "success (insert_elt a k) h"
proof -
  obtain key where "effect (a.(k)) h h key"
    using assms by (auto intro: effect_intros)
  moreover
  obtain i and h\<^sub>1 where "effect (ref k) h h\<^sub>1 i"
    and [simp]: "Ref.get h\<^sub>1 i = k"
    and [simp]: "Array.length h\<^sub>1 a = Array.length h a"
    by (auto simp: ref_def length_def) (metis Ref.get_alloc array_get_alloc effect_heapI)
  moreover
  obtain h\<^sub>2 where *: "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
    using success_shiftr [of h\<^sub>1 i a key] and assms
    by (auto simp: success_def effect_def shiftr_def)
  moreover
  have "effect (! i) h\<^sub>2 h\<^sub>2 (Ref.get h\<^sub>2 i)"
    and "Ref.get h\<^sub>2 i \<le> Ref.get h\<^sub>1 i"
    and "Ref.get h\<^sub>2 i < Array.length h\<^sub>2 a"
    using effect_shiftr_index [OF *] and effect_shiftr_length [OF *] and assms
    by (auto intro!: effect_intros)
  moreover
  then obtain h\<^sub>3 and r where "effect (a.(Ref.get h\<^sub>2 i) \<leftarrow> key) h\<^sub>2 h\<^sub>3 r"
    using assms by (auto simp: effect_def execute_simps)
  ultimately
  have "effect (insert_elt a k) h h\<^sub>3 r"
    by (auto simp: insert_elt_def intro: effect_intros)
  then show ?thesis by (metis effectE)
qed

lemma for_insert_elt_correct:
  assumes "l \<le> Array.length h a"
    and "1 \<le> l"
  shows "\<exists>h'. effect (for [1 ..< l] (insert_elt a)) h h' () \<and>
    Array.length h a = Array.length h' a \<and>
    sorted (take l (Array.get h' a)) \<and>
    mset (Array.get h a) = mset (Array.get h' a)"
using assms(2)
proof (induction rule: for_induct)
  case (succeed k h)
  then show ?case using assms and success_insert_elt [of k h a] by auto
next
  case base
  show ?case by (cases "Array.get h a") simp_all
next
  case (step j h' h'' u)
  with assms(1) have "j < Array.length h' a" by auto
  from step have sorted: "sorted (take j (Array.get h' a))" by blast
  from step(4) [unfolded insert_elt_def]
    obtain key and h\<^sub>1 and i and h\<^sub>2 and i'
    where key: "key = Array.get h' a ! j"
      and "effect (ref j) h' h\<^sub>1 i"
      and ref\<^sub>1: "Ref.get h\<^sub>1 i = j"
      and shiftr': "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
      and [simp]: "Ref.get h\<^sub>2 i = i'"
      and [simp]: "h'' = Array.update a i' key h\<^sub>2"
      and "i' < Array.length h\<^sub>2 a"
      by (elim effect_bindE effect_nthE effect_lookupE effect_updE)
         (auto intro: effect_intros, metis effect_refE)

  from \<open>effect (ref j) h' h\<^sub>1 i\<close> have [simp]: "Array.get h\<^sub>1 a = Array.get h' a"
    by (metis array_get_alloc effectE execute_ref option.sel)

  have [simp]: "Array.length h\<^sub>1 a = Array.length h' a" by (simp add: Array.length_def)

  from step and assms(1)
    have "j < Array.length h\<^sub>1 a" "sorted (take j (Array.get h\<^sub>1 a))" by auto
  note shiftr = effect_shiftr [OF ref\<^sub>1 this shiftr' [unfolded shiftr_def], simplified]
  have "i' \<le> j" using shiftr by simp

  have "i' < length (Array.get h\<^sub>2 a)"
    by (metis \<open>i' < Array.length h\<^sub>2 a\<close> length_def)
  have [simp]: "min (Suc j) i' = i'" using \<open>i' \<le> j\<close> by simp
  have [simp]: "min (length (Array.get h\<^sub>2 a)) i' = i'"
    using \<open>i' < length (Array.get h\<^sub>2 a)\<close> by (simp)
  have take_Suc_j: "take (Suc j) (list_update (Array.get h\<^sub>2 a) i' key) =
    take i' (Array.get h\<^sub>2 a) @ key # take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))"
    unfolding upd_conv_take_nth_drop [OF \<open>i' < length (Array.get h\<^sub>2 a)\<close>]
    by (auto) (metis Suc_diff_le \<open>i' \<le> j\<close> take_Suc_Cons)

  have "Array.length h a = Array.length h'' a"
    using shiftr by (auto) (metis step.hyps(1))
  moreover
  have "mset (Array.get h a) = mset (Array.get h'' a)"
    using shiftr and step by (simp add: key)
  moreover
  have "sorted (take (Suc j) (Array.get h'' a))"
  proof -
    from ro_shiftr_p.effect_while_post [OF shiftr' [unfolded shiftr_def]]
      have "i' = 0 \<or> (0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1))"
      by (auto dest!: ro_shiftr_p.success_not_cond_effect)
         (auto elim!: effect_elims simp: shiftr_p_def)
    then show ?thesis
    proof
      assume [simp]: "i' = 0"
      have *: "take (Suc j) (list_update (Array.get h\<^sub>2 a) 0 key) =
        key # take j (drop 1 (Array.get h\<^sub>2 a))"
        by (simp) (metis \<open>i' = 0\<close> append_Nil take_Suc_j diff_zero take_0)
      from sorted and shiftr
        have "sorted (take j (drop 1 (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take j (drop 1 (Array.get h\<^sub>2 a))). key < x" by simp_all
      then have "sorted (key # take j (drop 1 (Array.get h\<^sub>2 a)))"
        by (metis less_imp_le sorted.simps(2))
      then show ?thesis by (simp add: *)
    next
      assume "0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1)"
      moreover
      have "sorted (take i' (Array.get h\<^sub>2 a) @ take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))). key < x"
        using shiftr by auto
      ultimately have "\<forall>x \<in> set (take i' (Array.get h\<^sub>2 a)). x \<le> key"
        using sorted_take_nth [OF _ \<open>i' < length (Array.get h\<^sub>2 a)\<close>, of key]
        by (simp add: sorted_append)
      then show ?thesis
        using shiftr by (auto simp: take_Suc_j sorted_append less_imp_le)
    qed
  qed
  ultimately
  show ?case by blast
qed

lemma insertion_sort_correct:
  "\<exists>h'. effect (insertion_sort a) h h' u \<and>
    mset (Array.get h a) = mset (Array.get h' a) \<and>
    sorted (Array.get h' a)"
proof (cases "Array.length h a = 0")
  assume "Array.length h a = 0"
  then have "effect (insertion_sort a) h h ()"
    and "mset (Array.get h a) = mset (Array.get h a)"
    and "sorted (Array.get h a)"
    by (auto simp: insertion_sort_def length_def intro!: effect_intros)
  then show ?thesis by auto
next
  assume "Array.length h a \<noteq> 0"
  then have "1 \<le> Array.length h a" by auto
  from for_insert_elt_correct [OF le_refl this]
    show ?thesis
    by (auto simp: insertion_sort_alt_def sort_upto_def)
       (metis One_nat_def effect_bindI effect_insertion_sort effect_lengthI insertion_sort_alt_def sort_upto_def)
qed

export_code insertion_sort in Haskell

end


theory Pointwise imports Main begin

text {*
Lifting a relation to a function.
*}

definition pointwise where "pointwise P m m' = (\<forall> x. P (m x) (m' x))"

end


theory sledgeCategoryV2 imports FreeLogic

abbrevs "morphismE" = ":\<rightarrow>" and
        "morphism" = ":\<Rightarrow>" and
        "wedgeE" = "\<leftarrow>-()-\<rightarrow>" and
        "wedge" = "\<Leftarrow>-()-\<Rightarrow>" and
        "cowedgeE" = "-\<rightarrow>()\<leftarrow>-" and
        "ptimes" = "\<^bold>\<times>"

begin

(*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 180]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 spass e vampire remote_leo3]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

section \<open>The Basics of Category Theory\<close>

class category =
  fixes domain:: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
        codomain:: "'a\<Rightarrow> 'a" ("cod _" [110] 111) and
        composition:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>" 110)

  assumes
        S1: "E(dom x) \<^bold>\<rightarrow> E x" and
        S2: "E(cod y) \<^bold>\<rightarrow> E y" and
        S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
        S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
        S5: "x\<cdot>(dom x) \<cong> x" and
        S6: "(cod y)\<cdot>y \<cong> y"
begin

subsection\<open>Basic Definitions\<close>

abbreviation type ("type") where "type x \<equiv> x \<cong> dom x"

abbreviation typeE ("typeE") where "typeE x \<equiv> x \<simeq> dom x"

abbreviation arrow ("(_):(_)\<Rightarrow>(_)" [120,120,120] 119) where
  "x:a\<Rightarrow>b \<equiv> dom x \<cong> a \<and> cod x \<cong> b"

abbreviation arrowE ("(_):(_)\<rightarrow>(_)" [120,120,120] 119) where
  "x:a\<rightarrow>b \<equiv> dom x \<simeq> a \<and> cod x \<simeq> b"

abbreviation wedge ("_\<Leftarrow>_- (_) -_\<Rightarrow>_" [120,0,0,0,120] 119) where
  "a \<Leftarrow>f- (x) -g\<Rightarrow> b \<equiv> f:x\<Rightarrow>a \<and> g:x\<Rightarrow>b"

abbreviation wedgeE ("_\<leftarrow>_- (_) -_\<rightarrow>_" [120,0,0,0,120] 119) where
  "a \<leftarrow>f- (x) -g\<rightarrow> b \<equiv> f:x\<rightarrow>a \<and> g:x\<rightarrow>b"

abbreviation cowedgeE ("_-_\<rightarrow> (_) \<leftarrow>_-_" [120,0,0,120] 119) where
  "a -f\<rightarrow> (x) \<leftarrow>g- b \<equiv> f:a\<rightarrow>x \<and> g:b\<rightarrow>x"

\<comment> \<open>arrows appear in counterclockwise order starting at lower right corner\<close>
abbreviation commutativeSquare ("commSquare") where
  "commSquare g p q f \<equiv> ((dom f)\<Leftarrow>q-(dom p)-p\<Rightarrow>(dom g)) \<and> cod f \<cong> cod g \<and> g\<cdot>p \<cong> f\<cdot>q"

abbreviation commutativeSquareE ("commSquareE") where
  "commSquareE g p q f \<equiv> ((dom f)\<leftarrow>q-(dom p)-p\<rightarrow>(dom g)) \<and> cod f \<simeq> cod g \<and> g\<cdot>p \<simeq> f\<cdot>q"

abbreviation monic::"'a \<Rightarrow> bool" ("monic") where
  "(monic m) \<equiv> \<forall>f g. m\<cdot>f \<simeq> m\<cdot>g \<longrightarrow> f \<simeq> g"

abbreviation epi::"'a \<Rightarrow> bool" ("epi") where
  "(epi m) \<equiv> \<forall>f g. f\<cdot>m \<simeq> g\<cdot>m \<longrightarrow> f \<simeq> g"

abbreviation initial::"'a \<Rightarrow> bool" ("initial") where
  "(initial z) \<equiv> \<^bold>\<forall>t. (type t) \<longrightarrow> (\<^bold>\<exists>!f. f:z\<rightarrow>t)"

abbreviation final::"'a \<Rightarrow> bool" ("final") where
  "final z \<equiv> \<^bold>\<forall>t. (type t) \<longrightarrow> (\<^bold>\<exists>!f. f:t\<rightarrow>z)"

abbreviation isomorphism::"'a \<Rightarrow> bool" ("isomorphism") where
  "(isomorphism f) \<equiv> \<exists>g. f\<cdot>g \<cong> (dom g) \<and> g\<cdot>f \<cong> (dom f)"

abbreviation isomorphic::"'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<cong>" 120) where
  "isomorphic z y \<equiv> \<exists>f. dom f \<cong> z \<and> cod f \<cong> y \<and> isomorphism f"

subsection\<open>More Advanced Definitions\<close>
(*ToDo*)

\<comment> \<open>e is the equalizer for f and g\<close>
abbreviation isEqualizer::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("Equalizer")
  where "isEqualizer f g e \<equiv> f \<cdot> e \<cong> g \<cdot> e \<and>
          (\<^bold>\<forall>z. f \<cdot> z \<simeq> g \<cdot> z \<longrightarrow> (\<^bold>\<exists>!u. u:(dom z)\<rightarrow>(dom e) \<and> e \<cdot> u \<simeq> z))"

(*abbreviation coequalizer*)

abbreviation product::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("product") where
"product a b c p1 p2 \<equiv> p1:c\<Rightarrow>a \<and> p2:c\<Rightarrow>b \<and>
                        (\<^bold>\<forall>x f g. (a\<leftarrow>f-(x)-g\<rightarrow>b) \<longrightarrow>
                          (\<^bold>\<exists>!h. h:x\<rightarrow>c \<and> f \<simeq> p1\<cdot>h \<and> g \<simeq> p2\<cdot>h))"

abbreviation coproduct::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("coproduct") where
"coproduct a b c p1 p2 \<equiv> p1:a\<Rightarrow>c \<and> p2:b\<Rightarrow>c \<and>
                        (\<^bold>\<forall>x f g. (a-f\<rightarrow>(x)\<leftarrow>g-b) \<longrightarrow>
                          (\<^bold>\<exists>!h. h:c\<rightarrow>x \<and> f \<simeq> h\<cdot>p1 \<and> g \<simeq> h\<cdot>p2))"

abbreviation isPullback ("pullback") where
  "pullback g p q f \<equiv> commSquare g p q f \<and>
                        (\<^bold>\<forall>\<beta> \<gamma>. (dom f)\<leftarrow>\<beta>-(dom \<beta>)-\<gamma>\<rightarrow>(dom g) \<and> f\<cdot>\<beta> \<simeq> g\<cdot>\<gamma> \<longrightarrow>
                          (\<^bold>\<exists>!\<delta>. \<delta>:(dom \<beta>)\<rightarrow>(dom p) \<and> q\<cdot>\<delta> \<simeq> \<beta> \<and> p\<cdot>\<delta> \<simeq> \<gamma>))"

abbreviation isPushout ("pushout") where
  "pushout p f g q \<equiv> commSquare g p q f \<and>
                        (\<^bold>\<forall>\<beta> \<gamma>. ((cod g)-\<gamma>\<rightarrow>(cod \<gamma>)\<leftarrow>\<beta>-(cod f)) \<and> \<beta>\<cdot>f \<simeq> \<gamma>\<cdot>g \<longrightarrow>
                          (\<^bold>\<exists>!\<delta>. \<delta>:(cod p)\<rightarrow>(cod \<gamma>) \<and> \<delta>\<cdot>q \<simeq> \<beta> \<and> \<delta>\<cdot>p \<simeq> \<gamma>))"

end

subsection\<open>Functors\<close>

abbreviation isFunctor::"('a::category \<Rightarrow> 'b::category) \<Rightarrow> bool" ("Functor") where
  "isFunctor F \<equiv> (\<forall>x. E x \<longleftrightarrow> E (F x)) \<and>
                  (\<forall>x. type x \<longrightarrow> type (F x)) \<and>
                   (\<forall>x. F (dom x) \<cong> dom (F x)) \<and>
                  (\<^bold>\<forall>x y. E(x\<cdot>y) \<longrightarrow> (F (x\<cdot>y) \<simeq> (F x) \<cdot> (F y)))"

abbreviation isNaturalTransformation::"('c \<Rightarrow> 'd) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('c::category \<Rightarrow> 'd::category) \<Rightarrow> bool" ("natTrans")
  where "natTrans F G \<upsilon> \<equiv> isFunctor F \<and> isFunctor G \<and>
                              (\<^bold>\<forall>f::'c. (\<upsilon> (cod f))\<cdot>(F f) \<simeq> (G f)\<cdot>(\<upsilon> (dom f)))"

section\<open>Category with Binary Products\<close>

class productCategory = category +
  fixes product_func::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<^bold>\<times>" 115) and
        p1::"'a \<Rightarrow> 'a" and
        p2::"'a \<Rightarrow> 'a"
  assumes
          catProd1: "E (a \<^bold>\<times> b) \<longrightarrow> (E a \<and> E b)" and
          catProd3: "E (p1 (a \<^bold>\<times> b)) \<longrightarrow> (E (a \<^bold>\<times> b))" and
          catProd4: "E (p2 (a \<^bold>\<times> b)) \<longrightarrow> (E (a \<^bold>\<times> b))" and
          catProd2: "\<^bold>\<forall>a b. (product  (dom a) (dom b) ((dom a) \<^bold>\<times> (dom b)) (p1 ((dom a) \<^bold>\<times> (dom b))) (p2 ((dom a) \<^bold>\<times> (dom b))))" and
          catProd5: "\<^bold>\<forall>a b. (commSquareE a (p1 ((dom a) \<^bold>\<times> (dom b))) (a \<^bold>\<times> b) (p1 ((cod a) \<^bold>\<times> (cod b))))" and
          catProd6: "\<^bold>\<forall>a b. commSquareE b (p2 ((dom a) \<^bold>\<times> (dom b))) (a \<^bold>\<times> b) (p2 ((cod a) \<^bold>\<times> (cod b)))"

begin

lemma "type A" oops (*sledgehammer(S1 S2 S3 S4 S5 S6 catProd1 catProd2 catProd3 catProd4 catProd5 catProd6)*)

lemma "(typeE a \<and> typeE b) \<longrightarrow> typeE (a \<^bold>\<times> b)"
  by (metis S2 S3 S5 S6 catProd2)

\<comment> \<open>Surprisingly the next lemma cannot be proven though z3 finds a proof..\<close>
lemma "\<^bold>\<forall>a b. \<^bold>\<exists>p1 p2. product (dom a) (dom b) ((dom a) \<^bold>\<times> (dom b)) p1 p2" oops (*sledgehammer (S2 S3 S5 catProd2 catProd1 catProd4 catProd3)*)
  (*by (smt S2 S3 S5 catProd2) fails*)

end

section\<open>Cartesian Category\<close>

class cartesianCategory = productCategory +
  fixes finalObject::"'a" ("\<^bold>1") and
        finalMap::"'a \<Rightarrow> 'a" ("\<^bold>!")
  assumes
        cartesian1: "\<^bold>\<forall>f g. (f:(dom g)\<rightarrow>(cod g)) \<longrightarrow> (\<^bold>\<exists>e. isEqualizer f g e)" and
        cartesian2: "final \<^bold>1" and
        cartesian3: "\<^bold>\<forall>t. (\<^bold>! t):(dom t)\<rightarrow>\<^bold>1"
begin
lemma "True" nitpick[satisfy] oops
end

section\<open>Cartesian Closed Category\<close>

abbreviation (in productCategory) isExponential:: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("Exp")
  where "Exp a b c \<epsilon> \<equiv> \<^bold>\<exists>p1 p2. product a c (dom \<epsilon>) p1 p2 \<and> \<epsilon>:(a\<^bold>\<times>c)\<rightarrow>b \<and>
                        (\<^bold>\<forall>z f q1 q2. (product z a (dom f) q1 q2 \<and> f:(z\<^bold>\<times>a)\<rightarrow>b) \<longrightarrow>
                          (\<^bold>\<exists>!\<ff>. \<ff>:z\<rightarrow>c \<and> (\<^bold>\<exists>!\<jj>. \<jj>:(dom f)\<rightarrow>(dom \<epsilon>) \<and>
                            p2 \<cdot> \<jj> \<simeq> \<ff> \<cdot> q1 \<and> p1 \<cdot> \<jj> \<simeq> q2 \<and> \<epsilon> \<cdot> \<jj> \<simeq> f)))"

class exponentialCategory = productCategory +
  fixes  exp::"'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_\<^sup>_") and
         finalObject::"'a" ("\<^bold>1\<^sub>c")

  assumes E1: "\<^bold>\<forall>a b. (\<^bold>\<exists>\<epsilon>. Exp (dom a) (dom b) (exp a b) \<epsilon>)" and
          E2: "E (a\<^sup>b) \<longrightarrow> (E a \<and> E b)" and
          E3: "final \<^bold>1\<^sub>c"
begin
lemma "E (a\<^sup>b) \<longrightarrow> typeE (a\<^sup>b)"
  by (smt E1 E2 S3 S6)
end

class exponentialCategory2 = productCategory +
  fixes  exp2::"'a \<Rightarrow> 'a \<Rightarrow> 'a" and
         evaluation::"'a" ("\<epsilon>")

  assumes G1: "\<^bold>\<forall>a b. (typeE a \<and> typeE b) \<longrightarrow> (Exp a b (exp2 a b) \<epsilon>)" and
          G2: "E (exp2 a b) \<longrightarrow> (E a \<and> E b)"
begin
lemma "True" nitpick[satisfy] oops
end

section\<open>Topos\<close>

(*abbreviation (in cartesianCategory) subobjectClassifier::"'a \<Rightarrow> 'a \<Rightarrow> bool" ("subC") where
    "subC \<Omega> t \<equiv> t:(\<^bold>1\<^sub>c)\<Rightarrow>\<Omega> \<and> (\<^bold>\<forall>m s. (monic m \<and> s:(dom m)\<rightarrow>(\<^bold>1\<^sub>c)) \<longrightarrow> (\<^bold>\<exists>!\<Phi>. (\<Phi>:(cod m)\<rightarrow>\<Omega>) \<and>
                                                pullback t s m \<Phi>))"*)

class topos = cartesianCategory + exponentialCategory2 +
  fixes classifier::'a ("\<Omega>") and
        true::'a ("true") and
        characteristicMap::"'a \<Rightarrow> 'a" ("char") and
        diagnalMap::"'a \<Rightarrow> 'a" ("\<Delta>")
      assumes T1: "(E m \<and> monic m)  \<longrightarrow>
                            (((char m):(cod m)\<rightarrow>\<Omega>) \<and> pullback true (\<^bold>! (dom m)) m (char m) \<and>
                                (\<^bold>\<forall>\<Phi>. ((\<Phi>:(cod m)\<rightarrow>\<Omega>) \<and> pullback true (\<^bold>! (dom m)) m \<Phi>) \<longrightarrow> \<Phi> \<simeq> (char m)))" and
              T2: "\<^bold>\<forall>B. (p1((dom B)\<^bold>\<times>(dom B)))\<cdot>(\<Delta> B) \<simeq> (dom B)" and
              T3: "\<^bold>\<forall>B. (p2((dom B)\<^bold>\<times>(dom B)))\<cdot>(\<Delta> B) \<simeq> (dom B)" and
              T4: "E (char m) \<longrightarrow> E m" and
              T5: "E (\<Delta> B) \<longrightarrow> E B"
begin
lemma "True" nitpick[satisfy] oops

\<comment> \<open>We do not axiomatize the existence of \<Omega> because one existing morphism leads to the desired behaviour. This way the empty topos is possible.\<close>
lemma "(\<exists>x::'a. E x) \<longrightarrow> E \<Omega>" (*sledgehammer (S1 S2 S3 S4 S5 S6 catProd1 catProd2 cartesian1 cartesian2 G1 G2 T1)*)
  by (smt S1 S2 S3 S5 S6 T1 cartesian2)

\<comment> \<open>vampire finds by (metis S1 S2 S3 S5 S6 T1 cartesian2) but timeout --> splitting proof works\<close>
lemma "true:\<^bold>1\<Rightarrow>\<Omega>"
proof -
  consider (a) "E true" | (b) "\<not> (E true)" by auto
  then show ?thesis
  proof cases
case a
  then show ?thesis
    by (smt S1 S2 S3 S5 S6 T1 cartesian2 cartesian3)
next
  case b
  then show ?thesis
    by (smt S1 S2 S3 S5 S6 T1 cartesian2)
qed
qed

\<comment> \<open>This justifies our skolemization of \<Delta>\<close>
lemma "typeE B \<longrightarrow>  (\<^bold>\<exists>!f. ((p1(B\<^bold>\<times>B))\<cdot>f \<simeq>  B \<and> (p2(B\<^bold>\<times>B))\<cdot>f \<simeq> B))" (*sledgehammer (S1 S2 S3 S4 S5 S6 catProd1 catProd2 catProd3 catProd4 catProd5 catProd6 cartesian1 cartesian2 G1 G2 T1 T2 T3 T4 T5)*)
  by (smt S2 S3 S4 S5 catProd2)

end

end


(* ********************************************************************************

    Theory Powerset.thy is part of a package providing supplementary material
    to 'Synthesis of Implementations for Divide-and-conquer Specifications'.
    Copyright (c) 2023  M. Bortin

    The package is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    For more details see the license agreement (LICENSE) you should have
    received along with the package.

   ******************************************************************************* *)

theory Powerset
imports DaC_synthesis
begin

text "The following theory contains an introductory example application of the
      divide-and-conquer design tactic synthesising a function that computes a
      list representation for the power set of a given finite set."

text "Note that the explicit typing merely caters better readability and
      may be omitted as well."
definition pow :: "'a set \<rightarrow> 'a set set"
  where "pow = {(S, P) |S P. \<forall>X. (X \<in> P) = (X \<subseteq> S)}"

definition decomp_spec :: "'a set \<rightarrow> ('a, 'a set) Relt"
  where "decomp_spec = {({}, Empty)} \<union> {(G, Dcmp a (G - {a})) |G a. a \<in> G}"

definition comp_spec :: "('a, 'a set set) Relt \<rightarrow> 'a set set"
  where "comp_spec = {(Empty, {{}})} \<union>
                     {(Dcmp a P, P \<union> {{a} \<union> A |A. A \<in> P}) |a P. True}"

definition decomp_impl :: "'a list \<Rightarrow> ('a, 'a list) Relt"
  where "decomp_impl = (\<lambda>xs. case xs of
                               [] \<Rightarrow> Empty
                             | x # xs' \<Rightarrow> Dcmp x xs')"

definition comp_impl :: "('a, 'a list list) Relt \<Rightarrow> 'a list list"
  where "comp_impl = (\<lambda>x. case x of
                           Empty \<Rightarrow> [[]]
                         | Dcmp a xxs \<Rightarrow> xxs @ map (\<lambda>xs. a#xs) xxs)"

text "Next we apply the divide-and-conquer synthesis rule: "
interpretation powerset: DaC_synthesis
"{(xs, set xs) |xs. distinct xs}"                 (* \<alpha>\<^sub>1 *)
"{(xxs, {set xs |xs. xs \<in> set xxs}) |xxs. True}"                               (* \<alpha>\<^sub>2 *)
pow decomp_spec comp_spec decomp_impl comp_impl
  apply(unfold_locales)

  text "problem reduction principle:"
     apply(clarsimp simp: DaC_scheme_def decomp_spec_def comp_spec_def Relt_def pow_def)
     apply(elim disjE, clarsimp+)
     apply (metis insert_Diff insert_mono subset_Diff_insert subset_insert_iff)

  text "decomposition implementation:"
    apply(clarsimp simp: decomp_spec_def decomp_impl_def graph_of_def Relt_def)
    apply(case_tac xs, simp)
     apply(rule_tac b=Empty in relcompI, clarsimp+)
    apply(rename_tac x xs)
    apply(rule_tac b="Dcmp x (set xs)" in relcompI)
     apply simp+

  text "composition implementation:"
   apply(clarsimp simp: comp_spec_def comp_impl_def graph_of_def Relt_def)
   apply(rename_tac xxs)
   apply(case_tac xxs, simp)
    apply(rule_tac b=Empty in relcompI, clarsimp+)
   apply(rename_tac x xxs)
   apply(rule_tac b="Dcmp x {set xs |xs. xs \<in> set xxs}" in relcompI)
    apply fast
   apply clarsimp
  apply(rule set_eqI, rule iffI)
    apply (clarsimp, metis imageE list.simps(15))
   apply (clarsimp, metis imageI list.simps(15))

  text "reductivity:"
  apply clarsimp
  apply(rename_tac xs)
  apply(induct_tac xs rule: length_induct, clarsimp)
  apply(rename_tac xs)
  apply(subst lfp_unfold)
   apply(rule monoI)
   apply(rule monoD[OF monotypeF_mono])
   apply(erule monoD[OF Relt_mono])
  apply(subst singleton_eq)
  apply(rule monotypeF_univ[THEN iffD1])
  apply(subst graph_of_def, subst graph_of_def)
  apply(clarsimp simp: decomp_impl_def)
  apply(rename_tac xs)
  apply(case_tac xs, simp)
   apply(rule_tac b="Empty" in relcompI, simp, simp add: Relt_def)
  apply clarsimp
  apply(rename_tac x xs)
  apply(rule_tac b="Dcmp x xs" in relcompI, simp)
  apply(subst Relt_def, simp)
  done

text "Deriving the recursive equations for the synthesised function:"
lemma syn_powerset_eqs[simp] :
"powerset.dac [] = [[]]"
"powerset.dac (x#xs) = (let xxs = powerset.dac xs in xxs @ map (\<lambda>xs. x#xs) xxs)"
  by(subst powerset.dac_unfold, simp add: Let_def decomp_impl_def comp_impl_def ReltF_eqs)+

text "The correctness of the synthesised @{term powerset.dac} follows from the
      implementation property @{thm powerset.dac_impl} :"
lemma syn_powerset_corr :
"distinct xs \<Longrightarrow> (X \<subseteq> set xs) = (\<exists>ys \<in> set(powerset.dac xs). set ys = X)"
  apply(insert powerset.dac_impl)
  apply(drule_tac c="(set xs, {set ys |ys. ys \<in> set(powerset.dac xs)})" in subsetD)
   apply(rule_tac b=xs in relcompI, simp)
   apply(rule_tac b="powerset.dac xs" in relcompI, simp add: graph_of_def)
   apply simp
  apply(clarsimp simp: pow_def)
  by metis

text "The purpose of the restriction of inputs to distinct lists is
       (a) no more list representations will be generated than needed:"
lemma syn_powerset_length :
"distinct xs \<Longrightarrow> length(powerset.dac xs) = 2^(length xs)"
  by(induct xs, (simp add: Let_def)+)

text "and (b) each of the representations is in turn distinct:"
lemma syn_powerset_distinct :
"distinct xs \<Longrightarrow> \<forall>ys\<in>set(powerset.dac xs). distinct ys"
  apply(induct xs, (clarsimp simp: Let_def)+)
  apply(erule disjE, fast)
  by (smt (verit, ccfv_SIG) distinct.simps(2) imageE subsetD syn_powerset_corr)

text "Finally we can replace the synthesised function by the tail-recursive function:"
fun pow_tr where
"pow_tr [] rs = rs" |
"pow_tr (x#xs) rs = pow_tr xs (rs @ map (\<lambda>xs. x#xs) rs)"

lemma pow_tr_app :
"pow_tr (xs @ ys) rs = pow_tr ys (pow_tr xs rs)"
  by(induct xs arbitrary: rs, simp+)

lemma dac_pow_tr :
"powerset.dac (xs @ ys) = pow_tr (rev xs) (powerset.dac ys)"
  by(induct xs arbitrary: ys, simp_all add: Let_def pow_tr_app)

corollary pow_tr :
"pow_tr xs [[]] = powerset.dac (rev xs)"
  by (metis append_Nil2 dac_pow_tr rev_rev_ident syn_powerset_eqs(1))

text "The correctness of @{term pow_tr} now follows straight:"
lemma pow_tr_corr :
"distinct xs \<Longrightarrow> (X \<subseteq> set xs) = (\<exists>ys \<in> set(pow_tr xs [[]]). set ys = X)"
  apply(subst pow_tr)
  apply(subst syn_powerset_corr[THEN sym])
  by simp+

lemma pow_tr_length :
"distinct xs \<Longrightarrow> length(pow_tr xs [[]]) = 2^(length xs)"
  by(subst pow_tr, subst syn_powerset_length, simp+)

lemma pow_tr_distinct :
"distinct xs \<Longrightarrow> \<forall>ys\<in>set(pow_tr xs [[]]). distinct ys"
  by(subst pow_tr, rule syn_powerset_distinct, simp)

end


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

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

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

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

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

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

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

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

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

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

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

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

function nstooge1sort2 :: "int list => int list"
  and nstoogesort :: "int list => int list"
  and nstooge1sort1 :: "int list => int list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort xs)"
  oops

end


theory Examples
imports DerivedCombinators PartialEvaluation Typechecking
begin

definition base_environment :: "decl list" where
  "base_environment = [
      TypeDecl ''Nat'' [(''Zero'', []), (''Succ'', [''Nat''])],
      ExprDecl ''is_zero'' (\<epsilon> \<bar> \<kappa> UnitV \<cdot> \<prec>\<^bsub>''Nat''\<^esub>),
      ExprDecl ''pred'' (\<kappa> (VarV ''Zero'') \<nabla> \<epsilon> \<cdot> \<prec>\<^bsub>''Nat''\<^esub>),
      ExprDecl ''greater_than_helper'' IF (Var ''is_zero'') \<cdot> \<pi>\<^sub>1 THEN \<iota>\<^sub>l \<cdot> \<kappa> FalseV
                                       ELSE IF (Var ''is_zero'') \<cdot> \<pi>\<^sub>2 THEN \<iota>\<^sub>l \<cdot> \<kappa> TrueV
                                       ELSE \<iota>\<^sub>r \<cdot> (Var ''pred'') \<parallel> (Var ''pred'')
                                       FI FI,
      TypeDecl ''GTHelper'' [(''Success'', [''Bool'']), (''Recurse'', [''GTHelper''])],
      ExprDecl ''greater_than'' (\<lparr> \<Xi> \<rparr>\<^bsub>''GTHelper''\<^esub> \<cdot> \<lbrakk> Var ''greater_than_helper'' \<rbrakk>\<^bsub>''GTHelper''\<^esub>)]"

primrec nat_to_val :: "nat \<Rightarrow> val" where
  "nat_to_val 0 = ZeroV"
| "nat_to_val (Suc n) = SuccV (nat_to_val n)"

abbreviation long_run :: nat where
  "long_run \<equiv> Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))))))))"

lemma "partial_eval_prog long_run (Prog base_environment (Var ''greater_than_expr'') (PairV (SuccV (SuccV ZeroV)) (SuccV ZeroV))) = Some TrueV"
  by (simp add: greater_than_expr_def greater_than_helper_def is_zero_expr_def pred_expr_def)

lemma "partial_eval_prog long_run (Prog example_env greater_than_expr (PairV (SuccV ZeroV) (SuccV (SuccV ZeroV)))) = Some FalseV"
  by (simp add: greater_than_expr_def greater_than_helper_def is_zero_expr_def pred_expr_def)

end