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

section \<open>Test Iterings\<close>

theory Test_Iterings

imports Stone_Kleene_Relation_Algebras.Iterings Tests

begin

class test_itering = itering + tests + while +
  assumes while_def: "p \<star> y = (p * y)\<^sup>\<circ> * -p"
begin

lemma wnf_lemma_5:
  "(-p \<squnion> -q) * (-q * x \<squnion> --q * y) = -q * x \<squnion> --q * -p * y"
  by (smt (z3) mult_left_dist_sup sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_idempotent tests_dual.sup_idempotent mult_assoc tests_dual.wnf_lemma_3)

lemma test_case_split_left_equal:
  "-z * x = -z * y \<Longrightarrow> --z * x = --z * y \<Longrightarrow> x = y"
  by (metis case_split_left_equal tests_dual.inf_complement)

lemma preserves_equation:
  "-y * x \<le> x * -y \<longleftrightarrow> -y * x = -y * x * -y"
  apply (rule iffI)
  apply (simp add: test_preserves_equation tests_dual.sub_bot_least)
  by (simp add: test_preserves_equation tests_dual.sub_bot_least)

text \<open>Theorem 5\<close>

lemma preserve_test:
  "-y * x \<le> x * -y \<Longrightarrow> -y * x\<^sup>\<circ> = -y * x\<^sup>\<circ> * -y"
  using circ_simulate preserves_equation by blast

text \<open>Theorem 5\<close>

lemma import_test:
  "-y * x \<le> x * -y \<Longrightarrow> -y * x\<^sup>\<circ> = -y * (-y * x)\<^sup>\<circ>"
  by (simp add: circ_import tests_dual.sub_bot_least)

definition ite :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_ \<lhd> _ \<rhd> _" [58,58,58] 57)
  where "x \<lhd> p \<rhd> y \<equiv> p * x \<squnion> -p * y"

definition it :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_ \<rhd> _" [58,58] 57)
  where "p \<rhd> x \<equiv> p * x \<squnion> -p"

(*
definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 59)
  where "p \<star> y \<equiv> (p * y)\<^sup>\<circ> * -p"
*)

definition assigns :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "assigns x p q \<equiv> x = x * (p * q \<squnion> -p * -q)"

definition preserves :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "preserves x p \<equiv> p * x \<le> x * p \<and> -p * x \<le> x * -p"

lemma ite_neg:
  "x \<lhd> -p \<rhd> y = y \<lhd> --p \<rhd> x"
  by (simp add: ite_def sup_commute)

lemma ite_import_true:
  "x \<lhd> -p \<rhd> y = -p * x \<lhd> -p \<rhd> y"
  by (metis ite_def tests_dual.sup_idempotent mult_assoc)

lemma ite_import_false:
  "x \<lhd> -p \<rhd> y = x \<lhd> -p \<rhd> --p * y"
  by (metis ite_import_true ite_neg)

lemma ite_import_true_false:
  "x \<lhd> -p \<rhd> y = -p * x \<lhd> -p \<rhd> --p * y"
  using ite_import_false ite_import_true by auto

lemma ite_context_true:
  "-p * (x \<lhd> -p \<rhd> y) = -p * x"
  by (metis sup_monoid.add_0_left tests_dual.sup_right_zero tests_dual.top_double_complement wnf_lemma_5 sup_bot_right ite_def mult_assoc mult_left_zero)

lemma ite_context_false:
  "--p * (x \<lhd> -p \<rhd> y) = --p * y"
  by (metis ite_neg ite_context_true)

lemma ite_context_import:
  "-p * (x \<lhd> -q \<rhd> y) = -p * (x \<lhd> -p * -q \<rhd> y)"
  by (smt ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup)

lemma ite_conjunction:
  "(x \<lhd> -q \<rhd> y) \<lhd> -p \<rhd> y = x \<lhd> -p * -q \<rhd> y"
  by (smt sup_assoc sup_commute ite_def mult_assoc tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_complement_intro)

lemma ite_disjunction:
  "x \<lhd> -p \<rhd> (x \<lhd> -q \<rhd> y) = x \<lhd> -p \<squnion> -q \<rhd> y"
  by (smt (z3) tests_dual.sba_dual.sub_sup_closed sup_assoc ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_demorgan)

lemma wnf_lemma_6:
  "(-p \<squnion> -q) * (x \<lhd> --p * -q \<rhd> y) = (-p \<squnion> -q) * (y \<lhd> -p \<rhd> x)"
  by (smt (z3) ite_conjunction ite_context_false ite_context_true semiring.distrib_right tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.sub_inf_def tests_dual.sba_dual.sup_complement_intro tests_dual.sub_complement)

lemma it_ite:
  "-p \<rhd> x = x \<lhd> -p \<rhd> 1"
  by (simp add: it_def ite_def)

lemma it_neg:
  "--p \<rhd> x = 1 \<lhd> -p \<rhd> x"
  using it_ite ite_neg by auto

lemma it_import_true:
  "-p \<rhd> x = -p \<rhd> -p * x"
  using it_ite ite_import_true by auto

lemma it_context_true:
  "-p * (-p \<rhd> x) = -p * x"
  by (simp add: it_ite ite_context_true)

lemma it_context_false:
  "--p * (-p \<rhd> x) = --p"
  using it_ite ite_context_false by force

lemma while_unfold_it:
  "-p \<star> x = -p \<rhd> x * (-p \<star> x)"
  by (metis circ_loop_fixpoint it_def mult_assoc while_def)

lemma while_context_false:
  "--p * (-p \<star> x) = --p"
  by (metis it_context_false while_unfold_it)

lemma while_context_true:
  "-p * (-p \<star> x) = -p * x * (-p \<star> x)"
  by (metis it_context_true mult_assoc while_unfold_it)

lemma while_zero:
  "bot \<star> x = 1"
  by (metis circ_zero mult_left_one mult_left_zero one_def while_def)

lemma wnf_lemma_7:
  "1 * (bot \<star> 1) = 1"
  by (simp add: while_zero)

lemma while_import_condition:
  "-p \<star> x = -p \<star> -p * x"
  by (metis mult_assoc tests_dual.sup_idempotent while_def)

lemma while_import_condition_2:
  "-p * -q \<star> x = -p * -q \<star> -p * x"
  by (metis mult_assoc tests_dual.sup_idempotent sub_comm while_def)

lemma wnf_lemma_8:
  "-r * (-p \<squnion> --p * -q) \<star> (x \<lhd> --p * -q \<rhd> y) = -r * (-p \<squnion> -q) \<star> (y \<lhd> -p \<rhd> x)"
  by (metis mult_assoc while_def wnf_lemma_6 tests_dual.sba_dual.sup_complement_intro)

text \<open>Theorem 6 - see Theorem 31 on page 329 of Back and von Wright, Acta Informatica 36:295-334, 1999\<close>

lemma split_merge_loops:
  assumes "--p * y \<le> y * --p"
    shows "(-p \<squnion> -q) \<star> (x \<lhd> -p \<rhd> y) = (-p \<star> x) * (-q \<star> y)"
proof -
  have "-p \<squnion> -q \<star> (x \<lhd> -p \<rhd> y) = (-p * x \<squnion> --p * -q * y)\<^sup>\<circ> * --p * --q"
    by (smt ite_def mult_assoc sup_commute tests_dual.inf_demorgan while_def wnf_lemma_5)
  thus ?thesis
    by (smt assms circ_sup_1 circ_slide import_test mult_assoc preserves_equation sub_comm while_context_false while_def)
qed

lemma assigns_same:
  "assigns x (-p) (-p)"
  by (simp add: assigns_def)

lemma preserves_equation_test:
  "preserves x (-p) \<longleftrightarrow> -p * x = -p * x * -p \<and> --p * x = --p * x * --p"
  using preserves_def preserves_equation by auto

lemma preserves_test:
  "preserves (-q) (-p)"
  using tests_dual.sub_commutative preserves_def by auto

lemma preserves_zero:
  "preserves bot (-p)"
  using tests_dual.sba_dual.sub_bot_def preserves_test by blast

lemma preserves_one:
  "preserves 1 (-p)"
  using preserves_def by force

lemma preserves_sup:
  "preserves x (-p) \<Longrightarrow> preserves y (-p) \<Longrightarrow> preserves (x \<squnion> y) (-p)"
  by (simp add: mult_left_dist_sup mult_right_dist_sup preserves_equation_test)

lemma preserves_mult:
  "preserves x (-p) \<Longrightarrow> preserves y (-p) \<Longrightarrow> preserves (x * y) (-p)"
  by (smt (verit, best) mult_assoc preserves_equation_test)

lemma preserves_ite:
  "preserves x (-p) \<Longrightarrow> preserves y (-p) \<Longrightarrow> preserves (x \<lhd> -q \<rhd> y) (-p)"
  by (simp add: ite_def preserves_mult preserves_sup preserves_test)

lemma preserves_it:
  "preserves x (-p) \<Longrightarrow> preserves (-q \<rhd> x) (-p)"
  by (simp add: it_ite preserves_ite preserves_one)

lemma preserves_circ:
  "preserves x (-p) \<Longrightarrow> preserves (x\<^sup>\<circ>) (-p)"
  by (meson circ_simulate preserves_def)

lemma preserves_while:
  "preserves x (-p) \<Longrightarrow> preserves (-q \<star> x) (-p)"
  using while_def preserves_circ preserves_mult preserves_test by auto

lemma preserves_test_neg:
  "preserves x (-p) \<Longrightarrow> preserves x (--p)"
  using preserves_def by auto

lemma preserves_import_circ:
  "preserves x (-p) \<Longrightarrow> -p * x\<^sup>\<circ> = -p * (-p * x)\<^sup>\<circ>"
  using import_test preserves_def by blast

lemma preserves_simulate:
  "preserves x (-p) \<Longrightarrow> -p * x\<^sup>\<circ> = -p * x\<^sup>\<circ> * -p"
  using preserve_test preserves_def by auto

lemma preserves_import_ite:
  assumes "preserves z (-p)"
    shows "z * (x \<lhd> -p \<rhd> y) = z * x \<lhd> -p \<rhd> z * y"
proof -
  have 1: "-p * z * (x \<lhd> -p \<rhd> y) = -p * (z * x \<lhd> -p \<rhd> z * y)"
    by (smt assms ite_context_true mult_assoc preserves_equation_test)
  have "--p * z * (x \<lhd> -p \<rhd> y) = --p * (z * x \<lhd> -p \<rhd> z * y)"
    by (smt (z3) assms ite_context_false mult_assoc preserves_equation_test)
  thus ?thesis
    using 1 by (metis mult_assoc test_case_split_left_equal)
qed

lemma preserves_while_context:
  "preserves x (-p) \<Longrightarrow> -p * (-q \<star> x) = -p * (-p * -q \<star> x)"
  by (smt (verit, del_insts) mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan preserves_import_circ preserves_mult preserves_simulate preserves_test while_def)

lemma while_ite_context_false:
  assumes "preserves y (-p)"
    shows "--p * (-p \<squnion> -q \<star> (x \<lhd> -p \<rhd> y)) = --p * (-q \<star> y)"
proof -
  have "--p * (-p \<squnion> -q \<star> (x \<lhd> -p \<rhd> y)) = --p * (--p * -q * y)\<^sup>\<circ> * -(-p \<squnion> -q)"
    by (smt (z3) assms import_test mult_assoc preserves_equation preserves_equation_test sub_comm while_def tests_dual.sba_dual.sub_sup_demorgan preserves_test split_merge_loops while_context_false)
  thus ?thesis
    by (metis (no_types, lifting) assms preserves_def mult.assoc split_merge_loops while_context_false)
qed

text \<open>Theorem 7.1\<close>

lemma while_ite_norm:
  assumes "assigns z (-p) (-q)"
      and "preserves x1 (-q)"
      and "preserves x2 (-q)"
      and "preserves y1 (-q)"
      and "preserves y2 (-q)"
    shows "z * (x1 * (-r1 \<star> y1) \<lhd> -p \<rhd> x2 * (-r2 \<star> y2)) = z * (x1 \<lhd> -q \<rhd> x2) * ((-q * -r1 \<squnion> --q * -r2) \<star> (y1 \<lhd> -q \<rhd> y2))"
proof -
  have 1: "-(-q * -r1 \<squnion> --q * -r2) = -q * --r1 \<squnion> --q * --r2"
    by (smt (z3) tests_dual.complement_2 tests_dual.sub_sup_closed tests_dual.case_duality tests_dual.sub_sup_demorgan)
  have "-p * -q * x1 * (-q * -r1 * y1 \<squnion> --q * -r2 * y2)\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2) = -p * -q * x1 * -q * (-q * (-q * -r1 * y1 \<squnion> --q * -r2 * y2))\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2)"
    by (smt (verit, del_insts) assms(2,4,5) mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test)
  also have "... = -p * -q * x1 * -q * (-q * -r1 * y1)\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2)"
    using ite_context_true ite_def mult_assoc by auto
  finally have 2: "-p * -q * x1 * (-q * -r1 * y1 \<squnion> --q * -r2 * y2)\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2) = -p * -q * x1 * (-r1 * y1)\<^sup>\<circ> * --r1"
    by (smt (verit, del_insts) assms ite_context_true ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test)
  have "--p * --q * x2 * (-q * -r1 * y1 \<squnion> --q * -r2 * y2)\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2) = --p * --q * x2 * --q * (--q * (-q * -r1 * y1 \<squnion> --q * -r2 * y2))\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2)"
    by (smt (verit, del_insts) assms mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test preserves_test_neg)
  also have "... = --p * --q * x2 * --q * (--q * -r2 * y2)\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2)"
    using ite_context_false ite_def mult_assoc by auto
  finally have "--p * --q * x2 * (-q * -r1 * y1 \<squnion> --q * -r2 * y2)\<^sup>\<circ> * (-q * --r1 \<squnion> --q * --r2) = --p * --q * x2 * (-r2 * y2)\<^sup>\<circ> * --r2"
    by (smt (verit, del_insts) assms(3,5) ite_context_false ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test preserves_test_neg)
  thus ?thesis
    using 1 2 by (smt (z3) assms(1) assigns_def mult_assoc mult_right_dist_sup while_def ite_context_false ite_context_true tests_dual.sub_commutative)
qed

lemma while_it_norm:
  "assigns z (-p) (-q) \<Longrightarrow> preserves x (-q) \<Longrightarrow> preserves y (-q) \<Longrightarrow> z * (-p \<rhd> x * (-r \<star> y)) = z * (-q \<rhd> x) * (-q * -r \<star> y)"
  by (metis sup_bot_right tests_dual.sup_right_zero it_context_true it_ite tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)

