section \<open>\<open>3CNF-SAT\<close> To \<open>Set Cover\<close>\<close>

theory Three_Sat_To_Set_Cover
  imports Reductions "Poly_Reductions_Lib.SAT_Definition"
begin

subsection \<open>Preliminaries\<close>

type_synonym 'a ugraph = "'a set set"

definition
  "ugraph E \<equiv> finite E \<and> (\<forall>e \<in> E. card e = 2)" \<comment> \<open>Allow self-loops?\<close>

definition
  "is_independent_set E V \<equiv> \<forall>u \<in> V. \<forall>v \<in> V. {u, v} \<notin> E"

definition
  "independent_set \<equiv> {(E, k). \<exists>V. ugraph E \<and> V \<subseteq> \<Union> E \<and> card V \<ge> k \<and> is_independent_set E V}"

definition
  "is_vertex_cover E V \<equiv> \<forall> e \<in> E. \<exists> v \<in> V. v \<in> e"

definition
  "vertex_cover \<equiv>
  {(E, k). \<exists>V. ugraph E \<and> V \<subseteq> \<Union> E \<and> k \<le> card (\<Union> E) \<and> card V \<le> k \<and> is_vertex_cover E V}"

definition
  (* "set_cover \<equiv> {(T, k). \<exists> S \<subseteq> T. \<Union> S = \<Union> T \<and> card S \<le> k \<and> finite T \<and> finite (\<Union> T)}" *)
  "set_cover \<equiv> {(T, k). \<exists> S \<subseteq> T. \<Union> S = \<Union> T \<and> card S \<le> k}"

definition
  "is_vc \<equiv> \<lambda>(E, k). if k > card (\<Union> E) then (E, k) else (E, card (\<Union> E) - k)"

definition
  "vc_sc \<equiv> \<lambda>(E, k).
    if ugraph E \<and> k \<le> card (\<Union> E) then ({{e. e \<in> E \<and> v \<in> e} | v. v \<in> \<Union>E}, k)
    else ({{undefined}}, 0)"

lemma is_independent_set_is_vertex_cover:
  "is_independent_set E V \<longleftrightarrow> is_vertex_cover E ((\<Union>E) - V)" if "ugraph E"
  using that unfolding is_independent_set_def is_vertex_cover_def
proof safe
  fix e
  assume A: "ugraph E" "\<forall>u\<in>V. \<forall>v\<in>V. {u, v} \<notin> E" "e \<in> E"
  then obtain u v where "e = {u, v}"
    unfolding ugraph_def by (metis card_eq_SucD numeral_2_eq_2)
  with A(2,3) consider "u \<notin> V" "v \<notin> V" | "u \<in> V" "v \<in> \<Union> E - V" | "v \<in> V" "u \<in> \<Union> E - V"
    by auto
  then show "\<exists>v\<in>\<Union> E - V. v \<in> e"
    using \<open>e \<in> E\<close> unfolding \<open>e = _\<close> by cases auto
next
  fix u v
  assume "\<forall>e\<in>E. \<exists>v\<in>\<Union> E - V. v \<in> e" "u \<in> V" "v \<in> V" "{u, v} \<in> E"
  then show False
    by force
qed

lemma ugraph_vertex_set_finite:
  assumes "ugraph E"
  shows "finite (\<Union>E)"
  using assms by (auto 4 3 intro: card_ge_0_finite simp: ugraph_def)

subsection \<open>Independent Set to Set Cover\<close>
theorem is_reduction_is_vc:
  "is_reduction is_vc independent_set vertex_cover"
  unfolding is_reduction_def is_vc_def independent_set_def vertex_cover_def
proof (simp add: is_independent_set_is_vertex_cover , safe)
  show False if "card (\<Union> E) < k" "ugraph E" "k \<le> card V" "V \<subseteq> \<Union> E" for E k and V :: "'a set"
    using that by (auto 4 4 intro: card_ge_0_finite simp: ugraph_def dest: card_mono[rotated])
next
  show "\<exists>V. V \<subseteq> \<Union> E \<and> card V \<le> card (\<Union> E) - k \<and> is_vertex_cover E V"
    if "ugraph E" "V \<subseteq> \<Union> E" "k \<le> card V" "is_independent_set E V" for E k and V :: "'a set"
    using that
    by (subst (asm) is_independent_set_is_vertex_cover, (simp; fail))
      (intro exI conjI,
        auto simp: card_Diff_subset[OF finite_subset] dest: ugraph_vertex_set_finite)
next
  fix E :: "'a set set" and k :: nat and V :: "'a set"
  assume A: "\<not> card (\<Union>E) < k" "ugraph E" "V \<subseteq> \<Union> E" "card V \<le> card (\<Union>E) - k" "is_vertex_cover E V"
  then have "\<Union> E - (\<Union> E - V) = V"
    by auto
  with A show "\<exists>V. V \<subseteq> \<Union> E \<and> k \<le> card V \<and> is_independent_set E V"
    by (auto simp: is_independent_set_is_vertex_cover card_Diff_subset[OF finite_subset]
        dest: ugraph_vertex_set_finite intro!: exI[where x = "\<Union> E - V"])
qed

subsection \<open>Three Sat to Independent Set\<close>

definition
  "conflict l1 l2 \<equiv> \<exists>a. l1 = Pos a \<and> l2 = Neg a \<or> l1 = Neg a \<and> l2 = Pos a"

definition
  "sat_is F \<equiv> if (\<forall>cls \<in> set F. card cls = 3) then (
    {{(l1, i), (l2, i)} | l1 l2 i. i < length F \<and> l1 \<in> F ! i \<and> l2 \<in> F ! i \<and> l1 \<noteq> l2}
  \<union> {{(l1, i), (l2, j)} | l1 l2 i j.
      i < length F \<and> j < length F \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j \<and> conflict l1 l2}, length F)
  else ({}, 1)"

lemma conflict_models_ccontr:
  assumes "(\<sigma>\<up>) x" "(\<sigma>\<up>) y" "conflict x y"
  shows "False"
  using assms unfolding conflict_def lift_def by auto

lemma conflict_same[simp]:
  "conflict l l \<longleftrightarrow> False"
  unfolding conflict_def by simp

theorem is_reduction_sat_is:
  "is_reduction sat_is three_cnf_sat independent_set"
  unfolding is_reduction_def
proof safe
  fix F :: "'a lit set list"
  assume "F \<in> three_cnf_sat"
  then obtain \<sigma> where "\<sigma> \<Turnstile> F"
    unfolding three_cnf_sat_def sat_def by auto
  from \<open>F \<in> _\<close> have fin_1: "finite (\<Union> (set F))"
    unfolding three_cnf_sat_def by (auto 4 3 intro: card_ge_0_finite)
  let ?m = "length F"
  let ?l = "\<lambda>i. SOME l. (\<sigma>\<up>) l \<and> l \<in> F ! i"
  define V where "V \<equiv> {(?l i, i) | i. i < ?m}"
  have select: "(\<sigma>\<up>) (?l i) \<and> (?l i) \<in> F ! i" if "i < length F" for i
    using \<open>\<sigma> \<Turnstile> F\<close> that unfolding models_def by - (rule someI_ex, auto)
  { fix l i assume "l \<in> F ! i" "i < length F"
    have "card (F ! i) = 3"
      using \<open>F \<in> _\<close> \<open>i < _\<close> unfolding three_cnf_sat_def by auto
    with \<open>l \<in> _\<close> consider l' where "l \<noteq> l'" "l' \<in> F ! i"
      unfolding numeral_3_eq_3 by (force dest: card_eq_SucD)
  } note pair = this
  obtain E k where "sat_is F = (E, k)"
    by force
  let ?S = "((\<Union> (set F)) \<times> {0..<length F}) \<times> ((\<Union> (set F)) \<times> {0..<length F})"
  from \<open>F \<in> _\<close> have wf: "\<forall>cls \<in> set F. card cls = 3"
    unfolding three_cnf_sat_def by auto
  with \<open>sat_is F = _\<close> have "length F = k"
    unfolding sat_is_def by simp
  have "card V = length F"
    unfolding V_def setcompr_eq_image by (subst card_image) (auto intro: inj_onI)
  moreover have "is_independent_set E V"
    using \<open>sat_is F = (E, k)\<close> wf unfolding sat_is_def is_independent_set_def V_def
    by (auto intro: conflict_models_ccontr dest: select simp: doubleton_eq_iff)
  moreover have "ugraph E"
    using \<open>sat_is F = (E, k)\<close> wf unfolding sat_is_def is_independent_set_def ugraph_def
    apply safe
    subgoal
      using fin_1 by (fastforce intro: finite_surj[where A = "?S"])
    by (force simp: card_insert_if)+
  moreover have "V \<subseteq> \<Union> E"
    using \<open>sat_is F = (E, k)\<close> wf unfolding V_def sat_is_def is_independent_set_def ugraph_def
    apply simp
    apply (elim conjE)
    apply (drule sym)
    apply simp
    apply (rule subsetI)
    apply (rule UnI1)
    apply clarsimp
    apply (frule select)
    apply (rule pair)
    apply auto
    done
  ultimately show "sat_is F \<in> independent_set"
    unfolding independent_set_def by (auto simp: \<open>sat_is _ = _\<close> \<open>length F = _\<close>)
next
  fix F :: "'a lit set list"
  assume "sat_is F \<in> independent_set"
  obtain E k where "sat_is F = (E, k)"
    by force
  show "F \<in> three_cnf_sat"
  proof (cases "\<forall>cls \<in> set F. card cls = 3")
    case wf: True
    with \<open>sat_is F = _\<close> have "length F = k"
      unfolding sat_is_def by simp
    from \<open>sat_is F \<in> _\<close> obtain V where V:
      "ugraph E" "V \<subseteq> \<Union> E" "card V \<ge> k" "is_independent_set E V"
      unfolding independent_set_def \<open>sat_is _ = _\<close> by auto
    define \<sigma> where "\<sigma> \<equiv> \<lambda>x. (\<exists>i. (Pos x, i) \<in> V)"
    have V_inj: "l = l'" if "(l, i) \<in> V" "(l', i) \<in> V" for l l' i
    proof (rule ccontr)
      from that V(2) have "i < length F"
        using \<open>sat_is _ = _\<close> wf unfolding sat_is_def by auto
      from that V(2) have "l \<in> F ! i" "l' \<in> F ! i"
        using \<open>sat_is _ = _\<close> wf unfolding sat_is_def by fastforce+
      assume "l \<noteq> l'"
      with \<open>l \<in> _\<close> \<open>l' \<in> _\<close> \<open>i < _\<close> have "{(l, i), (l', i)} \<in> E"
        using \<open>sat_is _ = _\<close> wf unfolding sat_is_def by auto
      with V(4) that show False
        unfolding is_independent_set_def by auto
    qed
    have 1: "i < length F \<and> l \<in> F ! i" if "(l, i) \<in> V" for l i
      using that V(2) using \<open>sat_is _ = _\<close> wf unfolding sat_is_def by auto
    then have V_sub: "V \<subseteq> (\<lambda>i. (SOME l. (l, i) \<in> V, i)) ` {0..<length F}"
      by (auto 4 3 intro: someI V_inj)
    have 2: "\<exists>l. (l, i) \<in> V" if "i < length F" for i
    proof (rule ccontr)
      assume "\<nexists>l. (l, i) \<in> V"
      with that V_sub have "V \<subset> (\<lambda>i. (SOME l. (l, i) \<in> V, i)) ` {0..<length F}"
        by fastforce
      then have "card V < length F"
        apply -
        apply (drule psubset_card_mono[rotated])
        using card_image_le[of "{0..<length F}" "\<lambda>i. (SOME l. (l, i) \<in> V, i)"]
        by auto
      with \<open>card V \<ge> _\<close> \<open>length F = _\<close> show False
        by simp
    qed
    have no_conflict: False if "(l, i) \<in> V" "(l', j) \<in> V" "conflict l l'" for l l' i j
      using \<open>sat_is F = (E, k)\<close> that unfolding sat_is_def
      by (simp add: wf) (smt 1 UnCI V(4) is_independent_set_def mem_Collect_eq prod.sel(1))
    have "\<exists>l\<in>cls. (\<sigma>\<up>) l" if "cls \<in> set F" for cls
    proof -
      from that obtain i where "F ! i = cls" "i < length F"
        by (meson in_set_conv_nth)
      then obtain l where "(l, i) \<in> V"
        by (blast dest: 2)
      then have "(\<sigma>\<up>) l"
        unfolding \<sigma>_def lift_def by (cases l) (auto simp: conflict_def dest: no_conflict)
      moreover from \<open>_ \<in> V\<close> have "l \<in> cls"
        using \<open>F ! i = _\<close> by (auto dest: 1)
      ultimately show ?thesis
        by auto
    qed
    then have "\<sigma> \<Turnstile> F"
      unfolding models_def by auto
    with wf show "F \<in> three_cnf_sat"
      unfolding three_cnf_sat_def by (auto simp: sat_def)
  next
    case False
    with \<open>sat_is F \<in> _\<close> show "F \<in> three_cnf_sat"
      unfolding sat_is_def independent_set_def by simp
  qed
