theory BetaCR
imports CR
begin

(* TODO1: Does not work:*)

(* equivariance beta_star *)

(* proved manually below. *)

lemma eqvt_helper: "x1 \<longrightarrow>b* x2 \<Longrightarrow>  (p \<bullet> x1) \<longrightarrow>b* (p \<bullet> x2)"
  by (erule beta_star.induct)
     (metis beta.eqvt bs2 bs1)+

lemma [eqvt]: "p \<bullet> (x1 \<longrightarrow>b* x2) = ((p \<bullet> x1) \<longrightarrow>b* (p \<bullet> x2))"
  apply rule
  apply (drule permute_boolE)
  apply (erule eqvt_helper)
  apply (intro permute_boolI)
  apply (drule_tac p="-p" in eqvt_helper)
  by simp

definition
  equ :: "lam \<Rightarrow> lam \<Rightarrow> bool" ("_ \<approx> _")
where
  "t \<approx> s \<longleftrightarrow> (\<exists>r. t \<longrightarrow>b* r \<and> s \<longrightarrow>b* r)"

lemma equ_refl:
  shows "t \<approx> t"
  unfolding equ_def by auto

lemma equ_sym:
  assumes "t \<approx> s"
  shows "s \<approx> t"
  using assms unfolding equ_def
  by auto

lemma equ_trans:
  assumes "A \<approx> B" "B \<approx> C"
  shows "A \<approx> C"
  using assms unfolding equ_def
proof (elim exE conjE)
  fix D E
  assume a: "A \<longrightarrow>b* D" "B \<longrightarrow>b* D" "B \<longrightarrow>b* E" "C \<longrightarrow>b* E"
  then obtain F where "D \<longrightarrow>b* F" "E \<longrightarrow>b* F" using CR_for_Beta_star by blast
  then have "A \<longrightarrow>b* F \<and> C \<longrightarrow>b* F" using a bs3 by blast
  then show "\<exists>F. A \<longrightarrow>b* F \<and> C \<longrightarrow>b* F" by blast
qed

lemma App_beta: "A \<longrightarrow>b* B \<Longrightarrow> C \<longrightarrow>b* D \<Longrightarrow> App A C \<longrightarrow>b* App B D"
  apply (erule beta_star.induct)
  apply auto
  apply (erule beta_star.induct)
  apply auto
  done

lemma Lam_beta: "A \<longrightarrow>b* B \<Longrightarrow> Lam [x]. A \<longrightarrow>b* Lam [x]. B"
  by (erule beta_star.induct) auto

lemma Lam_rsp: "A \<approx> B \<Longrightarrow> Lam [x]. A \<approx> Lam [x]. B"
  unfolding equ_def
  apply auto
  apply (rule_tac x="Lam [x]. r" in exI)
  apply (auto simp add: Lam_beta)
  done

lemma [quot_respect]:
  shows "(op = ===> equ) Var Var"
  and   "(equ ===> equ ===> equ) App App"
  and   "(op = ===> equ ===> equ) CR.Lam CR.Lam"
  unfolding fun_rel_def equ_def
  apply auto
  apply (rule_tac x="App r ra" in exI)
  apply (auto simp add: App_beta)
  apply (rule_tac x="Lam [x]. r" in exI)
  apply (auto simp add: Lam_beta)
  done

lemma beta_subst1_pre: "B \<longrightarrow>b C \<Longrightarrow> A [x ::= B] \<longrightarrow>b* A [x ::= C]"
  by (nominal_induct A avoiding: x B C rule: lam.strong_induct)
     (auto simp add: App_beta Lam_beta)

lemma beta_subst1: "B \<longrightarrow>b* C \<Longrightarrow> A [x ::= B] \<longrightarrow>b* A [x ::= C]"
  apply (erule beta_star.induct)
  apply auto
  apply (subgoal_tac "A [x ::= M2] \<longrightarrow>b* A [x ::= M3]")
  apply (rotate_tac 1)
  apply (erule bs3)
  apply assumption
  apply (simp add: beta_subst1_pre)
  done

lemma beta_subst2_pre:
  assumes "A \<longrightarrow>b B" shows "A [x ::= C] \<longrightarrow>b* B [x ::= C]"
  using assms
  apply (nominal_induct avoiding: x C rule: beta.strong_induct)
  apply (auto simp add: App_beta fresh_star_def fresh_Pair Lam_beta)[3]
  apply (subst substitution_lemma)
  apply (auto simp add: fresh_star_def fresh_Pair fresh_at_base)[2]
  apply (auto simp add: fresh_star_def fresh_Pair)
  apply (rule beta_star.intros)
  defer
  apply (subst beta.intros)
  apply (auto simp add: fresh_fact)
  done

lemma beta_subst2: "A \<longrightarrow>b* B \<Longrightarrow> A [x ::= C] \<longrightarrow>b* B [x ::= C]"
  apply (erule beta_star.induct)
  apply auto
  apply (subgoal_tac "M2[x ::= C] \<longrightarrow>b* M3[x ::= C]")
  apply (rotate_tac 1)
  apply (erule bs3)
  apply assumption
  apply (simp add: beta_subst2_pre)
  done

lemma beta_subst: "A \<longrightarrow>b* B \<Longrightarrow> C \<longrightarrow>b* D \<Longrightarrow> A [x ::= C] \<longrightarrow>b* B [x ::= D]"
  using beta_subst1 beta_subst2 bs3 by metis

lemma subst_rsp_pre:
  "x \<approx> y \<Longrightarrow> xb \<approx> ya \<Longrightarrow> x [xa ::= xb] \<approx> y [xa ::= ya]"
  unfolding equ_def
  apply auto
  apply (rule_tac x="r [xa ::= ra]" in exI)
  apply (simp add: beta_subst)
  done

lemma [quot_respect]:
  shows "(equ ===> op = ===> equ ===> equ) subst subst"
unfolding fun_rel_def by (auto simp add: subst_rsp_pre)

lemma [quot_respect]:
  shows "(op = ===> equ ===> equ) permute permute"
  unfolding fun_rel_def equ_def
  apply (auto intro: eqvts)
  apply (rule_tac x="x \<bullet> r" in exI)
  using eqvts(1) permute_boolI by metis

quotient_type qlam = lam / equ
  by (auto intro!: equivpI reflpI sympI transpI simp add: equ_refl equ_sym)
     (erule equ_trans, assumption)

quotient_definition "QVar::name \<Rightarrow> qlam" is Var
quotient_definition "QApp::qlam \<Rightarrow> qlam \<Rightarrow> qlam" is App
quotient_definition QLam ("QLam [_]._")
  where "QLam::name \<Rightarrow> qlam \<Rightarrow> qlam" is CR.Lam

lemmas qlam_strong_induct = lam.strong_induct[quot_lifted]
lemmas qlam_induct = lam.induct[quot_lifted]

instantiation qlam :: pt
begin

quotient_definition "permute_qlam::perm \<Rightarrow> qlam \<Rightarrow> qlam"
  is "permute::perm \<Rightarrow> lam \<Rightarrow> lam"

instance
apply default
apply(descending)
apply(simp)
apply(rule equ_refl)
apply(descending)
apply(simp)
apply(rule equ_refl)
done

end

lemma qlam_perm[simp, eqvt]:
  shows "p \<bullet> (QVar x) = QVar (p \<bullet> x)"
  and "p \<bullet> (QApp t s) = QApp (p \<bullet> t) (p \<bullet> s)"
  and "p \<bullet> (QLam [x].t) = QLam [p \<bullet> x].(p \<bullet> t)"
  by(descending, simp add: equ_refl)+

lemma qlam_supports:
  shows "{atom x} supports (QVar x)"
  and   "supp (t, s) supports (QApp t s)"
  and   "supp (x, t) supports (QLam [x].t)"
unfolding supports_def fresh_def[symmetric]
by (auto simp add: swap_fresh_fresh)

lemma qlam_fs:
  fixes t::"qlam"
  shows "finite (supp t)"
apply(induct t rule: qlam_induct)
apply(rule supports_finite)
apply(rule qlam_supports)
apply(simp)
apply(rule supports_finite)
apply(rule qlam_supports)
apply(simp add: supp_Pair)
apply(rule supports_finite)
apply(rule qlam_supports)
apply(simp add: supp_Pair finite_supp)
done

instantiation qlam :: fs
begin

instance
apply(default)
apply(rule qlam_fs)
done

end

quotient_definition subst_qlam ("_[_ ::q= _]")
  where "subst_qlam::qlam \<Rightarrow> name \<Rightarrow> qlam \<Rightarrow> qlam" is subst

definition
  "Supp t = \<Inter>{supp s | s. s \<approx> t}"

lemma Supp_rsp:
  "a \<approx> b \<Longrightarrow> Supp a = Supp b"
  unfolding Supp_def
  apply(rule_tac f="Inter" in arg_cong)
  apply(auto)
  apply (metis equ_trans)
  by (metis equivp_def qlam_equivp)

lemma [quot_respect]:
  shows "(equ ===> op=) Supp Supp"
  unfolding fun_rel_def by (auto simp add: Supp_rsp)

quotient_definition "supp_qlam::qlam \<Rightarrow> atom set"
  is "Supp::lam \<Rightarrow> atom set"

lemma Supp_supp:
  "Supp t \<subseteq> supp t"
unfolding Supp_def
apply(auto)
apply(drule_tac x="supp t" in spec)
apply(auto simp add: equ_refl)
done

lemma supp_subst:
  shows "supp (t[x ::= s]) \<subseteq> (supp t - {atom x}) \<union> supp s"
  by (induct t x s rule: subst.induct) (auto simp add: lam.supp supp_at_base)

lemma supp_beta: "x \<longrightarrow>b r \<Longrightarrow> supp r \<subseteq> supp x"
  apply (induct rule: beta.induct)
  apply (simp_all add: lam.supp)
  apply blast+
  using supp_subst by blast

lemma supp_beta_star: "x \<longrightarrow>b* r \<Longrightarrow> supp r \<subseteq> supp x"
  apply (erule beta_star.induct)
  apply auto
  using supp_beta by blast

lemma supp_equ: "x \<approx> y \<Longrightarrow> \<exists>z. z \<approx> x \<and> supp z \<subseteq> supp x \<inter> supp y"
  unfolding equ_def
  apply (simp (no_asm) only: equ_def[symmetric])
  apply (elim exE)
  apply (rule_tac x=r in exI)
  apply rule
  apply (metis bs1 equ_def)
  using supp_beta_star by blast

lemma supp_psubset: "Supp x \<subset> supp x \<Longrightarrow> \<exists>t. t \<approx> x \<and> supp t \<subset> supp x"
proof -
  assume "Supp x \<subset> supp x"
  then obtain a where "a \<in> supp x" "a \<notin> Supp x" by blast
  then obtain y where nin: "y \<approx> x" "a \<notin> supp y" unfolding Supp_def by blast
  then obtain t where eq: "t \<approx> x" "supp t \<subseteq> supp x \<inter> supp y"
    using supp_equ equ_sym by blast
  then have "supp t \<subset> supp x" using nin
    by (metis `(a\<Colon>atom) \<in> supp (x\<Colon>lam)` le_infE psubset_eq set_rev_mp)
  then show "\<exists>t. t \<approx> x \<and> supp t \<subset> supp x" using eq by blast
qed

lemma Supp_exists: "\<exists>t. supp t = Supp t \<and> t \<approx> x"
proof -
  have "\<And>fs x. supp x = fs \<Longrightarrow> \<exists>t. supp t = Supp t \<and> t \<approx> x"
  proof -
    fix fs
    show "\<And>x. supp x = fs \<Longrightarrow> \<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x"
    proof (cases "finite fs")
      case True
      assume fs: "finite fs"
      then show "\<And>x. supp x = fs \<Longrightarrow> \<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x"
      proof (induct fs rule: finite_psubset_induct, clarify)
        fix A :: "atom set" fix x :: lam
        assume IH: "\<And>B xa. \<lbrakk>B \<subset> supp x; supp xa = B\<rbrakk> \<Longrightarrow> \<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> xa"
        show "\<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x"
        proof (cases "supp x = Supp x")
          assume "supp x = Supp x"
          then show "\<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x"
            by (rule_tac x="x" in exI) (simp add: equ_refl)
        next
          assume "supp x \<noteq> Supp x"
          then have "Supp x \<subset> supp x" using Supp_supp by blast
          then obtain y where a1: "supp y \<subset> supp x" "y \<approx> x"
            using supp_psubset by blast
          then obtain t where "supp t = Supp t \<and> t \<approx> y"
            using IH[of "supp y" y] by blast
          then show "\<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x" using a1 equ_trans
            by blast
        qed
      qed
    next
      case False
      fix x :: lam
      assume "supp x = fs" "infinite fs"
      then show "\<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x"
        by (auto simp add: finite_supp)
    qed simp
  qed
  then show "\<exists>t\<Colon>lam. supp t = Supp t \<and> t \<approx> x" by blast