lemma while_else_norm:
  "assigns z (-p) (-q) \<Longrightarrow> preserves x (-q) \<Longrightarrow> preserves y (-q) \<Longrightarrow> z * (1 \<lhd> -p \<rhd> x * (-r \<star> y)) = z * (1 \<lhd> -q \<rhd> x) * (--q * -r \<star> y)"
  by (metis sup_bot_left tests_dual.sup_right_zero ite_context_false tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)

lemma while_while_pre_norm:
  "-p \<star> x * (-q \<star> y) = -p \<rhd> x * (-p \<squnion> -q \<star> (y \<lhd> -q \<rhd> x))"
  by (smt sup_commute circ_sup_1 circ_left_unfold circ_slide it_def ite_def mult_assoc mult_left_one mult_right_dist_sup tests_dual.inf_demorgan while_def wnf_lemma_5)

text \<open>Theorem 7.2\<close>

lemma while_while_norm:
  "assigns z (-p) (-r) \<Longrightarrow> preserves x (-r) \<Longrightarrow> preserves y (-r) \<Longrightarrow> z * (-p \<star> x * (-q \<star> y)) = z * (-r \<rhd> x) * (-r * (-p \<squnion> -q) \<star> (y \<lhd> -q \<rhd> x))"
  by (smt tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite while_it_norm while_while_pre_norm)

lemma while_seq_replace:
  "assigns z (-p) (-q) \<Longrightarrow> z * (-p \<star> x * z) * y = z * (-q \<star> x * z) * y"
  by (smt assigns_def circ_slide mult_assoc tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_2 tests_dual.wnf_lemma_3 tests_dual.wnf_lemma_4 while_def)

lemma while_ite_replace:
  "assigns z (-p) (-q) \<Longrightarrow> z * (x \<lhd> -p \<rhd> y) = z * (x \<lhd> -q \<rhd> y)"
  by (smt assigns_def ite_def mult_assoc mult_left_dist_sup sub_comm tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_3)

lemma while_post_norm_an:
  assumes "preserves y (-p)"
    shows "(-p \<star> x) * y = y \<lhd> --p \<rhd> (-p \<star> x * (--p \<rhd> y))"
proof -
  have "-p * (-p * x * (--p * y \<squnion> -p))\<^sup>\<circ> * --p = -p * x * ((--p * y \<squnion> -p) * -p * x)\<^sup>\<circ> * (--p * y \<squnion> -p) * --p"
    by (metis circ_slide_1 while_def mult_assoc while_context_true)
  also have "... = -p * x * (--p * y * bot \<squnion> -p * x)\<^sup>\<circ> * --p * y"
    by (smt assms sup_bot_right mult_assoc tests_dual.sup_complement tests_dual.sup_idempotent mult_left_zero mult_right_dist_sup preserves_equation_test sub_comm)
  finally have "-p * (-p * x * (--p * y \<squnion> -p))\<^sup>\<circ> * --p = -p * x * (-p * x)\<^sup>\<circ> * --p * y"
    by (metis circ_sup_mult_zero sup_commute mult_assoc)
  thus ?thesis
    by (smt circ_left_unfold tests_dual.double_negation it_def ite_def mult_assoc mult_left_one mult_right_dist_sup while_def)
qed

lemma while_post_norm:
  "preserves y (-p) \<Longrightarrow> (-p \<star> x) * y = -p \<star> x * (1 \<lhd> -p \<rhd> y) \<lhd> -p \<rhd> y"
  using it_neg ite_neg while_post_norm_an by force

lemma wnf_lemma_9:
  assumes "assigns z (-p) (-q)"
      and "preserves x1 (-q)"
      and "preserves y1 (-q)"
      and "preserves x2 (-q)"
      and "preserves y2 (-q)"
      and "preserves x2 (-p)"
      and "preserves y2 (-p)"
    shows "z * (x1 \<lhd> -q \<rhd> x2) * (-q * -p \<squnion> -r \<star> (y1 \<lhd> -q * -p \<rhd> y2)) = z * (x1 \<lhd> -p \<rhd> x2) * (-p \<squnion> -r \<star> (y1 \<lhd> -p \<rhd> y2))"
proof -
  have "z * --p * --q * (x1 \<lhd> -q \<rhd> x2) * (-q * -p \<squnion> -r \<star> (y1 \<lhd> -q * -p \<rhd> y2)) = z * --p * --q * x2 * --q * (--q * (-q * -p \<squnion> -r) \<star> (y1 \<lhd> -q * -p \<rhd> y2))"
    by (smt (verit, del_insts) assms(3-5) tests_dual.double_negation ite_context_false mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context)
  also have "... = z * --p * --q * x2 * --q * (--q * -r \<star> --q * y2)"
    by (smt sup_bot_left tests_dual.double_negation ite_conjunction ite_context_false mult_assoc tests_dual.sup_complement mult_left_dist_sup mult_left_zero while_import_condition_2)
  also have "... = z * --p * --q * x2 * (-r \<star> y2)"
    by (metis assms(4,5) mult_assoc preserves_equation_test preserves_test_neg preserves_while_context while_import_condition_2)
  finally have 1: "z * --p * --q * (x1 \<lhd> -q \<rhd> x2) * (-q * -p \<squnion> -r \<star> (y1 \<lhd> -q * -p \<rhd> y2)) = z * --p * --q * (x1 \<lhd> -q \<rhd> x2) * (-p \<squnion> -r \<star> (y1 \<lhd> -p \<rhd> y2))"
    by (smt assms(6,7) ite_context_false mult_assoc preserves_equation_test sub_comm while_ite_context_false)
  have "z * -p * -q * (x1 \<lhd> -q \<rhd> x2) * (-q * -p \<squnion> -r \<star> (y1 \<lhd> -q * -p \<rhd> y2)) = z * -p * -q * (x1 \<lhd> -q \<rhd> x2) * -q * (-q * (-p \<squnion> -r) \<star> -q * (y1 \<lhd> -p \<rhd> y2))"
    by (smt (verit, del_insts) assms(2-5) tests_dual.double_negation ite_context_import mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
  hence "z * -p * -q * (x1 \<lhd> -q \<rhd> x2) * (-q * -p \<squnion> -r \<star> (y1 \<lhd> -q * -p \<rhd> y2)) = z * -p * -q * (x1 \<lhd> -q \<rhd> x2) * (-p \<squnion> -r \<star> (y1 \<lhd> -p \<rhd> y2))"
    by (smt assms(2-5) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
  thus ?thesis
    using 1 by (smt assms(1) assigns_def mult_assoc mult_left_dist_sup mult_right_dist_sup while_ite_replace)
qed

text \<open>Theorem 7.3\<close>

lemma while_seq_norm:
  assumes "assigns z1 (-r1) (-q)"
      and "preserves x2 (-q)"
      and "preserves y2 (-q)"
      and "preserves z2 (-q)"
      and "z1 * z2 = z2 * z1"
      and "assigns z2 (-q) (-r)"
      and "preserves y1 (-r)"
      and "preserves z1 (-r)"
      and "preserves x2 (-r)"
      and "preserves y2 (-r)"
    shows "x1 * z1 * z2 * (-r1 \<star> y1 * z1) * x2 * (-r2 \<star> y2) = x1 * z1 * z2 * (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> x2) * (-q \<squnion> -r2 \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2))"
proof -
  have 1: "preserves (y1 * z1 * (1 \<lhd> -q \<rhd> x2)) (-r)"
    by (simp add: assms(7-9) ite_def preserves_mult preserves_sup preserves_test)
  hence 2: "preserves (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2) (-r)"
    by (simp add: assms(10) preserves_ite)
  have "x1 * z1 * z2 * (-r1 \<star> y1 * z1) * x2 * (-r2 \<star> y2) = x1 * z1 * z2 * (-q \<star> y1 * z1) * x2 * (-r2 \<star> y2)"
    using assms(1,5) mult_assoc while_seq_replace by auto
  also have "... = x1 * z1 * z2 * (-q \<star> y1 * z1 * (1 \<lhd> -q \<rhd> x2 * (-r2 \<star> y2)) \<lhd> -q \<rhd> x2 * (-r2 \<star> y2))"
    by (smt assms(2,3) mult_assoc preserves_mult preserves_while while_post_norm)
  also have "... = x1 * z1 * (z2 * (-q \<star> y1 * z1 * (1 \<lhd> -q \<rhd> x2) * (--q * -r2 \<star> y2)) \<lhd> -q \<rhd> z2 * x2 * (-r2 \<star> y2))"
    by (smt assms(2-4) assigns_same mult_assoc preserves_import_ite while_else_norm)
  also have "... = x1 * z1 * (z2 * (-r \<rhd> y1 * z1 * (1 \<lhd> -q \<rhd> x2)) * (-r * (-q \<squnion> -r2) \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2)) \<lhd> -q \<rhd> z2 * x2 * (-r2 \<star> y2))"
    by (smt assms(6-10) tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_while_norm wnf_lemma_8)
  also have "... = x1 * z1 * z2 * ((-r \<rhd> y1 * z1 * (1 \<lhd> -q \<rhd> x2)) * (-r * (-q \<squnion> -r2) \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2)) \<lhd> -r \<rhd> x2 * (-r2 \<star> y2))"
    by (smt assms(4,6) mult_assoc preserves_import_ite while_ite_replace)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 \<lhd> -q \<rhd> x2)) * (-r * (-q \<squnion> -r2) \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2)) \<lhd> -r \<rhd> x2 * (-r2 \<star> y2))"
    by (smt mult_assoc it_context_true ite_import_true)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 \<lhd> -q \<rhd> x2)) * -r * (-r * (-q \<squnion> -r2) \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2)) \<lhd> -r \<rhd> x2 * (-r2 \<star> y2))"
    using 1 by (simp add: preserves_equation_test)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 \<lhd> -q \<rhd> x2)) * -r * (-q \<squnion> -r2 \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2)) \<lhd> -r \<rhd> x2 * (-r2 \<star> y2))"
    using 2 by (smt (z3) tests_dual.sba_dual.sub_sup_closed mult_assoc preserves_while_context)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 \<lhd> -q \<rhd> x2) * (-q \<squnion> -r2 \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2)) \<lhd> -q \<rhd> x2 * (-r2 \<star> y2))"
    by (smt assms(6-9) tests_dual.double_negation ite_import_true mult_assoc tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_one while_ite_replace)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -r \<rhd> x2) * ((-r * (-q \<squnion> -r2) \<squnion> --r * -r2) \<star> ((y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2) \<lhd> -r \<rhd> y2))"
    by (smt assms(6-10) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_ite_norm)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -r \<rhd> x2) * ((-r * (-q \<squnion> -r2) \<squnion> --r * -r2) \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -r * -q \<rhd> y2))"
    using ite_conjunction by simp
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -r \<rhd> x2) * ((-r * -q \<squnion> -r2) \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -r * -q \<rhd> y2))"
    by (smt (z3) mult_left_dist_sup sup_assoc tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> x2) * (-q \<squnion> -r2 \<star> (y1 * z1 * (1 \<lhd> -q \<rhd> x2) \<lhd> -q \<rhd> y2))"
    using 1 by (metis assms(2,3,6,9,10) mult_assoc wnf_lemma_9)
  finally show ?thesis
    .
qed

end

end


section\<open>Free Abelian Groups\<close>

theory Free_Abelian_Groups
  imports
    Product_Groups "HOL-Cardinals.Cardinal_Arithmetic"
   "HOL-Library.Countable_Set" "HOL-Library.Poly_Mapping" "HOL-Library.Equipollence"

begin

(*Move? But where?*)
lemma eqpoll_Fpow:
  assumes "infinite A" shows "Fpow A \<approx> A"
  unfolding eqpoll_iff_card_of_ordIso
  by (metis assms card_of_Fpow_infinite)

lemma infinite_iff_card_of_countable: "\<lbrakk>countable B; infinite B\<rbrakk> \<Longrightarrow> infinite A \<longleftrightarrow> ( |B| \<le>o |A| )"
  unfolding infinite_iff_countable_subset card_of_ordLeq countable_def
  by (force intro: card_of_ordLeqI ordLeq_transitive)

lemma iso_imp_eqpoll_carrier: "G \<cong> H \<Longrightarrow> carrier G \<approx> carrier H"
  by (auto simp: is_iso_def iso_def eqpoll_def)

subsection\<open>Generalised finite product\<close>

definition
  gfinprod :: "[('b, 'm) monoid_scheme, 'a \<Rightarrow> 'b, 'a set] \<Rightarrow> 'b"
  where "gfinprod G f A =
   (if finite {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>} then finprod G f {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>} else \<one>\<^bsub>G\<^esub>)"

context comm_monoid begin

lemma gfinprod_closed [simp]:
  "f \<in> A \<rightarrow> carrier G \<Longrightarrow> gfinprod G f A \<in> carrier G"
  unfolding gfinprod_def
  by (auto simp: image_subset_iff_funcset intro: finprod_closed)

lemma gfinprod_cong:
  "\<lbrakk>A = B; f \<in> B \<rightarrow> carrier G;
    \<And>i. i \<in> B =simp=> f i = g i\<rbrakk> \<Longrightarrow> gfinprod G f A = gfinprod G g B"
  unfolding gfinprod_def
  by (auto simp: simp_implies_def cong: conj_cong intro: finprod_cong)

lemma gfinprod_eq_finprod [simp]: "\<lbrakk>finite A; f \<in> A \<rightarrow> carrier G\<rbrakk> \<Longrightarrow> gfinprod G f A = finprod G f A"
  by (auto simp: gfinprod_def intro: finprod_mono_neutral_cong_left)

lemma gfinprod_insert [simp]:
  assumes "finite {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>}" "f \<in> A \<rightarrow> carrier G" "f i \<in> carrier G"
  shows "gfinprod G f (insert i A) = (if i \<in> A then gfinprod G f A else f i \<otimes> gfinprod G f A)"
proof -
  have f: "f \<in> {x \<in> A. f x \<noteq> \<one>} \<rightarrow> carrier G"
    using assms by (auto simp: image_subset_iff_funcset)
  have "{x. x = i \<and> f x \<noteq> \<one> \<or> x \<in> A \<and> f x \<noteq> \<one>} = (if f i = \<one> then {x \<in> A. f x \<noteq> \<one>} else insert i {x \<in> A. f x \<noteq> \<one>})"
    by auto
  then show ?thesis
    using assms
    unfolding gfinprod_def by (simp add: conj_disj_distribR insert_absorb f split: if_split_asm)