qed

subsection \<open>Vertex Cover to Set Cover\<close>
theorem is_reduction_vc_sc:
  "is_reduction vc_sc vertex_cover set_cover"
  unfolding is_reduction_def vc_sc_def vertex_cover_def set_cover_def
  apply clarsimp
  apply safe
  subgoal for E k V
    apply (rule exI[where x = "{{e \<in> E. v \<in> e} |v. v \<in> V}"])
    apply (intro conjI)
    subgoal
      by fastforce
    subgoal
      apply safe
      subgoal for e _ v
        by auto
      subgoal for e _ v e'
        unfolding is_vertex_cover_def by simp (metis mem_Collect_eq)
      done
    subgoal
      unfolding setcompr_eq_image
      by (rule order.trans, rule card_image_le) (auto dest: ugraph_vertex_set_finite finite_subset)
    done
  subgoal premises prems for E k S
  proof -
    define vv where "vv \<equiv> \<lambda>X. SOME v. X = {e \<in> E. v \<in> e}"
    let ?S = "vv ` S"
    have *: "{e \<in> E. v \<in> e} = {e \<in> E. vv {e \<in> E. v \<in> e} \<in> e}" for v
      unfolding vv_def by (rule someI) auto
    then have "vv {e \<in> E. v \<in> e} \<in> \<Union>E" if "{e \<in> E. v \<in> e} \<noteq> {}" for v
      using that by auto
    then have 1: "vv X \<in> \<Union>E" if "X \<in> S" for X
      using \<open>S \<subseteq> _\<close> that by blast
    from \<open>ugraph _\<close> have "finite E"
      unfolding ugraph_def by auto
    moreover have "S \<subseteq> Pow E"
      by (rule order.trans, rule prems) auto
    ultimately have "finite S"
      using \<open>finite E\<close> finite_subset by auto
    have "is_vertex_cover E ?S"
      unfolding is_vertex_cover_def
    proof safe
      fix e :: "'a set" assume "e \<in> E"
      from \<open>e \<in> E\<close> \<open>ugraph E\<close> have "card e = 2"
        unfolding ugraph_def by auto
      then obtain v where "v \<in> e"
        by force
      with \<open>\<Union> S = _\<close> \<open>e \<in> E\<close> have "e \<in> \<Union> S"
        by auto
      with \<open>S \<subseteq> {_ | _. _}\<close> obtain v where "{e \<in> E. v \<in> e} \<in> S" "v \<in> e"
        by auto
      with *[of v] \<open>e \<in> E\<close> show "\<exists>v\<in>vv ` S. v \<in> e"
        by auto
    qed
    have "?S \<subseteq> \<Union> E"
      by (auto dest: 1)
    moreover have "card ?S \<le> k"
      using \<open>card S \<le> _\<close> \<open>finite S\<close> by (auto intro: card_image_le order.trans)
    moreover have "is_vertex_cover E ?S"
      using prems
      unfolding is_vertex_cover_def
      apply auto
      subgoal premises prems for e
      proof -
        from \<open>e \<in> E\<close> \<open>ugraph E\<close> have "card e = 2"
          unfolding ugraph_def by auto
        then obtain v where "v \<in> e"
          by force
        with \<open>\<Union> S = _\<close> \<open>e \<in> E\<close> have "e \<in> \<Union> S"
          by auto
        with \<open>S \<subseteq> {_ | _. _}\<close> obtain v where "{e \<in> E. v \<in> e} \<in> S" "v \<in> e"
          by auto
        with *[of v] \<open>e \<in> E\<close> show ?thesis
          by auto
      qed
      done
    ultimately show ?thesis
      by auto
  qed
  by (simp add: finite_subset)+

theorem sat_sc:
  "is_reduction (vc_sc o is_vc o sat_is) three_cnf_sat set_cover"
  by (rule is_reduction_trans is_reduction_sat_is is_reduction_is_vc is_reduction_vc_sc)+

end


theory Name
imports Main
begin

text \<open>
  I would like to model names as @{typ string}s. Unfortunately, there is no default order on lists,
  as there could be multiple reasonable implementations: e.g.\ lexicographic and point-wise.
  For both choices, users can import the corresponding instantiation.

  In Isabelle, only at most one implementation of a given type class for a given type may be present
  in the same theory. Consequently, I avoided importing a list ordering from the library, because it
  may cause conflicts with users who use another ordering. The general approach for these situations
  is to introduce a type copy.

  The full flexibility of strings (i.e.\ string manipulations) is only required where fresh names
  are being produced. Otherwise, only a linear order on terms is needed. Conveniently, Sternagel and
  Thiemann @{cite sternagel2015deriving} provide tooling to automatically generate such a
  lexicographic order.
\<close>

datatype name = Name (as_string: string)

\<comment> \<open>Mostly copied from \<open>List_Lexorder\<close>\<close>

instantiation name :: ord
begin

definition less_name where
"xs < ys \<longleftrightarrow> (as_string xs, as_string ys) \<in> lexord {(u, v). (of_char u :: nat) < of_char v}"

definition less_eq_name where
"(xs :: name) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance name :: order
proof
  fix xs :: "name"
  show "xs \<le> xs" by (simp add: less_eq_name_def)
next
  fix xs ys zs :: "name"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: less_eq_name_def less_name_def)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "name"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: less_eq_name_def less_name_def)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "name"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: less_name_def less_eq_name_def)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance name :: linorder
proof
  fix xs ys :: "name"
  have "(as_string xs, as_string ys) \<in> lexord {(u, v). (of_char u::nat) < of_char v} \<or> xs = ys \<or> (as_string ys, as_string xs) \<in> lexord {(u, v). (of_char u::nat) < of_char v}"
    by (metis (no_types, lifting) case_prodI lexord_linear linorder_neqE_nat mem_Collect_eq name.expand of_char_eq_iff)
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: less_eq_name_def less_name_def)
qed

lemma less_name_code[code]:
  "Name xs < Name [] \<longleftrightarrow> False"
  "Name [] < Name (x # xs) \<longleftrightarrow> True"
  "Name (x # xs) < Name (y # ys) \<longleftrightarrow> (of_char x::nat) < of_char y \<or> x = y \<and> Name xs < Name ys"
unfolding less_name_def by auto

lemma le_name_code[code]:
  "Name (x # xs) \<le> Name [] \<longleftrightarrow> False"
  "Name [] \<le> Name (x # xs) \<longleftrightarrow> True"
  "Name (x # xs) \<le> Name (y # ys) \<longleftrightarrow> (of_char x::nat) < of_char y \<or> x = y \<and> Name xs \<le> Name ys"
unfolding less_eq_name_def less_name_def by auto

context begin

qualified definition append :: "name \<Rightarrow> name \<Rightarrow> name" where
"append v1 v2 = Name (as_string v1 @ as_string v2)"

lemma name_append_less:
  assumes "xs \<noteq> Name []"
  shows "append ys xs > ys"
proof -
  have "Name (ys @ xs) > Name ys" if "xs \<noteq> []" for xs ys
    using that
    proof (induction ys)
      case Nil
      thus ?case
        unfolding less_name_def
        by (cases xs) auto
    next
      case (Cons y ys)
      thus ?case
        unfolding less_name_def
        by auto
    qed
  with assms show ?thesis
    unfolding append_def
    by (cases xs, cases ys) auto
qed

end

end


(*  Title:      ZF/AC/AC18_AC19.thy
    Author:     Krzysztof Grabczewski

The proof of AC1 \<Longrightarrow> AC18 \<Longrightarrow> AC19 \<Longrightarrow> AC1
*)

theory AC18_AC19
imports AC_Equiv
begin

definition
  uu    :: "i \<Rightarrow> i" where
    "uu(a) \<equiv> {c \<union> {0}. c \<in> a}"

(* ********************************************************************** *)
(* AC1 \<Longrightarrow> AC18                                                           *)
(* ********************************************************************** *)

lemma PROD_subsets:
     "\<lbrakk>f \<in> (\<Prod>b \<in> {P(a). a \<in> A}. b);  \<forall>a \<in> A. P(a)<=Q(a)\<rbrakk>
      \<Longrightarrow> (\<lambda>a \<in> A. f`P(a)) \<in> (\<Prod>a \<in> A. Q(a))"
by (rule lam_type, drule apply_type, auto)

lemma lemma_AC18:
     "\<lbrakk>\<forall>A. 0 \<notin> A \<longrightarrow> (\<exists>f. f \<in> (\<Prod>X \<in> A. X)); A \<noteq> 0\<rbrakk>
      \<Longrightarrow> (\<Inter>a \<in> A. \<Union>b \<in> B(a). X(a, b)) \<subseteq>
          (\<Union>f \<in> \<Prod>a \<in> A. B(a). \<Inter>a \<in> A. X(a, f`a))"
apply (rule subsetI)
apply (erule_tac x = "{{b \<in> B (a) . x \<in> X (a,b) }. a \<in> A}" in allE)
apply (erule impE, fast)
apply (erule exE)
apply (rule UN_I)
 apply (fast elim!: PROD_subsets)
apply (simp, fast elim!: not_emptyE dest: apply_type [OF _ RepFunI])
done

lemma AC1_AC18: "AC1 \<Longrightarrow> PROP AC18"
  unfolding AC1_def
apply (rule AC18.intro)
apply (fast elim!: lemma_AC18 apply_type intro!: equalityI INT_I UN_I)
done

(* ********************************************************************** *)
(* AC18 \<Longrightarrow> AC19                                                          *)
(* ********************************************************************** *)

theorem (in AC18) AC19
  unfolding AC19_def
apply (intro allI impI)
apply (rule AC18 [of _ "\<lambda>x. x", THEN mp], blast)
done

(* ********************************************************************** *)
(* AC19 \<Longrightarrow> AC1                                                           *)
(* ********************************************************************** *)

lemma RepRep_conj:
        "\<lbrakk>A \<noteq> 0; 0 \<notin> A\<rbrakk> \<Longrightarrow> {uu(a). a \<in> A} \<noteq> 0 \<and> 0 \<notin> {uu(a). a \<in> A}"
apply (unfold uu_def, auto)
apply (blast dest!: sym [THEN RepFun_eq_0_iff [THEN iffD1]])
done

lemma lemma1_1: "\<lbrakk>c \<in> a; x = c \<union> {0}; x \<notin> a\<rbrakk> \<Longrightarrow> x - {0} \<in> a"
apply clarify
apply (rule subst_elem, assumption)
apply (fast elim: notE subst_elem)
done

lemma lemma1_2:
        "\<lbrakk>f`(uu(a)) \<notin> a; f \<in> (\<Prod>B \<in> {uu(a). a \<in> A}. B); a \<in> A\<rbrakk>
                \<Longrightarrow> f`(uu(a))-{0} \<in> a"
apply (unfold uu_def, fast elim!: lemma1_1 dest!: apply_type)
done

lemma lemma1: "\<exists>f. f \<in> (\<Prod>B \<in> {uu(a). a \<in> A}. B) \<Longrightarrow> \<exists>f. f \<in> (\<Prod>B \<in> A. B)"
apply (erule exE)
apply (rule_tac x = "\<lambda>a\<in>A. if (f` (uu(a)) \<in> a, f` (uu(a)), f` (uu(a))-{0})"
       in exI)
apply (rule lam_type)
apply (simp add: lemma1_2)
done

lemma lemma2_1: "a\<noteq>0 \<Longrightarrow> 0 \<in> (\<Union>b \<in> uu(a). b)"
by (unfold uu_def, auto)

lemma lemma2: "\<lbrakk>A\<noteq>0; 0\<notin>A\<rbrakk> \<Longrightarrow> (\<Inter>x \<in> {uu(a). a \<in> A}. \<Union>b \<in> x. b) \<noteq> 0"
apply (erule not_emptyE)
apply (rule_tac a = 0 in not_emptyI)
apply (fast intro!: lemma2_1)
done

lemma AC19_AC1: "AC19 \<Longrightarrow> AC1"
apply (unfold AC19_def AC1_def, clarify)
apply (case_tac "A=0", force)
apply (erule_tac x = "{uu (a) . a \<in> A}" in allE)
apply (erule impE)
apply (erule RepRep_conj, assumption)
apply (rule lemma1)
apply (drule lemma2, assumption, auto)
done

end


(*  Title:      HOL/Algebra/Module.thy
    Author:     Clemens Ballarin, started 15 April 2003
    Copyright:  Clemens Ballarin
*)

theory Module
imports Ring
begin

section \<open>Modules over an Abelian Group\<close>