qed

lemma subst3: "x \<noteq> y \<and> atom x \<notin> Supp s \<Longrightarrow> Lam [x]. t [y ::= s] \<approx> Lam [x]. (t [y ::= s])"
proof -
  assume as: "x \<noteq> y \<and> atom x \<notin> Supp s"
  obtain s' where s: "supp s' = Supp s'" "s' \<approx> s" using Supp_exists[of s] by blast
  then have lhs: "Lam [x]. t [y ::= s] \<approx> Lam [x]. t [y ::= s']" using subst_rsp_pre equ_refl equ_sym by blast
  have supp: "Supp s' = Supp s" using Supp_rsp s(2) by blast
  have lhs_rhs: "Lam [x]. t [y ::= s'] = Lam [x]. (t [y ::= s'])"
    by (simp add: fresh_def supp_Pair s supp as supp_at_base)
  have "t [y ::= s'] \<approx> t [y ::= s]"
    using subst_rsp_pre[OF equ_refl s(2)] .
  with Lam_rsp have rhs: "Lam [x]. (t [y ::= s']) \<approx> Lam [x]. (t [y ::= s])" .
  show ?thesis
    using lhs[unfolded lhs_rhs] rhs equ_trans by blast
qed

thm subst3[quot_lifted]

lemma Supp_Lam:
  "atom a \<notin> Supp (Lam [a].t)"
proof -
  have "atom a \<notin> supp (Lam [a].t)" by (simp add: lam.supp)
  then show ?thesis using Supp_supp
    by blast
qed

lemma [eqvt]: "(p \<bullet> (a \<approx> b)) = ((p \<bullet> a) \<approx> (p \<bullet> b))"
  unfolding equ_def
  by perm_simp rule

lemma [eqvt]: "p \<bullet> (Supp x) = Supp (p \<bullet> x)"
  unfolding Supp_def
  by perm_simp rule

lemmas s = Supp_Lam[quot_lifted]

lemma var_beta_pre: "s \<longrightarrow>b* r \<Longrightarrow> s = Var name \<Longrightarrow> r = Var name"
  apply (induct rule: beta_star.induct)
  apply simp
  apply (subgoal_tac "M2 = Var name")
  apply (thin_tac "M1 \<longrightarrow>b* M2")
  apply (thin_tac "M1 = Var name")
  apply (thin_tac "M1 = Var name \<Longrightarrow> M2 = Var name")
  defer
  apply simp
  apply (erule_tac beta.cases)
  apply simp_all
  done

lemma var_beta: "Var name \<longrightarrow>b* r \<longleftrightarrow> r = Var name"
  by (auto simp add: var_beta_pre)

lemma qlam_eq_iff:
  "(QVar n = QVar m) = (n = m)"
  apply descending unfolding equ_def var_beta by auto

lemma "supp (QVar n) = {atom n}"
  unfolding supp_def
  apply simp
  unfolding qlam_eq_iff
  apply (fold supp_def)
  apply (simp add: supp_at_base)
  done

end


theory "List-Interleavings"
imports Main
begin

inductive interleave' :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where [simp]: "interleave' [] [] []"
  | "interleave' xs ys zs \<Longrightarrow>interleave' (x#xs) ys (x#zs)"
  | "interleave' xs ys zs \<Longrightarrow>interleave' xs (x#ys) (x#zs)"

definition interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" (infixr "\<otimes>" 64)
  where "xs \<otimes> ys = Collect (interleave' xs ys)"
lemma elim_interleave'[pred_set_conv]: "interleave' xs ys zs \<longleftrightarrow> zs \<in> xs \<otimes> ys" unfolding interleave_def by simp

lemmas interleave_intros[intro?] = interleave'.intros[to_set]
lemmas interleave_intros(1)[simp]
lemmas interleave_induct[consumes 1, induct set: interleave, case_names Nil left right] = interleave'.induct[to_set]
lemmas interleave_cases[consumes 1, cases set: interleave] = interleave'.cases[to_set]
lemmas interleave_simps = interleave'.simps[to_set]

inductive_cases interleave_ConsE[elim]: "(x#xs) \<in> ys \<otimes> zs"
inductive_cases interleave_ConsConsE[elim]: "xs \<in> y#ys \<otimes> z#zs"
inductive_cases interleave_ConsE2[elim]: "xs \<in> x#ys \<otimes> zs"
inductive_cases interleave_ConsE3[elim]: "xs \<in> ys \<otimes> x#zs"

lemma interleave_comm: "xs \<in> ys \<otimes> zs \<Longrightarrow> xs \<in> zs \<otimes> ys"
  by (induction rule: interleave_induct) (auto intro: interleave_intros)

lemma interleave_Nil1[simp]: "[] \<otimes> xs = {xs}"
  by (induction xs) (auto intro: interleave_intros elim: interleave_cases)

lemma interleave_Nil2[simp]: "xs \<otimes> [] = {xs}"
  by (induction xs) (auto intro: interleave_intros elim: interleave_cases)

lemma interleave_nil_simp[simp]: "[] \<in> xs \<otimes> ys \<longleftrightarrow> xs = [] \<and> ys = []"
  by (auto elim: interleave_cases)

lemma append_interleave: "xs @ ys \<in> xs \<otimes> ys"
  by (induction xs) (auto intro: interleave_intros)

lemma interleave_assoc1: "a \<in> xs \<otimes> ys \<Longrightarrow> b \<in> a \<otimes> zs \<Longrightarrow> \<exists> c. c \<in> ys \<otimes> zs \<and>  b \<in> xs  \<otimes> c"
  by (induction b arbitrary: a  xs ys zs)
     (simp, fastforce del: interleave_ConsE elim!: interleave_ConsE  intro: interleave_intros)

lemma interleave_assoc2: "a \<in> ys \<otimes> zs \<Longrightarrow> b \<in> xs \<otimes> a \<Longrightarrow> \<exists> c. c \<in> xs \<otimes> ys \<and>  b \<in> c \<otimes> zs"
  by (induction b arbitrary: a  xs ys zs )
     (simp, fastforce del: interleave_ConsE elim!: interleave_ConsE  intro: interleave_intros)

lemma interleave_set: "zs \<in> xs \<otimes> ys \<Longrightarrow> set zs = set xs \<union> set ys"
  by(induction rule:interleave_induct) auto

lemma interleave_tl: "xs \<in> ys \<otimes> zs \<Longrightarrow> tl xs \<in> tl ys \<otimes> zs \<or> tl xs \<in> ys \<otimes> (tl zs)"
  by(induction rule:interleave_induct) auto

lemma interleave_butlast: "xs \<in> ys \<otimes> zs \<Longrightarrow> butlast xs \<in> butlast ys \<otimes> zs \<or> butlast xs \<in> ys \<otimes> (butlast zs)"
  by (induction rule:interleave_induct) (auto intro: interleave_intros)

lemma interleave_take: "zs \<in> xs \<otimes> ys \<Longrightarrow> \<exists> n\<^sub>1 n\<^sub>2. n = n\<^sub>1 + n\<^sub>2 \<and>  take n zs \<in> take n\<^sub>1 xs \<otimes> take n\<^sub>2 ys"
  apply(induction arbitrary: n rule:interleave_induct)
  apply auto
  apply arith
  apply (case_tac n, simp)
  apply (drule_tac x = nat in meta_spec)
  apply auto
  apply (rule_tac x = "Suc n\<^sub>1" in exI)
  apply (rule_tac x = "n\<^sub>2" in exI)
  apply (auto intro: interleave_intros)[1]

  apply (case_tac n, simp)
  apply (drule_tac x = nat in meta_spec)
  apply auto
  apply (rule_tac x = "n\<^sub>1" in exI)
  apply (rule_tac x = "Suc n\<^sub>2" in exI)
  apply (auto intro: interleave_intros)[1]
  done

lemma filter_interleave: "xs \<in> ys \<otimes> zs \<Longrightarrow> filter P xs \<in> filter P ys \<otimes> filter P zs"
  by (induction rule: interleave_induct)  (auto intro: interleave_intros)

lemma interleave_filtered: "xs \<in> interleave (filter P xs)  (filter (\<lambda>x'. \<not> P x') xs)"
  by (induction xs) (auto intro: interleave_intros)

function foo where
  "foo [] [] = undefined"
| "foo xs [] = undefined"
| "foo [] ys = undefined"
| "foo (x#xs) (y#ys) = undefined (foo xs (y#ys)) (foo (x#xs) ys)"
by pat_completeness auto
termination by lexicographic_order
lemmas list_induct2'' = foo.induct[case_names NilNil ConsNil NilCons ConsCons]

lemma interleave_filter:
  assumes "xs \<in> filter P ys \<otimes> filter P zs"
  obtains xs' where "xs' \<in> ys \<otimes> zs" and "xs = filter P xs'"
using assms
apply atomize_elim
proof(induction ys zs arbitrary: xs rule: list_induct2'')
case NilNil
  thus ?case by simp
next
case (ConsNil ys xs)
  thus ?case by auto
next
case (NilCons zs xs)
  thus ?case by auto