qed

lemma gfinprod_distrib:
  assumes fin: "finite {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>}" "finite {x \<in> A. g x \<noteq> \<one>\<^bsub>G\<^esub>}"
     and "f \<in> A \<rightarrow> carrier G" "g \<in> A \<rightarrow> carrier G"
  shows "gfinprod G (\<lambda>i. f i \<otimes> g i) A = gfinprod G f A \<otimes> gfinprod G g A"
proof -
  have "finite {x \<in> A. f x \<otimes> g x \<noteq> \<one>}"
    by (auto intro: finite_subset [OF _ finite_UnI [OF fin]])
  then have "gfinprod G (\<lambda>i. f i \<otimes> g i) A = gfinprod G (\<lambda>i. f i \<otimes> g i) ({i \<in> A. f i \<noteq> \<one>\<^bsub>G\<^esub>} \<union> {i \<in> A. g i \<noteq> \<one>\<^bsub>G\<^esub>})"
    unfolding gfinprod_def
    using assms by (force intro: finprod_mono_neutral_cong)
  also have "\<dots> = gfinprod G f A \<otimes> gfinprod G g A"
  proof -
    have "finprod G f ({i \<in> A. f i \<noteq> \<one>\<^bsub>G\<^esub>} \<union> {i \<in> A. g i \<noteq> \<one>\<^bsub>G\<^esub>}) = gfinprod G f A"
      "finprod G g ({i \<in> A. f i \<noteq> \<one>\<^bsub>G\<^esub>} \<union> {i \<in> A. g i \<noteq> \<one>\<^bsub>G\<^esub>}) = gfinprod G g A"
      using assms by (auto simp: gfinprod_def intro: finprod_mono_neutral_cong_right)
    moreover have "(\<lambda>i. f i \<otimes> g i) \<in> {i \<in> A. f i \<noteq> \<one>} \<union> {i \<in> A. g i \<noteq> \<one>} \<rightarrow> carrier G"
      using assms by (force simp: image_subset_iff_funcset)
    ultimately show ?thesis
      using assms
      apply simp
      apply (subst finprod_multf, auto)
      done
  qed
  finally show ?thesis .
qed

lemma gfinprod_mono_neutral_cong_left:
  assumes "A \<subseteq> B"
    and 1: "\<And>i. i \<in> B - A \<Longrightarrow> h i = \<one>"
    and gh: "\<And>x. x \<in> A \<Longrightarrow> g x = h x"
    and h: "h \<in> B \<rightarrow> carrier G"
  shows "gfinprod G g A = gfinprod G h B"
proof (cases "finite {x \<in> B. h x \<noteq> \<one>}")
  case True
  then have "finite {x \<in> A. h x \<noteq> \<one>}"
    apply (rule rev_finite_subset)
    using \<open>A \<subseteq> B\<close> by auto
  with True assms show ?thesis
    apply (simp add: gfinprod_def cong: conj_cong)
    apply (auto intro!: finprod_mono_neutral_cong_left)
    done
next
  case False
  have "{x \<in> B. h x \<noteq> \<one>} \<subseteq> {x \<in> A. h x \<noteq> \<one>}"
    using 1 by auto
  with False have "infinite {x \<in> A. h x \<noteq> \<one>}"
    using infinite_super by blast
  with False assms show ?thesis
    by (simp add: gfinprod_def cong: conj_cong)
qed

lemma gfinprod_mono_neutral_cong_right:
  assumes "A \<subseteq> B" "\<And>i. i \<in> B - A \<Longrightarrow> g i = \<one>" "\<And>x. x \<in> A \<Longrightarrow> g x = h x" "g \<in> B \<rightarrow> carrier G"
  shows "gfinprod G g B = gfinprod G h A"
  using assms  by (auto intro!: gfinprod_mono_neutral_cong_left [symmetric])

lemma gfinprod_mono_neutral_cong:
  assumes [simp]: "finite B" "finite A"
    and *: "\<And>i. i \<in> B - A \<Longrightarrow> h i = \<one>" "\<And>i. i \<in> A - B \<Longrightarrow> g i = \<one>"
    and gh: "\<And>x. x \<in> A \<inter> B \<Longrightarrow> g x = h x"
    and g: "g \<in> A \<rightarrow> carrier G"
    and h: "h \<in> B \<rightarrow> carrier G"
 shows "gfinprod G g A = gfinprod G h B"
proof-
  have "gfinprod G g A = gfinprod G g (A \<inter> B)"
    by (rule gfinprod_mono_neutral_cong_right) (use assms in auto)
  also have "\<dots> = gfinprod G h (A \<inter> B)"
    by (rule gfinprod_cong) (use assms in auto)
  also have "\<dots> = gfinprod G h B"
    by (rule gfinprod_mono_neutral_cong_left) (use assms in auto)
  finally show ?thesis .
qed

end

lemma (in comm_group) hom_group_sum:
  assumes hom: "\<And>i. i \<in> I \<Longrightarrow> f i \<in> hom (A i) G" and grp: "\<And>i. i \<in> I \<Longrightarrow> group (A i)"
  shows "(\<lambda>x. gfinprod G (\<lambda>i. (f i) (x i)) I) \<in> hom (sum_group I A) G"
  unfolding hom_def
proof (intro CollectI conjI ballI)
  show "(\<lambda>x. gfinprod G (\<lambda>i. f i (x i)) I) \<in> carrier (sum_group I A) \<rightarrow> carrier G"
    using assms
    by (force simp: hom_def carrier_sum_group intro: gfinprod_closed simp flip: image_subset_iff_funcset)
next
  fix x y
  assume x: "x \<in> carrier (sum_group I A)" and y: "y \<in> carrier (sum_group I A)"
  then have finx: "finite {i \<in> I. x i \<noteq> \<one>\<^bsub>A i\<^esub>}" and finy: "finite {i \<in> I. y i \<noteq> \<one>\<^bsub>A i\<^esub>}"
    using assms by (auto simp: carrier_sum_group)
  have finfx: "finite {i \<in> I. f i (x i) \<noteq> \<one>}"
    using assms by (auto simp: is_group hom_one [OF hom] intro: finite_subset [OF _ finx])
  have finfy: "finite {i \<in> I. f i (y i) \<noteq> \<one>}"
    using assms by (auto simp: is_group hom_one [OF hom] intro: finite_subset [OF _ finy])
  have carr: "f i (x i) \<in> carrier G"  "f i (y i) \<in> carrier G" if "i \<in> I" for i
    using hom_carrier [OF hom] that x y assms
    by (fastforce simp add: carrier_sum_group)+
  have lam: "(\<lambda>i. f i ( x i \<otimes>\<^bsub>A i\<^esub> y i)) \<in> I \<rightarrow> carrier G"
    using x y assms by (auto simp: hom_def carrier_sum_group PiE_def Pi_def)
  have lam': "(\<lambda>i. f i (if i \<in> I then x i \<otimes>\<^bsub>A i\<^esub> y i else undefined)) \<in> I \<rightarrow> carrier G"
    by (simp add: lam Pi_cong)
  with lam x y assms
  show "gfinprod G (\<lambda>i. f i ((x \<otimes>\<^bsub>sum_group I A\<^esub> y) i)) I
      = gfinprod G (\<lambda>i. f i (x i)) I \<otimes> gfinprod G (\<lambda>i. f i (y i)) I"
    by (simp add: carrier_sum_group PiE_def Pi_def hom_mult [OF hom]
                  gfinprod_distrib finfx finfy carr cong: gfinprod_cong)
qed

subsection\<open>Free Abelian groups on a set, using the "frag" type constructor.          \<close>

definition free_Abelian_group :: "'a set \<Rightarrow> ('a \<Rightarrow>\<^sub>0 int) monoid"
  where "free_Abelian_group S = \<lparr>carrier = {c. Poly_Mapping.keys c \<subseteq> S}, monoid.mult = (+), one  = 0\<rparr>"

lemma group_free_Abelian_group [simp]: "group (free_Abelian_group S)"
proof -
  have "\<And>x. Poly_Mapping.keys x \<subseteq> S \<Longrightarrow> x \<in> Units (free_Abelian_group S)"
    unfolding free_Abelian_group_def Units_def
    by clarsimp (metis eq_neg_iff_add_eq_0 neg_eq_iff_add_eq_0 keys_minus)
  then show ?thesis
    unfolding free_Abelian_group_def
    by unfold_locales (auto simp: dest: subsetD [OF keys_add])
qed

lemma carrier_free_Abelian_group_iff [simp]:
  shows "x \<in> carrier (free_Abelian_group S) \<longleftrightarrow> Poly_Mapping.keys x \<subseteq> S"
  by (auto simp: free_Abelian_group_def)

lemma one_free_Abelian_group [simp]: "\<one>\<^bsub>free_Abelian_group S\<^esub> = 0"
  by (auto simp: free_Abelian_group_def)

lemma mult_free_Abelian_group [simp]: "x \<otimes>\<^bsub>free_Abelian_group S\<^esub> y = x + y"
  by (auto simp: free_Abelian_group_def)

lemma inv_free_Abelian_group [simp]: "Poly_Mapping.keys x \<subseteq> S \<Longrightarrow> inv\<^bsub>free_Abelian_group S\<^esub> x = -x"
  by (rule group.inv_equality [OF group_free_Abelian_group]) auto

lemma abelian_free_Abelian_group: "comm_group(free_Abelian_group S)"
  apply (rule group.group_comm_groupI [OF group_free_Abelian_group])
  by (simp add: free_Abelian_group_def)

lemma pow_free_Abelian_group [simp]:
  fixes n::nat
  shows "Group.pow (free_Abelian_group S) x n = frag_cmul (int n) x"
  by (induction n) (auto simp: nat_pow_def free_Abelian_group_def frag_cmul_distrib)

lemma int_pow_free_Abelian_group [simp]:
  fixes n::int
  assumes "Poly_Mapping.keys x \<subseteq> S"
  shows "Group.pow (free_Abelian_group S) x n = frag_cmul n x"
proof (induction n)
  case (nonneg n)
  then show ?case
    by (simp add: int_pow_int)
next
  case (neg n)
  have "x [^]\<^bsub>free_Abelian_group S\<^esub> - int (Suc n)
     = inv\<^bsub>free_Abelian_group S\<^esub> (x [^]\<^bsub>free_Abelian_group S\<^esub> int (Suc n))"
    by (rule group.int_pow_neg [OF group_free_Abelian_group]) (use assms in \<open>simp add: free_Abelian_group_def\<close>)
  also have "\<dots> = frag_cmul (- int (Suc n)) x"
    by (metis assms inv_free_Abelian_group pow_free_Abelian_group int_pow_int minus_frag_cmul
              order_trans keys_cmul)
  finally show ?case .
qed

lemma frag_of_in_free_Abelian_group [simp]:
   "frag_of x \<in> carrier(free_Abelian_group S) \<longleftrightarrow> x \<in> S"
  by simp

lemma free_Abelian_group_induct:
  assumes major: "Poly_Mapping.keys x \<subseteq> S"
      and minor: "P(0)"
           "\<And>x y. \<lbrakk>Poly_Mapping.keys x \<subseteq> S; Poly_Mapping.keys y \<subseteq> S; P x; P y\<rbrakk> \<Longrightarrow> P(x-y)"
           "\<And>a. a \<in> S \<Longrightarrow> P(frag_of a)"
         shows "P x"
proof -
  have "Poly_Mapping.keys x \<subseteq> S \<and> P x"
    using major
  proof (induction x rule: frag_induction)
    case (diff a b)
    then show ?case
      by (meson Un_least minor(2) order.trans keys_diff)
  qed (auto intro: minor)
  then show ?thesis ..
qed

lemma sum_closed_free_Abelian_group:
    "(\<And>i. i \<in> I \<Longrightarrow> x i \<in> carrier (free_Abelian_group S)) \<Longrightarrow> sum x I \<in> carrier (free_Abelian_group S)"
  apply (induction I rule: infinite_finite_induct, auto)
  by (metis (no_types, hide_lams) UnE subsetCE keys_add)

lemma (in comm_group) free_Abelian_group_universal:
  fixes f :: "'c \<Rightarrow> 'a"
  assumes "f ` S \<subseteq> carrier G"
  obtains h where "h \<in> hom (free_Abelian_group S) G" "\<And>x. x \<in> S \<Longrightarrow> h(frag_of x) = f x"
proof
  have fin: "Poly_Mapping.keys u \<subseteq> S \<Longrightarrow> finite {x \<in> S. f x [^] poly_mapping.lookup u x \<noteq> \<one>}" for u :: "'c \<Rightarrow>\<^sub>0 int"
    apply (rule finite_subset [OF _ finite_keys [of u]])
    unfolding keys.rep_eq by force
  define h :: "('c \<Rightarrow>\<^sub>0 int) \<Rightarrow> 'a"
    where "h \<equiv> \<lambda>x. gfinprod G (\<lambda>a. f a [^] poly_mapping.lookup x a) S"
  show "h \<in> hom (free_Abelian_group S) G"
  proof (rule homI)
    fix x y
    assume xy: "x \<in> carrier (free_Abelian_group S)" "y \<in> carrier (free_Abelian_group S)"
    then show "h (x \<otimes>\<^bsub>free_Abelian_group S\<^esub> y) = h x \<otimes> h y"
      using assms unfolding h_def free_Abelian_group_def
      by (simp add: fin gfinprod_distrib image_subset_iff Poly_Mapping.lookup_add int_pow_mult cong: gfinprod_cong)
  qed (use assms in \<open>force simp: free_Abelian_group_def h_def intro: gfinprod_closed\<close>)
  show "h(frag_of x) = f x" if "x \<in> S" for x
  proof -
    have fin: "(\<lambda>a. f x [^] (1::int)) \<in> {x} \<rightarrow> carrier G" "f x [^] (1::int) \<in> carrier G"
      using assms that by force+
    show ?thesis
      by (cases " f x [^] (1::int) = \<one>") (use assms that in \<open>auto simp: h_def gfinprod_def finprod_singleton\<close>)
  qed
qed

lemma eqpoll_free_Abelian_group_infinite:
  assumes "infinite A" shows "carrier(free_Abelian_group A) \<approx> A"