subsection \<open>Definitions\<close>

record ('a, 'b) module = "'b ring" +
  smult :: "['a, 'b] => 'b" (infixl "\<odot>\<index>" 70)

locale module = R?: cring + M?: abelian_group M for M (structure) +
  assumes smult_closed [simp, intro]:
      "[| a \<in> carrier R; x \<in> carrier M |] ==> a \<odot>\<^bsub>M\<^esub> x \<in> carrier M"
    and smult_l_distr:
      "[| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      (a \<oplus> b) \<odot>\<^bsub>M\<^esub> x = a \<odot>\<^bsub>M\<^esub> x \<oplus>\<^bsub>M\<^esub> b \<odot>\<^bsub>M\<^esub> x"
    and smult_r_distr:
      "[| a \<in> carrier R; x \<in> carrier M; y \<in> carrier M |] ==>
      a \<odot>\<^bsub>M\<^esub> (x \<oplus>\<^bsub>M\<^esub> y) = a \<odot>\<^bsub>M\<^esub> x \<oplus>\<^bsub>M\<^esub> a \<odot>\<^bsub>M\<^esub> y"
    and smult_assoc1:
      "[| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      (a \<otimes> b) \<odot>\<^bsub>M\<^esub> x = a \<odot>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x)"
    and smult_one [simp]:
      "x \<in> carrier M ==> \<one> \<odot>\<^bsub>M\<^esub> x = x"

locale algebra = module + cring M +
  assumes smult_assoc2:
      "[| a \<in> carrier R; x \<in> carrier M; y \<in> carrier M |] ==>
      (a \<odot>\<^bsub>M\<^esub> x) \<otimes>\<^bsub>M\<^esub> y = a \<odot>\<^bsub>M\<^esub> (x \<otimes>\<^bsub>M\<^esub> y)"

lemma moduleI:
  fixes R (structure) and M (structure)
  assumes cring: "cring R"
    and abelian_group: "abelian_group M"
    and smult_closed:
      "!!a x. [| a \<in> carrier R; x \<in> carrier M |] ==> a \<odot>\<^bsub>M\<^esub> x \<in> carrier M"
    and smult_l_distr:
      "!!a b x. [| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      (a \<oplus> b) \<odot>\<^bsub>M\<^esub> x = (a \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x)"
    and smult_r_distr:
      "!!a x y. [| a \<in> carrier R; x \<in> carrier M; y \<in> carrier M |] ==>
      a \<odot>\<^bsub>M\<^esub> (x \<oplus>\<^bsub>M\<^esub> y) = (a \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> (a \<odot>\<^bsub>M\<^esub> y)"
    and smult_assoc1:
      "!!a b x. [| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      (a \<otimes> b) \<odot>\<^bsub>M\<^esub> x = a \<odot>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x)"
    and smult_one:
      "!!x. x \<in> carrier M ==> \<one> \<odot>\<^bsub>M\<^esub> x = x"
  shows "module R M"
  by (auto intro: module.intro cring.axioms abelian_group.axioms
    module_axioms.intro assms)

lemma algebraI:
  fixes R (structure) and M (structure)
  assumes R_cring: "cring R"
    and M_cring: "cring M"
    and smult_closed:
      "!!a x. [| a \<in> carrier R; x \<in> carrier M |] ==> a \<odot>\<^bsub>M\<^esub> x \<in> carrier M"
    and smult_l_distr:
      "!!a b x. [| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      (a \<oplus> b) \<odot>\<^bsub>M\<^esub> x = (a \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x)"
    and smult_r_distr:
      "!!a x y. [| a \<in> carrier R; x \<in> carrier M; y \<in> carrier M |] ==>
      a \<odot>\<^bsub>M\<^esub> (x \<oplus>\<^bsub>M\<^esub> y) = (a \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> (a \<odot>\<^bsub>M\<^esub> y)"
    and smult_assoc1:
      "!!a b x. [| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      (a \<otimes> b) \<odot>\<^bsub>M\<^esub> x = a \<odot>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x)"
    and smult_one:
      "!!x. x \<in> carrier M ==> (one R) \<odot>\<^bsub>M\<^esub> x = x"
    and smult_assoc2:
      "!!a x y. [| a \<in> carrier R; x \<in> carrier M; y \<in> carrier M |] ==>
      (a \<odot>\<^bsub>M\<^esub> x) \<otimes>\<^bsub>M\<^esub> y = a \<odot>\<^bsub>M\<^esub> (x \<otimes>\<^bsub>M\<^esub> y)"
  shows "algebra R M"
apply intro_locales
apply (rule cring.axioms ring.axioms abelian_group.axioms comm_monoid.axioms assms)+
apply (rule module_axioms.intro)
 apply (simp add: smult_closed)
 apply (simp add: smult_l_distr)
 apply (simp add: smult_r_distr)
 apply (simp add: smult_assoc1)
 apply (simp add: smult_one)
apply (rule cring.axioms ring.axioms abelian_group.axioms comm_monoid.axioms assms)+
apply (rule algebra_axioms.intro)
 apply (simp add: smult_assoc2)
done

lemma (in algebra) R_cring:
  "cring R"
  ..

lemma (in algebra) M_cring:
  "cring M"
  ..

lemma (in algebra) module:
  "module R M"
  by (auto intro: moduleI R_cring is_abelian_group
    smult_l_distr smult_r_distr smult_assoc1)

subsection \<open>Basic Properties of Algebras\<close>

lemma (in algebra) smult_l_null [simp]:
  "x \<in> carrier M ==> \<zero> \<odot>\<^bsub>M\<^esub> x = \<zero>\<^bsub>M\<^esub>"
proof -
  assume M: "x \<in> carrier M"
  note facts = M smult_closed [OF R.zero_closed]
  from facts have "\<zero> \<odot>\<^bsub>M\<^esub> x = (\<zero> \<odot>\<^bsub>M\<^esub> x \<oplus>\<^bsub>M\<^esub> \<zero> \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub> (\<zero> \<odot>\<^bsub>M\<^esub> x)" by algebra
  also from M have "... = (\<zero> \<oplus> \<zero>) \<odot>\<^bsub>M\<^esub> x \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub> (\<zero> \<odot>\<^bsub>M\<^esub> x)"
    by (simp add: smult_l_distr del: R.l_zero R.r_zero)
  also from facts have "... = \<zero>\<^bsub>M\<^esub>" apply algebra apply algebra done
  finally show ?thesis .
qed

lemma (in algebra) smult_r_null [simp]:
  "a \<in> carrier R ==> a \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub> = \<zero>\<^bsub>M\<^esub>"
proof -
  assume R: "a \<in> carrier R"
  note facts = R smult_closed
  from facts have "a \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub> = (a \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub> \<oplus>\<^bsub>M\<^esub> a \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>) \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub> (a \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>)"
    by algebra
  also from R have "... = a \<odot>\<^bsub>M\<^esub> (\<zero>\<^bsub>M\<^esub> \<oplus>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>) \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub> (a \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>)"
    by (simp add: smult_r_distr del: M.l_zero M.r_zero)
  also from facts have "... = \<zero>\<^bsub>M\<^esub>" by algebra
  finally show ?thesis .
qed

lemma (in algebra) smult_l_minus:
  "[| a \<in> carrier R; x \<in> carrier M |] ==> (\<ominus>a) \<odot>\<^bsub>M\<^esub> x = \<ominus>\<^bsub>M\<^esub> (a \<odot>\<^bsub>M\<^esub> x)"
proof -
  assume RM: "a \<in> carrier R" "x \<in> carrier M"
  from RM have a_smult: "a \<odot>\<^bsub>M\<^esub> x \<in> carrier M" by simp
  from RM have ma_smult: "\<ominus>a \<odot>\<^bsub>M\<^esub> x \<in> carrier M" by simp
  note facts = RM a_smult ma_smult
  from facts have "(\<ominus>a) \<odot>\<^bsub>M\<^esub> x = (\<ominus>a \<odot>\<^bsub>M\<^esub> x \<oplus>\<^bsub>M\<^esub> a \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub>(a \<odot>\<^bsub>M\<^esub> x)"
    by algebra
  also from RM have "... = (\<ominus>a \<oplus> a) \<odot>\<^bsub>M\<^esub> x \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub>(a \<odot>\<^bsub>M\<^esub> x)"
    by (simp add: smult_l_distr)
  also from facts smult_l_null have "... = \<ominus>\<^bsub>M\<^esub>(a \<odot>\<^bsub>M\<^esub> x)"
    apply algebra apply algebra done
  finally show ?thesis .
qed

lemma (in algebra) smult_r_minus:
  "[| a \<in> carrier R; x \<in> carrier M |] ==> a \<odot>\<^bsub>M\<^esub> (\<ominus>\<^bsub>M\<^esub>x) = \<ominus>\<^bsub>M\<^esub> (a \<odot>\<^bsub>M\<^esub> x)"
proof -
  assume RM: "a \<in> carrier R" "x \<in> carrier M"
  note facts = RM smult_closed
  from facts have "a \<odot>\<^bsub>M\<^esub> (\<ominus>\<^bsub>M\<^esub>x) = (a \<odot>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub>x \<oplus>\<^bsub>M\<^esub> a \<odot>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub>(a \<odot>\<^bsub>M\<^esub> x)"
    by algebra
  also from RM have "... = a \<odot>\<^bsub>M\<^esub> (\<ominus>\<^bsub>M\<^esub>x \<oplus>\<^bsub>M\<^esub> x) \<oplus>\<^bsub>M\<^esub> \<ominus>\<^bsub>M\<^esub>(a \<odot>\<^bsub>M\<^esub> x)"
    by (simp add: smult_r_distr)
  also from facts smult_r_null have "... = \<ominus>\<^bsub>M\<^esub>(a \<odot>\<^bsub>M\<^esub> x)" by algebra
  finally show ?thesis .
qed

end


theory HEAP1CBJNewNoLemmas
imports HEAP1
begin

lemma lnew1: "disjoint s1 s2 \<Longrightarrow> disjoint (s1 - s3) (s2 \<union> s3)"
 by (metis Diff_disjoint Diff_triv Un_Diff_Int bot_eq_sup_iff disjoint_def inf_sup_distrib1)
(*by (metis Diff_Int2 Diff_Int_distrib2 Diff_cancel Int_Diff Int_Un_distrib disjoint_def sup_bot.left_neutral)*)

thm Diff_disjoint Diff_triv Un_Diff_Int bot_eq_sup_iff  inf_sup_distrib1
thm Diff_Int2 Diff_Int_distrib2 Diff_cancel Int_Diff Int_Un_distrib  sup_bot.left_neutral

theorem try1new: "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
apply (simp add: lnew1)
thm lnew1[of "locs f" "locs_of d s" "locs_of d s"]
  \<comment> \<open>fails because of commutativity is missing; we also need lemmas about locs and locs_of\<close>
oops

lemma lnew2: "disjoint s1 s2 \<Longrightarrow> disjoint s2 s1"
by (metis disjoint_def inf_commute)

theorem try2new: "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
apply (rule lnew2)
\<comment> \<open>need to make -\<triangleleft> into - and + into union\<close>
oops

lemma l_locs_dom_ar_iff:
  "nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> r \<in> dom f \<Longrightarrow> locs({r} -\<triangleleft> f) = locs f - locs_of r (the(f r))"
sorry

lemma l4: "nat1 n \<Longrightarrow> nat1 m \<Longrightarrow> locs_of d (n+m) = (locs_of d n) \<union> (locs_of (d+n) m)"
unfolding locs_of_def
  apply auto
  unfolding inv_VDMNat1_def
  by auto

theorem try3new: "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
apply (rule lnew2)
apply (simp add: l_locs_dom_ar_iff)
apply (simp add: l4 inv_VDMNat1_def)
thm l4[of s "the(f(d+s))" d]
 \<comment> \<open>fails because ISabelle doesn't know nat1'ness of the(f(d+s))\<close>
oops

lemma f_nat1_map_nat1_elem:
	"nat1_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> 0 < (the(f x))"
	unfolding nat1_map_def nat1_def inv_VDMNat1_def
  by auto

theorem try4new: "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
apply (rule lnew2)
apply (simp add: l_locs_dom_ar_iff)
apply (simp add: l4 f_nat1_map_nat1_elem inv_VDMNat1_def)
apply (rule lnew1)
apply (rule lnew2)
apply assumption
done

end


section\<open>Main ZF Theory: Everything Except AC\<close>

theory ZF imports List IntDiv CardinalArith begin

(*The theory of "iterates" logically belongs to Nat, but can't go there because
  primrec isn't available into after Datatype.*)

subsection\<open>Iteration of the function \<^term>\<open>F\<close>\<close>

consts  iterates :: "[i=>i,i,i] => i"   (\<open>(_^_ '(_'))\<close> [60,1000,1000] 60)

primrec
    "F^0 (x) = x"
    "F^(succ(n)) (x) = F(F^n (x))"

definition
  iterates_omega :: "[i=>i,i] => i" (\<open>(_^\<omega> '(_'))\<close> [60,1000] 60) where
    "F^\<omega> (x) == \<Union>n\<in>nat. F^n (x)"

lemma iterates_triv:
     "[| n\<in>nat;  F(x) = x |] ==> F^n (x) = x"
by (induct n rule: nat_induct, simp_all)

lemma iterates_type [TC]:
     "[| n \<in> nat;  a \<in> A; !!x. x \<in> A ==> F(x) \<in> A |]
      ==> F^n (a) \<in> A"
by (induct n rule: nat_induct, simp_all)

lemma iterates_omega_triv:
    "F(x) = x ==> F^\<omega> (x) = x"
by (simp add: iterates_omega_def iterates_triv)

lemma Ord_iterates [simp]:
     "[| n\<in>nat;  !!i. Ord(i) ==> Ord(F(i));  Ord(x) |]
      ==> Ord(F^n (x))"
by (induct n rule: nat_induct, simp_all)

lemma iterates_commute: "n \<in> nat ==> F(F^n (x)) = F^n (F(x))"
by (induct_tac n, simp_all)

subsection\<open>Transfinite Recursion\<close>

text\<open>Transfinite recursion for definitions based on the
    three cases of ordinals\<close>

definition
  transrec3 :: "[i, i, [i,i]=>i, [i,i]=>i] =>i" where
    "transrec3(k, a, b, c) ==
       transrec(k, \<lambda>x r.
         if x=0 then a
         else if Limit(x) then c(x, \<lambda>y\<in>x. r`y)
         else b(Arith.pred(x), r ` Arith.pred(x)))"

lemma transrec3_0 [simp]: "transrec3(0,a,b,c) = a"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_succ [simp]:
     "transrec3(succ(i),a,b,c) = b(i, transrec3(i,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_Limit:
     "Limit(i) ==>
      transrec3(i,a,b,c) = c(i, \<lambda>j\<in>i. transrec3(j,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], force)

declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

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_list_nat_PairEvens
imports "../../Test_Base"
begin

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

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

datatype Nat = Z | S "Nat"

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

fun pairs :: "'t list => (('t, 't) pair) list" where
"pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

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

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

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

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

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

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

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

theorem property0 :
  "((let eta :: Nat = length xs
     in ((let md :: Nat = imod eta (S (S Z))
          in (if
                ((case eta of
                    Z => Z
                    | S x => (if le eta Z then (case Z of S y => p Z) else S Z) =
                    (if le (S (S Z)) Z then (case Z of S z => minus Z (p Z)) else
                       (case Z of S x2 => p Z))) &
                   (md ~= Z))
                then
                minus md (S (S Z))
                else
                md)) =
           Z)) ==>
      ((map
          (% (x3 :: ('a, 'a) pair) => (case x3 of pair2 y2 z2 => y2))
          (pairs xs)) =
         (evens xs)))"
  oops