next
case (ConsCons y ys z zs xs)
  show ?case
  proof(cases "P y")
  case False
    with ConsCons.prems(1)
    have "xs \<in> filter P ys \<otimes> filter P (z#zs)" by simp
    from ConsCons.IH(1)[OF this]
    obtain xs' where "xs' \<in> ys \<otimes> (z # zs)" "xs = filter P xs'" by auto
    hence "y#xs' \<in> y#ys \<otimes> z#zs" and "xs = filter P (y#xs')"
      using False by (auto intro: interleave_intros)
    thus ?thesis by blast
  next
 case True
    show ?thesis
    proof(cases "P z")
    case False
      with ConsCons.prems(1)
      have "xs \<in> filter P (y#ys) \<otimes> filter P zs" by simp
      from ConsCons.IH(2)[OF this]
      obtain xs' where "xs' \<in> y#ys \<otimes> zs" "xs = filter P xs'" by auto
      hence "z#xs' \<in> y#ys \<otimes> z#zs" and "xs = filter P (z#xs')"
        using False by (auto intro: interleave_intros)
      thus ?thesis by blast
    next
    case True
      from ConsCons.prems(1) \<open>P y\<close> \<open>P z\<close>
      have "xs \<in> y # filter P ys  \<otimes> z # filter P zs"  by simp
      thus ?thesis
      proof(rule interleave_ConsConsE)
        fix xs'
        assume "xs = y # xs'" and "xs' \<in> interleave (filter P ys) (z # filter P zs)"
        hence "xs' \<in> filter P ys  \<otimes> filter P (z#zs)" using \<open>P z\<close> by simp
        from ConsCons.IH(1)[OF this]
        obtain xs'' where "xs'' \<in> ys \<otimes> (z # zs)" and "xs' = filter P xs''" by auto
        hence "y#xs'' \<in> y#ys  \<otimes> z#zs" and "y#xs' = filter P (y#xs'')"
          using \<open>P y\<close> by (auto intro: interleave_intros)
        thus ?thesis using \<open>xs = _\<close> by blast
      next
        fix xs'
        assume "xs = z # xs'" and "xs' \<in> y # filter P ys  \<otimes> filter P zs"
        hence "xs' \<in> filter P (y#ys) \<otimes> filter P zs" using \<open>P y\<close> by simp
        from ConsCons.IH(2)[OF this]
        obtain xs'' where "xs'' \<in> y#ys \<otimes> zs" and "xs' = filter P xs''" by auto
        hence "z#xs'' \<in> y#ys \<otimes> z#zs" and "z#xs' = filter P (z#xs'')"
          using \<open>P z\<close> by (auto intro: interleave_intros)
        thus ?thesis using \<open>xs = _\<close> by blast
      qed
    qed
  qed
qed

end


section \<open>Many-Typed (Many-Sorted) First-Order Logic\<close>
theory Sig imports Preliminaries
begin

text\<open>In this formalization, we call ``types" what the first-order logic community usually calls ``sorts".\<close>

subsection\<open>Signatures\<close>

locale Signature =
fixes
    wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf :: "'fsym \<Rightarrow> 'tp"
and parOf :: "'psym \<Rightarrow> 'tp list"
assumes
    countable_tp: "countable (UNIV :: 'tp set)"
and countable_wtFsym: "countable {f::'fsym. wtFsym f}"
and countable_wtPsym: "countable {p::'psym. wtPsym p}"
begin

text\<open>Partitioning of the variables in countable sets for each type:\<close>

definition tpOfV_pred :: "(var \<Rightarrow> 'tp) \<Rightarrow> bool" where
"tpOfV_pred f \<equiv> \<forall> \<sigma>. infinite (f -` {\<sigma>})"

definition "tpOfV \<equiv> SOME f. tpOfV_pred f"

lemma infinite_fst_vimage:
"infinite ((fst :: 'a \<times> nat \<Rightarrow> 'a) -` {a})" (is "infinite (?f -` {a})")
proof-
  have "?f -` {a} = {(a,n::nat) | n . True}" (is "_ = ?A") by auto
  moreover
  {have 0: "?A = range (Pair a)" by auto
   have "infinite ?A" unfolding 0 apply(rule range_inj_infinite)
   unfolding inj_on_def by auto
  }
  ultimately show ?thesis by auto
qed

lemma tpOfV_pred: "\<exists> f. tpOfV_pred f"
proof-
  define Ut Uv where "Ut = (UNIV :: 'tp set)" and "Uv = (UNIV :: var set)"
  define Unt where "Unt = (UNIV :: nat set)"
  define U2 where "U2 = (UNIV :: ('tp \<times> nat) set)"
  have U2: "U2 \<equiv> Ut \<times> Unt" unfolding Ut_def Unt_def U2_def UNIV_Times_UNIV .
  have "|U2| =o |Unt \<times> Ut|" unfolding U2 by (metis card_of_Times_commute)
  also have "|Unt \<times> Ut| =o |Unt|"
  apply(rule card_of_Times_infinite_simps(1)) unfolding Ut_def Unt_def
  apply (metis nat_not_finite)
  apply (metis UNIV_not_empty)
  by (metis countable_card_of_nat countable_tp)
  also have "|Unt| =o |Uv|" apply(rule ordIso_symmetric)
  unfolding Unt_def Uv_def using card_of_var card_of_nat[THEN ordIso_symmetric]
  by(rule ordIso_transitive)
  finally have "|U2| =o |Uv|" .
  hence "|Uv| =o |U2|" by(rule ordIso_symmetric)
  then obtain g where g: "bij_betw g Uv U2" unfolding card_of_ordIso[symmetric] by blast
  show ?thesis apply(rule exI[of _ "fst o g"]) unfolding tpOfV_pred_def apply safe
  unfolding vimage_comp [symmetric] apply (drule finite_vimageD)
  using g unfolding bij_betw_def Uv_def U2_def by (auto simp: infinite_fst_vimage)
qed

lemma tpOfV_pred_tpOfV: "tpOfV_pred tpOfV"
using tpOfV_pred unfolding tpOfV_def by (rule someI_ex)

lemma tpOfV: "infinite (tpOfV -` {\<sigma>})"
using tpOfV_pred_tpOfV unfolding tpOfV_pred_def by auto

definition "tpart1 V \<equiv> \<Union> \<sigma>. part1 (V \<inter> tpOfV -` {\<sigma>})"
definition "tpart2 V \<equiv> \<Union> \<sigma>. part2 (V \<inter> tpOfV -` {\<sigma>})"
definition "tinfinite V \<equiv> \<forall> \<sigma>. infinite (V \<inter> tpOfV -` {\<sigma>})"

lemma tinfinite_var[simp,intro]: "tinfinite (UNIV :: var set)"
unfolding tinfinite_def using tpOfV by auto

lemma tinifnite_singl[simp]:
assumes "tinfinite V"  shows "tinfinite (V - {x})"
unfolding tinfinite_def proof safe
  fix \<sigma> assume 0: "finite ((V - {x}) \<inter> tpOfV -` {\<sigma>})"
  have "finite ((V \<inter> tpOfV -` {\<sigma>}) - {x})" apply(rule finite_subset[OF _ 0]) by auto
  thus False using assms unfolding tinfinite_def by auto
qed

lemma tpart1_Un_tpart2[simp]:
assumes "tinfinite V" shows "tpart1 V \<union> tpart2 V = V"
using assms part1_Un_part2 unfolding tinfinite_def tpart1_def tpart2_def
unfolding UN_Un_distrib[symmetric] by blast

lemma tpart1_Int_tpart2[simp]:
assumes "tinfinite V" shows "tpart1 V \<inter> tpart2 V = {}"
using assms part1_Int_part2 unfolding tinfinite_def tpart1_def tpart2_def
unfolding Int_UN_distrib2 apply auto apply (case_tac "xa = xb", auto)
using part1_su part2_su by blast (* fixme: clean proof *)

lemma tpart1_su:
assumes "tinfinite V"  shows "tpart1 V \<subseteq> V"
using assms unfolding tinfinite_def tpart1_def
using part1_su by (auto intro: UN_least)

lemma tpart1_in:
assumes "tinfinite V" and "x \<in> tpart1 V" shows "x \<in> V"
using assms tpart1_su by auto

lemma tinfinite_tpart1[simp]:
assumes "tinfinite V"
shows "tinfinite (tpart1 V)"
unfolding tinfinite_def tpart1_def proof safe
  fix \<sigma> assume
  "finite ((\<Union>\<sigma>'. part1 (V \<inter> tpOfV -` {\<sigma>'})) \<inter> tpOfV -` {\<sigma>})" (is "finite ?A")
  moreover have "?A = part1 (V \<inter> tpOfV -` {\<sigma>})"
  using assms part1_su unfolding tinfinite_def by auto
  moreover have "infinite ..."
  using assms infinite_part1 unfolding tinfinite_def by auto
  ultimately show False by auto
qed

lemma tinfinite_tpart2[simp]:
assumes "tinfinite V"
shows "tinfinite (tpart2 V)"
unfolding tinfinite_def tpart2_def proof safe
  fix \<sigma> assume
  "finite ((\<Union>\<sigma>'. part2 (V \<inter> tpOfV -` {\<sigma>'})) \<inter> tpOfV -` {\<sigma>})" (is "finite ?A")
  moreover have "?A = part2 (V \<inter> tpOfV -` {\<sigma>})"
  using assms part2_su unfolding tinfinite_def by auto
  moreover have "infinite ..."
  using assms infinite_part2 unfolding tinfinite_def by auto
  ultimately show False by auto
qed

lemma tpart2_su:
assumes "tinfinite V"  shows "tpart2 V \<subseteq> V"
using assms unfolding tinfinite_def tpart2_def
using part2_su by (auto intro: UN_least)

lemma tpart2_in:
assumes "tinfinite V" and "x \<in> tpart2 V" shows "x \<in> V"
using assms tpart2_su by auto

text\<open>Typed-pick: picking a variable of a given type\<close>

definition "tpick \<sigma> V \<equiv> pick (V \<inter> tpOfV -` {\<sigma>})"

lemma tinfinite_ex: "tinfinite V \<Longrightarrow> \<exists> x \<in> V. tpOfV x = \<sigma>"
unfolding tinfinite_def using infinite_imp_nonempty by auto

lemma tpick: assumes "tinfinite V" shows "tpick \<sigma> V \<in> V \<inter> tpOfV -` {\<sigma>}"
proof-
  obtain x where "x \<in> V \<and> tpOfV x = \<sigma>"
  using tinfinite_ex[OF assms] by auto
  hence "x \<in> V \<inter> tpOfV -` {\<sigma>}" by blast
  thus ?thesis unfolding tpick_def by (rule pick)
qed

lemma tpick_in[simp]: "tinfinite V \<Longrightarrow> tpick \<sigma> V \<in> V"
and tpOfV_tpick[simp]: "tinfinite V \<Longrightarrow> tpOfV (tpick \<sigma> V) = \<sigma>"
using tpick by auto

lemma finite_tinfinite:
assumes "finite V"
shows "tinfinite (UNIV - V)"
using assms infinite_var unfolding tinfinite_def
by (metis Diff_Int2 Diff_Int_distrib2 Int_UNIV_left finite_Diff2 tpOfV)

(* get variable terms for the given types: *)
fun getVars where
"getVars [] = []"
|
"getVars (\<sigma> # \<sigma>l) =
 (let xl = getVars \<sigma>l in (tpick \<sigma> (UNIV - set xl)) # xl)"

lemma distinct_getVars: "distinct (getVars \<sigma>l)"
using tpick_in[OF finite_tinfinite] by (induct \<sigma>l, auto simp: Let_def)

lemma length_getVars[simp]: "length (getVars \<sigma>l) = length \<sigma>l"
by(induct \<sigma>l, auto simp: Let_def)

lemma map_tpOfV_getVars[simp]: "map tpOfV (getVars \<sigma>l) = \<sigma>l"
using tpOfV_tpick[OF finite_tinfinite] by (induct \<sigma>l, auto simp: Let_def)

lemma tpOfV_getVars_nth[simp]:
assumes "i < length \<sigma>l"  shows "tpOfV (getVars \<sigma>l ! i) = \<sigma>l ! i"
using assms using map_tpOfV_getVars by (metis length_getVars nth_map)

end (* context Signature *)

end


section \<open> Iverson Bracket examples from Jim's ``Uncertainty and Probabilistic UTP''\<close>

theory utp_iverson_bracket_examples
  imports "HOL.Series" "HOL-Analysis.Infinite_Sum" "UTP_prob_relations.utp_iverson_bracket"
begin

term "(($r\<^sup>> = C) \<and> ($a\<^sup>> = $a\<^sup><))\<^sub>e"

declare [[show_types]]

lemma Example_2: "(\<Sum>i::int \<in> {1..4}. (2*i+1)) = 3 + 5 + 7 + 9"
  apply (subgoal_tac "(\<Sum>i::int \<in> {1..4}. (2*i+1)) =
    (\<Sum>i::int \<in> ({1}). (2*i+1)) + (\<Sum>i::int \<in> ({2..4}). (2*i+1))")
  defer
  using simp_from_to apply auto[1]
  apply (subgoal_tac "(\<Sum>i::int \<in> ({2..4}). (2*i+1)) =
    (\<Sum>i::int \<in> ({2}). (2*i+1)) + (\<Sum>i::int \<in> ({3..4}). (2*i+1))")
  defer
  using simp_from_to apply auto[1]
  apply (subgoal_tac "(\<Sum>i::int \<in> {3..4}. (2*i+1)) =
    (\<Sum>i::int \<in> ({3}). (2*i+1)) + (\<Sum>i::int \<in> ({4}). (2*i+1))")
  defer
  using simp_from_to apply auto[1]
  by (auto)

term "(\<lbrakk>(\<lambda>i. (i \<in> {1..4}))\<rbrakk>\<^sub>\<I>) i"
(*
lemma Example_2_iverson_bracket:
  (* shows "(\<Sum>\<^sub>\<infinity>i::int. ((2*i+1)*(\<lbrakk>(\<lambda>i. i \<in> {1::int..4})\<rbrakk>\<^sub>\<I> i))) = 3 + 5 + 7 + 9" *)
  shows "(\<Sum>i::int. ((2*i+1)*(\<lbrakk>(\<lambda>i. i \<in> {1::int..4})\<rbrakk>\<^sub>\<I> i))) = 3 + 5 + 7 + 9"
proof -
  have "(\<Sum>i::int. ((2*i+1)*(\<lbrakk>(\<lambda>i. i \<in> {1::int..4})\<rbrakk>\<^sub>\<I> i))) =
    (\<Sum>i\<in> ({i. i \<in> {1..4}} \<union> {i. i \<notin> {1..4}}). ((2*i+1)*(\<lbrakk>(\<lambda>i. i \<in> {1::int..4})\<rbrakk>\<^sub>\<I> i)))"
qed
*)

(*
lemma Example_2_iverson_bracket':
  assumes "finite (A::int set)" "{1..4} \<subseteq> A"
  shows "(\<Sum>i\<in>A. ((2*i+1)*(\<lbrakk>(\<lambda>i. ((1 \<le> i) \<and> (i \<le> 4)))\<rbrakk>\<^sub>\<I> i))) = 3 + 5 + 7 + 9"
  apply (simp add: expr_defs)
  sorry

*)
(*
lemma Example_3_double_counting_rule:
  "(\<Sum>i\<in>A. P i) = (\<Sum>i|True. \<lbrakk>P\<rbrakk>\<^sub>\<I>)\<^sub>e"
  oops
*)
term "f sums a"
term "(\<lambda>n. \<Sum>i<n. f i) \<longlonglongrightarrow> s"
term "suminf"
term "\<Sum> f"

term "(\<Sum>\<^sub>\<infinity> n|True. f n)"

subsection \<open> Example - Experiment with state space \<close>
datatype color = Red | Green | Yellow
alphabet StColor =
  c :: color

term "{s. P s}"
term "{s. P s = (1::\<real>)}"
(* c is a lens *)
term "c"
term "(c = Yellow)\<^sub>e"
term "c\<^sub>v"
term "c\<^sub>v P = Red"
(* *)
term "c\<^sup>>" (* "[get\<^bsub>c\<^esub>]\<^sub>e \<up> snd\<^sub>L" :: "'a \<times> 'b StColor_scheme \<Rightarrow> color" *)
term "$c\<^sup>>"
term "$c"
(* *)
term "c\<^sup><"
term "$c\<^sup><"
term "$\<^bold>v\<^sup>>"
term "$\<^bold>v\<^sup>>"
term "$\<^bold>v\<^sup><"
term "get\<^bsub>c\<^esub>" (* :: "'a StColor_scheme \<Rightarrow> color" *)
term "($c\<^sup>> = Red)\<^sub>e"
term "(($c\<^sup>> = Red) \<and> ($c\<^sup>< = Green))\<^sub>e"
term "(($c\<^sup>> = Red) \<and> ($c\<^sup>< = Green))\<^sub>u ::color\<leftrightarrow>color"

term "{(Green, Red)}"

(* {(Green, Red)} *)
definition red_green :: "StColor rel" where
"red_green = (($c\<^sup>> = Red) \<and> ($c\<^sup>< = Green))\<^sub>u"

(* {(Gree, Red), (Gree, Yellow)} *)
definition red_green2 :: "StColor rel" where
"red_green2 = ((($c\<^sup>> = Red) \<and> ($c\<^sup>< = Green)) \<or> (($c\<^sup>> = Yellow) \<and> ($c\<^sup>< = Green)))\<^sub>u"

term "get\<^bsub>c\<^esub> s"

lemma "{\<s>::StColor \<times> StColor. c\<^sub>v (snd \<s>) = Red \<and> c\<^sub>v (fst \<s>) = Green}
  = (insert (THE s::StColor \<times> StColor. c\<^sub>v (snd \<s>) = Red \<and> c\<^sub>v (fst \<s>) = Green) {})"
  sorry

lemma "card red_green = 1"
  apply (simp add: red_green_def)
  apply (simp add: expr_defs lens_defs)
  sorry

lemma "card red_green2 = 1"
  apply (simp add: red_green2_def)
  apply (simp add: expr_defs lens_defs)
  sorry

term "red_green \<Zcomp> red_green2"

subsection \<open> Example \<close>

datatype Attacker = C | D
datatype Status = S | F

alphabet RA =
  r:: Attacker
  a:: Status

subsubsection \<open> Nondeterminism \<close>
(* \<or> in a non-probabilistic program is a union of set-based programs (P \<or> Q) *)
(* {s:: RA \<times> RA. r\<^sub>v (snd s) = C \<or> r\<^sub>v (snd s) = D} *)
term "((r := \<guillemotleft>C\<guillemotright>) \<or> (r := \<guillemotleft>D\<guillemotright>))"

subsubsection \<open> Semantics \<close>
term "(r := \<guillemotleft>C\<guillemotright>)"
term "\<lbrakk> \<lbrakk>(r := \<guillemotleft>C\<guillemotright>)\<rbrakk>\<^sub>P \<rbrakk>\<^sub>\<I>"

term "(($r\<^sup>> = C) \<and> ($a\<^sup>> = $a\<^sup><))\<^sub>e"
term "(($r\<^sup>> = C) \<and> ($a\<^sup>> = $a\<^sup><))\<^sub>u"
(* r := C *)
definition "r0 = \<lbrakk>(($r\<^sup>> = C) \<and> ($a\<^sup>> = $a\<^sup><))\<^sub>e\<rbrakk>\<^sub>\<I>"
(* r := D *)
definition "r1 = \<lbrakk>(($r\<^sup>> = D) \<and> ($a\<^sup>> = $a\<^sup><))\<^sub>e\<rbrakk>\<^sub>\<I>"
expr_ctr r0 r1
(* a := S *)
definition "a0 = \<lbrakk>(($r\<^sup>> = $r\<^sup><) \<and> ($a\<^sup>> = S))\<^sub>e\<rbrakk>\<^sub>\<I>"
expr_ctr a0
(* a := F *)
definition "a1 = \<lbrakk>(($r\<^sup>> = $r\<^sup><) \<and> ($a\<^sup>> = F))\<^sub>e\<rbrakk>\<^sub>\<I>"
(*expr_ctr a1*)
full_exprs
(* b01 = (if 1/2 then a := S else a := F) *)
term "((1/2)*a0 + (1/2)*@a1)\<^sub>e"
term "((1/2)*a0 + (1/2)*a1)\<^sub>e"
term "((1/2)*@a0 + (1/2)*@a1)\<^sub>e"
definition "b01 = ((1/2)*a0 + (1/2)*@a1)\<^sub>e"

term "(f+0)\<^sub>e"
term "\<lambda>s. (f s + 0)"
expr_ctr b01
term "r' = C"
term "(c' = $a\<^sup><)"
term "(\<Sum>\<^sub>\<infinity> r'. (\<lbrakk>((r' = C) \<and> (c' = $a\<^sup><))\<^sub>e\<rbrakk>\<^sub>\<I>))\<^sub>e"
(* b0 = ( r := C ; if 1/2 then a := S else a := F ) *)
(* Manual substitution *)
term "
  (\<Sum>\<^sub>\<infinity> r'. \<Sum>\<^sub>\<infinity> a'.
    (
      \<lbrakk>((r' = C) \<and> (a' = $a\<^sup><))\<^sub>e\<rbrakk>\<^sub>\<I>
      *
      (
        (1/2) * \<lbrakk>(($r\<^sup>> = r') \<and> ($a\<^sup>> = S))\<^sub>e\<rbrakk>\<^sub>\<I> +
        (1/2) * \<lbrakk>(($r\<^sup>> = $r\<^sup><) \<and> ($a\<^sup>> = F))\<^sub>e\<rbrakk>\<^sub>\<I>
      )
    )
  )\<^sub>e"
term "((($r\<^sup>> = C) \<and> ($a\<^sup>> = $a\<^sup><))\<lbrakk>r'/r\<^sup>>\<rbrakk>)\<^sub>e"
term "(r0\<lbrakk>r'/r\<^sup>>\<rbrakk>)\<^sub>e"
term "(r0\<lbrakk>r',a'/r\<^sup>>,a\<^sup><\<rbrakk>)\<^sub>e"
term "(b01\<lbrakk>r',a'/r\<^sup>>,a\<^sup><\<rbrakk>)\<^sub>e"

definition "b0 = (\<Sum>\<^sub>\<infinity> r'. \<Sum>\<^sub>\<infinity> a'. ((r0\<lbrakk>r',a'/r\<^sup>>,a\<^sup><\<rbrakk>) * (b01\<lbrakk>r',a'/r\<^sup>>,a\<^sup><\<rbrakk>)))\<^sub>e"
expr_ctr b0

definition "b11 = (3/10*a0 + 7/10*@a1)\<^sub>e"
expr_ctr b11
(* b1 = ( r := D ; if 3/10 then a := S else a := F ) *)
definition "b1 = (\<Sum>\<^sub>\<infinity> r'. \<Sum>\<^sub>\<infinity> a'. ((r1\<lbrakk>r',a'/r\<^sup>>,a\<^sup><\<rbrakk>) * (b11\<lbrakk>r',a'/r\<^sup>>,a\<^sup><\<rbrakk>)))\<^sub>e"
expr_ctr b1

term "b01\<or> b11"

definition "DWTA = ((3/5)*b0+(2/5)*b1)\<^sub>e"

end


theory FS_Set
imports
  Nominal2.Nominal2
begin

section \<open>Finitely Supported Sets\<close>

text \<open>We define the type of finitely supported sets (over some permutation type~@{typ "'a::pt"}).

Note that we cannot more generally define the (sub-)type of finitely supported elements for
arbitrary permutation types~@{typ "'a::pt"}: there is no guarantee that this type is non-empty.\<close>

typedef 'a fs_set = "{x::'a::pt set. finite (supp x)}"
  by (simp add: exI[where x="{}"] supp_set_empty)

setup_lifting type_definition_fs_set

text \<open>Type~@{typ "'a fs_set"} is a finitely supported permutation type.\<close>

instantiation fs_set :: (pt) pt
begin

  lift_definition permute_fs_set :: "perm \<Rightarrow> 'a fs_set \<Rightarrow> 'a fs_set" is permute
    by (metis permute_finite supp_eqvt)

  instance
   apply (intro_classes)
    apply (metis (mono_tags) permute_fs_set.rep_eq Rep_fs_set_inverse permute_zero)
   apply (metis (mono_tags) permute_fs_set.rep_eq Rep_fs_set_inverse permute_plus)
  done

end

instantiation fs_set :: (pt) fs
begin

  instance
  proof (intro_classes)
    fix x :: "'a fs_set"
    from Rep_fs_set have "finite (supp (Rep_fs_set x))" by simp
    hence "finite {a. infinite {b. (a \<rightleftharpoons> b) \<bullet> Rep_fs_set x \<noteq> Rep_fs_set x}}" by (unfold supp_def)
    hence "finite {a. infinite {b. ((a \<rightleftharpoons> b) \<bullet> x) \<noteq>  x}}" by transfer
    thus "finite (supp x)" by (fold supp_def)
  qed

end

text \<open>Set membership.\<close>

lift_definition member_fs_set :: "'a::pt \<Rightarrow> 'a fs_set \<Rightarrow> bool" is "(\<in>)" .

notation
  member_fs_set ("'(\<in>\<^sub>f\<^sub>s')") and
  member_fs_set ("(_/ \<in>\<^sub>f\<^sub>s _)" [51, 51] 50)

lemma member_fs_set_permute_iff [simp]: "p \<bullet> x \<in>\<^sub>f\<^sub>s p \<bullet> X \<longleftrightarrow> x \<in>\<^sub>f\<^sub>s X"
by transfer (simp add: mem_permute_iff)

lemma member_fs_set_eqvt [eqvt]: "x \<in>\<^sub>f\<^sub>s X \<Longrightarrow> p \<bullet> x \<in>\<^sub>f\<^sub>s p \<bullet> X"
by simp

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2022  Daniel de la Concepcion

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES LOSS OF USE, DATA, OR PROFITS OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Rings - Zariski Topology - Properties\<close>

theory Ring_Zariski_ZF_2 imports Ring_Zariski_ZF Topology_ZF_1

begin

theorem (in ring0) zariski_t0:
  shows "{D(I). I\<in>\<I>}{is T\<^sub>0}" unfolding isT0_def
proof-
  {
    fix x y assume ass:"x:Spec" "y:Spec" "x\<noteq>y"
    from ass(3) have "\<not>(x\<subseteq>y) \<or> \<not>(y\<subseteq>x)" by auto
    then have "y\<in>D(x) \<or> x\<in>D(y)" using ass(1,2)
      unfolding Spec_def using ass(1,2) openBasic_def
      by auto
    then have "(x \<in> D(y) \<and> y \<notin> D(y)) \<or> (y \<in> D(x) \<and> x \<notin> D(x))"
      using ass(1,2) unfolding Spec_def
      using openBasic_def by auto
    then have "\<exists>U\<in>{D(I). I\<in>\<I>}. (x \<in> U \<and> y \<notin> U) \<or> (y \<in> U \<and> x \<notin> U)"
      using ass(1,2) unfolding Spec_def by auto
  }
  then show "\<forall>x y. x \<in> \<Union>RepFun(\<I>, D) \<and> y \<in> \<Union>RepFun(\<I>, D) \<and> x \<noteq> y \<longrightarrow>
          (\<exists>U\<in>RepFun(\<I>, D). x \<in> U \<and> y \<notin> U \<or> y \<in> U \<and> x \<notin> U)"
    using total_spec by auto
qed

text\<open>Noetherian rings have compact Zariski topology\<close>

theorem (in ring0) zariski_compact:
  assumes "\<forall>I\<in>\<I>. (I{is finitely generated})"
  shows "Spec {is compact in} {D(I). I\<in>\<I>}"
  unfolding IsCompact_def
proof(safe)
  show "\<And>x. x \<in> Spec \<Longrightarrow> x \<in> \<Union>RepFun(\<I>, D)" using total_spec by auto
  fix M assume M:"M \<subseteq> RepFun(\<I>, D)" "Spec \<subseteq> \<Union>M"
  let ?J ="{J\<in>\<I>. D(J)\<in>M}"
  have m:"M = RepFun(?J,D)" using M(1) by auto
  then have mm:"\<Union>M = D(\<oplus>\<^sub>I?J)" using union_open_basic[of ?J] by auto
  obtain T where T:"T\<in>FinPow(?J)" "(\<oplus>\<^sub>I?J) = \<oplus>\<^sub>IT" using
    sum_ideals_noetherian[OF assms(1), of ?J] by blast
  from T(2) have "D(\<oplus>\<^sub>I?J) = D(\<oplus>\<^sub>IT)" by auto
  moreover have "T\<subseteq>\<I>" using T(1) unfolding FinPow_def by auto
  ultimately have "D(\<oplus>\<^sub>I?J) = \<Union>RepFun(T,D)" using union_open_basic[of T]
    by auto
  with mm have "\<Union>M = \<Union>RepFun(T,D)" by auto
  then have "Spec \<subseteq> \<Union>RepFun(T,D)" using M(2) by auto moreover
  from T(1) have "RepFun(T,D) \<subseteq> RepFun(?J,D)" unfolding FinPow_def by auto
  with m have "RepFun(T,D) \<subseteq> M" by auto moreover
  from T(1) have "Finite(RepFun(T,D))" unfolding FinPow_def
    using Finite_RepFun by auto
  ultimately show "\<exists>N\<in>FinPow(M). Spec \<subseteq> \<Union>N" unfolding FinPow_def
    by auto
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2009-1       |
            |              January 2010                 |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Test_rename
imports CSP_F
begin

datatype Event = a1 | a2 | a3 | aa

definition
  RenList :: " (Event * Event) set list"
  where
  RenList_def :
  "RenList == [a1 <-- aa, a2 <-- aa, a3 <-- aa]"

(* automatic proof *)

(* note: [[ ]]* is used } *)

lemma "(a1 -> a2 -> a3 -> STOP)[[RenList]]* =F
       (aa -> aa -> aa-> STOP)"
apply (simp add: RenList_def)
apply (cspF_auto | auto)+
done

(* step by step proof *)

lemma "(a1 -> a2 -> a3 -> STOP)[[RenList]]* =F
       (aa -> aa -> aa-> STOP)"
apply (simp add: RenList_def)

(* a1 *)

apply (cspF_auto)+
apply (auto)

(* a2 *)

apply (cspF_auto)+
apply (auto)

(* a3 *)

apply (cspF_auto)+
apply (auto)

(* STOP *)

apply (cspF_auto)+
done

(* the other renaming technique *)

definition
  Ren :: " (Event * Event) set"
  where
  Ren_def :
  "Ren == ({a1,a2,a3} <<- aa)"

(* automatic proof *)

(* note: [[ ]] is used } *)

lemma "(a1 -> a2 -> a3 -> STOP)[[Ren]] =F
       (aa -> aa -> aa-> STOP)"
apply (simp add: Ren_def)
apply (cspF_auto | auto)+
done

end


(*  Title:      HOL/Algebra/Exact_Sequence.thy
    Author:     Martin Baillon (first part) and LC Paulson (material ported from HOL Light)
*)

section \<open>Exact Sequences\<close>

theory Exact_Sequence
  imports Elementary_Groups Solvable_Groups
begin

subsection \<open>Definitions\<close>

inductive exact_seq :: "'a monoid list \<times> ('a \<Rightarrow> 'a) list \<Rightarrow> bool"  where
unity:     " group_hom G1 G2 f \<Longrightarrow> exact_seq ([G2, G1], [f])" |
extension: "\<lbrakk> exact_seq ((G # K # l), (g # q)); group H ; h \<in> hom G H ;
              kernel G H h = image g (carrier K) \<rbrakk> \<Longrightarrow> exact_seq (H # G # K # l, h # g # q)"

inductive_simps exact_seq_end_iff [simp]: "exact_seq ([G,H], (g # q))"
inductive_simps exact_seq_cons_iff [simp]: "exact_seq ((G # K # H # l), (g # h # q))"

abbreviation exact_seq_arrow ::
  "('a \<Rightarrow> 'a) \<Rightarrow> 'a monoid list \<times> ('a \<Rightarrow> 'a) list \<Rightarrow>  'a monoid \<Rightarrow> 'a monoid list \<times> ('a \<Rightarrow> 'a) list"
  ("(3_ / \<longlongrightarrow>\<index> _)" [1000, 60])
  where "exact_seq_arrow  f t G \<equiv> (G # (fst t), f # (snd t))"

subsection \<open>Basic Properties\<close>

lemma exact_seq_length1: "exact_seq t \<Longrightarrow> length (fst t) = Suc (length (snd t))"
  by (induct t rule: exact_seq.induct) auto

lemma exact_seq_length2: "exact_seq t \<Longrightarrow> length (snd t) \<ge> Suc 0"
  by (induct t rule: exact_seq.induct) auto

lemma dropped_seq_is_exact_seq:
  assumes "exact_seq (G, F)" and "(i :: nat) < length F"
  shows "exact_seq (drop i G, drop i F)"
proof-
  { fix t i assume "exact_seq t" "i < length (snd t)"
    hence "exact_seq (drop i (fst t), drop i (snd t))"
    proof (induction arbitrary: i)
      case (unity G1 G2 f) thus ?case
        by (simp add: exact_seq.unity)
    next
      case (extension G K l g q H h) show ?case
      proof (cases)
        assume "i = 0" thus ?case
          using exact_seq.extension[OF extension.hyps] by simp
      next
        assume "i \<noteq> 0" hence "i \<ge> Suc 0" by simp
        then obtain k where "k < length (snd (G # K # l, g # q))" "i = Suc k"
          using Suc_le_D extension.prems by auto
        thus ?thesis using extension.IH by simp
      qed
    qed }

  thus ?thesis using assms by auto
qed

lemma truncated_seq_is_exact_seq:
  assumes "exact_seq (l, q)" and "length l \<ge> 3"
  shows "exact_seq (tl l, tl q)"
  using exact_seq_length1[OF assms(1)] dropped_seq_is_exact_seq[OF assms(1), of "Suc 0"]
        exact_seq_length2[OF assms(1)] assms(2) by (simp add: drop_Suc)

lemma exact_seq_imp_exact_hom:
   assumes "exact_seq (G1 # l,q) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
   shows "g1 ` (carrier G1) = kernel G2 G3 g2"
proof-
  { fix t assume "exact_seq t" and "length (fst t) \<ge> 3 \<and> length (snd t) \<ge> 2"
    hence "(hd (tl (snd t))) ` (carrier (hd (tl (tl (fst t))))) =
            kernel (hd (tl (fst t))) (hd (fst t)) (hd (snd t))"
    proof (induction)
      case (unity G1 G2 f)
      then show ?case by auto
    next
      case (extension G l g q H h)
      then show ?case by auto
    qed }
  thus ?thesis using assms by fastforce
qed

lemma exact_seq_imp_exact_hom_arbitrary:
   assumes "exact_seq (G, F)"
     and "Suc i < length F"
   shows "(F ! (Suc i)) ` (carrier (G ! (Suc (Suc i)))) = kernel (G ! (Suc i)) (G ! i) (F ! i)"
proof -
  have "length (drop i F) \<ge> 2" "length (drop i G) \<ge> 3"
    using assms(2) exact_seq_length1[OF assms(1)] by auto
  then obtain l q
    where "drop i G = (G ! i) # (G ! (Suc i)) # (G ! (Suc (Suc i))) # l"
     and  "drop i F = (F ! i) # (F ! (Suc i)) # q"
    by (metis Cons_nth_drop_Suc Suc_less_eq assms exact_seq_length1 fst_conv
        le_eq_less_or_eq le_imp_less_Suc prod.sel(2))
  thus ?thesis
  using dropped_seq_is_exact_seq[OF assms(1), of i] assms(2)
        exact_seq_imp_exact_hom[of "G ! i" "G ! (Suc i)" "G ! (Suc (Suc i))" l q] by auto
qed

lemma exact_seq_imp_group_hom :
  assumes "exact_seq ((G # l, q)) \<longlongrightarrow>\<^bsub>g\<^esub> H"
  shows "group_hom G H g"
proof-
  { fix t assume "exact_seq t"
    hence "group_hom (hd (tl (fst t))) (hd (fst t)) (hd(snd t))"
    proof (induction)
      case (unity G1 G2 f)
      then show ?case by auto
    next
      case (extension G l g q H h)
      then show ?case unfolding group_hom_def group_hom_axioms_def by auto
    qed }
  note aux_lemma = this
  show ?thesis using aux_lemma[OF assms]
    by simp
qed

lemma exact_seq_imp_group_hom_arbitrary:
  assumes "exact_seq (G, F)" and "(i :: nat) < length F"
  shows "group_hom (G ! (Suc i)) (G ! i) (F ! i)"
proof -
  have "length (drop i F) \<ge> 1" "length (drop i G) \<ge> 2"
    using assms(2) exact_seq_length1[OF assms(1)] by auto
  then obtain l q
    where "drop i G = (G ! i) # (G ! (Suc i)) # l"
     and  "drop i F = (F ! i) # q"
    by (metis Cons_nth_drop_Suc Suc_leI assms exact_seq_length1 fst_conv
        le_eq_less_or_eq le_imp_less_Suc prod.sel(2))
  thus ?thesis
  using dropped_seq_is_exact_seq[OF assms(1), of i] assms(2)
        exact_seq_imp_group_hom[of "G ! i" "G ! (Suc i)" l q "F ! i"] by simp
qed

subsection \<open>Link Between Exact Sequences and Solvable Conditions\<close>

lemma exact_seq_solvable_imp :
  assumes "exact_seq ([G1],[]) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
    and "inj_on g1 (carrier G1)"
    and "g2 ` (carrier G2) = carrier G3"
  shows "solvable G2 \<Longrightarrow> (solvable G1) \<and> (solvable G3)"
proof -
  assume G2: "solvable G2"
  have "group_hom G1 G2 g1"
    using exact_seq_imp_group_hom_arbitrary[OF assms(1), of "Suc 0"] by simp
  hence "solvable G1"
    using group_hom.inj_hom_imp_solvable[of G1 G2 g1] assms(2) G2 by simp
  moreover have "group_hom G2 G3 g2"
    using exact_seq_imp_group_hom_arbitrary[OF assms(1), of 0] by simp
  hence "solvable G3"
    using group_hom.surj_hom_imp_solvable[of G2 G3 g2] assms(3) G2 by simp
  ultimately show ?thesis by simp
qed

lemma exact_seq_solvable_recip :
  assumes "exact_seq ([G1],[]) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
    and "inj_on g1 (carrier G1)"
    and "g2 ` (carrier G2) = carrier G3"
  shows "(solvable G1) \<and> (solvable G3) \<Longrightarrow> solvable G2"
proof -
  assume "(solvable G1) \<and> (solvable G3)"
  hence G1: "solvable G1" and G3: "solvable G3" by auto
  have g1: "group_hom G1 G2 g1" and g2: "group_hom G2 G3 g2"
    using exact_seq_imp_group_hom_arbitrary[OF assms(1), of "Suc 0"]
          exact_seq_imp_group_hom_arbitrary[OF assms(1), of 0] by auto
  show ?thesis
    using solvable_condition[OF g1 g2 assms(3)]
          exact_seq_imp_exact_hom[OF assms(1)] G1 G3 by auto
qed

proposition exact_seq_solvable_iff :
  assumes "exact_seq ([G1],[]) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
    and "inj_on g1 (carrier G1)"
    and "g2 ` (carrier G2) = carrier G3"
  shows "(solvable G1) \<and> (solvable G3) \<longleftrightarrow>  solvable G2"
  using exact_seq_solvable_recip exact_seq_solvable_imp assms by blast

lemma exact_seq_eq_triviality:
  assumes "exact_seq ([E,D,C,B,A], [k,h,g,f])"
  shows "trivial_group C \<longleftrightarrow> f ` carrier A = carrier B \<and> inj_on k (carrier D)" (is "_ = ?rhs")
proof
  assume C: "trivial_group C"
  with assms have "inj_on k (carrier D)"
    apply (auto simp: group_hom.image_from_trivial_group trivial_group_def hom_one)
    apply (simp add: group_hom_def group_hom_axioms_def group_hom.inj_iff_trivial_ker)
    done
  with assms C show ?rhs
    apply (auto simp: group_hom.image_from_trivial_group trivial_group_def hom_one)
     apply (auto simp: group_hom_def group_hom_axioms_def hom_def kernel_def)
    done
next
  assume ?rhs
  with assms show "trivial_group C"
    apply (simp add: trivial_group_def)
    by (metis group_hom.inj_iff_trivial_ker group_hom.trivial_hom_iff group_hom_axioms.intro group_hom_def)
qed

lemma exact_seq_imp_triviality:
   "\<lbrakk>exact_seq ([E,D,C,B,A], [k,h,g,f]); f \<in> iso A B; k \<in> iso D E\<rbrakk> \<Longrightarrow> trivial_group C"
  by (metis (no_types, lifting) Group.iso_def bij_betw_def exact_seq_eq_triviality mem_Collect_eq)

lemma exact_seq_epi_eq_triviality:
   "exact_seq ([D,C,B,A], [h,g,f]) \<Longrightarrow> (f ` carrier A = carrier B) \<longleftrightarrow> trivial_homomorphism B C g"
  by (auto simp: trivial_homomorphism_def kernel_def)

lemma exact_seq_mon_eq_triviality:
   "exact_seq ([D,C,B,A], [h,g,f]) \<Longrightarrow> inj_on h (carrier C) \<longleftrightarrow> trivial_homomorphism B C g"
  by (auto simp: trivial_homomorphism_def kernel_def group.is_monoid inj_on_one_iff' image_def) blast

lemma exact_sequence_sum_lemma:
  assumes "comm_group G" and h: "h \<in> iso A C" and k: "k \<in> iso B D"
    and ex: "exact_seq ([D,G,A], [g,i])" "exact_seq ([C,G,B], [f,j])"
    and fih: "\<And>x. x \<in> carrier A \<Longrightarrow> f(i x) = h x"
    and gjk: "\<And>x. x \<in> carrier B \<Longrightarrow> g(j x) = k x"
  shows "(\<lambda>(x, y). i x \<otimes>\<^bsub>G\<^esub> j y) \<in> Group.iso (A \<times>\<times> B) G \<and> (\<lambda>z. (f z, g z)) \<in> Group.iso G (C \<times>\<times> D)"
    (is "?ij \<in> _ \<and> ?gf \<in> _")
proof (rule epi_iso_compose_rev)
  interpret comm_group G
    by (rule assms)
  interpret f: group_hom G C f
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  interpret g: group_hom G D g
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  interpret i: group_hom A G i
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  interpret j: group_hom B G j
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  have kerf: "kernel G C f = j ` carrier B" and "group A" "group B" "i \<in> hom A G"
    using ex by (auto simp: group_hom_def group_hom_axioms_def)
  then obtain h' where "h' \<in> hom C A" "(\<forall>x \<in> carrier A. h'(h x) = x)"
    and hh': "(\<forall>y \<in> carrier C. h(h' y) = y)" and "group_isomorphisms A C h h'"
    using h by (auto simp: group.iso_iff_group_isomorphisms group_isomorphisms_def)
  have homij: "?ij \<in> hom (A \<times>\<times> B) G"
    unfolding case_prod_unfold
    apply (rule hom_group_mult)
    using ex by (simp_all add: group_hom_def hom_of_fst [unfolded o_def] hom_of_snd [unfolded o_def])
  show homgf: "?gf \<in> hom G (C \<times>\<times> D)"
    using ex by (simp add: hom_paired)
  show "?ij \<in> epi (A \<times>\<times> B) G"
  proof (clarsimp simp add: epi_iff_subset homij)
    fix x
    assume x: "x \<in> carrier G"
    with \<open>i \<in> hom A G\<close> \<open>h' \<in> hom C A\<close> have "x \<otimes>\<^bsub>G\<^esub> inv\<^bsub>G\<^esub>(i(h'(f x))) \<in> kernel G C f"
      by (simp add: kernel_def hom_in_carrier hh' fih)
    with kerf obtain y where y: "y \<in> carrier B" "j y = x \<otimes>\<^bsub>G\<^esub> inv\<^bsub>G\<^esub>(i(h'(f x)))"
      by auto
    have "i (h' (f x)) \<otimes>\<^bsub>G\<^esub> (x \<otimes>\<^bsub>G\<^esub> inv\<^bsub>G\<^esub> i (h' (f x))) = x \<otimes>\<^bsub>G\<^esub> (i (h' (f x)) \<otimes>\<^bsub>G\<^esub> inv\<^bsub>G\<^esub> i (h' (f x)))"
      by (meson \<open>h' \<in> hom C A\<close> x f.hom_closed hom_in_carrier i.hom_closed inv_closed m_lcomm)
    also have "\<dots> = x"
      using \<open>h' \<in> hom C A\<close> hom_in_carrier x by fastforce
    finally show "x \<in> (\<lambda>(x, y). i x \<otimes>\<^bsub>G\<^esub> j y) ` (carrier A \<times> carrier B)"
      using x y apply (clarsimp simp: image_def)
      apply (rule_tac x="h'(f x)" in bexI)
       apply (rule_tac x=y in bexI, auto)
      by (meson \<open>h' \<in> hom C A\<close> f.hom_closed hom_in_carrier)
  qed
  show "(\<lambda>z. (f z, g z)) \<circ> (\<lambda>(x, y). i x \<otimes>\<^bsub>G\<^esub> j y) \<in> Group.iso (A \<times>\<times> B) (C \<times>\<times> D)"
    apply (rule group.iso_eq [where f = "\<lambda>(x,y). (h x,k y)"])
    using ex
    apply (auto simp: group_hom_def group_hom_axioms_def DirProd_group iso_paired2 h k fih gjk kernel_def set_eq_iff)
     apply (metis f.hom_closed f.r_one fih imageI)
    apply (metis g.hom_closed g.l_one gjk imageI)
    done
qed

subsection \<open>Splitting lemmas and Short exact sequences\<close>
text\<open>Ported from HOL Light by LCP\<close>

definition short_exact_sequence
  where "short_exact_sequence A B C f g \<equiv> \<exists>T1 T2 e1 e2. exact_seq ([T1,A,B,C,T2], [e1,f,g,e2]) \<and> trivial_group T1 \<and> trivial_group T2"

lemma short_exact_sequenceD:
  assumes "short_exact_sequence A B C f g" shows "exact_seq ([A,B,C], [f,g]) \<and> f \<in> epi B A \<and> g \<in> mon C B"
  using assms
  apply (auto simp: short_exact_sequence_def group_hom_def group_hom_axioms_def)
  apply (simp add: epi_iff_subset group_hom.intro group_hom.kernel_to_trivial_group group_hom_axioms.intro)
  by (metis (no_types, lifting) group_hom.inj_iff_trivial_ker group_hom.intro group_hom_axioms.intro
      hom_one image_empty image_insert mem_Collect_eq mon_def trivial_group_def)

lemma short_exact_sequence_iff:
  "short_exact_sequence A B C f g \<longleftrightarrow> exact_seq ([A,B,C], [f,g]) \<and> f \<in> epi B A \<and> g \<in> mon C B"
proof -
  have "short_exact_sequence A B C f g"
    if "exact_seq ([A, B, C], [f, g])" and "f \<in> epi B A" and "g \<in> mon C B"
  proof -
    show ?thesis
      unfolding short_exact_sequence_def
    proof (intro exI conjI)
      have "kernel A (singleton_group \<one>\<^bsub>A\<^esub>) (\<lambda>x. \<one>\<^bsub>A\<^esub>) = f ` carrier B"
        using that by (simp add: kernel_def singleton_group_def epi_def)
      moreover have "kernel C B g = {\<one>\<^bsub>C\<^esub>}"
        using that group_hom.inj_iff_trivial_ker mon_def by fastforce
      ultimately show "exact_seq ([singleton_group (one A), A, B, C, singleton_group (one C)], [\<lambda>x. \<one>\<^bsub>A\<^esub>, f, g, id])"
        using that
        by (simp add: group_hom_def group_hom_axioms_def group.id_hom_singleton)
    qed auto
qed
  then show ?thesis
    using short_exact_sequenceD by blast
qed

lemma very_short_exact_sequence:
  assumes "exact_seq ([D,C,B,A], [h,g,f])" "trivial_group A" "trivial_group D"
  shows "g \<in> iso B C"
  using assms
  apply simp
  by (metis (no_types, lifting) group_hom.image_from_trivial_group group_hom.iso_iff
      group_hom.kernel_to_trivial_group group_hom.trivial_ker_imp_inj group_hom_axioms.intro group_hom_def hom_carrier inj_on_one_iff')

lemma splitting_sublemma_gen:
  assumes ex: "exact_seq ([C,B,A], [g,f])" and fim: "f ` carrier A = H"
      and "subgroup K B" and 1: "H \<inter> K \<subseteq> {one B}" and eq: "set_mult B H K = carrier B"
  shows "g \<in> iso (subgroup_generated B K) (subgroup_generated C(g ` carrier B))"
proof -
  interpret KB: subgroup K B
    by (rule assms)
  interpret fAB: group_hom A B f
    using ex by simp
  interpret gBC: group_hom B C g
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  have "group A" "group B" "group C" and kerg: "kernel B C g = f ` carrier A"
      using ex by (auto simp: group_hom_def group_hom_axioms_def)
  have ker_eq: "kernel B C g = H"
    using ex by (simp add: fim)
  then have "subgroup H B"
    using ex by (simp add: group_hom.img_is_subgroup)
  show ?thesis
    unfolding iso_iff
  proof (intro conjI)
    show "g \<in> hom (subgroup_generated B K) (subgroup_generated C(g ` carrier B))"
      by (metis ker_eq \<open>subgroup K B\<close> eq gBC.hom_between_subgroups gBC.set_mult_ker_hom(2) order_refl subgroup.subset)
    show "g ` carrier (subgroup_generated B K) = carrier (subgroup_generated C(g ` carrier B))"
      by (metis assms(3) eq fAB.H.subgroupE(1) gBC.img_is_subgroup gBC.set_mult_ker_hom(2) ker_eq subgroup.carrier_subgroup_generated_subgroup)
    interpret gKBC: group_hom "subgroup_generated B K" C g
      apply (auto simp: group_hom_def group_hom_axioms_def \<open>group C\<close>)
      by (simp add: fAB.H.hom_from_subgroup_generated gBC.homh)
    have *: "x = \<one>\<^bsub>B\<^esub>"
      if x: "x \<in> carrier (subgroup_generated B K)" and "g x = \<one>\<^bsub>C\<^esub>" for x
    proof -
      have x': "x \<in> carrier B"
        using that fAB.H.carrier_subgroup_generated_subset by blast
      moreover have "x \<in> H"
        using kerg fim x' that by (auto simp: kernel_def set_eq_iff)
      ultimately show ?thesis
        by (metis "1" x Int_iff singletonD KB.carrier_subgroup_generated_subgroup subsetCE)
    qed
    show "inj_on g (carrier (subgroup_generated B K))"
      using "*" gKBC.inj_on_one_iff by auto
  qed
qed

lemma splitting_sublemma:
  assumes ex: "short_exact_sequence C B A g f" and fim: "f ` carrier A = H"
      and "subgroup K B" and 1: "H \<inter> K \<subseteq> {one B}" and eq: "set_mult B H K = carrier B"
    shows "f \<in> iso A (subgroup_generated B H)" (is ?f)
          "g \<in> iso (subgroup_generated B K) C" (is ?g)
proof -
  show ?f
    using short_exact_sequenceD [OF ex]
    apply (clarsimp simp add: group_hom_def group.iso_onto_image)
    using fim group.iso_onto_image by blast
  have "C = subgroup_generated C(g ` carrier B)"
    using short_exact_sequenceD [OF ex]
    apply simp
    by (metis epi_iff_subset group.subgroup_generated_group_carrier hom_carrier subset_antisym)
  then show ?g
    using short_exact_sequenceD [OF ex]
    by (metis "1" \<open>subgroup K B\<close> eq fim splitting_sublemma_gen)
qed

lemma splitting_lemma_left_gen:
  assumes ex: "exact_seq ([C,B,A], [g,f])" and f': "f' \<in> hom B A" and iso: "(f' \<circ> f) \<in> iso A A"
    and injf: "inj_on f (carrier A)" and surj: "g ` carrier B = carrier C"
 obtains H K where "H \<lhd> B" "K \<lhd> B" "H \<inter> K \<subseteq> {one B}" "set_mult B H K = carrier B"
                   "f \<in> iso A (subgroup_generated B H)" "g \<in> iso (subgroup_generated B K) C"
proof -
  interpret gBC: group_hom B C g
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  have "group A" "group B" "group C" and kerg: "kernel B C g = f ` carrier A"
    using ex by (auto simp: group_hom_def group_hom_axioms_def)
  then have *: "f ` carrier A \<inter> kernel B A f' = {\<one>\<^bsub>B\<^esub>} \<and> f ` carrier A <#>\<^bsub>B\<^esub> kernel B A f' = carrier B"
    using group_semidirect_sum_image_ker [of f A B f' A] assms by auto
  interpret f'AB: group_hom B A f'
    using assms by (auto simp: group_hom_def group_hom_axioms_def)
  let ?H = "f ` carrier A"
  let ?K = "kernel B A f'"
  show thesis
  proof
    show "?H \<lhd> B"
      by (simp add: gBC.normal_kernel flip: kerg)
    show "?K \<lhd> B"
      by (rule f'AB.normal_kernel)
    show "?H \<inter> ?K \<subseteq> {\<one>\<^bsub>B\<^esub>}" "?H <#>\<^bsub>B\<^esub> ?K = carrier B"
      using * by auto
    show "f \<in> Group.iso A (subgroup_generated B ?H)"
      using ex by (simp add: injf iso_onto_image group_hom_def group_hom_axioms_def)
    have C: "C = subgroup_generated C(g ` carrier B)"
      using surj by (simp add: gBC.subgroup_generated_group_carrier)
    show "g \<in> Group.iso (subgroup_generated B ?K) C"
      apply (subst C)
      apply (rule splitting_sublemma_gen [OF ex refl])
      using * by (auto simp: f'AB.subgroup_kernel)
  qed
qed

lemma splitting_lemma_left:
  assumes ex: "exact_seq ([C,B,A], [g,f])" and f': "f' \<in> hom B A"
    and inv: "(\<And>x. x \<in> carrier A \<Longrightarrow> f'(f x) = x)"
    and injf: "inj_on f (carrier A)" and surj: "g ` carrier B = carrier C"
 obtains H K where "H \<lhd> B" "K \<lhd> B" "H \<inter> K \<subseteq> {one B}" "set_mult B H K = carrier B"
                   "f \<in> iso A (subgroup_generated B H)" "g \<in> iso (subgroup_generated B K) C"
proof -
  interpret fAB: group_hom A B f
    using ex by simp
  interpret gBC: group_hom B C g
    using ex by (simp add: group_hom_def group_hom_axioms_def)
  have "group A" "group B" "group C" and kerg: "kernel B C g = f ` carrier A"
      using ex by (auto simp: group_hom_def group_hom_axioms_def)
  have iso: "f' \<circ> f \<in> Group.iso A A"
    using ex by (auto simp: inv intro:  group.iso_eq [OF \<open>group A\<close> id_iso])
  show thesis
    by (metis that splitting_lemma_left_gen [OF ex f' iso injf surj])
qed

lemma splitting_lemma_right_gen:
  assumes ex: "short_exact_sequence C B A g f" and g': "g' \<in> hom C B" and iso: "(g \<circ> g') \<in> iso C C"
 obtains H K where "H \<lhd> B" "subgroup K B" "H \<inter> K \<subseteq> {one B}" "set_mult B H K = carrier B"
                   "f \<in> iso A (subgroup_generated B H)" "g \<in> iso (subgroup_generated B K) C"
proof
  interpret fAB: group_hom A B f
    using short_exact_sequenceD [OF ex] by (simp add: group_hom_def group_hom_axioms_def)
  interpret gBC: group_hom B C g
    using short_exact_sequenceD [OF ex] by (simp add: group_hom_def group_hom_axioms_def)
  have *: "f ` carrier A \<inter> g' ` carrier C = {\<one>\<^bsub>B\<^esub>}"
          "f ` carrier A <#>\<^bsub>B\<^esub> g' ` carrier C = carrier B"
          "group A" "group B" "group C"
          "kernel B C g = f ` carrier A"
    using group_semidirect_sum_ker_image [of g g' C C B] short_exact_sequenceD [OF ex]
    by (simp_all add: g' iso group_hom_def)
  show "kernel B C g \<lhd> B"
    by (simp add: gBC.normal_kernel)
  show "(kernel B C g) \<inter> (g' ` carrier C) \<subseteq> {\<one>\<^bsub>B\<^esub>}" "(kernel B C g) <#>\<^bsub>B\<^esub> (g' ` carrier C) = carrier B"
    by (auto simp: *)
  show "f \<in> Group.iso A (subgroup_generated B (kernel B C g))"
    by (metis "*"(6) fAB.group_hom_axioms group.iso_onto_image group_hom_def short_exact_sequenceD [OF ex])
  show "subgroup (g' ` carrier C) B"
    using splitting_sublemma
    by (simp add: fAB.H.is_group g' gBC.is_group group_hom.img_is_subgroup group_hom_axioms_def group_hom_def)
  then show "g \<in> Group.iso (subgroup_generated B (g' ` carrier C)) C"
    by (metis (no_types, lifting) iso_iff fAB.H.hom_from_subgroup_generated gBC.homh image_comp inj_on_imageI iso subgroup.carrier_subgroup_generated_subgroup)
qed

lemma splitting_lemma_right:
  assumes ex: "short_exact_sequence C B A g f" and g': "g' \<in> hom C B" and gg': "\<And>z. z \<in> carrier C \<Longrightarrow> g(g' z) = z"
 obtains H K where "H \<lhd> B" "subgroup K B" "H \<inter> K \<subseteq> {one B}" "set_mult B H K = carrier B"
                   "f \<in> iso A (subgroup_generated B H)" "g \<in> iso (subgroup_generated B K) C"
proof -
  have *: "group A" "group B" "group C"
    using group_semidirect_sum_ker_image [of g g' C C B] short_exact_sequenceD [OF ex]
    by (simp_all add: g'  group_hom_def)
  show thesis
    apply (rule splitting_lemma_right_gen [OF ex g' group.iso_eq [OF _ id_iso]])
    using * apply (auto simp: gg' intro: that)
    done
qed

end


(* Author: Tobias Nipkow *)

section \<open>1-2 Brother Tree Implementation of Maps\<close>

theory Brother12_Map
imports
  Brother12_Set
  Map_by_Ordered
begin

fun lookup :: "('a \<times> 'b) bro \<Rightarrow> 'a::linorder \<Rightarrow> 'b option" where
"lookup N0 x = None" |
"lookup (N1 t) x = lookup t x" |
"lookup (N2 l (a,b) r) x =
  (case cmp x a of
     LT \<Rightarrow> lookup l x |
     EQ \<Rightarrow> Some b |
     GT \<Rightarrow> lookup r x)"

locale update = insert
begin

fun upd :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a\<times>'b) bro \<Rightarrow> ('a\<times>'b) bro" where
"upd x y N0 = L2 (x,y)" |
"upd x y (N1 t) = n1 (upd x y t)" |
"upd x y (N2 l (a,b) r) =
  (case cmp x a of
     LT \<Rightarrow> n2 (upd x y l) (a,b) r |
     EQ \<Rightarrow> N2 l (a,y) r |
     GT \<Rightarrow> n2 l (a,b) (upd x y r))"

definition update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a\<times>'b) bro \<Rightarrow> ('a\<times>'b) bro" where
"update x y t = tree(upd x y t)"

end

context delete
begin

fun del :: "'a::linorder \<Rightarrow> ('a\<times>'b) bro \<Rightarrow> ('a\<times>'b) bro" where
"del _ N0         = N0" |
"del x (N1 t)     = N1 (del x t)" |
"del x (N2 l (a,b) r) =
  (case cmp x a of
     LT \<Rightarrow> n2 (del x l) (a,b) r |
     GT \<Rightarrow> n2 l (a,b) (del x r) |
     EQ \<Rightarrow> (case del_min r of
              None \<Rightarrow> N1 l |
              Some (ab, r') \<Rightarrow> n2 l ab r'))"

definition delete :: "'a::linorder \<Rightarrow> ('a\<times>'b) bro \<Rightarrow> ('a\<times>'b) bro" where
"delete a t = tree (del a t)"

end

subsection "Functional Correctness Proofs"

subsubsection "Proofs for lookup"

lemma lookup_map_of: "t \<in> T h \<Longrightarrow>
  sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by(induction h arbitrary: t) (auto simp: map_of_simps split: option.splits)

subsubsection "Proofs for update"

context update
begin

lemma inorder_upd: "t \<in> T h \<Longrightarrow>
  sorted1(inorder t) \<Longrightarrow> inorder(upd x y t) = upd_list x y (inorder t)"
by(induction h arbitrary: t) (auto simp: upd_list_simps inorder_n1 inorder_n2)

lemma inorder_update: "t \<in> T h \<Longrightarrow>
  sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd inorder_tree)

end

subsubsection \<open>Proofs for deletion\<close>

context delete
begin

lemma inorder_del:
  "t \<in> T h \<Longrightarrow> sorted1(inorder t) \<Longrightarrow> inorder(del x t) = del_list x (inorder t)"
by(induction h arbitrary: t) (auto simp: del_list_simps inorder_n2
     inorder_del_min[OF UnI1] inorder_del_min[OF UnI2] split: option.splits)

lemma inorder_delete:
  "t \<in> T h \<Longrightarrow> sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del inorder_tree)

end

subsection \<open>Invariant Proofs\<close>

subsubsection \<open>Proofs for update\<close>

context update
begin

lemma upd_type:
  "(t \<in> B h \<longrightarrow> upd x y t \<in> Bp h) \<and> (t \<in> U h \<longrightarrow> upd x y t \<in> T h)"
apply(induction h arbitrary: t)
 apply (simp)
apply (fastforce simp: Bp_if_B n2_type dest: n1_type)
done

lemma update_type:
  "t \<in> B h \<Longrightarrow> update x y t \<in> B h \<union> B (Suc h)"
unfolding update_def by (metis upd_type tree_type)

end

subsubsection "Proofs for deletion"

context delete
begin

lemma del_type:
  "t \<in> B h \<Longrightarrow> del x t \<in> T h"
  "t \<in> U h \<Longrightarrow> del x t \<in> Um h"
proof (induction h arbitrary: x t)
  case (Suc h)
  { case 1
    then obtain l a b r where [simp]: "t = N2 l (a,b) r" and
      lr: "l \<in> T h" "r \<in> T h" "l \<in> B h \<or> r \<in> B h" by auto
    { assume "x < a"
      have ?case
      proof cases
        assume "l \<in> B h"
        from n2_type3[OF Suc.IH(1)[OF this] lr(2)]
        show ?thesis using `x<a` by(simp)
      next
        assume "l \<notin> B h"
        hence "l \<in> U h" "r \<in> B h" using lr by auto
        from n2_type1[OF Suc.IH(2)[OF this(1)] this(2)]
        show ?thesis using `x<a` by(simp)
      qed
    } moreover
    { assume "x > a"
      have ?case
      proof cases
        assume "r \<in> B h"
        from n2_type3[OF lr(1) Suc.IH(1)[OF this]]
        show ?thesis using `x>a` by(simp)
      next
        assume "r \<notin> B h"
        hence "l \<in> B h" "r \<in> U h" using lr by auto
        from n2_type2[OF this(1) Suc.IH(2)[OF this(2)]]
        show ?thesis using `x>a` by(simp)
      qed
    } moreover
    { assume [simp]: "x=a"
      have ?case
      proof (cases "del_min r")
        case None
        show ?thesis
        proof cases
          assume "r \<in> B h"
          with del_minNoneN0[OF this None] lr show ?thesis by(simp)
        next
          assume "r \<notin> B h"
          hence "r \<in> U h" using lr by auto
          with del_minNoneN1[OF this None] lr(3) show ?thesis by (simp)
        qed
      next
        case [simp]: (Some br')
        obtain b r' where [simp]: "br' = (b,r')" by fastforce
        show ?thesis
        proof cases
          assume "r \<in> B h"
          from del_min_type(1)[OF this] n2_type3[OF lr(1)]
          show ?thesis by simp
        next
          assume "r \<notin> B h"
          hence "l \<in> B h" and "r \<in> U h" using lr by auto
          from del_min_type(2)[OF this(2)] n2_type2[OF this(1)]
          show ?thesis by simp
        qed
      qed
    } ultimately show ?case by auto
  }
  { case 2 with Suc.IH(1) show ?case by auto }
qed auto

lemma delete_type:
  "t \<in> B h \<Longrightarrow> delete x t \<in> B h \<union> B(h-1)"
unfolding delete_def
by (cases h) (simp, metis del_type(1) tree_type Suc_eq_plus1 diff_Suc_1)

end

subsection "Overall correctness"

interpretation Map_by_Ordered
where empty = N0 and lookup = lookup and update = update.update
and delete = delete.delete and inorder = inorder and inv = "\<lambda>t. \<exists>h. t \<in> B h"
proof (standard, goal_cases)
  case 2 thus ?case by(auto intro!: lookup_map_of)
next
  case 3 thus ?case by(auto intro!: update.inorder_update)
next
  case 4 thus ?case by(auto intro!: delete.inorder_delete)
next
  case 6 thus ?case using update.update_type by (metis Un_iff)
next
  case 7 thus ?case using delete.delete_type by blast
qed auto

end


(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section {* General Algorithms for Iterators over Finite Sets *}
theory SetIteratorCollectionsGA
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
begin

subsection {* Iterate add to Set *}

definition iterate_add_to_set where
    "iterate_add_to_set s ins (it::('x,'x_set) set_iterator) =
     it (\<lambda>_. True) (\<lambda>x \<sigma>. ins x \<sigma>) s"

lemma iterate_add_to_set_correct :
assumes ins_OK: "set_ins \<alpha> invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_add_to_set s ins it) = S0 \<union> \<alpha> s \<and> invar (iterate_add_to_set s ins it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = S \<union> \<alpha> s \<and> invar \<sigma>"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def)
done

lemma iterate_add_to_set_dj_correct :
assumes ins_dj_OK: "set_ins_dj \<alpha> invar ins_dj"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "S0 \<inter> \<alpha> s = {}"
shows "\<alpha> (iterate_add_to_set s ins_dj it) = S0 \<union> \<alpha> s \<and> invar (iterate_add_to_set s ins_dj it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = S \<union> \<alpha> s \<and> invar \<sigma>"])
apply (insert ins_dj_OK s_OK dj)
apply (simp_all add: set_ins_dj_def set_eq_iff)
done

subsection {* Iterator to Set *}

definition iterate_to_set where
    "iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) =
     iterate_add_to_set (emp ()) ins_dj it"

lemma iterate_to_set_alt_def[code] :
    "iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) =
     it (\<lambda>_. True) (\<lambda>x \<sigma>. ins_dj x \<sigma>) (emp ())"
unfolding iterate_to_set_def iterate_add_to_set_def by simp

lemma iterate_to_set_correct :
assumes ins_dj_OK: "set_ins_dj \<alpha> invar ins_dj"
assumes emp_OK: "set_empty \<alpha> invar emp"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_to_set emp ins_dj it) = S0 \<and> invar (iterate_to_set emp ins_dj it)"
unfolding iterate_to_set_def
using iterate_add_to_set_dj_correct [OF ins_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: set_empty_def)

subsection {* Iterate image/filter add to Set *}

text {* Iterators only visit element once. Therefore the image operations makes sense for
filters only if an injective function is used. However, when adding to a set using
non-injective functions is fine. *}

lemma iterate_image_filter_add_to_set_correct :
assumes ins_OK: "set_ins \<alpha> invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_add_to_set s ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<union> \<alpha> s \<and>
       invar (iterate_add_to_set s ins  (set_iterator_image_filter f it))"
unfolding iterate_add_to_set_def set_iterator_image_filter_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = {b . \<exists>a. a \<in> S \<and> f a = Some b} \<union> \<alpha> s \<and> invar \<sigma>"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def split: option.split)
apply auto
done

lemma iterate_image_filter_to_set_correct :
assumes ins_OK: "set_ins \<alpha> invar ins"
assumes emp_OK: "set_empty \<alpha> invar emp"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_to_set emp ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<and>
       invar (iterate_to_set emp ins  (set_iterator_image_filter f it))"
unfolding iterate_to_set_def
using iterate_image_filter_add_to_set_correct [OF ins_OK _ it, of "emp ()" f] emp_OK
by (simp add: set_empty_def)

text{* For completeness lets also consider injective versions. *}

lemma iterate_inj_image_filter_add_to_set_correct :
assumes ins_dj_OK: "set_ins_dj \<alpha> invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "{y. \<exists>x. x \<in> S0 \<and> f x = Some y} \<inter> \<alpha> s = {}"
assumes f_inj_on: "inj_on f (S0 \<inter> dom f)"
shows "\<alpha> (iterate_add_to_set s ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<union> \<alpha> s \<and>
       invar (iterate_add_to_set s ins  (set_iterator_image_filter f it))"
proof -
  from set_iterator_image_filter_correct [OF it f_inj_on]
  have it_f: "set_iterator (set_iterator_image_filter f it)
        {y. \<exists>x. x \<in> S0 \<and> f x = Some y}" by simp

  from iterate_add_to_set_dj_correct [OF ins_dj_OK, OF s_OK it_f dj]
  show ?thesis by auto
qed

lemma iterate_inj_image_filter_to_set_correct :
assumes ins_OK: "set_ins_dj \<alpha> invar ins"
assumes emp_OK: "set_empty \<alpha> invar emp"
assumes it: "set_iterator it S0"
assumes f_inj_on: "inj_on f (S0 \<inter> dom f)"
shows "\<alpha> (iterate_to_set emp ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<and>
       invar (iterate_to_set emp ins  (set_iterator_image_filter f it))"
unfolding iterate_to_set_def
using iterate_inj_image_filter_add_to_set_correct [OF ins_OK _ it _ f_inj_on, of "emp ()"] emp_OK
by (simp add: set_empty_def)

subsection {* Iterate diff Set *}

definition iterate_diff_set where
    "iterate_diff_set s del (it::('x,'x_set) set_iterator) =
     it (\<lambda>_. True) (\<lambda>x \<sigma>. del x \<sigma>) s"

lemma iterate_diff_correct :
assumes del_OK: "set_delete \<alpha> invar del"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_diff_set s del it) = \<alpha> s - S0 \<and> invar (iterate_diff_set s del it)"
unfolding iterate_diff_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = \<alpha> s - S \<and> invar \<sigma>"])
apply (insert del_OK s_OK)
apply (auto simp add: set_delete_def set_eq_iff)
done

subsection {* Iterate add to Map *}

definition iterate_add_to_map where
    "iterate_add_to_map m update (it::('k \<times> 'v,'kv_map) set_iterator) =
     it (\<lambda>_. True) (\<lambda>(k,v) \<sigma>. update k v \<sigma>) m"

lemma iterate_add_to_map_correct :
assumes upd_OK: "map_update \<alpha> invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
shows "\<alpha> (iterate_add_to_map m upd it) = \<alpha> m ++ M  \<and> invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>d \<sigma>. (\<alpha> \<sigma> = \<alpha> m ++ M |` d) \<and> invar \<sigma>"])
apply (simp_all add: map_update_def restrict_map_insert)
done

lemma iterate_add_to_map_dj_correct :
assumes upd_OK: "map_update_dj \<alpha> invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
assumes dj: "dom M \<inter> dom (\<alpha> m) = {}"
shows "\<alpha> (iterate_add_to_map m upd it) = \<alpha> m ++ M  \<and> invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>d \<sigma>. (\<alpha> \<sigma> = \<alpha> m ++ M |` d) \<and> invar \<sigma>"])
apply (simp_all add: map_update_dj_def restrict_map_insert set_eq_iff)
done

subsection {* Iterator to Map *}

definition iterate_to_map where
    "iterate_to_map emp upd_dj (it::('k \<times> 'v,'kv_map) set_iterator) =
     iterate_add_to_map (emp ()) upd_dj it"

lemma iterate_to_map_alt_def[code] :
    "iterate_to_map emp upd_dj it =
     it (\<lambda>_. True) (\<lambda>(k, v) \<sigma>. upd_dj k v \<sigma>) (emp ())"
unfolding iterate_to_map_def iterate_add_to_map_def by simp

lemma iterate_to_map_correct :
assumes upd_dj_OK: "map_update_dj \<alpha> invar upd_dj"
assumes emp_OK: "map_empty \<alpha> invar emp"
assumes it: "map_iterator it M"
shows "\<alpha> (iterate_to_map emp upd_dj it) = M \<and> invar (iterate_to_map emp upd_dj it)"
unfolding iterate_to_map_def
using iterate_add_to_map_dj_correct [OF upd_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: map_empty_def)

end


(* Title: thys/Numerals_Ex.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten

   Further contributions by Franz Regensburger (FABR) 02/2022 :
   - Re-ordering of sections
 *)

theory Numerals_Ex
  imports Numerals
begin

subsection \<open>About the expansion of the numeral notation\<close>

(* Some spikes by FABR concerning the notation <...>:

   The notation <...> produces a proper list of cells
   where lists of natural numbers are monadic encoded as blocks of Oc\<up>(n+1) for all n in the list

   The empty list of natural numbers is encoded as the empty cell list
 *)

lemma "<[]> == []" by auto
lemma "<[]::(nat list)> = ([]::(cell list))" by auto

(* value requests typed naturals. Otherwise, the syntactic expansion of <..> fails

    value "<0>"   \<longrightarrow> Error: Term to be evaluated contains free dictionaries
    value "<1>"   \<longrightarrow> Error: Term to be evaluated contains free dictionaries
 *)

value "<0::nat>"  (* OK *)
value "<1::nat>"  (* OK *)

(* empty nat list \<longrightarrow> empty cell list \<longrightarrow> the empty word epsilon *)

value "<[]::(nat list)>"

value "<[1::nat, 2::nat]>"

(* tuples *)

value "<(0::nat)>"
value "<(1::nat)>"

value "<(1::nat, 2::nat)>"

(* the following yield identical expansions; nested tuples are flattened *)
value "<[1::nat, 2::nat, 3::nat]>"
value "<(1::nat, 2::nat, 3::nat)>"
value "<(1::nat, (2::nat, 3::nat))>"
value "<(1::nat, [2::nat, 3::nat])>"

(*
   However:, nested lists are not possible (no need for such things)
   value "<[1::nat, [2::nat, 3::nat]]>"  \<longrightarrow> Error
 *)

end


theory Incidence_Structure
  imports
    "../../Orderings_Ext"
    "HOL-Data_Structures.Set_Specs"
begin

locale Incidence_Structure =
  fixes empty :: 'g
  fixes insert :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
  fixes delete :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
  fixes incidence :: "'b \<Rightarrow> 'g \<Rightarrow> ('a \<times> 'b) list"
  fixes invar :: "'g \<Rightarrow> bool"
  assumes incidence_empty: "incidence v empty = []"
  assumes incidence_insert:
    "invar G \<and> Sorted_Less.sorted (incidence v G) \<Longrightarrow>
     incidence v (insert x p G) = (if v = x then ins_list p (incidence v G) else incidence v G)"
  assumes incidence_delete:
    "invar G \<and> Sorted_Less.sorted (incidence v G) \<Longrightarrow>
     incidence v (delete x p G) = (if v = x then List_Ins_Del.del_list p (incidence v G) else incidence v G)"
  assumes invar_empty: "invar empty"
  assumes invar_insert: "invar G \<and> Sorted_Less.sorted (incidence v G) \<Longrightarrow> invar (insert v p G)"
  assumes invar_delete: "invar G \<and> Sorted_Less.sorted (incidence v G) \<Longrightarrow> invar (delete v p G)"

definition (in Incidence_Structure) invar' :: "'g \<Rightarrow> bool" where
  "invar' G \<equiv> invar G \<and> (\<forall>v. Sorted_Less.sorted (incidence v G))"

lemma (in Incidence_Structure) invar'_empty:
  shows "invar' empty"
  using invar_empty
  by (simp add: invar'_def incidence_empty)

lemma (in Incidence_Structure) invar'_insert:
  assumes "invar' G"
  shows "invar' (insert v p G)"
  using assms
  by (auto simp add: invar'_def incidence_insert intro: invar_insert sorted_ins_list)

lemma (in Incidence_Structure) invar'_delete:
  assumes "invar' G"
  shows "invar' (delete v p G)"
  using assms
  by (auto simp add: invar'_def incidence_delete intro: invar_delete sorted_del_list)

end