proof (rule lepoll_antisym)
  have "carrier (free_Abelian_group A) \<lesssim> {f::'a\<Rightarrow>int. f ` A \<subseteq> UNIV \<and> {x. f x \<noteq> 0} \<subseteq> A \<and> finite {x. f x \<noteq> 0}}"
    unfolding lepoll_def
    by (rule_tac x="Poly_Mapping.lookup" in exI) (auto simp: poly_mapping_eqI lookup_not_eq_zero_eq_in_keys inj_onI)
  also have "\<dots> \<lesssim> Fpow (A \<times> (UNIV::int set))"
    by (rule lepoll_restricted_funspace)
  also have "\<dots> \<approx> A \<times> (UNIV::int set)"
  proof (rule eqpoll_Fpow)
    show "infinite (A \<times> (UNIV::int set))"
      using assms finite_cartesian_productD1 by fastforce
  qed
  also have "\<dots> \<approx> A"
    unfolding eqpoll_iff_card_of_ordIso
  proof -
    have "|A \<times> (UNIV::int set)| <=o |A|"
      by (simp add: assms card_of_Times_ordLeq_infinite flip: infinite_iff_card_of_countable)
    moreover have "|A| \<le>o |A \<times> (UNIV::int set)|"
      by simp
    ultimately have "|A| *c |(UNIV::int set)| =o |A|"
      by (simp add: cprod_def ordIso_iff_ordLeq)
    then show "|A \<times> (UNIV::int set)| =o |A|"
      by (metis Times_cprod ordIso_transitive)
  qed
  finally show "carrier (free_Abelian_group A) \<lesssim> A" .
  have "inj_on frag_of A"
    by (simp add: frag_of_eq inj_on_def)
  moreover have "frag_of ` A \<subseteq> carrier (free_Abelian_group A)"
    by (simp add: image_subsetI)
  ultimately show "A \<lesssim> carrier (free_Abelian_group A)"
    by (force simp: lepoll_def)
qed

proposition (in comm_group) eqpoll_homomorphisms_from_free_Abelian_group:
   "{f. f \<in> extensional (carrier(free_Abelian_group S)) \<and> f \<in> hom (free_Abelian_group S) G}
    \<approx> (S \<rightarrow>\<^sub>E carrier G)"  (is "?lhs \<approx> ?rhs")
  unfolding eqpoll_def bij_betw_def
proof (intro exI conjI)
  let ?f = "\<lambda>f. restrict (f \<circ> frag_of) S"
  show "inj_on ?f ?lhs"
  proof (clarsimp simp: inj_on_def)
    fix g h
    assume
      g: "g \<in> extensional (carrier (free_Abelian_group S))" "g \<in> hom (free_Abelian_group S) G"
      and h: "h \<in> extensional (carrier (free_Abelian_group S))" "h \<in> hom (free_Abelian_group S) G"
      and eq: "restrict (g \<circ> frag_of) S = restrict (h \<circ> frag_of) S"
    have 0: "0 \<in> carrier (free_Abelian_group S)"
      by simp
    interpret hom_g: group_hom "free_Abelian_group S" G g
      using g by (auto simp: group_hom_def group_hom_axioms_def is_group)
    interpret hom_h: group_hom "free_Abelian_group S" G h
      using h by (auto simp: group_hom_def group_hom_axioms_def is_group)
    have "Poly_Mapping.keys c \<subseteq> S \<Longrightarrow> Poly_Mapping.keys c \<subseteq> S \<and> g c = h c" for c
    proof (induction c rule: frag_induction)
      case zero
      show ?case
        using hom_g.hom_one hom_h.hom_one by auto
    next
      case (one x)
      then show ?case
        using eq by (simp add: fun_eq_iff) (metis comp_def)
    next
      case (diff a b)
      then show ?case
        using hom_g.hom_mult hom_h.hom_mult hom_g.hom_inv hom_h.hom_inv
        apply (auto simp: dest: subsetD [OF keys_diff])
        by (metis keys_minus uminus_add_conv_diff)
    qed
    then show "g = h"
      by (meson g h carrier_free_Abelian_group_iff extensionalityI)
  qed
  have "f \<in> (\<lambda>f. restrict (f \<circ> frag_of) S) `
            {f \<in> extensional (carrier (free_Abelian_group S)). f \<in> hom (free_Abelian_group S) G}"
    if f: "f \<in> S \<rightarrow>\<^sub>E carrier G"
    for f :: "'c \<Rightarrow> 'a"
  proof -
    obtain h where h: "h \<in> hom (free_Abelian_group S) G" "\<And>x. x \<in> S \<Longrightarrow> h(frag_of x) = f x"
    proof (rule free_Abelian_group_universal)
      show "f ` S \<subseteq> carrier G"
        using f by blast
    qed auto
    let ?h = "restrict h (carrier (free_Abelian_group S))"
    show ?thesis
    proof
      show "f = restrict (?h \<circ> frag_of) S"
        using f by (force simp: h)
      show "?h \<in> {f \<in> extensional (carrier (free_Abelian_group S)). f \<in> hom (free_Abelian_group S) G}"
        using h by (auto simp: hom_def dest!: subsetD [OF keys_add])
    qed
  qed
  then show "?f ` ?lhs = S \<rightarrow>\<^sub>E carrier G"
    by (auto simp: hom_def Ball_def Pi_def)
qed

lemma hom_frag_minus:
  assumes "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \<subseteq> S"
  shows "h (-a) = - (h a)"
proof -
  have "Poly_Mapping.keys (h a) \<subseteq> T"
    by (meson assms carrier_free_Abelian_group_iff hom_in_carrier)
  then show ?thesis
    by (metis (no_types) assms carrier_free_Abelian_group_iff group_free_Abelian_group group_hom.hom_inv group_hom_axioms_def group_hom_def inv_free_Abelian_group)
qed

lemma hom_frag_add:
  assumes "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \<subseteq> S" "Poly_Mapping.keys b \<subseteq> S"
  shows "h (a+b) = h a + h b"
proof -
  have "Poly_Mapping.keys (h a) \<subseteq> T"
    by (meson assms carrier_free_Abelian_group_iff hom_in_carrier)
  moreover
  have "Poly_Mapping.keys (h b) \<subseteq> T"
    by (meson assms carrier_free_Abelian_group_iff hom_in_carrier)
  ultimately show ?thesis
    using assms hom_mult by fastforce
qed

lemma hom_frag_diff:
  assumes "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \<subseteq> S" "Poly_Mapping.keys b \<subseteq> S"
  shows "h (a-b) = h a - h b"
  by (metis (no_types, lifting) assms diff_conv_add_uminus hom_frag_add hom_frag_minus keys_minus)

proposition isomorphic_free_Abelian_groups:
   "free_Abelian_group S \<cong> free_Abelian_group T \<longleftrightarrow> S \<approx> T"  (is "(?FS \<cong> ?FT) = ?rhs")
proof
  interpret S: group "?FS"
    by simp
  interpret T: group "?FT"
    by simp
  interpret G2: comm_group "integer_mod_group 2"
    by (rule abelian_integer_mod_group)
  let ?Two = "{0..<2::int}"
  have [simp]: "\<not> ?Two \<subseteq> {a}" for a
    by (simp add: subset_iff) presburger
  assume L: "?FS \<cong> ?FT"
  let ?HS = "{h \<in> extensional (carrier ?FS). h \<in> hom ?FS (integer_mod_group 2)}"
  let ?HT = "{h \<in> extensional (carrier ?FT). h \<in> hom ?FT (integer_mod_group 2)}"
  have "S \<rightarrow>\<^sub>E ?Two \<approx> ?HS"
    apply (rule eqpoll_sym)
    using G2.eqpoll_homomorphisms_from_free_Abelian_group by (simp add: carrier_integer_mod_group)
  also have "\<dots> \<approx> ?HT"
  proof -
    obtain f g where "group_isomorphisms ?FS ?FT f g"
      using L S.iso_iff_group_isomorphisms by (force simp: is_iso_def)
    then have f: "f \<in> hom ?FS ?FT"
      and g: "g \<in> hom ?FT ?FS"
      and gf: "\<forall>x \<in> carrier ?FS. g(f x) = x"
      and fg: "\<forall>y \<in> carrier ?FT. f(g y) = y"
      by (auto simp: group_isomorphisms_def)
    let ?f = "\<lambda>h. restrict (h \<circ> g) (carrier ?FT)"
    let ?g = "\<lambda>h. restrict (h \<circ> f) (carrier ?FS)"
    show ?thesis
    proof (rule lepoll_antisym)
      show "?HS \<lesssim> ?HT"
        unfolding lepoll_def
      proof (intro exI conjI)
        show "inj_on ?f ?HS"
          apply (rule inj_on_inverseI [where g = ?g])
          using hom_in_carrier [OF f]
          by (auto simp: gf fun_eq_iff carrier_integer_mod_group Ball_def Pi_def extensional_def)
        show "?f ` ?HS \<subseteq> ?HT"
        proof clarsimp
          fix h
          assume h: "h \<in> hom ?FS (integer_mod_group 2)"
          have "h \<circ> g \<in> hom ?FT (integer_mod_group 2)"
            by (rule hom_compose [OF g h])
          moreover have "restrict (h \<circ> g) (carrier ?FT) x = (h \<circ> g) x" if "x \<in> carrier ?FT" for x
            using g that by (simp add: hom_def)
          ultimately show "restrict (h \<circ> g) (carrier ?FT) \<in> hom ?FT (integer_mod_group 2)"
            using T.hom_restrict by fastforce
        qed
      qed
    next
      show "?HT \<lesssim> ?HS"
        unfolding lepoll_def
      proof (intro exI conjI)
        show "inj_on ?g ?HT"
          apply (rule inj_on_inverseI [where g = ?f])
          using hom_in_carrier [OF g]
          by (auto simp: fg fun_eq_iff carrier_integer_mod_group Ball_def Pi_def extensional_def)
        show "?g ` ?HT \<subseteq> ?HS"
        proof clarsimp
          fix k
          assume k: "k \<in> hom ?FT (integer_mod_group 2)"
          have "k \<circ> f \<in> hom ?FS (integer_mod_group 2)"
            by (rule hom_compose [OF f k])
          moreover have "restrict (k \<circ> f) (carrier ?FS) x = (k \<circ> f) x" if "x \<in> carrier ?FS" for x
            using f that by (simp add: hom_def)
          ultimately show "restrict (k \<circ> f) (carrier ?FS) \<in> hom ?FS (integer_mod_group 2)"
            using S.hom_restrict by fastforce
        qed
      qed
    qed
  qed
  also have "\<dots> \<approx> T \<rightarrow>\<^sub>E ?Two"
    using G2.eqpoll_homomorphisms_from_free_Abelian_group by (simp add: carrier_integer_mod_group)
  finally have *: "S \<rightarrow>\<^sub>E ?Two \<approx> T \<rightarrow>\<^sub>E ?Two" .
  then have "finite (S \<rightarrow>\<^sub>E ?Two) \<longleftrightarrow> finite (T \<rightarrow>\<^sub>E ?Two)"
    by (rule eqpoll_finite_iff)
  then have "finite S \<longleftrightarrow> finite T"
    by (auto simp: finite_funcset_iff)
  then consider "finite S" "finite T" | "~ finite S" "~ finite T"
    by blast
  then show ?rhs
  proof cases
    case 1
    with * have "2 ^ card S = (2::nat) ^ card T"
      by (simp add: card_PiE finite_PiE eqpoll_iff_card)
    then have "card S = card T"
      by auto
    then show ?thesis
      using eqpoll_iff_card 1 by blast
  next
    case 2
    have "carrier (free_Abelian_group S) \<approx> carrier (free_Abelian_group T)"
      using L by (simp add: iso_imp_eqpoll_carrier)
    then show ?thesis
      using 2 eqpoll_free_Abelian_group_infinite eqpoll_sym eqpoll_trans by metis
  qed
next
  assume ?rhs
  then obtain f g where f: "\<And>x. x \<in> S \<Longrightarrow> f x \<in> T \<and> g(f x) = x"
                    and g: "\<And>y. y \<in> T \<Longrightarrow> g y \<in> S \<and> f(g y) = y"
    using eqpoll_iff_bijections by metis
  interpret S: comm_group "?FS"
    by (simp add: abelian_free_Abelian_group)
  interpret T: comm_group "?FT"
    by (simp add: abelian_free_Abelian_group)
  have "(frag_of \<circ> f) ` S \<subseteq> carrier (free_Abelian_group T)"
    using f by auto
  then obtain h where h: "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)"
    and h_frag: "\<And>x. x \<in> S \<Longrightarrow> h (frag_of x) = (frag_of \<circ> f) x"
    using T.free_Abelian_group_universal [of "frag_of \<circ> f" S] by blast
  interpret hhom: group_hom "free_Abelian_group S" "free_Abelian_group T" h
    by (simp add: h group_hom_axioms_def group_hom_def)
  have "(frag_of \<circ> g) ` T \<subseteq> carrier (free_Abelian_group S)"
    using g by auto
  then obtain k where k: "k \<in> hom (free_Abelian_group T) (free_Abelian_group S)"
    and k_frag: "\<And>x. x \<in> T \<Longrightarrow> k (frag_of x) = (frag_of \<circ> g) x"
    using S.free_Abelian_group_universal [of "frag_of \<circ> g" T] by blast
  interpret khom: group_hom "free_Abelian_group T" "free_Abelian_group S" k
    by (simp add: k group_hom_axioms_def group_hom_def)
  have kh: "Poly_Mapping.keys x \<subseteq> S \<Longrightarrow> Poly_Mapping.keys x \<subseteq> S \<and> k (h x) = x" for x
  proof (induction rule: frag_induction)
    case zero
    then show ?case
      apply auto
      by (metis group_free_Abelian_group h hom_one k one_free_Abelian_group)
  next
    case (one x)
    then show ?case
      by (auto simp: h_frag k_frag f)
  next
    case (diff a b)
    with keys_diff have "Poly_Mapping.keys (a - b) \<subseteq> S"
      by (metis Un_least order_trans)
    with diff hhom.hom_closed show ?case
      by (simp add: hom_frag_diff [OF h] hom_frag_diff [OF k])
  qed
  have hk: "Poly_Mapping.keys y \<subseteq> T \<Longrightarrow> Poly_Mapping.keys y \<subseteq> T \<and> h (k y) = y" for y
  proof (induction rule: frag_induction)
    case zero
    then show ?case
      apply auto
      by (metis group_free_Abelian_group h hom_one k one_free_Abelian_group)
  next
    case (one y)
    then show ?case
      by (auto simp: h_frag k_frag g)
  next
    case (diff a b)
    with keys_diff have "Poly_Mapping.keys (a - b) \<subseteq> T"
      by (metis Un_least order_trans)
    with diff khom.hom_closed show ?case
      by (simp add: hom_frag_diff [OF h] hom_frag_diff [OF k])
  qed
  have "h \<in> iso ?FS ?FT"
    unfolding iso_def bij_betw_iff_bijections mem_Collect_eq
  proof (intro conjI exI ballI h)
    fix x
    assume x: "x \<in> carrier (free_Abelian_group S)"
    show "h x \<in> carrier (free_Abelian_group T)"
      by (meson x h hom_in_carrier)
    show "k (h x) = x"
      using x by (simp add: kh)
  next
    fix y
    assume y: "y \<in> carrier (free_Abelian_group T)"
    show "k y \<in> carrier (free_Abelian_group S)"
      by (meson y k hom_in_carrier)
    show "h (k y) = y"
      using y by (simp add: hk)
  qed
  then show "?FS \<cong> ?FT"
    by (auto simp: is_iso_def)