end


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

    Theory DaC_synthesis2.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 DaC_synthesis2
  imports Preliminaries
begin

text "To illustrate how the design tactic may work also without support for
      type constructor classes, this theory sets up the same synthesis rule
      but for another relator instance which enables two recursive calls of
      the synthesised function (e.g. the quicksort algorithm proceeds this way)."

datatype ('u, 'a) Relt = Empty | Dcmp 'u 'a 'a

definition Relt :: "'a \<rightarrow> 'b \<Rightarrow> ('v, 'a) Relt \<rightarrow> ('v, 'b) Relt"
  where  "Relt r = {(Empty, Empty)} \<union>
                    {(Dcmp x A A', Dcmp x B B') |x A B A' B'. (A, B) \<in> r \<and> (A', B') \<in> r}"

subsection "The relator axioms"

lemma Relt_mono:
  "mono Relt"
  unfolding Relt_def
  by(rule monoI, fast)

lemma Relt_comp:
  "Relt r \<diamondop> Relt s = Relt (r \<diamondop> s)"
  unfolding Relt_def
  by(rule equalityI, blast+)

lemma Relt_Id:
  "Relt Id = Id"
  unfolding Relt_def
  by (clarsimp, rule set_eqI, smt (verit, best) IdE IdI Relt.exhaust insert_iff mem_Collect_eq)

lemma Relt_conv:
"(Relt r)\<^sup>\<circ> \<subseteq> Relt (r\<^sup>\<circ>)"
  unfolding Relt_def
  by blast

subsection "Derived properties"

lemma Relt_conv_eq :
"(Relt r)\<^sup>\<circ> = Relt (r\<^sup>\<circ>)"
  by (metis Relt_conv converse_converse converse_subset_swap subset_antisym)

lemma Relt_simple :
"simple r \<Longrightarrow> simple(Relt r)"
  by (metis (no_types, opaque_lifting) Relt_Id Relt_comp Relt_conv_eq Relt_mono monoD simple_def)

lemma Relt_entire :
"entire r \<Longrightarrow> entire(Relt r)"
  by (metis Relt_Id Relt_comp Relt_conv_eq Relt_mono entire_def monoE)

lemma Relt_graph_of :
"\<exists>g. Relt(graph_of f) = graph_of g"
  apply(subgoal_tac "simple (graph_of f)")
  apply(subgoal_tac "entire (graph_of f)")
  apply (simp add: Relt_entire Relt_simple mapping)
  by(simp add: graph_of_def simple_def entire_def, fast)+

subsubsection "The induced endofunctor"

definition
  "ReltF f = funct_of(Relt (graph_of f))"

lemma ReltF_eqs :
"ReltF f Empty = Empty"
"ReltF f (Dcmp x u v) = Dcmp x (f u) (f v)"
  by(simp add: ReltF_def Relt_def funct_of_def graph_of_def)+

lemma ReltF :
"Relt(graph_of f) = graph_of(ReltF f)"
  by (metis ReltF_def Relt_graph_of graph_of_funct_of)

text "the functor axioms:"

lemma ReltF1 :
"ReltF id = id"
  by (metis ReltF_def Relt_Id graph_of_funct_of graph_of_id)

lemma ReltF2 :
  "ReltF (g \<circ> f) = ReltF g \<circ> ReltF f"
  by (metis ReltF Relt_comp graph_of_comp graph_of_funct_of)

section "The divide-and-conquer synthesis for the above relator"

text "Note that we actually just copy-and-paste the respective section
      from the theory DaC-synthesis.thy"

definition
"DaC_scheme decompose compose = (\<lambda>r. decompose \<diamondop> Relt r \<diamondop> compose)"

lemma DaC_mono :
"decompose \<subseteq> decompose' \<Longrightarrow> compose \<subseteq> compose' \<Longrightarrow> r \<subseteq> r' \<Longrightarrow>
 DaC_scheme decompose compose r \<subseteq> DaC_scheme decompose' compose' r'"
  apply(simp add: DaC_scheme_def, erule relcomp_mono, erule relcomp_mono[rotated 1])
  by(rule monoD[OF Relt_mono])

locale DaC_synthesis =
  fixes \<alpha>\<^sub>1 :: "'a \<rightarrow> 'b"
    and \<alpha>\<^sub>2 :: "'c \<rightarrow> 'd"
  and spec :: "'b \<rightarrow> 'd"
  and abs_dcmp :: "'b \<rightarrow> ('x, 'b) Relt"
  and abs_cmp  :: "('x, 'd) Relt \<rightarrow> 'd"
  and dcmp     :: "'a \<Rightarrow> ('x, 'a) Relt"
  and cmp      :: "('x, 'c) Relt \<Rightarrow> 'c"
assumes
  DaC : "DaC_scheme abs_dcmp abs_cmp spec \<subseteq> spec"
and
  decomp : "\<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> (graph_of dcmp) \<subseteq> abs_dcmp \<diamondop> Relt (\<alpha>\<^sub>1\<^sup>\<circ>)"
and
  comp   : "(graph_of cmp) \<diamondop> \<alpha>\<^sub>2 \<subseteq> Relt \<alpha>\<^sub>2 \<diamondop> abs_cmp"
and
  reduct : "Id \<subseteq> lfp(\<lambda>x. monotypeF (graph_of dcmp) (Relt x))"
begin

lemma DaC_simple :
"simple d \<Longrightarrow> simple c \<Longrightarrow> simple (lfp (DaC_scheme d c))"
  apply(simp add: simple_def)
  apply(subst rdiv_univ)
  apply(rule lfp_lowerbound)
  apply(subst rdiv_univ[THEN sym])
  apply(subst lfp_unfold)
   apply(rule monoI, rule DaC_mono, rule subset_refl, rule subset_refl, assumption)
  apply(simp add: DaC_scheme_def)
  apply(fold DaC_scheme_def)
  apply(subst converse_relcomp)+
  apply(subst Relt_conv_eq)
  apply(subst O_assoc)+
  apply(rule subset_trans)
   apply(rule relcomp_mono[rotated 1])
    apply(rule relcomp_mono[rotated 1])
     apply(subst O_assoc[THEN sym])+
     apply(rule relcomp_mono)
      apply(erule relcomp_mono)
      apply(rule subset_refl)+
  apply simp
  apply(rule subset_trans)
   apply(rule relcomp_mono[rotated 1])
    apply(subst O_assoc[THEN sym])
    apply(rule relcomp_mono)
     apply(subst Relt_comp)
     apply(rule monoD[OF Relt_mono])
     apply(rule rdiv_univ[THEN iffD2])
     apply(rule subset_refl)+
  apply(subst Relt_Id)
  by simp