qed

lemma isomorphic_group_integer_free_Abelian_group_singleton:
  "integer_group \<cong> free_Abelian_group {x}"
proof -
  have "(\<lambda>n. frag_cmul n (frag_of x)) \<in> iso integer_group (free_Abelian_group {x})"
  proof (rule isoI [OF homI])
    show "bij_betw (\<lambda>n. frag_cmul n (frag_of x)) (carrier integer_group) (carrier (free_Abelian_group {x}))"
      apply (rule bij_betwI [where g = "\<lambda>y. Poly_Mapping.lookup y x"])
      by (auto simp: integer_group_def in_keys_iff intro!: poly_mapping_eqI)
  qed (auto simp: frag_cmul_distrib)
  then show ?thesis
    unfolding is_iso_def
    by blast
qed

lemma group_hom_free_Abelian_groups_id:
  "id \<in> hom (free_Abelian_group S) (free_Abelian_group T) \<longleftrightarrow> S \<subseteq> T"
proof -
  have "x \<in> T" if ST: "\<And>c:: 'a \<Rightarrow>\<^sub>0 int. Poly_Mapping.keys c \<subseteq> S \<longrightarrow> Poly_Mapping.keys c \<subseteq> T" and "x \<in> S" for x
    using ST [of "frag_of x"] \<open>x \<in> S\<close> by simp
  then show ?thesis
    by (auto simp: hom_def free_Abelian_group_def Pi_def)
qed

proposition iso_free_Abelian_group_sum:
  assumes "pairwise (\<lambda>i j. disjnt (S i) (S j)) I"
  shows "(\<lambda>f. sum' f I) \<in> iso (sum_group I (\<lambda>i. free_Abelian_group(S i))) (free_Abelian_group (\<Union>(S ` I)))"
    (is "?h \<in> iso ?G ?H")
proof (rule isoI)
  show hom: "?h \<in> hom ?G ?H"
  proof (rule homI)
    show "?h c \<in> carrier ?H" if "c \<in> carrier ?G" for c
      using that
      apply (simp add: sum.G_def carrier_sum_group)
      apply (rule order_trans [OF keys_sum])
      apply (auto simp: free_Abelian_group_def)
      done
    show "?h (x \<otimes>\<^bsub>?G\<^esub> y) = ?h x \<otimes>\<^bsub>?H\<^esub> ?h y"
      if "x \<in> carrier ?G" "y \<in> carrier ?G"  for x y
      using that by (simp add: sum.finite_Collect_op carrier_sum_group sum.distrib')
  qed
  interpret GH: group_hom "?G" "?H" "?h"
    using hom by (simp add: group_hom_def group_hom_axioms_def)
  show "bij_betw ?h (carrier ?G) (carrier ?H)"
    unfolding bij_betw_def
  proof (intro conjI subset_antisym)
    show "?h ` carrier ?G \<subseteq> carrier ?H"
      apply (clarsimp simp: sum.G_def carrier_sum_group simp del: carrier_free_Abelian_group_iff)
      by (force simp: PiE_def Pi_iff intro!: sum_closed_free_Abelian_group)
    have *: "poly_mapping.lookup (Abs_poly_mapping (\<lambda>j. if j \<in> S i then poly_mapping.lookup x j else 0)) k
           = (if k \<in> S i then poly_mapping.lookup x k else 0)" if "i \<in> I" for i k and x :: "'b \<Rightarrow>\<^sub>0 int"
      using that by (auto simp: conj_commute cong: conj_cong)
    have eq: "Abs_poly_mapping (\<lambda>j. if j \<in> S i then poly_mapping.lookup x j else 0) = 0
     \<longleftrightarrow> (\<forall>c \<in> S i. poly_mapping.lookup x c = 0)" if "i \<in> I" for i and x :: "'b \<Rightarrow>\<^sub>0 int"
      apply (auto simp: poly_mapping_eq_iff fun_eq_iff)
      apply (simp add: * Abs_poly_mapping_inverse conj_commute cong: conj_cong)
      apply (force dest!: spec split: if_split_asm)
      done
    have "x \<in> ?h ` {x \<in> \<Pi>\<^sub>E i\<in>I. {c. Poly_Mapping.keys c \<subseteq> S i}. finite {i \<in> I. x i \<noteq> 0}}"
      if x: "Poly_Mapping.keys x \<subseteq> \<Union> (S ` I)" for x :: "'b \<Rightarrow>\<^sub>0 int"
    proof -
      let ?f = "(\<lambda>i c. if c \<in> S i then Poly_Mapping.lookup x c else 0)"
      define J where "J \<equiv> {i \<in> I. \<exists>c\<in>S i. c \<in> Poly_Mapping.keys x}"
      have "J \<subseteq> (\<lambda>c. THE i. i \<in> I \<and> c \<in> S i) ` Poly_Mapping.keys x"
      proof (clarsimp simp: J_def)
        show "i \<in> (\<lambda>c. THE i. i \<in> I \<and> c \<in> S i) ` Poly_Mapping.keys x"
          if "i \<in> I" "c \<in> S i" "c \<in> Poly_Mapping.keys x" for i c
        proof
          show "i = (THE i. i \<in> I \<and> c \<in> S i)"
            using assms that by (auto simp: pairwise_def disjnt_def intro: the_equality [symmetric])
        qed (simp add: that)
      qed
      then have fin: "finite J"
        using finite_subset finite_keys by blast
      have [simp]: "Poly_Mapping.keys (Abs_poly_mapping (?f i)) = {k. ?f i k \<noteq> 0}" if "i \<in> I" for i
        by (simp add: eq_onp_def keys.abs_eq conj_commute cong: conj_cong)
      have [simp]: "Poly_Mapping.lookup (Abs_poly_mapping (?f i)) c = ?f i c" if "i \<in> I" for i c
        by (auto simp: Abs_poly_mapping_inverse conj_commute cong: conj_cong)
      show ?thesis
      proof
        have "poly_mapping.lookup x c = poly_mapping.lookup (?h (\<lambda>i\<in>I. Abs_poly_mapping (?f i))) c"
          for c
        proof (cases "c \<in> Poly_Mapping.keys x")
          case True
          then obtain i where "i \<in> I" "c \<in> S i" "?f i c \<noteq> 0"
            using x by (auto simp: in_keys_iff)
          then have 1: "poly_mapping.lookup (sum' (\<lambda>j. Abs_poly_mapping (?f j)) (I - {i})) c = 0"
            using assms
            apply (simp add: sum.G_def Poly_Mapping.lookup_sum pairwise_def disjnt_def)
            apply (force simp: eq split: if_split_asm intro!: comm_monoid_add_class.sum.neutral)
            done
          have 2: "poly_mapping.lookup x c = poly_mapping.lookup (Abs_poly_mapping (?f i)) c"
            by (auto simp: \<open>c \<in> S i\<close> Abs_poly_mapping_inverse conj_commute cong: conj_cong)
          have "finite {i \<in> I. Abs_poly_mapping (?f i) \<noteq> 0}"
            by (rule finite_subset [OF _ fin]) (use \<open>i \<in> I\<close> J_def eq in \<open>auto simp: in_keys_iff\<close>)
          with \<open>i \<in> I\<close> have "?h (\<lambda>j\<in>I. Abs_poly_mapping (?f j)) = Abs_poly_mapping (?f i) + sum' (\<lambda>j. Abs_poly_mapping (?f j)) (I - {i})"
            by (simp add: sum_diff1')
          then show ?thesis
            by (simp add: 1 2 Poly_Mapping.lookup_add)
        next
          case False
          then have "poly_mapping.lookup x c = 0"
            using keys.rep_eq by force
          then show ?thesis
            unfolding sum.G_def by (simp add: lookup_sum * comm_monoid_add_class.sum.neutral)
        qed
        then show "x = ?h (\<lambda>i\<in>I. Abs_poly_mapping (?f i))"
          by (rule poly_mapping_eqI)
        have "(\<lambda>i. Abs_poly_mapping (?f i)) \<in> (\<Pi> i\<in>I. {c. Poly_Mapping.keys c \<subseteq> S i})"
          by (auto simp: PiE_def Pi_def in_keys_iff)
        then show "(\<lambda>i\<in>I. Abs_poly_mapping (?f i))
                 \<in> {x \<in> \<Pi>\<^sub>E i\<in>I. {c. Poly_Mapping.keys c \<subseteq> S i}. finite {i \<in> I. x i \<noteq> 0}}"
          using fin unfolding J_def by (simp add: eq in_keys_iff cong: conj_cong)
      qed
    qed
    then show "carrier ?H \<subseteq> ?h ` carrier ?G"
      by (simp add: carrier_sum_group) (auto simp: free_Abelian_group_def)
    show "inj_on ?h (carrier (sum_group I (\<lambda>i. free_Abelian_group (S i))))"
      unfolding GH.inj_on_one_iff
    proof clarify
      fix x
      assume "x \<in> carrier ?G" "?h x = \<one>\<^bsub>?H\<^esub>"
      then have eq0: "sum' x I = 0"
        and xs: "\<And>i. i \<in> I \<Longrightarrow> Poly_Mapping.keys (x i) \<subseteq> S i" and xext: "x \<in> extensional I"
        and fin: "finite {i \<in> I. x i \<noteq> 0}"
        by (simp_all add: carrier_sum_group PiE_def Pi_def)
      have "x i = 0" if "i \<in> I" for i
      proof -
        have "sum' x (insert i (I - {i})) = 0"
          using eq0 that by (simp add: insert_absorb)
        moreover have "Poly_Mapping.keys (sum' x (I - {i})) = {}"
        proof -
          have "x i = - sum' x (I - {i})"
            by (metis (mono_tags, lifting) diff_zero eq0 fin sum_diff1' minus_diff_eq that)
          then have "Poly_Mapping.keys (x i) = Poly_Mapping.keys (sum' x (I - {i}))"
            by simp
          then have "Poly_Mapping.keys (sum' x (I - {i})) \<subseteq> S i"
            using that xs by metis
          moreover
          have "Poly_Mapping.keys (sum' x (I - {i})) \<subseteq> (\<Union>j \<in> I - {i}. S j)"
          proof -
            have "Poly_Mapping.keys (sum' x (I - {i})) \<subseteq> (\<Union>i\<in>{j \<in> I. j \<noteq> i \<and> x j \<noteq> 0}. Poly_Mapping.keys (x i))"
              using keys_sum [of x "{j \<in> I. j \<noteq> i \<and> x j \<noteq> 0}"] by (simp add: sum.G_def)
            also have "\<dots> \<subseteq> \<Union> (S ` (I - {i}))"
              using xs by force
            finally show ?thesis .
          qed
          moreover have "A = {}" if "A \<subseteq> S i" "A \<subseteq> \<Union> (S ` (I - {i}))" for A
            using assms that \<open>i \<in> I\<close>
            by (force simp: pairwise_def disjnt_def image_def subset_iff)
          ultimately show ?thesis
            by metis
        qed
        then have [simp]: "sum' x (I - {i}) = 0"
          by (auto simp: sum.G_def)
        have "sum' x (insert i (I - {i})) = x i"
          by (subst sum.insert' [OF finite_subset [OF _ fin]]) auto
        ultimately show ?thesis
          by metis
      qed
      with xext [unfolded extensional_def]
      show "x = \<one>\<^bsub>sum_group I (\<lambda>i. free_Abelian_group (S i))\<^esub>"
        by (force simp: free_Abelian_group_def)
    qed
  qed
qed

lemma isomorphic_free_Abelian_group_Union:
  "pairwise disjnt I \<Longrightarrow> free_Abelian_group(\<Union> I) \<cong> sum_group I free_Abelian_group"
  using iso_free_Abelian_group_sum [of "\<lambda>X. X" I]
  by (metis SUP_identity_eq empty_iff group.iso_sym group_free_Abelian_group is_iso_def sum_group)

lemma isomorphic_sum_integer_group:
   "sum_group I (\<lambda>i. integer_group) \<cong> free_Abelian_group I"
proof -
  have "sum_group I (\<lambda>i. integer_group) \<cong> sum_group I (\<lambda>i. free_Abelian_group {i})"
    by (rule iso_sum_groupI) (auto simp: isomorphic_group_integer_free_Abelian_group_singleton)
  also have "\<dots> \<cong> free_Abelian_group I"
    using iso_free_Abelian_group_sum [of "\<lambda>x. {x}" I] by (auto simp: is_iso_def)
  finally show ?thesis .
qed

end


chapter "Shallow IMP"
section{*Commands*}
text{*Instead of using a deep-embedding for the abstract syntax we use shallow embedding.
      To do so we need an explicit notion of substitution and variables.
      We use abbreviation in order that we do not hide the core theory behind
      another definition layer. Which makes it more suited for exploitation by simp, auto, etc*}

theory utp_rel
imports "utp_pred" "utp_alphabet" "utp_urel_setup"

begin

type_synonym '\<alpha> cond      = "'\<alpha> upred"
type_synonym ('\<alpha>, '\<beta>) rel = "('\<alpha> \<times> '\<beta>) upred"
type_synonym '\<alpha> hrel      = "('\<alpha> \<times> '\<alpha>) upred"

translations
  (type) "('\<alpha>, '\<beta>) rel" <= (type) "('\<alpha> \<times> '\<beta>) upred"

subsection{*SKIP*}

definition skip_ra :: "('\<beta>, '\<alpha>) lens \<Rightarrow>'\<alpha> hrel" where
[urel_defs]: "skip_ra v = ($v\<acute> =\<^sub>u $v)"

syntax
  "_skip_ra" :: "salpha \<Rightarrow> logic" ("II\<^bsub>_\<^esub>")

translations
  "_skip_ra v" == "CONST skip_ra v"

lift_definition assigns_r :: "'\<alpha> usubst \<Rightarrow> '\<alpha> hrel" ("\<langle>_\<rangle>\<^sub>a")
  is "\<lambda> \<sigma> (A, A'). A' = \<sigma>(A)" .

definition skip_r :: "'\<alpha> hrel" where
[urel_defs]:"skip_r = assigns_r id"

subsection{*Assign*}

definition assigns_ra :: "'\<alpha> usubst \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> '\<alpha> hrel" ("\<langle>_\<rangle>\<^bsub>_\<^esub>") where
"\<langle>\<sigma>\<rangle>\<^bsub>a\<^esub> = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II\<^bsub>a\<^esub>)"

abbreviation assign_r :: "('t, '\<alpha>) uvar \<Rightarrow> ('t, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"  where
  "assign_r v expr \<equiv> assigns_r [v \<mapsto>\<^sub>s expr]"

abbreviation assign_2_r ::
  "('t1, '\<alpha>) uvar \<Rightarrow> ('t2, '\<alpha>) uvar \<Rightarrow> ('t1, '\<alpha>) uexpr \<Rightarrow> ('t2, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel" where
  "assign_2_r x y u v \<equiv> assigns_r [x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v]"

subsection{*Conditional*}

abbreviation rcond::"('\<alpha>, '\<beta>) rel \<Rightarrow> '\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<alpha>, '\<beta>) rel"
                                                          ("(3_ \<triangleleft> _ \<triangleright>\<^sub>r/ _)" [52,0,53] 52)
where "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<equiv> (P \<triangleleft>\<lceil>b\<rceil>\<^sub>< \<triangleright> Q)"

subsection{*Sequential composition*}

lift_definition seqr::"('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<beta>, '\<gamma>) rel \<Rightarrow> ('\<alpha>, '\<gamma>) rel"  is
  "\<lambda> P Q r. r \<in> ({p. P p} O {q. Q q})" .

lift_definition conv_r :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta> \<times> '\<alpha>) uexpr" ("_\<^sup>-" [999] 999)
is "\<lambda> e (b1, b2). e (b2, b1)" .

subsection{*Syntax setup*}

nonterminal
  svid_list and uexpr_list

syntax
  "_svid_unit"  :: "svid \<Rightarrow> svid_list" ("_")
  "_svid_list"  :: "svid \<Rightarrow> svid_list \<Rightarrow> svid_list" ("_,/ _")
  "_uexpr_unit" :: "('a, '\<alpha>) uexpr \<Rightarrow> uexpr_list" ("_" [40] 40)
  "_uexpr_list" :: "('a, '\<alpha>) uexpr \<Rightarrow> uexpr_list \<Rightarrow> uexpr_list" ("_,/ _" [40,40] 40)
  "_assignment" :: "svid_list \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  ("_ :== _ " [60, 60] 52)
  "_mk_usubst"  :: "svid_list \<Rightarrow> uexprs \<Rightarrow> '\<alpha> usubst"

translations
  "_mk_usubst \<sigma> (_svid_unit x) v" == "\<sigma>(&x \<mapsto>\<^sub>s v)"
  "_mk_usubst \<sigma> (_svid_list x xs) (_uexprs v vs)" == "(_mk_usubst (\<sigma>(&x \<mapsto>\<^sub>s v)) xs vs)"
  "_assignment xs vs" => "CONST assigns_r (_mk_usubst (CONST id) xs vs)"
  "x :== v" <= "CONST assigns_r (CONST subst_upd (CONST id) (CONST svar x) v)"
  "x :== v" <= "CONST assigns_r (CONST subst_upd (CONST id) x v)"
  "x,y :== u,v" <= "CONST assigns_r (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"

adhoc_overloading
  useq seqr and
  uskip skip_r

subsection{*While-loop*}
text{*In order to specify while loops we need a concept that refers to the result of the execution
      of body of the loop. We call the result of the execution of the body the next state space.
      Rel is a function that takes a substitution on a state and apply it on a given init
      state. The resulting state from the application is the next state.
      Now we need to reason on the next state space to see if we continue the execution of the body
      or we skip it.*}

definition while :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while\<^sup>\<top> _ do _ od") where
"while b C =  (\<nu> X \<bullet> (C ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

abbreviation while_top :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while _ do _ od") where
"while b do P od \<equiv> while\<^sup>\<top> b do P od"

definition while_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while\<^sub>\<bottom> _ do _ od") where
"while\<^sub>\<bottom> b do P od = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

declare while_def [urel_defs]

subsection{*While-loop inv*}
text {* While loops with invariant decoration *}

definition while_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while _ invr _ do _ od" 70) where
"while b invr p do S od = while\<^sup>\<top> b do S od"

subsection{*assert and assume*}

definition rassume :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<top>" [999] 999) where
[urel_defs]: "rassume c = II \<triangleleft> c \<triangleright>\<^sub>r false"

definition rassert :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" ("_\<^sub>\<bottom>" [999] 999) where
[urel_defs]: "rassert c = II \<triangleleft> c \<triangleright>\<^sub>r true"

subsection{*throw*}
text{*To model exceptions we need to use the flag OK from UTP.
      It is a way to capture the termination or non termination of a program.*}

subsection{*block*}
text{*Block is used to model scoping. This feature can be used to introduce local variables and
      to handle parameter passing in procedures. To model the block we need a feature to abstract
      over the state-space. This way we can  initialize the value of the variable when we jump inside the block
      and restore it when we exit the block. This feature is provided implicitly by the type_def
      used to model UTP expr. It is @{const Abs_uexpr}. The definition of block takes 4 parameters:
     \begin{itemize}
       \<^item> initP: It is used to initialize the values of variables when we jump inside the block.
       \<^item> body: It contains the body of the block.
       \<^item> restore : a function used to restore the values of variables when we jump outside the block.
       \<^item> return : A function used to return a value if the block uses the traditional return
                  statement.
     \end{itemize}
*}

definition block :: "('a, 'c) rel \<Rightarrow> ('c, 'd) rel  \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'd \<times> 'b \<Rightarrow> ('d, 'e) rel) \<Rightarrow>
                     ('a \<times> 'b \<Rightarrow> 'd \<times> 'b \<Rightarrow> ('e, 'b) rel) \<Rightarrow> ('a, 'b) rel" where
[urel_defs]:"block initP body restore return =
             Abs_uexpr (\<lambda>(s, s').
             \<lbrakk>initP ;; body ;;
             Abs_uexpr (\<lambda>(t, t').\<lbrakk>restore (s, s') (t, t');; return(s, s') (t, t')\<rbrakk>\<^sub>e (t, t'))\<rbrakk>\<^sub>e (s, s'))"

subsection {* Program values *}

abbreviation prog_val :: "'\<alpha> hrel \<Rightarrow> ('\<alpha> hrel, '\<alpha>) uexpr" ("\<lbrace>|_|\<rbrace>\<^sub>u")
where "\<lbrace>|P|\<rbrace>\<^sub>u \<equiv> \<guillemotleft>P\<guillemotright>"

lift_definition call :: "('\<alpha> hrel, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
is "\<lambda> P b. P (fst b) b" .

lemma call_prog_val: "call \<lbrace>|P|\<rbrace>\<^sub>u = P"
  by (simp add: call_def urel_defs lit.rep_eq Rep_uexpr_inverse)

notation (latex)
  skip_r  ("\<SKIP>") and
  cond  ("\<IF> _ \<THEN> _ \<ELSE> _"  60) and
  while  ("\<WHILE> _ \<DO> _ \<OD>"  60)

subsection {*Props *}

text {* We describe some properties of relations *}

definition ufunctional :: "('a, 'b) rel \<Rightarrow> bool"
where "ufunctional R \<longleftrightarrow> II \<sqsubseteq> R\<^sup>- ;; R"

declare ufunctional_def [urel_defs]

definition uinj :: "('a, 'b) rel \<Rightarrow> bool"
where "uinj R \<longleftrightarrow> II \<sqsubseteq> R ;; R\<^sup>-"

declare uinj_def [urel_defs]

text {* A test is like a precondition, except that it identifies to the postcondition. It
        forms the basis for Kleene Algebra with Tests (KAT). *}

definition lift_test :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel" ("\<lceil>_\<rceil>\<^sub>t")
where "\<lceil>b\<rceil>\<^sub>t = (\<lceil>b\<rceil>\<^sub>< \<and> II)"

declare cond_def [urel_defs]
declare skip_r_def [urel_defs]

text {* We implement a poor man's version of alphabet restriction that hides a variable within a relation *}

definition rel_var_res :: "'\<alpha> hrel \<Rightarrow> ('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> hrel" (infix "\<restriction>\<^sub>\<alpha>" 80) where
"P \<restriction>\<^sub>\<alpha> x = (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P)"

declare rel_var_res_def [urel_defs]

-- {* Configuration for UTP tactics (see @{theory utp_tactics}). *}

update_uexpr_rep_eq_thms -- {* Reread @{text rep_eq} theorems. *}

lemma Rep_inverse[code]:"Rep_uexpr (Abs_uexpr x) = x"
by rel_auto

end


\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Typed Set-Theoretic Binary Relations\<close>
theory TSBinary_Relations
  imports
    HOTG.SBinary_Relations
    TSPairs
begin

subsection \<open>Dependent Binary Relations\<close>

definition [typedef]: "Dep_Bin_Rel A B \<equiv> Collection (\<Sum>x : A. (B x))"

abbreviation "Bin_Rel A B \<equiv> Dep_Bin_Rel A (\<lambda>_. B)"

lemma subset_dep_pairs_iff_Dep_Bin_Rel:
  "R \<subseteq> (\<Sum>x \<in> A. (B x)) \<longleftrightarrow> R : Dep_Bin_Rel (Element A) (\<lambda>x. Element (B x))"
  by unfold_types auto

soft_type_translation
  "R \<subseteq> (\<Sum>x \<in> A. (B x))" \<rightleftharpoons> "R : Dep_Bin_Rel (Element A) (\<lambda>x. Element (B x))"
  using subset_dep_pairs_iff_Dep_Bin_Rel by auto

lemma Dep_Bin_RelI:
  "(\<And>p. p \<in> R \<Longrightarrow> p : \<Sum>x : A. (B x)) \<Longrightarrow> R : Dep_Bin_Rel A B"
  unfolding Dep_Bin_Rel_def by (rule CollectionI)

lemma Dep_Bin_Rel_memE [elim]:
  assumes "R : Dep_Bin_Rel A B"
  and "p \<in> R"
  obtains x y where "x : A" "y : B x" "p = \<langle>x, y\<rangle>"
  using assms unfolding Dep_Bin_Rel_def
  by (auto dest: Collection_memD)

lemma Dep_Bin_Rel_covariant_dom:
  "R : Dep_Bin_Rel A B \<Longrightarrow> (\<And>x. x : A \<Longrightarrow> x : A') \<Longrightarrow> R : Dep_Bin_Rel A' B"
  unfolding Dep_Bin_Rel_def
  by (elim Collection_covariant) (blast intro: Dep_Pair_covariant_fst)

lemma Dep_Bin_Rel_covariant_rng:
  assumes "R : Dep_Bin_Rel A B"
  and "\<And>x y. x : A \<Longrightarrow> y : B x \<Longrightarrow> \<langle>x, y\<rangle> \<in> R \<Longrightarrow> y : B' x"
  shows "R : Dep_Bin_Rel A B'"
  using assms unfolding Dep_Bin_Rel_def
  by (elim Collection_covariant) (auto intro: Dep_Pair_covariant_snd)

subsection \<open>Predicates on Binary Relations\<close>

overloading
  set_injective_on_type \<equiv> "set_injective_on :: set type \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_injective_on_type (T :: set type) R \<equiv>
    set_injective_on (type_pred T) R"
end

lemma set_injective_on_type_iff_set_injective_on [iff]:
  "set_injective_on (T :: set type) R \<longleftrightarrow> set_injective_on (type_pred T) R"
  unfolding set_injective_on_type_def by simp

overloading
  set_right_unique_on_type \<equiv> "set_right_unique_on :: set type \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_right_unique_on_type (T :: set type) R \<equiv>
    set_right_unique_on (type_pred T) R"
end

lemma set_right_unique_on_type_iff_set_right_unique_on [iff]:
  "set_right_unique_on (T :: set type) R \<longleftrightarrow> set_right_unique_on (type_pred T) R"
  unfolding set_right_unique_on_type_def by simp

overloading
  set_left_total_on_type \<equiv> "set_left_total_on :: set type \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_left_total_on_type (T :: set type) R \<equiv>
    set_left_total_on (type_pred T) R"
end

lemma set_left_total_on_type_iff_set_left_total_on [iff]:
  "set_left_total_on (T :: set type) R \<longleftrightarrow> set_left_total_on (type_pred T) R"
  unfolding set_left_total_on_type_def by simp

overloading
  set_surjective_at_type \<equiv> "set_surjective_at :: set type \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_surjective_at_type (T :: set type) R \<equiv>
    set_surjective_at (type_pred T) R"
end

lemma set_surjective_at_type_iff_set_surjective_at [iff]:
  "set_surjective_at (T :: set type) R \<longleftrightarrow> set_surjective_at (type_pred T) R"
  unfolding set_surjective_at_type_def by simp

subsection \<open>Functions on Binary Relations\<close>

lemma extend_type [type]:
  "extend : (x : A) \<Rightarrow> B x \<Rightarrow> Dep_Bin_Rel A B \<Rightarrow> Dep_Bin_Rel A B"
  by unfold_types auto

lemma glue_type [type]: "glue : Collection (Dep_Bin_Rel A B) \<Rightarrow> Dep_Bin_Rel A B"
  by unfold_types auto

overloading
  set_restrict_left_type \<equiv> "set_restrict_left :: set \<Rightarrow> set type \<Rightarrow> set"
begin
  definition "set_restrict_left_type R (T :: set type) \<equiv>
    set_restrict_left R (type_pred T)"
end

lemma set_restrict_left_type_eq_set_restrict_left [simp]:
  "set_restrict_left R (T :: set type) = set_restrict_left R (type_pred T)"
  unfolding set_restrict_left_type_def by simp

lemma set_restrict_left_set_eq_set_restrict_left_type [simp]:
  "set_restrict_left R S = set_restrict_left R (Element S)"
  by (auto iff: mem_iff_Element)

lemma set_restrict_left_type [type]:
  "set_restrict_left : Dep_Bin_Rel A B \<Rightarrow> (P : Set \<Rightarrow> Bool) \<Rightarrow>
    Dep_Bin_Rel (A & type P) B"
  by unfold_types force

lemma set_restrict_left_set_type [type]:
  "set_restrict_left : Dep_Bin_Rel A B \<Rightarrow> (A' : Set) \<Rightarrow>
    Dep_Bin_Rel (A & Element A') B"
  (*TODO: should be proved with lemma above*)
  by unfold_types force

lemma set_restrict_left_type_type [type]:
  "set_restrict_left : Dep_Bin_Rel A B \<Rightarrow> (T : Any) \<Rightarrow> Dep_Bin_Rel (A & T) B"
  (*TODO: should be proved with lemma above*)
  by unfold_types force

lemma agree_type_iff_agree [iff]:
  "agree (T :: set type) \<R> \<longleftrightarrow> agree (type_pred T) \<R>"
  unfolding agree_def by simp

lemma dom_type [type]: "dom : Dep_Bin_Rel A B \<Rightarrow> Collection A"
  by (auto intro: CollectionI)

lemma rng_type: "rng : Dep_Bin_Rel A B \<Rightarrow> Collection (type (\<lambda>y. \<exists>x : A. y : B x))"
  by (auto intro!: CollectionI elim!: Dep_Bin_Rel_memE simp: meaning_of_type)

lemma rng_type' [type]: "rng : Bin_Rel A B \<Rightarrow> Collection B"
  by (auto intro: CollectionI)

lemma set_rel_inv_type:
  "set_rel_inv : Dep_Bin_Rel A B \<Rightarrow> Bin_Rel (type (\<lambda>y. \<exists>x : A. y : B x)) A"
  by unfold_types force

lemma set_rel_inv_type' [type]: "set_rel_inv : Bin_Rel A B \<Rightarrow> Bin_Rel B A"
  by unfold_types auto

lemma Dep_Bin_Rel_mem_set_rel_invE [elim]:
  assumes "R : Dep_Bin_Rel A B"
  and "p \<in> set_rel_inv R"
  obtains x y where "x : A" "y : B x" "\<langle>x, y\<rangle> \<in> R" "p = \<langle>y, x\<rangle>"
  using assms by auto

lemma Dep_Bin_Rel_pair_mem_set_rel_inv_iff [iff]:
  "R : Dep_Bin_Rel A B \<Longrightarrow> \<langle>a, b\<rangle> \<in> set_rel_inv R \<longleftrightarrow> \<langle>b, a\<rangle> \<in> R"
  by auto

lemma Dep_Bin_Rel_set_rel_inv_set_rel_inv_eq_self [simp]:
  "R : Dep_Bin_Rel A B \<Longrightarrow> set_rel_inv (set_rel_inv R) = R"
  by (rule eqI) (auto simp: set_rel_inv_inv_eq)

lemma diag_type [type]: "diag : (A : Set) \<Rightarrow> Bin_Rel (Element A) (Element A)"
  by (auto intro: Dep_Bin_RelI)

lemma set_comp_type [type]:
  "set_comp : (S : Bin_Rel B C) \<Rightarrow> (R : Bin_Rel A B) \<Rightarrow> Bin_Rel A C"
  by unfold_types auto

end


section \<open>Examples\<close>

theory OG_Examples imports OG_Syntax begin

subsection \<open>Mutual Exclusion\<close>

subsubsection \<open>Peterson's Algorithm I\<close>

text \<open>Eike Best. "Semantics of Sequential and Parallel Programs", page 217.\<close>

record Petersons_mutex_1 =
 pr1 :: nat
 pr2 :: nat
 in1 :: bool
 in2 :: bool
 hold :: nat

lemma Petersons_mutex_1:
  "\<parallel>- \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2 \<rbrace>
  COBEGIN \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>
  WHILE True INV \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>
  DO
  \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace> \<langle> \<acute>in1:=True,,\<acute>pr1:=1 \<rangle>;;
  \<lbrace>\<acute>pr1=1 \<and> \<acute>in1\<rbrace>  \<langle> \<acute>hold:=1,,\<acute>pr1:=2 \<rangle>;;
  \<lbrace>\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)\<rbrace>
  AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN \<acute>pr1:=3 END;;
  \<lbrace>\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)\<rbrace>
   \<langle>\<acute>in1:=False,,\<acute>pr1:=0\<rangle>
  OD \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>
  \<parallel>
  \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
  WHILE True INV \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
  DO
  \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace> \<langle> \<acute>in2:=True,,\<acute>pr2:=1 \<rangle>;;
  \<lbrace>\<acute>pr2=1 \<and> \<acute>in2\<rbrace> \<langle>  \<acute>hold:=2,,\<acute>pr2:=2 \<rangle>;;
  \<lbrace>\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))\<rbrace>
  AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3  END;;
  \<lbrace>\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))\<rbrace>
    \<langle>\<acute>in2:=False,,\<acute>pr2:=0\<rangle>
  OD \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
  COEND
  \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>"
apply oghoare
\<comment> \<open>104 verification conditions.\<close>
apply auto
done

subsubsection \<open>Peterson's Algorithm II: A Busy Wait Solution\<close>

text \<open>Apt and Olderog. "Verification of sequential and concurrent Programs", page 282.\<close>

record Busy_wait_mutex =
 flag1 :: bool
 flag2 :: bool
 turn  :: nat
 after1 :: bool
 after2 :: bool

lemma Busy_wait_mutex:
 "\<parallel>-  \<lbrace>True\<rbrace>
  \<acute>flag1:=False,, \<acute>flag2:=False,,
  COBEGIN \<lbrace>\<not>\<acute>flag1\<rbrace>
        WHILE True
        INV \<lbrace>\<not>\<acute>flag1\<rbrace>
        DO \<lbrace>\<not>\<acute>flag1\<rbrace> \<langle> \<acute>flag1:=True,,\<acute>after1:=False \<rangle>;;
           \<lbrace>\<acute>flag1 \<and> \<not>\<acute>after1\<rbrace> \<langle> \<acute>turn:=1,,\<acute>after1:=True \<rangle>;;
           \<lbrace>\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)\<rbrace>
            WHILE \<not>(\<acute>flag2 \<longrightarrow> \<acute>turn=2)
            INV \<lbrace>\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)\<rbrace>
            DO \<lbrace>\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)\<rbrace> SKIP OD;;
           \<lbrace>\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>flag2 \<and> \<acute>after2 \<longrightarrow> \<acute>turn=2)\<rbrace>
            \<acute>flag1:=False
        OD
       \<lbrace>False\<rbrace>
  \<parallel>
     \<lbrace>\<not>\<acute>flag2\<rbrace>
        WHILE True
        INV \<lbrace>\<not>\<acute>flag2\<rbrace>
        DO \<lbrace>\<not>\<acute>flag2\<rbrace> \<langle> \<acute>flag2:=True,,\<acute>after2:=False \<rangle>;;
           \<lbrace>\<acute>flag2 \<and> \<not>\<acute>after2\<rbrace> \<langle> \<acute>turn:=2,,\<acute>after2:=True \<rangle>;;
           \<lbrace>\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)\<rbrace>
            WHILE \<not>(\<acute>flag1 \<longrightarrow> \<acute>turn=1)
            INV \<lbrace>\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)\<rbrace>
            DO \<lbrace>\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)\<rbrace> SKIP OD;;
           \<lbrace>\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>flag1 \<and> \<acute>after1 \<longrightarrow> \<acute>turn=1)\<rbrace>
            \<acute>flag2:=False
        OD
       \<lbrace>False\<rbrace>
  COEND
  \<lbrace>False\<rbrace>"