lemma DaC_entire :
"entire c \<Longrightarrow> entire(lfp(DaC_scheme (graph_of dcmp) c))"
  apply(simp add: entire_def)
  apply(rule subset_trans, rule reduct)
  apply(rule_tac H="\<lambda>x. x \<diamondop> x\<^sup>\<circ>" in lfp_fusion)
  apply(rule monoI, rule DaC_mono, simp+)
  apply(rule allI)
  apply(subgoal_tac "monotypeF (graph_of dcmp) (Relt (x \<diamondop> x\<^sup>\<circ>)) \<subseteq>
                    (monotypeF (graph_of dcmp) (Relt (x \<diamondop> x\<^sup>\<circ>)) \<diamondop> (graph_of dcmp)) \<diamondop> (graph_of dcmp)\<^sup>\<circ>")
   apply(erule subset_trans)
   apply(rule subset_trans)
    apply(rule relcomp_mono)
     apply(rule monotypeF1)
    apply(rule subset_refl)
   apply(subst Relt_comp[THEN sym])
   apply(simp add: DaC_scheme_def)
   apply(subst converse_relcomp)+
   apply(subst Relt_conv_eq)
   apply(subst O_assoc)+
   apply(rule relcomp_mono, rule subset_refl)+
   apply(rule subset_trans[rotated 1])
    apply(subst O_assoc[THEN sym])+
    apply(rule relcomp_mono)
     apply(erule relcomp_mono)
     apply(rule subset_refl)+
   apply simp
  apply(subst O_assoc)+
  apply(rule subset_trans[rotated 1])
   apply(rule_tac s'=Id in relcomp_mono)
    apply(rule subset_refl)
   apply(clarsimp simp: graph_of_def, fast)
  by simp

lemma DaC_impl :
"\<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) \<diamondop> \<alpha>\<^sub>2 \<subseteq> spec"
  apply(subst O_assoc[THEN sym])
  apply(subst ldiv_univ)
  apply(subst rdiv_univ)
  apply(rule lfp_lowerbound)
  apply(subst rdiv_univ[THEN sym])
  apply(subst ldiv_univ[THEN sym])
  apply(simp add: DaC_scheme_def)
  apply(rule subset_trans[rotated 1])
   apply(rule DaC)
  apply(subst O_assoc[THEN sym])+
  apply(rule subset_trans)
   apply(rule relcomp_mono)
    apply(rule relcomp_mono)
     apply(rule relcomp_mono)
      apply(rule decomp)
     apply(rule subset_refl)+
  apply(subst O_assoc)+
  apply(rule subset_trans)
   apply(rule relcomp_mono[rotated 1])
    apply(rule relcomp_mono[rotated 1])
     apply(rule relcomp_mono[rotated 1])
      apply(rule comp)
     apply(rule subset_refl)+
  apply(simp add: DaC_scheme_def)
  apply(rule relcomp_mono, rule subset_refl)
  apply(subst O_assoc[THEN sym])+
  apply(subst Relt_comp)+
  apply(rule relcomp_mono[rotated 1], rule subset_refl)
  apply(rule monoD[OF Relt_mono])
  apply(rule subset_trans)
   apply(rule relcomp_mono)
    apply(rule rdiv_univ[THEN iffD2])
    apply(rule subset_refl)+
  apply(rule ldiv_univ[THEN iffD2])
  by(rule subset_refl)

theorem DaC_synthesis :
"\<exists>\<phi>. lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of \<phi> \<and>
     \<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> graph_of \<phi> \<diamondop> \<alpha>\<^sub>2 \<subseteq> spec"
  apply(subgoal_tac "\<exists>\<phi>. lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of \<phi>")
   apply clarify
   apply(rule exI, rule conjI, assumption)
   apply(erule subst)
   apply(rule DaC_impl)
  apply(rule mapping)
   apply(rule DaC_simple)
    apply(clarsimp simp: simple_def graph_of_def)
   apply(clarsimp simp: simple_def graph_of_def)
  apply(rule DaC_entire)
  apply(clarsimp simp: entire_def graph_of_def)
  by fast

definition "dac = (THE \<phi>. lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of \<phi>)"

lemma dac_unq :
"lfp (DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of f \<Longrightarrow> f = dac"
  by (smt (verit, ccfv_threshold) dac_def graph_of_funct_of the_equality)

lemma dac_lfp :
"graph_of dac = lfp(DaC_scheme (graph_of dcmp) (graph_of cmp))"
  using DaC_synthesis dac_unq by fastforce

lemma dac_unfold' :
"graph_of dac = (graph_of dcmp) \<diamondop> Relt(graph_of dac) \<diamondop> (graph_of cmp)"
proof -
  have "graph_of dac = lfp (DaC_scheme (graph_of dcmp) (graph_of cmp))" (is "?l = ?r")
    by (simp add: dac_lfp)
  also have "... = DaC_scheme (graph_of dcmp) (graph_of cmp) ?r"
    by(rule lfp_unfold, rule monoI, rule DaC_mono, simp+)
  also have "... = DaC_scheme (graph_of dcmp) (graph_of cmp) ?l"
    by (simp add: dac_lfp)
  finally show ?thesis by(simp add: DaC_scheme_def)
qed

lemma dac_unq_function' :
"(graph_of dcmp) \<diamondop> Relt(graph_of f) \<diamondop> (graph_of cmp) \<subseteq> graph_of f \<Longrightarrow> dac = f"
  by (simp add: DaC_scheme_def dac_lfp graph_of_sub lfp_lowerbound)

lemma dac_unfold :
"dac = cmp \<circ> ReltF dac \<circ> dcmp"
  by (metis ReltF dac_lfp dac_unfold' dac_unq graph_of_comp)

lemma dac_unq_function :
"f = cmp \<circ> ReltF f \<circ> dcmp \<Longrightarrow> f = dac"
  by (metis ReltF dac_unq_function' graph_of_comp subset_refl)

lemma dac_impl :
"\<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> (graph_of dac) \<diamondop> \<alpha>\<^sub>2 \<subseteq> spec"
  by (simp add: DaC_impl dac_lfp)

end  (* the synthesis tactic *)

end


(*  Title:      ZF/Induct/Ntree.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Datatype definition n-ary branching trees\<close>

theory Ntree imports ZF begin

text \<open>
  Demonstrates a simple use of function space in a datatype
  definition.  Based upon theory \<open>Term\<close>.
\<close>

consts
  ntree :: "i => i"
  maptree :: "i => i"
  maptree2 :: "[i, i] => i"

datatype "ntree(A)" = Branch ("a \<in> A", "h \<in> (\<Union>n \<in> nat. n -> ntree(A))")
  monos UN_mono [OF subset_refl Pi_mono]  \<comment> \<open>MUST have this form\<close>
  type_intros nat_fun_univ [THEN subsetD]
  type_elims UN_E

datatype "maptree(A)" = Sons ("a \<in> A", "h \<in> maptree(A) -||> maptree(A)")
  monos FiniteFun_mono1  \<comment> \<open>Use monotonicity in BOTH args\<close>
  type_intros FiniteFun_univ1 [THEN subsetD]

datatype "maptree2(A, B)" = Sons2 ("a \<in> A", "h \<in> B -||> maptree2(A, B)")
  monos FiniteFun_mono [OF subset_refl]
  type_intros FiniteFun_in_univ'

definition
  ntree_rec :: "[[i, i, i] => i, i] => i"  where
  "ntree_rec(b) ==
    Vrecursor(\<lambda>pr. ntree_case(\<lambda>x h. b(x, h, \<lambda>i \<in> domain(h). pr`(h`i))))"

definition
  ntree_copy :: "i => i"  where
  "ntree_copy(z) == ntree_rec(\<lambda>x h r. Branch(x,r), z)"

text \<open>
  \medskip \<open>ntree\<close>
\<close>

lemma ntree_unfold: "ntree(A) = A \<times> (\<Union>n \<in> nat. n -> ntree(A))"
  by (blast intro: ntree.intros [unfolded ntree.con_defs]
    elim: ntree.cases [unfolded ntree.con_defs])

lemma ntree_induct [consumes 1, case_names Branch, induct set: ntree]:
  assumes t: "t \<in> ntree(A)"
    and step: "!!x n h. [| x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  \<forall>i \<in> n. P(h`i)
      |] ==> P(Branch(x,h))"
  shows "P(t)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using t
  apply induct
  apply (erule UN_E)
  apply (assumption | rule step)+
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

lemma ntree_induct_eqn [consumes 1]:
  assumes t: "t \<in> ntree(A)"
    and f: "f \<in> ntree(A)->B"
    and g: "g \<in> ntree(A)->B"
    and step: "!!x n h. [| x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  f O h = g O h |] ==>
      f ` Branch(x,h) = g ` Branch(x,h)"
  shows "f`t=g`t"
  \<comment> \<open>Induction on @{term "ntree(A)"} to prove an equation\<close>
  using t
  apply induct
  apply (assumption | rule step)+
  apply (insert f g)
  apply (rule fun_extension)
  apply (assumption | rule comp_fun)+
  apply (simp add: comp_fun_apply)
  done

text \<open>
  \medskip Lemmas to justify using \<open>Ntree\<close> in other recursive
  type definitions.
\<close>

lemma ntree_mono: "A \<subseteq> B ==> ntree(A) \<subseteq> ntree(B)"
  apply (unfold ntree.defs)
  apply (rule lfp_mono)
    apply (rule ntree.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemma ntree_univ: "ntree(univ(A)) \<subseteq> univ(A)"
  \<comment> \<open>Easily provable by induction also\<close>
  apply (unfold ntree.defs ntree.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (blast intro: Pair_in_univ nat_fun_univ [THEN subsetD])
  done

lemma ntree_subset_univ: "A \<subseteq> univ(B) ==> ntree(A) \<subseteq> univ(B)"
  by (rule subset_trans [OF ntree_mono ntree_univ])

text \<open>
  \medskip \<open>ntree\<close> recursion.
\<close>

lemma ntree_rec_Branch:
    "function(h) ==>
     ntree_rec(b, Branch(x,h)) = b(x, h, \<lambda>i \<in> domain(h). ntree_rec(b, h`i))"
  apply (rule ntree_rec_def [THEN def_Vrecursor, THEN trans])
  apply (simp add: ntree.con_defs rank_pair2 [THEN [2] lt_trans] rank_apply)
  done

lemma ntree_copy_Branch [simp]:
    "function(h) ==>
     ntree_copy (Branch(x, h)) = Branch(x, \<lambda>i \<in> domain(h). ntree_copy (h`i))"
  by (simp add: ntree_copy_def ntree_rec_Branch)

lemma ntree_copy_is_ident: "z \<in> ntree(A) ==> ntree_copy(z) = z"
  by (induct z set: ntree)
    (auto simp add: domain_of_fun Pi_Collect_iff fun_is_function)

text \<open>
  \medskip \<open>maptree\<close>
\<close>

lemma maptree_unfold: "maptree(A) = A \<times> (maptree(A) -||> maptree(A))"
  by (fast intro!: maptree.intros [unfolded maptree.con_defs]
    elim: maptree.cases [unfolded maptree.con_defs])

lemma maptree_induct [consumes 1, induct set: maptree]:
  assumes t: "t \<in> maptree(A)"
    and step: "!!x n h. [| x \<in> A;  h \<in> maptree(A) -||> maptree(A);
                  \<forall>y \<in> field(h). P(y)
               |] ==> P(Sons(x,h))"
  shows "P(t)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using t
  apply induct
  apply (assumption | rule step)+
  apply (erule Collect_subset [THEN FiniteFun_mono1, THEN subsetD])
  apply (drule FiniteFun.dom_subset [THEN subsetD])
  apply (drule Fin.dom_subset [THEN subsetD])
  apply fast
  done

text \<open>
  \medskip \<open>maptree2\<close>
\<close>

lemma maptree2_unfold: "maptree2(A, B) = A \<times> (B -||> maptree2(A, B))"
  by (fast intro!: maptree2.intros [unfolded maptree2.con_defs]
    elim: maptree2.cases [unfolded maptree2.con_defs])

lemma maptree2_induct [consumes 1, induct set: maptree2]:
  assumes t: "t \<in> maptree2(A, B)"
    and step: "!!x n h. [| x \<in> A;  h \<in> B -||> maptree2(A,B);  \<forall>y \<in> range(h). P(y)
               |] ==> P(Sons2(x,h))"
  shows "P(t)"
  using t
  apply induct
  apply (assumption | rule step)+
   apply (erule FiniteFun_mono [OF subset_refl Collect_subset, THEN subsetD])
   apply (drule FiniteFun.dom_subset [THEN subsetD])
   apply (drule Fin.dom_subset [THEN subsetD])
   apply fast
   done

end


(* Author: Gerwin Klein, Tobias Nipkow *)

theory Big_Step imports Com begin

subsection "Big-Step Semantics of Commands"

text \<open>
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes \<open>(c,s) \<Rightarrow> s'\<close>.
\<close>

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

text\<open>We want to execute the big-step rules:\<close>

code_pred big_step .

text\<open>For inductive definitions we need command
       \texttt{values} instead of \texttt{value}.\<close>

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text\<open>We need to translate the result state into a list
to display it.\<close>

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text\<open>Proof automation:\<close>

text \<open>The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules.\<close>
declare big_step.intros [intro]

text\<open>The standard induction rule
@{thm [display] big_step.induct [no_vars]}\<close>

thm big_step.induct

text\<open>
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the \<open>c\<close>, \<open>s\<close>,
and \<open>s'\<close> that we are likely to encounter. Splitting
the tuple parameter fixes this:
\<close>
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text \<open>
@{thm [display] big_step_induct [no_vars]}
\<close>

subsection "Rule inversion"

text\<open>What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it:\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text\<open>This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands:\<close>

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text\<open>Only [elim]: [elim!] would not terminate.\<close>

text\<open>An automatic example:\<close>

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text\<open>Rule inversion by hand via the ``cases'' method:\<close>

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  \<comment> \<open>inverting assms\<close>
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text \<open>An example combining rule inversion and derivations\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  \<comment> \<open>The other direction is analogous\<close>
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text \<open>
  We call two statements \<open>c\<close> and \<open>c'\<close> equivalent wrt.\ the
  big-step semantics when \emph{\<open>c\<close> started in \<open>s\<close> terminates
  in \<open>s'\<close> iff \<open>c'\<close> started in the same \<open>s\<close> also terminates
  in the same \<open>s'\<close>}. Formally:
\<close>
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

text \<open>
Warning: \<open>\<sim>\<close> is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
\<close>
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
  { fix s t assume "(?w, s) \<Rightarrow> t"
    \<comment> \<open>as a first thing we note that, if @{text b} is @{text False} in state @{text s},\<close>
    \<comment> \<open>then both statements do nothing:\<close>
    { assume "\<not>bval b s"
      hence "t = s" using \<open>(?w,s) \<Rightarrow> t\<close> by blast
      hence "(?iw, s) \<Rightarrow> t" using \<open>\<not>bval b s\<close> by blast
    }
    moreover
    \<comment> \<open>on the other hand, if @{text b} is @{text True} in state @{text s},\<close>
    \<comment> \<open>then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"}\<close>
    { assume "bval b s"
      with \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>now we can build a derivation tree for the @{text IF}\<close>
      \<comment> \<open>first, the body of the True-branch:\<close>
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      \<comment> \<open>then the whole @{text IF}\<close>
      with \<open>bval b s\<close> have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    \<comment> \<open>both cases together give us what we want:\<close>
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  \<comment> \<open>now the other direction:\<close>
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    \<comment> \<open>again, if @{text b} is @{text False} in state @{text s}, then the False-branch\<close>
    \<comment> \<open>of the @{text IF} is executed, and both statements do nothing:\<close>
    { assume "\<not>bval b s"
      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
      hence "(?w, s) \<Rightarrow> t" using \<open>\<not>bval b s\<close> by blast
    }
    moreover
    \<comment> \<open>on the other hand, if @{text b} is @{text True} in state @{text s},\<close>
    \<comment> \<open>then this time only the @{text IfTrue} rule can have be used\<close>
    { assume "bval b s"
      with \<open>(?iw, s) \<Rightarrow> t\<close> have "(c;; ?w, s) \<Rightarrow> t" by auto
      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>with this information, we can build a derivation tree for the @{text WHILE}\<close>
      with \<open>bval b s\<close>
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    \<comment> \<open>both cases together again give us what we want:\<close>
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text \<open>Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.\<close>

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text \<open>Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically.\<close>

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text \<open>This proof is automatic.\<close>

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

text \<open>
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
\<close>

theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  \<comment> \<open>the only interesting case, @{text WhileTrue}:\<close>
  fix b c s s\<^sub>1 t t'
  \<comment> \<open>The assumptions of the rule:\<close>
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  \<comment> \<open>Ind.Hyp; note the @{text"\<And>"} because of arbitrary:\<close>
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  \<comment> \<open>Premise of implication:\<close>
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with \<open>bval b s\<close> obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ \<comment> \<open>prove the rest automatically\<close>

end


theory Weak_Bisimilarity_Implies_Equivalence
imports
  Weak_Logical_Equivalence
begin

section \<open>Weak Bisimilarity Implies Weak Logical Equivalence\<close>

context indexed_weak_nominal_ts
begin

  lemma weak_bisimilarity_implies_weak_equivalence_Act:
    assumes "\<And>P Q. P \<approx>\<cdot> Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x"
    and "P \<approx>\<cdot> Q"
    \<comment> \<open>not needed: and @{prop "weak_formula x"}\<close>
    and "P \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"
    shows "Q \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"
  proof -
    have "finite (supp Q)"
      by (fact finite_supp)
    with \<open>P \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x\<close> obtain \<alpha>' x' P' where eq: "Act \<alpha> x = Act \<alpha>' x'" and trans: "P \<Rightarrow>\<langle>\<alpha>'\<rangle> P'" and valid: "P' \<Turnstile> x'" and fresh: "bn \<alpha>' \<sharp>* Q"
      by (metis valid_weak_action_modality_strong)

    from \<open>P \<approx>\<cdot> Q\<close> and fresh and trans obtain Q' where trans': "Q \<Rightarrow>\<langle>\<alpha>'\<rangle> Q'" and bisim': "P' \<approx>\<cdot> Q'"
      by (metis weakly_bisimilar_weak_simulation_step)

    from eq obtain p where px: "x' = p \<bullet> x"
      by (metis Act_eq_iff_perm)

    with valid have "-p \<bullet> P' \<Turnstile> x"
      by (metis permute_minus_cancel(1) valid_eqvt)
    moreover from bisim' have "(-p \<bullet> P') \<approx>\<cdot> (-p \<bullet> Q')"
      by (metis weakly_bisimilar_eqvt)
    ultimately have "-p \<bullet> Q' \<Turnstile> x"
      using \<open>\<And>P Q. P \<approx>\<cdot> Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x\<close> by metis
    with px have "Q' \<Turnstile> x'"
      by (metis permute_minus_cancel(1) valid_eqvt)

    with eq and trans' show "Q \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"
      unfolding valid_weak_action_modality by metis
  qed

  lemma weak_bisimilarity_implies_weak_equivalence_Pred:
    assumes "\<And>P Q. P \<approx>\<cdot> Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x"
    and "P \<approx>\<cdot> Q"
    \<comment> \<open>not needed: and @{prop "weak_formula x"}\<close>
    and "P \<Turnstile> \<langle>\<langle>\<tau>\<rangle>\<rangle>(Conj (binsert (Pred \<phi>) (bsingleton x)))"
    shows "Q \<Turnstile> \<langle>\<langle>\<tau>\<rangle>\<rangle>(Conj (binsert (Pred \<phi>) (bsingleton x)))"
  proof -
    let ?c = "Conj (binsert (Pred \<phi>) (bsingleton x))"

    from \<open>P \<Turnstile> \<langle>\<langle>\<tau>\<rangle>\<rangle>?c\<close> obtain P' where trans: "P \<Rightarrow> P'" and valid: "P' \<Turnstile> ?c"
      using valid_weak_action_modality by auto

    have "bn \<tau>  \<sharp>* Q"
      by (simp add: fresh_star_def)
    with \<open>P \<approx>\<cdot> Q\<close> and trans obtain Q' where trans': "Q \<Rightarrow> Q'" and bisim': "P' \<approx>\<cdot> Q'"
      by (metis weakly_bisimilar_weak_simulation_step weak_transition_tau_iff)

    from valid have *: "P' \<turnstile> \<phi>" and **: "P' \<Turnstile> x"
      by (simp add: binsert.rep_eq)+

    from bisim' and * obtain Q'' where trans'': "Q' \<Rightarrow> Q''" and bisim'': "P' \<approx>\<cdot> Q''" and ***: "Q'' \<turnstile> \<phi>"
      by (metis is_weak_bisimulation_def weakly_bisimilar_is_weak_bisimulation)

    from bisim'' and ** have "Q'' \<Turnstile> x"
      using \<open>\<And>P Q. P \<approx>\<cdot> Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x\<close> by metis
    with *** have "Q'' \<Turnstile> ?c"
      by (simp add: binsert.rep_eq)

    moreover from trans' and trans'' have "Q \<Rightarrow>\<langle>\<tau>\<rangle> Q''"
      by (metis tau_transition_trans weak_transition_tau_iff)

    ultimately show "Q \<Turnstile> \<langle>\<langle>\<tau>\<rangle>\<rangle>?c"
      unfolding valid_weak_action_modality by metis
  qed

  theorem weak_bisimilarity_implies_weak_equivalence: assumes "P \<approx>\<cdot> Q" shows "P \<equiv>\<cdot> Q"
  proof -
  {
    fix x :: "('idx, 'pred, 'act) formula"
    assume "weak_formula x"
      then have "\<And>P Q. P \<approx>\<cdot> Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x"
    proof (induct rule: weak_formula.induct)
      case (wf_Conj xset) then show ?case
        by simp
    next
      case (wf_Not x) then show ?case
        by simp
    next
      case (wf_Act x \<alpha>) then show ?case
        by (metis weakly_bisimilar_symp weak_bisimilarity_implies_weak_equivalence_Act sympE)
    next
      case (wf_Pred x \<phi>) then show ?case
        by (metis weakly_bisimilar_symp weak_bisimilarity_implies_weak_equivalence_Pred sympE)
      qed
    }
    with assms show ?thesis
      unfolding weakly_logically_equivalent_def by simp
  qed

end

end


theory CoreStructures
imports COFEs
begin

section \<open> Core Structures \<close>
text \<open> This section introduces the concepts of cameras, resource algebras and related structures. \<close>
subsection \<open>Resource Algebra\<close>
class ra =
  fixes valid :: "'a \<Rightarrow> bool"
    and core :: "'a \<Rightarrow> 'a option"
    and op :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes ra_assoc: "op (op a b) c = op a (op b c)"
    and ra_comm: "op a b = op b a"
    and ra_core_id: "\<exists>a'. core a = Some a' \<Longrightarrow> op (the (core a)) a = a"
    and ra_core_idem: "\<exists>a'. core a = Some a' \<Longrightarrow> core (the (core a)) = core a"
    and ra_core_mono: "\<lbrakk>\<exists>a'. core a = Some a'; \<exists>c. b=op a c\<rbrakk> \<Longrightarrow>
      (\<exists>b'. (core b = Some b') \<and> (\<exists>c. (the (core b)) = op (the (core a)) c))"
    and ra_valid_op: "valid (op a b) \<Longrightarrow> valid a"

subsection \<open>Camera\<close>
text \<open>Camera, a more general notion of resource algebras based on an OFE.\<close>
class camera = ofe +
  fixes valid_raw :: "'a::ofe \<Rightarrow> sprop" and pcore :: "'a \<Rightarrow> 'a option"
    and op :: "'a \<Rightarrow>'a \<Rightarrow> 'a" (infixl "\<cdot>" 60)
  assumes valid_raw_non_expansive: "non_expansive valid_raw"
    and pcore_non_expansive: "non_expansive pcore"
    and op_non_expansive: "non_expansive2 op"
    and camera_assoc: "(a \<cdot> b) \<cdot> c = a \<cdot> (b \<cdot> c)"
    and camera_comm: "a \<cdot> b = b \<cdot> a"
    and camera_pcore_id: "pcore a = Some a' \<Longrightarrow> a' \<cdot> a = a"
    and camera_pcore_idem: "pcore a = Some a' \<Longrightarrow> pcore a' = pcore a"
    and camera_pcore_mono: "\<lbrakk>pcore a = Some a'; \<exists>c. b= a \<cdot> c\<rbrakk> \<Longrightarrow>
      (\<exists>b'. (pcore b = Some b') \<and> (\<exists>c. b' = a' \<cdot> c))"
    and camera_valid_op: "Rep_sprop (valid_raw (a \<cdot> b)) n
      \<Longrightarrow> Rep_sprop (valid_raw a) n"
    and camera_extend: "\<lbrakk>Rep_sprop (valid_raw a) n; n_equiv n a (b1 \<cdot> b2)\<rbrakk> \<Longrightarrow>
      \<exists>c1 c2. (a = c1 \<cdot> c2 \<and> n_equiv n c1 b1 \<and> n_equiv n c2 b2)"
begin
abbreviation n_valid :: "'a \<Rightarrow> nat \<Rightarrow> bool" where "n_valid x \<equiv> Rep_sprop (valid_raw x)"

definition valid :: "'a \<Rightarrow> bool" where
  "valid a = (\<forall>n. n_valid a n)"

definition incl :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "incl a b = (\<exists>c. b = a \<cdot> c)"

definition n_incl :: "nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "n_incl n a b = (\<exists>c. n_equiv n b (a \<cdot> c))"

(* Frame-preserving update *)
definition camera_upd :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "\<leadsto>" 50) where
  "a\<leadsto>B \<equiv> (\<forall>n x. n_valid (a \<cdot> x) n \<longrightarrow> (\<exists>b\<in>B. n_valid (b \<cdot> x) n))"

definition camera_updP :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" (infix "\<leadsto>:" 50) where
  "a \<leadsto>: P \<equiv> \<forall>n x. n_valid (a \<cdot> x) n \<longrightarrow> (\<exists>b. P b \<and> n_valid (b \<cdot> x) n)"

(* Auxiliary camera lemmas *)
lemmas valid_raw_ne [elim] = non_expansiveE[OF valid_raw_non_expansive]
lemmas pcore_ne [elim] = non_expansiveE[OF pcore_non_expansive]
lemmas op_ne [elim] = non_expansive2E[OF op_non_expansive]

lemma camera_upd_refl: "a\<leadsto>{a}" unfolding camera_upd_def by simp

lemma camera_n_incl_le: "\<lbrakk>n_incl n x y; m\<le>n\<rbrakk> \<Longrightarrow> n_incl m x y"
  by (auto simp: n_incl_def) (meson ofe_class.ofe_mono)

lemma op_equiv: "\<lbrakk>n_equiv n x y; n_equiv n a b\<rbrakk> \<Longrightarrow> n_equiv n (x \<cdot> a) (y \<cdot> b)"
proof -
  assume "n_equiv n x y" "n_equiv n a b"
  hence "n_equiv n (x,a) (y,b)" by simp
  thus "n_equiv n (op x a) (op y b)"
    using op_non_expansive non_expansive2_def by fastforce
qed

lemma op_equiv_subst:
  "\<lbrakk>n_equiv n a (b \<cdot> c); n_equiv m b d; n\<le>m\<rbrakk> \<Longrightarrow> n_equiv n a (d \<cdot> c)"
  by (meson op_equiv ofe_class.ofe_mono ofe_class.ofe_refl ofe_class.ofe_trans)

lemma valid_op_op_weaken: "\<lbrakk>n_equiv n x (y \<cdot> z); n_valid (x \<cdot> x') n\<rbrakk>
  \<Longrightarrow> n_valid (op (op y z) x') n"
proof -
  assume assm1: "n_equiv n x (y \<cdot> z)"
  assume assm2: "n_valid (x \<cdot> x') n"
  from assm1 have "n_equiv n (x \<cdot> x') ((y \<cdot> z) \<cdot> x')"
    by (simp add: ofe_class.ofe_refl op_equiv)
  from ne_sprop_weaken[OF this order.refl valid_raw_non_expansive assm2]
  show "n_valid ((y \<cdot> z) \<cdot> x') n" .
qed

lemma n_valid_incl_subst: "\<lbrakk>n_incl n a b; n_valid (b \<cdot> c) m; m\<le>n\<rbrakk>
  \<Longrightarrow> n_valid (a \<cdot> c) m"
  using n_incl_def
  by (smt (verit, ccfv_threshold) camera_assoc camera_comm camera_valid_op ofe_class.ofe_mono valid_op_op_weaken)

lemma n_valid_ne: "\<lbrakk>n_equiv n x y; n_valid x n\<rbrakk> \<Longrightarrow> n_valid y n"
proof -
  assume assms: "n_equiv n x y" "n_valid x n"
  then show "Rep_sprop (valid_raw y) n" using valid_raw_non_expansive ne_sprop_weaken by blast
qed

lemma incl_op_extend: "incl a b \<Longrightarrow> incl a (b \<cdot> c)"
  by (auto simp: incl_def camera_assoc)
lemma n_incl_op_extend: "n_incl n a (a \<cdot> c)"
  by (meson n_incl_def ofe_class.ofe_eq_limit)
lemma n_incl_extend: "\<lbrakk>n_incl n a b; m\<le>n\<rbrakk> \<Longrightarrow> n_incl m (a \<cdot> c) (b \<cdot> c)"
  using n_incl_def
  by (smt (verit, ccfv_SIG) camera_n_incl_le local.camera_assoc local.camera_comm ofe_class.ofe_eq_limit op_ne)
lemma incl_n_incl: "incl a b \<Longrightarrow> n_incl n a b"
  using ofe_class.ofe_refl by (auto simp: incl_def n_incl_def)

lemma pcore_mono: "\<lbrakk>\<forall>x. \<exists>y. pcore x = Some y; incl a b\<rbrakk> \<Longrightarrow> incl (the (pcore a)) (the (pcore b))"
  apply (auto simp: incl_def) using local.camera_pcore_mono by fastforce

lemmas camera_props = camera_assoc camera_comm camera_pcore_id camera_pcore_idem camera_pcore_mono
  camera_valid_op camera_extend valid_raw_ne pcore_ne op_ne
end

lemma n_incl_incl: "n_incl n (a::'a::{camera,discrete}) b \<longleftrightarrow> incl a b"
 by (auto simp: incl_def n_incl_def d_equiv)

subsection \<open>Camera Extensions\<close>
text \<open>Total Camera - A camera with a total core\<close>
class total_camera = camera +
  assumes total_pcore: "\<exists>b. pcore a = Some b"
begin
definition core :: "'a \<Rightarrow> 'a" where
  "core = the \<circ> pcore"

lemma core_ne: "non_expansive core"
  unfolding non_expansive_def core_def
  by (smt (verit, del_insts) comp_apply local.pcore_ne n_equiv_option_def ofe_class.ofe_refl option.sel)

lemma camera_core_id: "(core a) \<cdot> a = a"
  and camera_core_idem: "core (core a) = core a"
  and camera_core_mono: "incl a b \<Longrightarrow> incl (core a) (core b)"
  apply (simp_all add: core_def incl_def comp_def camera_pcore_id total_pcore camera_pcore_idem)
  using camera_pcore_mono total_pcore by fastforce

lemma camera_core_mono_n: "n_incl n a b \<Longrightarrow> n_incl n (core a) (core b)"
  by (metis core_ne local.incl_def local.n_incl_def non_expansiveE camera_core_mono)

lemma camera_core_n_valid: "n_valid a n \<Longrightarrow> n_valid (core a) n"
  by (metis camera_core_id local.camera_valid_op)
end

text \<open>Unital Camera - A camera with a unit element\<close>
class ucamera = camera +
  fixes \<epsilon>
  assumes \<epsilon>_valid: "valid \<epsilon>"
    and \<epsilon>_left_id: "\<epsilon> \<cdot> a = a"
    and \<epsilon>_pcore: "pcore \<epsilon> = Some \<epsilon>"
begin
subclass total_camera
proof
  fix a
  from \<epsilon>_left_id have "\<exists>c. a = \<epsilon> \<cdot> c" by metis
  from camera_pcore_mono[OF \<epsilon>_pcore this] show "\<exists>b. pcore a = Some b" by auto
qed

lemma \<epsilon>_core: "core \<epsilon> = \<epsilon>" using core_def \<epsilon>_pcore by simp

lemma total_n_inclI: "n2\<le>n1 \<Longrightarrow> n_equiv n1 x1 x2 \<Longrightarrow> n_incl n2 x1 (x2::'a)"
proof (unfold n_incl_def; standard)
  assume "n2\<le>n1" "n_equiv n1 x1 x2"
  then have "n_equiv n2 x1 x2" by (rule ofe_class.ofe_mono)
  then have "n_equiv n2 (op x1 \<epsilon>) x2"
    by (metis camera_comm \<epsilon>_left_id)
  then show "n_equiv n2 x2 (op x1 \<epsilon>)" by (simp add: ofe_class.ofe_sym)
qed

lemma total_n_incl_extend: "\<lbrakk>n_equiv n a b; m\<le>n\<rbrakk> \<Longrightarrow> n_incl m (a\<cdot>c) (b\<cdot>c)"
  using total_n_inclI n_incl_extend by blast

lemma n_incl_\<epsilon>[simp]: "n_incl n \<epsilon> a"
proof (unfold n_incl_def)
  have "n_equiv n a a" by (simp add: ofe_class.ofe_refl)
  then have "n_equiv n a (\<epsilon>\<cdot>a)" by (simp add: \<epsilon>_left_id)
  then show "\<exists>c. n_equiv n a (\<epsilon> \<cdot> c)" by fast
qed

lemma \<epsilon>_right_id: "a\<cdot>\<epsilon>=a"
  by (auto simp: \<epsilon>_left_id camera_comm)

lemma n_incl_refl[simp]: "n_incl n a a"
proof (unfold n_incl_def)
  have "n_equiv n a (a\<cdot>\<epsilon>)"
    by (auto simp: \<epsilon>_right_id ofe_class.ofe_refl)
  then show "\<exists>c. n_equiv n a (a \<cdot> c)" by auto
qed

lemma \<epsilon>_n_valid: "n_valid \<epsilon> n" by (simp add: \<epsilon>_valid[unfolded valid_def])
end

text \<open>A camera with the identity for its core.\<close>
class core_id = camera + assumes pcore_id: "pcore a = Some a"
begin
lemma the_core_id: "the (pcore a) = a" by (simp add: pcore_id)
end

lemma core_id: "core (a::'a::{core_id,total_camera}) = a"
  by (simp add: the_core_id core_def)

text \<open>The semantics of the \<^class>\<open>core_id\<close> class but for single values.\<close>
definition pcore_id_pred :: "'a::total_camera \<Rightarrow> bool" where
  "pcore_id_pred a \<equiv> pcore a = Some a"

lemma core_id_pred: "pcore_id_pred a \<longleftrightarrow> core a = a"
  by (auto simp: pcore_id_pred_def core_def) (metis option.sel total_pcore)

lemma \<epsilon>_pcore_id_def: "pcore_id_pred \<epsilon>"
  by (auto simp: pcore_id_pred_def \<epsilon>_pcore)

lemma core_id_pcore_idpred [simp]: "pcore_id_pred (a::'a::{core_id,total_camera})"
  by (simp add: pcore_id_pred_def pcore_id)

text \<open>Discrete Camera - A camera based on a discrete OFE with non-step indexed validity.\<close>
class dcamera = camera + discrete + assumes d_valid: "n_valid x 0 \<Longrightarrow> valid x"
begin
lemma dcamera_valid_iff: "valid x \<longleftrightarrow> n_valid x n"
by (auto simp: d_valid)(auto simp: valid_def)
end

definition dcamera_val :: "'a::camera \<Rightarrow> bool" where
  "dcamera_val v \<equiv> discrete_val v \<and> (n_valid v 0 \<longrightarrow> valid v)"

lemma dcamera_dcamera_val [simp]: "dcamera_val (x::'a::dcamera)"
  by (simp add: dcamera_val_def d_valid discrete_val_def d_equiv d_eq)

text \<open>Discrete Unital Camera\<close>
class ducamera = dcamera + ucamera

subsection \<open>Camera morphisms\<close>
text \<open>Camera morphisms as a locale, ...\<close>
locale camera_morphism = fixes f :: "'a::ucamera \<Rightarrow> 'b::ucamera"
  assumes morphism_ne: "non_expansive f"
  and morphism_valid: "n_valid x n \<Longrightarrow> n_valid (f x) n"
  and morphism_pcore: "map_option f (pcore x) = pcore (f x)"
  and morphism_op: "f (x \<cdot> y) = (f x) \<cdot> (f y)"

interpretation id_morph: camera_morphism id
  by unfold_locales (auto simp: non_expansive_def option.map_id)

interpretation const_\<epsilon>_morph: camera_morphism "\<lambda>_. \<epsilon>"
  by unfold_locales (auto simp: non_expansive_def ofe_refl \<epsilon>_n_valid \<epsilon>_pcore \<epsilon>_left_id total_pcore)

lemma n_incl_morph: "\<lbrakk>camera_morphism f; n_incl n x y\<rbrakk> \<Longrightarrow> n_incl n (f x) (f y)"
  by (auto simp: n_incl_def camera_morphism_def) fast

lemma comp_morph: "\<lbrakk>camera_morphism f; camera_morphism g\<rbrakk> \<Longrightarrow> camera_morphism (f \<circ> g)"
   by (transfer; auto simp: camera_morphism_def ne_comp) (metis option.map_comp)

text \<open>... and as a semantic subtype.\<close>
typedef (overloaded) ('a::ucamera,'b::ucamera) cmra_morph = "{f::'a \<Rightarrow> 'b. camera_morphism f}"
  using const_\<epsilon>_morph.camera_morphism_axioms by auto
setup_lifting type_definition_cmra_morph
lemmas [simp] = Rep_cmra_morph_inverse Rep_cmra_morph_inject
lemmas [simp, intro!] = Rep_cmra_morph[unfolded mem_Collect_eq]

lift_definition id_morph :: "('a::ucamera, 'a) cmra_morph" is "id::('a\<Rightarrow>'a)"
  by (rule id_morph.camera_morphism_axioms)

lift_definition morph_comp :: "('b::ucamera,'c::ucamera) cmra_morph \<Rightarrow> ('a::ucamera,'b) cmra_morph \<Rightarrow> ('a,'c) cmra_morph" is
  "\<lambda>(f::('b,'c) cmra_morph) (g::('a,'b) cmra_morph). (Rep_cmra_morph f) \<circ> (Rep_cmra_morph g)"
  using comp_morph by blast

instantiation cmra_morph :: (ucamera,ucamera) ofe begin
lift_definition n_equiv_cmra_morph :: "nat \<Rightarrow> ('a, 'b) cmra_morph \<Rightarrow> ('a, 'b) cmra_morph \<Rightarrow> bool" is
  "\<lambda>n f g. \<forall>x. n_equiv n (f x) (g x)" .
lift_definition ofe_eq_cmra_morph :: "('a, 'b) cmra_morph \<Rightarrow> ('a, 'b) cmra_morph \<Rightarrow> bool" is
  "\<lambda>f g. \<forall>x. ofe_eq (f x) (g x)" .
instance by (standard; transfer) (auto simp: ofe_refl ofe_sym ofe_limit intro: ofe_trans ofe_mono)
end

instance cmra_morph :: (ducamera,ducamera) discrete by (standard; transfer) (auto simp: d_equiv d_eq)

(* Index into resource maps to allow more than one instance of a camera *)
type_synonym gname = nat

text \<open>Locale to denote that a resource type contains a certain camera type. Allows modular proofs.\<close>
locale inG =
fixes get_cmra :: "gname \<Rightarrow> 'a::ucamera \<Rightarrow> 'b::camera option"
  and put_cmra :: "gname \<Rightarrow> 'b \<Rightarrow> 'a"
assumes get_put: "get_cmra \<gamma> (put_cmra \<gamma> x) = Some x"
  and put_ne: "n_equiv n (put_cmra \<gamma> x) (put_cmra \<gamma> y) \<longleftrightarrow> n_equiv n x y"
  and put_ne2: "n_equiv n (put_cmra \<gamma> x) z \<Longrightarrow> \<exists>y'. z=put_cmra \<gamma> y'"
  and put_n_valid: "n_valid (put_cmra \<gamma> x) n \<longleftrightarrow> n_valid x n"
  and put_pcore: "pcore (put_cmra \<gamma> x) = Some (case (pcore x) of Some y \<Rightarrow> (put_cmra \<gamma> y) | None \<Rightarrow> \<epsilon>)"
  and put_op: "put_cmra \<gamma> (x \<cdot> y) = (put_cmra \<gamma> x) \<cdot> (put_cmra \<gamma> y)"
begin
  lemma put_valid: "valid (put_cmra \<gamma> x) \<longleftrightarrow> valid x"
    by (auto simp: valid_def put_n_valid)
end
end


section \<open>Graphs defined by Successor Functions\<close>
theory Succ_Graph
imports
  Collections.Refine_Dflt
begin

text \<open>
  This code is used in various examples
\<close>

type_synonym 'a slg = "'a \<Rightarrow> 'a list"
definition slg_rel_def_internal: "slg_rel R \<equiv>
  {(succs,G). \<forall>v. (succs v, G``{v}) \<in> \<langle>R\<rangle>list_set_rel}"

lemma slg_rel_def: "\<langle>R\<rangle>slg_rel \<equiv>
  {(succs,G). \<forall>v. (succs v, G``{v}) \<in> \<langle>R\<rangle>list_set_rel}"
  by (auto simp: slg_rel_def_internal relAPP_def)

lemma [relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>slg_rel)"
  unfolding slg_rel_def
  apply (rule single_valuedI)
  apply (auto dest: single_valuedD[OF list_set_rel_sv])
  done

consts i_slg :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] =
  REL_INTFI[of slg_rel i_slg]

definition [simp]: "slg_succs E v \<equiv> E``{v}"

lemma [autoref_itype]: "slg_succs ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp

context begin interpretation autoref_syn .

definition [code_unfold, simp]: "slg_succs_impl succs v \<equiv> succs v"

lemma refine_slg_succs[autoref_rules_raw]:
  "(slg_succs_impl,slg_succs)\<in>\<langle>Id\<rangle>slg_rel\<rightarrow>Id\<rightarrow>\<langle>Id\<rangle>list_set_rel"
  apply (intro fun_relI)
  apply (simp add: slg_succs_def slg_rel_def)
  done

subsection "Graph Representations"
(* TODO: Correctness proofs *)

definition succ_of_list :: "(nat\<times>nat) list \<Rightarrow> nat \<Rightarrow> nat set"
  where
  "succ_of_list l \<equiv> let
    m = fold (\<lambda>(u,v) g.
          case g u of
            None \<Rightarrow> g(u\<mapsto>{v})
          | Some s \<Rightarrow> g(u\<mapsto>insert v s)
        ) l Map.empty
  in
    (\<lambda>u. case m u of None \<Rightarrow> {} | Some s \<Rightarrow> s)

"

schematic_goal succ_of_list_impl:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat\<rightharpoonup>nat set" and R="\<langle>nat_rel,R\<rangle>iam_map_rel" for R]
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>list_set_rel"]

  shows "(?f::?'c,succ_of_list) \<in> ?R"
  unfolding succ_of_list_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition succ_of_list_impl uses succ_of_list_impl
export_code succ_of_list_impl checking SML

definition acc_of_list :: "nat list \<Rightarrow> nat set"
  where "acc_of_list l \<equiv> fold insert l {}"

schematic_goal acc_of_list_impl:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>iam_set_rel" for R]

  shows "(?f::?'c,acc_of_list) \<in> ?R"
  unfolding acc_of_list_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition acc_of_list_impl uses acc_of_list_impl
export_code acc_of_list_impl checking SML

end


theory ProductCategory

imports
  Main
  "Category2/Category"
  "Category2/Functors"

begin

value "OppositeCategory"

section "Products of Categories"

subsection "Basic construction"
text{* We define the cartesian product of two categories as: *}

definition ProductCategory :: "('o1, 'm1, 'a1) Category_scheme \<Rightarrow> ('o2, 'm2, 'a2) Category_scheme \<Rightarrow> ('o1 \<times> 'o2, 'm1 \<times> 'm2) Category" where
  "ProductCategory C1 C2 \<equiv> MakeCat \<lparr>
    Obj = Obj C1 \<times> Obj C2,
    Mor = Mor C1 \<times> Mor C2,
    Dom = \<lambda>(f1, f2). (Dom C1 f1, Dom C2 f2),
    Cod = \<lambda>(f1, f2). (Cod C1 f1, Cod C2 f2),
    Id = \<lambda>(o1, o2). (Id C1 o1, Id C2 o2),
    Comp = \<lambda>(f, g) (f', g'). (Comp C1 f f', Comp C2 g g')
  \<rparr>"

text{* Categories are closed under product: *}
theorem ProductClosure:
  assumes "Category C1"
  and "Category C2"
  shows "Category (ProductCategory C1 C2)"
apply (simp add: ProductCategory_def)
apply (rule MakeCat)
apply (unfold_locales)
apply (auto)

apply (simp add: Category.Cdom assms(1))
apply (simp add: Category.Cdom assms(2))
apply (simp add: Category.Ccod assms(1))
apply (simp add: Category.Ccod assms(2))
apply (simp add: Category.CatIdDomCod(1) Category.CatIdDomCod(2) Category.CatIdInMor MapsTo_def assms(1) assms(2))
apply (simp add: Category.Cidl assms(1))
apply (simp add: Category.Cidl assms(2))
apply (simp add: Category.Cidr assms(1))
apply (simp add: Category.Cidr assms(2))

apply (smt Category.Cassoc Category.select_convs(2) Category.select_convs(3) Category.select_convs(4) CompDefinedE CompDefinedI SigmaD1 assms(1) old.prod.case prod.inject)
apply (metis (no_types, lifting) Category.Cassoc Category.select_convs(2) Category.select_convs(3) Category.select_convs(4) CompDefinedE CompDefinedI SigmaD2 assms(2) old.prod.case prod.inject)
apply (smt Category.MapsToMorDomCod(1) Category.MapsToMorDomCod(2) Category.MapsToMorDomCod(3) Category.select_convs(2) Category.select_convs(3) Category.select_convs(4) CompDefinedI MapsTo_def SigmaD1 SigmaD2 SigmaI assms(1) assms(2) old.prod.case prod.inject)
done

subsection "Left and Right Projection Functors"
text{* We now define left and right projection functors for product categories *}

(* Let [C], [D] two categories. [ProductLeftProjectionFunctor] maps product category [C] \<times> [D] to [C] *)
definition MakeCatLeftProjection where
  "MakeCatLeftProjection C \<equiv> MakeCat \<lparr>
      Obj = fst ` Obj C,
      Mor = fst ` Mor C,
      Dom = \<lambda>f. fst (Dom C (f, SOME g. True)),
      Cod = \<lambda>f. fst (Cod C (f, SOME g. True)),
      Id = \<lambda>X. fst (Id C (X, SOME X'. True)),
      Comp =
        \<lambda>f f'. fst (Comp C (f, SOME g. True) (f', SOME g'. True))
  \<rparr>"

definition LeftProjectionFtor' where
  "LeftProjectionFtor' C \<equiv> \<lparr>
    CatDom = C,
    CatCod = MakeCatLeftProjection C,
    MapM = \<lambda>(f1, f2). f1
  \<rparr>"

(*
definition
  MakeCat :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'m,'a) Category_scheme" where
  "MakeCat C \<equiv> \<lparr>
      Obj = Obj C ,
      Mor = Mor C ,
      Dom = restrict (Dom C) (Mor C) ,
      Cod = restrict (Cod C) (Mor C) ,
      Id  = restrict (Id C) (Obj C) ,
      Comp = \<lambda> f g . (restrict (split (Comp C)) ({(f,g) | f g . f \<approx>>\<^bsub>C\<^esub> g})) (f,g),
      \<dots> = Category.more C
  \<rparr>"
*)

lemma ExtentionalityClosure:
  assumes "Category C"
  shows "MakeCat C = C"

proof -
  { have "Obj C = Obj (MakeCat C)"
    using assms
    by (simp add: MakeCatObj)
  }
  next { have "Mor C = Mor (MakeCat C)"
    using assms
    by (simp add: MakeCatMor)
  }
  next { have "Dom C = Dom (MakeCat C)"
    using assms (* lemma MakeCatDom: "f \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> dom\<^bsub>C\<^esub> f = dom\<^bsub>MakeCat C\<^esub> f" *)
    sorry
  }
  next { have "Cod C = Cod (MakeCat C)"
    sorry
  }
  next { have "Id C = Id (MakeCat C)"
    sorry
  }
  next { have "Comp C = Comp (MakeCat C)"
    sorry
  }
  then show ?thesis sorry
qed

lemma
  assumes "Category C1"
  and "Category C2"
  and "Obj C2 \<noteq> {}"
  and "Mor C2 \<noteq> {}"
  shows "MakeCatLeftProjection (ProductCategory C1 C2) = C1"
unfolding MakeCatLeftProjection_def
unfolding MakeCat_def

proof -
  have "fst ` (obj\<^bsub>ProductCategory C1 C2\<^esub>) = Obj C1" using assms by (simp add: ProductCategory_def MakeCat_def)
  have "fst ` (mor\<^bsub>ProductCategory C1 C2\<^esub>) = Mor C1" using assms by (simp add: ProductCategory_def MakeCat_def)
  have "(\<lambda>f. fst (dom\<^bsub>ProductCategory C1 C2\<^esub> (f, SOME g. True))) = Dom C1"

(*
    sledgehammer supported_provers
    sledgehammer[provers="cvc4 remote_vampire z3 spass e alt_ergo verit cvc3", verbose]
    (* sledgehammer[provers="alt_ergo", verbose] *)
    sledgehammer[provers="cvc3", smt_trace, verbose]
*)

    by (simp add: ProductCategory_def MakeCat_def, auto)
apply (subst CatObjProductLeftProjection)
apply (subst CatDomProductLeftProjection)

theorem LeftProjectionClosure:
  assumes "Category C1"
  and "Category C2"
  and "Obj C2 \<noteq> {}"
  shows "Category (MakeProductLeftProjection (ProductCategory C1 C2))"

(*
apply (simp add: ProductCategory_def MakeProductLeftProjection_def)
apply (rule MakeCat)
apply (unfold_locales)
apply (auto)
*)

unfolding Category_def
unfolding ExtCategory_def
unfolding Category_axioms_def

proof (intro conjI)
  have ax1: "Dom (MakeProductLeftProjection (ProductCategory C1 C2)) = Dom C1"
    using assms
    sorry
    sledgehammer supported_provers

    by (simp add: ProductCategory_def MakeProductLeftProjection_def MakeCat_def, auto)

  have " Dom (MakeProductLeftProjection (ProductCategory C1 C2)) \<in> extensional (mor\<^bsub>MakeProductLeftProjection (ProductCategory C1 C2)\<^esub>)"

definition ProductLeftProjectionFunctor where
  "ProductLeftProjectionFunctor C \<equiv>
    MakeFtor \<lparr>
      CatDom = C,
      CatCod = MakeProductLeftProjection C,
      MapM = \<lambda>(m1, m2). m1
  \<rparr>"

end


theory Context_Free_Grammar_Example
imports "~~/src/HOL/Library/Code_Prolog"
begin
(*
declare mem_def[code_pred_inline]
*)

subsection {* Alternative rules for length *}

definition size_list :: "'a list => nat"
where "size_list = size"

lemma size_list_simps:
  "size_list [] = 0"
  "size_list (x # xs) = Suc (size_list xs)"
by (auto simp add: size_list_def)

declare size_list_simps[code_pred_def]
declare size_list_def[symmetric, code_pred_inline]

setup {*
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
*}

datatype alphabet = a | b

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

lemma
  "S\<^sub>1p w \<Longrightarrow> w = []"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

definition "filter_a = filter (\<lambda>x. x = a)"

lemma [code_pred_def]: "filter_a [] = []"
unfolding filter_a_def by simp

lemma [code_pred_def]: "filter_a (x#xs) = (if x = a then x # filter_a xs else filter_a xs)"
unfolding filter_a_def by simp

declare filter_a_def[symmetric, code_pred_inline]

definition "filter_b = filter (\<lambda>x. x = b)"

lemma [code_pred_def]: "filter_b [] = []"
unfolding filter_b_def by simp

lemma [code_pred_def]: "filter_b (x#xs) = (if x = b then x # filter_b xs else filter_b xs)"
unfolding filter_b_def by simp

declare filter_b_def[symmetric, code_pred_inline]

setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s1p", "a1p", "b1p"], 2)],
  replacing = [(("s1p", "limited_s1p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]}) *}

theorem S\<^sub>1_sound:
"S\<^sub>1p w \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

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

setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s2p", "a2p", "b2p"], 3)],
  replacing = [(("s2p", "limited_s2p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]}) *}

theorem S\<^sub>2_sound:
  "S\<^sub>2p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

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

setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s3p", "a3p", "b3p"], 6)],
  replacing = [(("s3p", "limited_s3p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]}) *}

lemma S\<^sub>3_sound:
  "S\<^sub>3p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, size=1, expect = no_counterexample]
oops

(*
setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = [],
  timeout = seconds 10.0,
  prolog_system = Code_Prolog.SWI_PROLOG}) *}

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>3"
quickcheck[tester = prolog, size=1, iterations=1]
oops
*)

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

setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s4p", "a4p", "b4p"], 6)],
  replacing = [(("s4p", "limited_s4p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]}) *}

theorem S\<^sub>4_sound:
  "S\<^sub>4p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, size=1, iterations=1, expect = no_counterexample]
oops

(*
theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
oops
*)

hide_const a b

end