apply oghoare
\<comment> \<open>122 vc\<close>
apply auto
done

subsubsection \<open>Peterson's Algorithm III: A Solution using Semaphores\<close>

record  Semaphores_mutex =
 out :: bool
 who :: nat

lemma Semaphores_mutex:
 "\<parallel>- \<lbrace>i\<noteq>j\<rbrace>
  \<acute>out:=True ,,
  COBEGIN \<lbrace>i\<noteq>j\<rbrace>
       WHILE True INV \<lbrace>i\<noteq>j\<rbrace>
       DO \<lbrace>i\<noteq>j\<rbrace> AWAIT \<acute>out THEN  \<acute>out:=False,, \<acute>who:=i END;;
          \<lbrace>\<not>\<acute>out \<and> \<acute>who=i \<and> i\<noteq>j\<rbrace> \<acute>out:=True OD
       \<lbrace>False\<rbrace>
  \<parallel>
       \<lbrace>i\<noteq>j\<rbrace>
       WHILE True INV \<lbrace>i\<noteq>j\<rbrace>
       DO \<lbrace>i\<noteq>j\<rbrace> AWAIT \<acute>out THEN  \<acute>out:=False,,\<acute>who:=j END;;
          \<lbrace>\<not>\<acute>out \<and> \<acute>who=j \<and> i\<noteq>j\<rbrace> \<acute>out:=True OD
       \<lbrace>False\<rbrace>
  COEND
  \<lbrace>False\<rbrace>"
apply oghoare
\<comment> \<open>38 vc\<close>
apply auto
done

subsubsection \<open>Peterson's Algorithm III: Parameterized version:\<close>

lemma Semaphores_parameterized_mutex:
 "0<n \<Longrightarrow> \<parallel>- \<lbrace>True\<rbrace>
  \<acute>out:=True ,,
 COBEGIN
  SCHEME [0\<le> i< n]
    \<lbrace>True\<rbrace>
     WHILE True INV \<lbrace>True\<rbrace>
      DO \<lbrace>True\<rbrace> AWAIT \<acute>out THEN  \<acute>out:=False,, \<acute>who:=i END;;
         \<lbrace>\<not>\<acute>out \<and> \<acute>who=i\<rbrace> \<acute>out:=True OD
    \<lbrace>False\<rbrace>
 COEND
  \<lbrace>False\<rbrace>"
apply oghoare
\<comment> \<open>20 vc\<close>
apply auto
done

subsubsection\<open>The Ticket Algorithm\<close>

record Ticket_mutex =
 num :: nat
 nextv :: nat
 turn :: "nat list"
 index :: nat

lemma Ticket_mutex:
 "\<lbrakk> 0<n; I=\<guillemotleft>n=length \<acute>turn \<and> 0<\<acute>nextv \<and> (\<forall>k l. k<n \<and> l<n \<and> k\<noteq>l
    \<longrightarrow> \<acute>turn!k < \<acute>num \<and> (\<acute>turn!k =0 \<or> \<acute>turn!k\<noteq>\<acute>turn!l))\<guillemotright> \<rbrakk>
   \<Longrightarrow> \<parallel>- \<lbrace>n=length \<acute>turn\<rbrace>
   \<acute>index:= 0,,
   WHILE \<acute>index < n INV \<lbrace>n=length \<acute>turn \<and> (\<forall>i<\<acute>index. \<acute>turn!i=0)\<rbrace>
    DO \<acute>turn:= \<acute>turn[\<acute>index:=0],, \<acute>index:=\<acute>index +1 OD,,
  \<acute>num:=1 ,, \<acute>nextv:=1 ,,
 COBEGIN
  SCHEME [0\<le> i< n]
    \<lbrace>\<acute>I\<rbrace>
     WHILE True INV \<lbrace>\<acute>I\<rbrace>
      DO \<lbrace>\<acute>I\<rbrace> \<langle> \<acute>turn :=\<acute>turn[i:=\<acute>num],, \<acute>num:=\<acute>num+1 \<rangle>;;
         \<lbrace>\<acute>I\<rbrace> WAIT \<acute>turn!i=\<acute>nextv END;;
         \<lbrace>\<acute>I \<and> \<acute>turn!i=\<acute>nextv\<rbrace> \<acute>nextv:=\<acute>nextv+1
      OD
    \<lbrace>False\<rbrace>
 COEND
  \<lbrace>False\<rbrace>"
apply oghoare
\<comment> \<open>35 vc\<close>
apply simp_all
\<comment> \<open>16 vc\<close>
apply(tactic \<open>ALLGOALS (clarify_tac \<^context>)\<close>)
\<comment> \<open>11 vc\<close>
apply simp_all
apply(tactic \<open>ALLGOALS (clarify_tac \<^context>)\<close>)
\<comment> \<open>10 subgoals left\<close>
apply(erule less_SucE)
 apply simp
apply simp
\<comment> \<open>9 subgoals left\<close>
apply(case_tac "i=k")
 apply force
apply simp
apply(case_tac "i=l")
 apply force
apply force
\<comment> \<open>8 subgoals left\<close>
prefer 8
apply force
apply force
\<comment> \<open>6 subgoals left\<close>
prefer 6
apply(erule_tac x=j in allE)
apply fastforce
\<comment> \<open>5 subgoals left\<close>
prefer 5
apply(case_tac [!] "j=k")
\<comment> \<open>10 subgoals left\<close>
apply simp_all
apply(erule_tac x=k in allE)
apply force
\<comment> \<open>9 subgoals left\<close>
apply(case_tac "j=l")
 apply simp
 apply(erule_tac x=k in allE)
 apply(erule_tac x=k in allE)
 apply(erule_tac x=l in allE)
 apply force
apply(erule_tac x=k in allE)
apply(erule_tac x=k in allE)
apply(erule_tac x=l in allE)
apply force
\<comment> \<open>8 subgoals left\<close>
apply force
apply(case_tac "j=l")
 apply simp
apply(erule_tac x=k in allE)
apply(erule_tac x=l in allE)
apply force
apply force
apply force
\<comment> \<open>5 subgoals left\<close>
apply(erule_tac x=k in allE)
apply(erule_tac x=l in allE)
apply(case_tac "j=l")
 apply force
apply force
apply force
\<comment> \<open>3 subgoals left\<close>
apply(erule_tac x=k in allE)
apply(erule_tac x=l in allE)
apply(case_tac "j=l")
 apply force
apply force
apply force
\<comment> \<open>1 subgoals left\<close>
apply(erule_tac x=k in allE)
apply(erule_tac x=l in allE)
apply(case_tac "j=l")
 apply force
apply force
done

subsection\<open>Parallel Zero Search\<close>

text \<open>Synchronized Zero Search. Zero-6\<close>

text \<open>Apt and Olderog. "Verification of sequential and concurrent Programs" page 294:\<close>

record Zero_search =
   turn :: nat
   found :: bool
   x :: nat
   y :: nat

lemma Zero_search:
  "\<lbrakk>I1= \<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
      \<and> (\<not>\<acute>found \<and> a<\<acute> x \<longrightarrow> f(\<acute>x)\<noteq>0) \<guillemotright> ;
    I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
      \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0) \<guillemotright> \<rbrakk> \<Longrightarrow>
  \<parallel>- \<lbrace>\<exists> u. f(u)=0\<rbrace>
  \<acute>turn:=1,, \<acute>found:= False,,
  \<acute>x:=a,, \<acute>y:=a+1 ,,
  COBEGIN \<lbrace>\<acute>I1\<rbrace>
       WHILE \<not>\<acute>found
       INV \<lbrace>\<acute>I1\<rbrace>
       DO \<lbrace>a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<rbrace>
          WAIT \<acute>turn=1 END;;
          \<lbrace>a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<rbrace>
          \<acute>turn:=2;;
          \<lbrace>a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<rbrace>
          \<langle> \<acute>x:=\<acute>x+1,,
            IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
       OD;;
       \<lbrace>\<acute>I1  \<and> \<acute>found\<rbrace>
       \<acute>turn:=2
       \<lbrace>\<acute>I1 \<and> \<acute>found\<rbrace>
  \<parallel>
      \<lbrace>\<acute>I2\<rbrace>
       WHILE \<not>\<acute>found
       INV \<lbrace>\<acute>I2\<rbrace>
       DO \<lbrace>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<rbrace>
          WAIT \<acute>turn=2 END;;
          \<lbrace>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<rbrace>
          \<acute>turn:=1;;
          \<lbrace>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<rbrace>
          \<langle> \<acute>y:=(\<acute>y - 1),,
            IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
       OD;;
       \<lbrace>\<acute>I2 \<and> \<acute>found\<rbrace>
       \<acute>turn:=1
       \<lbrace>\<acute>I2 \<and> \<acute>found\<rbrace>
  COEND
  \<lbrace>f(\<acute>x)=0 \<or> f(\<acute>y)=0\<rbrace>"
apply oghoare
\<comment> \<open>98 verification conditions\<close>
apply auto
\<comment> \<open>auto takes about 3 minutes !!\<close>
done

text \<open>Easier Version: without AWAIT.  Apt and Olderog. page 256:\<close>

lemma Zero_Search_2:
"\<lbrakk>I1=\<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
    \<and> (\<not>\<acute>found \<and> a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<guillemotright>;
 I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
    \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<guillemotright>\<rbrakk> \<Longrightarrow>
  \<parallel>- \<lbrace>\<exists>u. f(u)=0\<rbrace>
  \<acute>found:= False,,
  \<acute>x:=a,, \<acute>y:=a+1,,
  COBEGIN \<lbrace>\<acute>I1\<rbrace>
       WHILE \<not>\<acute>found
       INV \<lbrace>\<acute>I1\<rbrace>
       DO \<lbrace>a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<rbrace>
          \<langle> \<acute>x:=\<acute>x+1,,IF f(\<acute>x)=0 THEN  \<acute>found:=True ELSE  SKIP FI\<rangle>
       OD
       \<lbrace>\<acute>I1 \<and> \<acute>found\<rbrace>
  \<parallel>
      \<lbrace>\<acute>I2\<rbrace>
       WHILE \<not>\<acute>found
       INV \<lbrace>\<acute>I2\<rbrace>
       DO \<lbrace>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<rbrace>
          \<langle> \<acute>y:=(\<acute>y - 1),,IF f(\<acute>y)=0 THEN  \<acute>found:=True ELSE  SKIP FI\<rangle>
       OD
       \<lbrace>\<acute>I2 \<and> \<acute>found\<rbrace>
  COEND
  \<lbrace>f(\<acute>x)=0 \<or> f(\<acute>y)=0\<rbrace>"
apply oghoare
\<comment> \<open>20 vc\<close>
apply auto
\<comment> \<open>auto takes aprox. 2 minutes.\<close>
done

subsection \<open>Producer/Consumer\<close>

subsubsection \<open>Previous lemmas\<close>

lemma nat_lemma2: "\<lbrakk> b = m*(n::nat) + t; a = s*n + u; t=u; b-a < n \<rbrakk> \<Longrightarrow> m \<le> s"
proof -
  assume "b = m*(n::nat) + t" "a = s*n + u" "t=u"
  hence "(m - s) * n = b - a" by (simp add: diff_mult_distrib)
  also assume "\<dots> < n"
  finally have "m - s < 1" by simp
  thus ?thesis by arith
qed

lemma mod_lemma: "\<lbrakk> (c::nat) \<le> a; a < b; b - c < n \<rbrakk> \<Longrightarrow> b mod n \<noteq> a mod n"
apply(subgoal_tac "b=b div n*n + b mod n" )
 prefer 2  apply (simp add: div_mult_mod_eq [symmetric])
apply(subgoal_tac "a=a div n*n + a mod n")
 prefer 2
 apply(simp add: div_mult_mod_eq [symmetric])
apply(subgoal_tac "b - a \<le> b - c")
 prefer 2 apply arith
apply(drule le_less_trans)
back
 apply assumption
apply(frule less_not_refl2)
apply(drule less_imp_le)
apply (drule_tac m = "a" and k = n in div_le_mono)
apply(safe)
apply(frule_tac b = "b" and a = "a" and n = "n" in nat_lemma2, assumption, assumption)
apply assumption
apply(drule order_antisym, assumption)
apply(rotate_tac -3)
apply(simp)
done

subsubsection \<open>Producer/Consumer Algorithm\<close>

record Producer_consumer =
  ins :: nat
  outs :: nat
  li :: nat
  lj :: nat
  vx :: nat
  vy :: nat
  buffer :: "nat list"
  b :: "nat list"

text \<open>The whole proof takes aprox. 4 minutes.\<close>

lemma Producer_consumer:
  "\<lbrakk>INIT= \<guillemotleft>0<length a \<and> 0<length \<acute>buffer \<and> length \<acute>b=length a\<guillemotright> ;
    I= \<guillemotleft>(\<forall>k<\<acute>ins. \<acute>outs\<le>k \<longrightarrow> (a ! k) = \<acute>buffer ! (k mod (length \<acute>buffer))) \<and>
            \<acute>outs\<le>\<acute>ins \<and> \<acute>ins-\<acute>outs\<le>length \<acute>buffer\<guillemotright> ;
    I1= \<guillemotleft>\<acute>I \<and> \<acute>li\<le>length a\<guillemotright> ;
    p1= \<guillemotleft>\<acute>I1 \<and> \<acute>li=\<acute>ins\<guillemotright> ;
    I2 = \<guillemotleft>\<acute>I \<and> (\<forall>k<\<acute>lj. (a ! k)=(\<acute>b ! k)) \<and> \<acute>lj\<le>length a\<guillemotright> ;
    p2 = \<guillemotleft>\<acute>I2 \<and> \<acute>lj=\<acute>outs\<guillemotright> \<rbrakk> \<Longrightarrow>
  \<parallel>- \<lbrace>\<acute>INIT\<rbrace>
 \<acute>ins:=0,, \<acute>outs:=0,, \<acute>li:=0,, \<acute>lj:=0,,
 COBEGIN \<lbrace>\<acute>p1 \<and> \<acute>INIT\<rbrace>
   WHILE \<acute>li <length a
     INV \<lbrace>\<acute>p1 \<and> \<acute>INIT\<rbrace>
   DO \<lbrace>\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a\<rbrace>
       \<acute>vx:= (a ! \<acute>li);;
      \<lbrace>\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)\<rbrace>
        WAIT \<acute>ins-\<acute>outs < length \<acute>buffer END;;
      \<lbrace>\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)
         \<and> \<acute>ins-\<acute>outs < length \<acute>buffer\<rbrace>
       \<acute>buffer:=(list_update \<acute>buffer (\<acute>ins mod (length \<acute>buffer)) \<acute>vx);;
      \<lbrace>\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a
         \<and> (a ! \<acute>li)=(\<acute>buffer ! (\<acute>ins mod (length \<acute>buffer)))
         \<and> \<acute>ins-\<acute>outs <length \<acute>buffer\<rbrace>
       \<acute>ins:=\<acute>ins+1;;
      \<lbrace>\<acute>I1 \<and> \<acute>INIT \<and> (\<acute>li+1)=\<acute>ins \<and> \<acute>li<length a\<rbrace>
       \<acute>li:=\<acute>li+1
   OD
  \<lbrace>\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li=length a\<rbrace>
  \<parallel>
  \<lbrace>\<acute>p2 \<and> \<acute>INIT\<rbrace>
   WHILE \<acute>lj < length a
     INV \<lbrace>\<acute>p2 \<and> \<acute>INIT\<rbrace>
   DO \<lbrace>\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>INIT\<rbrace>
        WAIT \<acute>outs<\<acute>ins END;;
      \<lbrace>\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>INIT\<rbrace>
       \<acute>vy:=(\<acute>buffer ! (\<acute>outs mod (length \<acute>buffer)));;
      \<lbrace>\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT\<rbrace>
       \<acute>outs:=\<acute>outs+1;;
      \<lbrace>\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT\<rbrace>
       \<acute>b:=(list_update \<acute>b \<acute>lj \<acute>vy);;
      \<lbrace>\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> (a ! \<acute>lj)=(\<acute>b ! \<acute>lj) \<and> \<acute>INIT\<rbrace>
       \<acute>lj:=\<acute>lj+1
   OD
  \<lbrace>\<acute>p2 \<and> \<acute>lj=length a \<and> \<acute>INIT\<rbrace>
 COEND
 \<lbrace> \<forall>k<length a. (a ! k)=(\<acute>b ! k)\<rbrace>"
apply oghoare
\<comment> \<open>138 vc\<close>
apply(tactic \<open>ALLGOALS (clarify_tac \<^context>)\<close>)
\<comment> \<open>112 subgoals left\<close>
apply(simp_all (no_asm))
\<comment> \<open>43 subgoals left\<close>
apply(tactic \<open>ALLGOALS (conjI_Tac \<^context> (K all_tac))\<close>)
\<comment> \<open>419 subgoals left\<close>
apply(tactic \<open>ALLGOALS (clarify_tac \<^context>)\<close>)
\<comment> \<open>99 subgoals left\<close>
apply(simp_all only:length_0_conv [THEN sym])
\<comment> \<open>20 subgoals left\<close>
apply (simp_all del:length_0_conv length_greater_0_conv add: nth_list_update mod_lemma)
\<comment> \<open>9 subgoals left\<close>
apply (force simp add:less_Suc_eq)
apply(hypsubst_thin, drule sym)
apply (force simp add:less_Suc_eq)+
done

subsection \<open>Parameterized Examples\<close>

subsubsection \<open>Set Elements of an Array to Zero\<close>

record Example1 =
  a :: "nat \<Rightarrow> nat"

lemma Example1:
 "\<parallel>- \<lbrace>True\<rbrace>
   COBEGIN SCHEME [0\<le>i<n] \<lbrace>True\<rbrace> \<acute>a:=\<acute>a (i:=0) \<lbrace>\<acute>a i=0\<rbrace> COEND
  \<lbrace>\<forall>i < n. \<acute>a i = 0\<rbrace>"
apply oghoare
apply simp_all
done

text \<open>Same example with lists as auxiliary variables.\<close>
record Example1_list =
  A :: "nat list"
lemma Example1_list:
 "\<parallel>- \<lbrace>n < length \<acute>A\<rbrace>
   COBEGIN
     SCHEME [0\<le>i<n] \<lbrace>n < length \<acute>A\<rbrace> \<acute>A:=\<acute>A[i:=0] \<lbrace>\<acute>A!i=0\<rbrace>
   COEND
    \<lbrace>\<forall>i < n. \<acute>A!i = 0\<rbrace>"
apply oghoare
apply force+
done

subsubsection \<open>Increment a Variable in Parallel\<close>

text \<open>First some lemmas about summation properties.\<close>
(*
lemma Example2_lemma1: "!!b. j<n \<Longrightarrow> (\<Sum>i::nat<n. b i) = (0::nat) \<Longrightarrow> b j = 0 "
apply(induct n)
 apply simp_all
apply(force simp add: less_Suc_eq)
done
*)
lemma Example2_lemma2_aux: "!!b. j<n \<Longrightarrow>
 (\<Sum>i=0..<n. (b i::nat)) =
 (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
apply(induct n)
 apply simp_all
apply(simp add:less_Suc_eq)
 apply(auto)
apply(subgoal_tac "n - j = Suc(n- Suc j)")
  apply simp
apply arith
done

lemma Example2_lemma2_aux2:
  "!!b. j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
apply(induct j)
 apply simp_all
done

lemma Example2_lemma2:
 "!!b. \<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
apply(erule_tac  t="sum (b(j := (Suc 0))) {0..<n}" in ssubst)
apply(frule_tac b=b in Example2_lemma2_aux)
apply(erule_tac  t="sum b {0..<n}" in ssubst)
apply(subgoal_tac "Suc (sum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(sum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
apply(rotate_tac -1)
apply(erule ssubst)
apply(subgoal_tac "j\<le>j")
 apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
apply(rotate_tac -1)
apply(erule ssubst)
apply simp_all
done

record Example2 =
 c :: "nat \<Rightarrow> nat"
 x :: nat

lemma Example_2: "0<n \<Longrightarrow>
 \<parallel>- \<lbrace>\<acute>x=0 \<and> (\<Sum>i=0..<n. \<acute>c i)=0\<rbrace>
 COBEGIN
   SCHEME [0\<le>i<n]
  \<lbrace>\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=0\<rbrace>
   \<langle> \<acute>x:=\<acute>x+(Suc 0),, \<acute>c:=\<acute>c (i:=(Suc 0)) \<rangle>
  \<lbrace>\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=(Suc 0)\<rbrace>
 COEND
 \<lbrace>\<acute>x=n\<rbrace>"
apply oghoare
apply (simp_all cong del: sum.cong_simp)
apply (tactic \<open>ALLGOALS (clarify_tac \<^context>)\<close>)
apply (simp_all cong del: sum.cong_simp)
   apply(erule (1) Example2_lemma2)
  apply(erule (1) Example2_lemma2)
 apply(erule (1) Example2_lemma2)
apply(simp)
done

end