section \<open>Additions to Separation Algebra Library\<close>
theory Sep_Algebra_Add
  imports "Separation_Algebra.Sep_Tactics"
      "HOL-Library.Function_Algebras"  "HOL-Library.Product_Plus"
begin

no_notation pred_K ("\<langle>_\<rangle>")
hide_const (open) Separation_Algebra.pure

subsection \<open>Simp-Lemmas for Separation Algebra\<close>

named_theorems sep_algebra_simps \<open>Advanced simplification lemmas for separation algebra\<close>

lemmas [sep_algebra_simps] = sep_conj_exists sep_add_ac
lemmas [simp] = sep_conj_assoc

lemmas sep_conj_c = sep_conj_commute sep_conj_left_commute

lemmas sep_conj_aci = sep_conj_ac sep_conj_empty sep_conj_empty'

subsection \<open>Separation Algebra with a Unique Zero\<close>

class unique_zero_sep_algebra = stronger_sep_algebra +
  assumes unique_zero: "x##x \<Longrightarrow> x=0"
begin
  lemma unique_zero_simps[simp]:
    "a##a \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a+b = a \<longleftrightarrow> b=0"
    "a##b \<Longrightarrow> a+b = b \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a + b = 0 \<longleftrightarrow> a=0 \<and> b=0"
    apply -
    using local.sep_disj_zero local.unique_zero apply blast
    apply (metis local.sep_add_disjD local.sep_add_zero local.unique_zero)
    apply (metis local.sep_add_disjD local.sep_add_zero_sym local.sep_disj_commute local.unique_zero)
    by (metis local.sep_add_disjD local.sep_add_zero local.sep_disj_zero local.unique_zero)

end

subsection \<open>Standard Instantiations\<close>

thm plus_fun_def
thm zero_fun_def

instantiation "fun" :: (type,stronger_sep_algebra) stronger_sep_algebra
begin
  definition "f1 ## f2 \<longleftrightarrow> (\<forall>x. f1 x ## f2 x)"

  instance
    apply standard
    unfolding sep_disj_fun_def plus_fun_def zero_fun_def
    apply (auto)
    subgoal
      by (simp add: sep_disj_commute)
    subgoal
      using sep_add_commute by auto
    subgoal
      by (simp add: sep_add_assoc)
    (*subgoal
      using sep_disj_addD1 by blast
    subgoal
      by (simp add: sep_disj_addI1)
    *)
    done

end

lemma plus_fun_alt[simp]: "(f1 + f2) x = (f1 x + f2 x)"
  by auto
lemma zero_fun_alt[simp]: "0 x \<equiv> 0"
  by auto

instance "fun" :: (type,unique_zero_sep_algebra) unique_zero_sep_algebra
  apply standard
  unfolding sep_disj_fun_def plus_fun_def zero_fun_def
  by (metis unique_zero)

lemma disj_fun_upd_iff[simp]:
  "\<lbrakk>f a = 0; g a = 0\<rbrakk> \<Longrightarrow> (f(a:=x) ## g(a:=y)) \<longleftrightarrow> (f ## g \<and> x ## y)"
  unfolding sep_disj_fun_def by force

lemma fun_upd_Z_Z[simp]: "fun_upd 0 i 0 = 0" by auto

lemma sep_disj_fun_updI[sep_algebra_simps, intro]: "\<lbrakk>f##g; a##b\<rbrakk> \<Longrightarrow> f(x:=a) ## g(x:=b)"
  by (simp add: sep_disj_fun_def)

lemma sep_disj_fun_Zupd_eq[sep_algebra_simps]:
  "f##0(x:=y) \<longleftrightarrow> f x ## y"
  "0(x:=y) ## f \<longleftrightarrow> y ## f x"
  by (auto simp add: sep_disj_fun_def)

lemma sep_disj_funD: "f##g \<Longrightarrow> f x ## g x" by (auto simp: sep_disj_fun_def)

lemma merge_fun_singleton: "fun_upd 0 i (a::'c::pre_sep_algebra) + fun_upd 0 i b = fun_upd 0 i (a+b)"
  by auto

lemma split_fun_upd_0: "fun_upd (a+b) i (0::'c::pre_sep_algebra) = fun_upd a i 0 + fun_upd b i 0"
  by auto

instantiation option :: (stronger_sep_algebra) stronger_sep_algebra begin

  fun sep_disj_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
    "sep_disj None None \<longleftrightarrow> True"
  | "sep_disj None (Some _) \<longleftrightarrow> True"
  | "sep_disj (Some _) None \<longleftrightarrow> True"
  | "sep_disj (Some x) (Some y) \<longleftrightarrow> x##y"

  lemma sep_disj_option_add_simps[simp]:
    "sep_disj None x"
    "sep_disj x None"
    by (cases x; simp)+

  fun plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
    "plus None None = None"
  | "plus None (Some x) = Some x"
  | "plus (Some x) None = Some x"
  | "plus (Some x) (Some y) = Some (x+y)"

  lemma plus_option_add_simps[simp]: "plus None x = x" "plus x None = x"
    by (cases x; simp)+

  definition "0 = None"

  instance
    apply standard
    apply (simp_all add: zero_option_def)
    apply (case_tac x; case_tac y; simp add: sep_disj_commute)
    apply (case_tac x; case_tac y; auto simp add: sep_disj_commute sep_add_commute)
    apply (case_tac x; case_tac y; case_tac z; simp add: sep_add_assoc)
    apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addD1)
    (*apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addI1)*)
    done

end

instantiation prod :: (stronger_sep_algebra, stronger_sep_algebra) stronger_sep_algebra
begin
  definition "a##b \<longleftrightarrow> fst a ## fst b \<and> snd a ## snd b"

  instance
    apply standard
    unfolding sep_disj_prod_def plus_prod_def zero_prod_def
    by (auto
      simp: sep_add_ac
      intro: sep_disj_commuteI sep_disj_addD1 sep_disj_addI1)
end

lemma sep_disj_prod_lower[sep_algebra_simps]: "(a,b) ## (c,d) \<longleftrightarrow> a##c \<and> b##d"
  by (simp add: sep_disj_prod_def)

lemma plus_prod_lower[sep_algebra_simps]: "(a,b) + (c,d) = (a+c,b+d)"
  by (simp add: plus_prod_def)

instance prod :: (unique_zero_sep_algebra,unique_zero_sep_algebra) unique_zero_sep_algebra
  by standard (auto simp: zero_prod_def sep_algebra_simps)

lemma prod_Z_lower[sep_algebra_simps]:
  "(a,b) = 0 \<longleftrightarrow> a=0 \<and> b=0"
  "0 = (a,b) \<longleftrightarrow> a=0 \<and> b=0"
  by (auto simp: zero_prod_def)

lemma plus_prod_eqI: "(a+b,c+d) = (a,c) + (b,d)" by (simp add: sep_algebra_simps)

lemma fst_Z[simp]: "fst 0 = 0" by (simp add: zero_prod_def)
lemma snd_Z[simp]: "snd 0 = 0" by (simp add: zero_prod_def)

lemma fst_plus[sep_algebra_simps]: "fst (a+b) = fst a + fst b" by (auto simp: plus_prod_def)
lemma snd_plus[sep_algebra_simps]: "snd (a+b) = snd a + snd b" by (auto simp: plus_prod_def)
lemma disj_fstI[sep_algebra_simps]: "a##b \<Longrightarrow> fst a ## fst b" by (auto simp: sep_disj_prod_def)
lemma disj_sndI[sep_algebra_simps]: "a##b \<Longrightarrow> snd a ## snd b" by (auto simp: sep_disj_prod_def)

datatype 'a tsa_opt = ZERO | TRIV (the_tsa: 'a)

instantiation tsa_opt :: (type) unique_zero_sep_algebra begin
  definition sep_disj_tsa_opt :: "'a tsa_opt \<Rightarrow> 'a tsa_opt \<Rightarrow> bool"
    where "a##b \<longleftrightarrow> a=ZERO \<or> b=ZERO"

  definition "a+b \<equiv> (case (a,b) of (ZERO,x) \<Rightarrow> x | (x,ZERO) \<Rightarrow> x)"
  definition "0 = ZERO"

  instance
    apply standard
    by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

end

instance tsa_opt :: (type) cancellative_sep_algebra
  apply standard
  by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

(* Lowering lemmas. If one side of operation breaks abstraction level,
  the other side is also lowered
*)
lemma TRIV_not_zero[simp]: "TRIV x \<noteq> 0" "0\<noteq>TRIV x" by (auto simp: zero_tsa_opt_def)
lemma TRIV_Z_lower[intro!]:
  "ZERO = 0"
  "0 = ZERO"
  by (auto simp: zero_tsa_opt_def)

lemma triv_Z_lower2[sep_algebra_simps]:
  "x + ZERO = x"
  "ZERO + x = x"
  by (auto simp: zero_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

lemma TRIV_disj_simps[sep_algebra_simps]:
  "TRIV a ## b \<longleftrightarrow> b=ZERO"
  "b ## TRIV a \<longleftrightarrow> b=ZERO"
  by (auto simp: sep_disj_tsa_opt_def)

subsection \<open>Additional Simplifier Setup\<close>

(*
  This may cause trouble on non-eta-normalized terms.
    (\<lambda>s. \<box> s) \<rightarrow> \<lambda>s. s=0
  The next lemma hopefully fixes that.
*)

lemma sep_empty_app[sep_algebra_simps]: "\<box> h \<longleftrightarrow> h=0"
  by (simp add: sep_empty_def)

lemma sep_empty_I[sep_algebra_simps]: "(\<lambda>h. h=0) = \<box>"
  by (simp add: sep_empty_def)

lemma sep_triv_ineqs[simp]:
  "\<box> \<noteq> sep_false"
  "sep_true \<noteq> sep_false"
  "sep_false \<noteq> \<box>"
  "sep_false \<noteq> sep_true"
  by (auto dest: fun_cong)

lemma sep_true_not_empty:
  assumes "(a::'a::sep_algebra) \<noteq> (b::'a)"
  shows "(\<box>::'a\<Rightarrow>bool) \<noteq> sep_true"
  by (metis (mono_tags, lifting) assms sep_empty_I)

subsection \<open>Pure Assertions\<close>

text \<open>The Separation Algebra entry only defines @{term "pred_K \<Phi>"}, which
  makes no constraint on the heap. We define \<open>\<up>\<Phi>\<close>, which requires an empty heap,
  and is more natural when using separation logic with deallocation.
\<close>

definition pred_lift :: "bool \<Rightarrow> 'a::sep_algebra \<Rightarrow> bool" ("\<up>_" [100] 100)
  where "(\<up>\<Phi>) s \<equiv> \<Phi> \<and> \<box> s"

text \<open>Relation between \<open>pred_lift\<close> and \<open>pred_K\<close>. Warning, do not use
  as simp-lemma, as \<open>sep_true\<close> is an abbreviation for \<open>\<langle>True\<rangle>\<close>\<close>
lemma "pred_K \<Phi> = (\<up>\<Phi> ** sep_true)" by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_merge_simps[sep_algebra_simps]:
  "(\<up>\<Phi> ** \<up>\<Psi>) = (\<up>(\<Phi>\<and>\<Psi>))"
  "(\<up>\<Phi> ** \<up>\<Psi> ** B) = (\<up>(\<Phi>\<and>\<Psi>) ** B)"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_move_front_simps[sep_algebra_simps]:
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi> ** B) = (\<up>\<Phi> ** A ** B)"
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi>) = (\<up>\<Phi> ** A)"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemmas pred_lift_move_merge_simps = pred_lift_merge_simps pred_lift_move_front_simps

lemma pred_lift_extract_simps:
  "(\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> h=0"
  "(\<up>\<Phi> ** A) h \<longleftrightarrow> \<Phi> \<and> A h"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pure_true_conv[sep_algebra_simps]: "\<up>True = \<box>" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pred_lift_false_conv[simp]: "\<up>False = sep_false" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pure_assn_eq_conv[simp]: "(\<up>\<Phi>) = (\<up>\<Psi>) \<longleftrightarrow> \<Phi>=\<Psi>"
  by (smt pred_lift_extract_simps(1))

lemmas sep_conj_false_simps =
  pred_lift_false_conv
  sep_conj_false_left sep_conj_false_right

definition sep_is_pure_assn :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> bool" where
  "sep_is_pure_assn A \<equiv> \<forall>s. A s \<longrightarrow> s=0"

definition pure_part :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> bool" where
  "pure_part A \<equiv> Ex A"

lemma pure_partI: "A s \<Longrightarrow> pure_part A" by (auto simp: pure_part_def)

lemma pure_part_pure_eq[simp]: "sep_is_pure_assn A \<Longrightarrow> \<up>pure_part A = A"
  apply (rule ext)
  by (auto simp: sep_is_pure_assn_def pure_part_def pred_lift_def sep_algebra_simps)

lemma pure_part_triv_simps[simp]:
  "\<not>pure_part sep_false"
  "pure_part \<box>"
  by (auto simp: pure_part_def)

lemma pure_part_pure[simp]: "pure_part (\<up>\<Phi>) = \<Phi>"
  by (auto simp: pure_part_def sep_algebra_simps pred_lift_def)

lemma pure_part_split_conj: "pure_part (A**B) \<Longrightarrow> pure_part A \<and> pure_part B"
  by (auto simp: pure_part_def sep_conj_def)

lemma sep_is_pure_lift_pred[simp]: "sep_is_pure_assn (\<up>\<Phi>)"
  by (auto simp: sep_is_pure_assn_def pred_lift_def sep_algebra_simps)

lemma sep_is_pure_assn_false[simp]: "sep_is_pure_assn sep_false" by (auto simp: sep_is_pure_assn_def)
lemma sep_is_pure_assn_empty[simp]: "sep_is_pure_assn \<box>" by (auto simp: sep_is_pure_assn_def sep_algebra_simps)

lemma sep_is_pure_assn_conjI: "sep_is_pure_assn A \<Longrightarrow> sep_is_pure_assn B \<Longrightarrow> sep_is_pure_assn (A**B)"
  by (auto simp: sep_is_pure_assn_def sep_conj_def)

lemma pure_part_pure_conj_eq: "pure_part (\<up>P ** Q) \<longleftrightarrow> P \<and> pure_part Q"
  unfolding pure_part_def by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma and_pure_true: "((A ** F) and ((\<up>\<Phi> ** sep_true) ** F)) s \<longrightarrow> ((\<up>\<Phi> ** A) ** F) s"
  unfolding sep_conj_def pred_lift_def
  by (auto simp: sep_algebra_simps)

subsection \<open>Exact Assertion\<close>

definition EXACT :: "'a::sep_algebra \<Rightarrow> 'a \<Rightarrow> bool" where [simp]: "EXACT h h' \<equiv> h'=h"
lemma strictly_exact_EXACT[simp]: "strictly_exact (EXACT h)"
  unfolding EXACT_def by (auto intro: strictly_exactI)

lemma EXACT_split: "a##b \<Longrightarrow> EXACT (a+b) = (EXACT a ** EXACT b)"
  unfolding EXACT_def sep_conj_def by auto

lemma EXACT_zero[simp]: "EXACT 0 = \<box>" by (auto simp: sep_algebra_simps)

lemma EXACT_eq_iff[simp]: "EXACT a = EXACT b \<longleftrightarrow> a=b"
  unfolding EXACT_def by metis

subsection \<open>List-Sum over Separation Algebra\<close>

(* TODO: Move. Clean up *)

definition "sepsum_list l \<equiv> foldr (+) l (0::_::stronger_sep_algebra)"

lemma sepsum_list_simps[simp]:
  "sepsum_list [] = 0"
  "sepsum_list (x#xs) = x + sepsum_list xs"
  by (auto simp: sepsum_list_def)

context begin

private named_theorems ss

private definition "sep_ldisj1 x ys \<equiv> \<forall>y\<in>List.set ys. x##y"

private lemma sep_ldisj1_simps[ss]:
  "sep_ldisj1 x []"
  "sep_ldisj1 x (y#ys) \<longleftrightarrow> x##y \<and> sep_ldisj1 x ys"
  by (auto simp: sep_ldisj1_def)

private lemma sep_ldisj1_append[ss]: "sep_ldisj1 x (ys\<^sub>1@ys\<^sub>2) \<longleftrightarrow> sep_ldisj1 x ys\<^sub>1 \<and> sep_ldisj1 x ys\<^sub>2"
  by (induction ys\<^sub>1) (auto simp: ss)

private definition "sep_ldisj xs ys \<equiv> \<forall>x\<in>List.set xs. sep_ldisj1 x ys"

private lemma sep_ldisj_simps[ss]:
  "sep_ldisj [] ys"
  "sep_ldisj xs []"
  "sep_ldisj (x#xs) ys \<longleftrightarrow> sep_ldisj1 x ys \<and> sep_ldisj xs ys"
  "sep_ldisj xs (y#ys) \<longleftrightarrow> sep_ldisj1 y xs \<and> sep_ldisj xs ys"
  by (auto simp: sep_ldisj_def sep_ldisj1_def sep_algebra_simps)

private lemma sep_ldisj_append1[ss]: "sep_ldisj (xs\<^sub>1@xs\<^sub>2) ys \<longleftrightarrow> sep_ldisj xs\<^sub>1 ys \<and> sep_ldisj xs\<^sub>2 ys"
  by (induction xs\<^sub>1) (auto simp: ss)

private lemma sep_ldisj_append2[ss]: "sep_ldisj xs (ys\<^sub>1@ys\<^sub>2) \<longleftrightarrow> sep_ldisj xs ys\<^sub>1 \<and> sep_ldisj xs ys\<^sub>2"
  by (induction ys\<^sub>1) (auto simp: ss)

private lemma sep_ldisj_commute[sep_algebra_simps]: "sep_ldisj xs ys \<longleftrightarrow> sep_ldisj ys xs"
  by (force simp: sep_ldisj_def sep_ldisj1_def sep_algebra_simps)

fun sep_distinct :: "_::stronger_sep_algebra list \<Rightarrow> bool" where
  "sep_distinct [] \<longleftrightarrow> True"
| "sep_distinct (x#xs) \<longleftrightarrow> sep_ldisj1 x xs \<and> sep_distinct xs"

declare sep_distinct.simps[simp del, ss add]

private lemma sep_distinct_append_aux[ss]:
  "sep_distinct (xs@ys) \<longleftrightarrow> sep_distinct xs \<and> sep_distinct ys \<and> sep_ldisj xs ys"
  by (induction xs) (auto simp: ss)

private lemma norm_ldisj1[ss]: "sep_distinct ys \<Longrightarrow> sep_ldisj1 x ys \<longleftrightarrow> x ## sepsum_list ys"
  by (induction ys arbitrary: x) (auto simp: ss)

private lemma norm_ldisj[ss]: "sep_distinct xs \<Longrightarrow> sep_distinct ys \<Longrightarrow> sep_ldisj xs ys \<longleftrightarrow> sepsum_list xs ## sepsum_list ys"
  by (induction xs) (auto simp: ss)

lemma sep_distinct_append[simp]:
  "sep_distinct (xs@ys) \<longleftrightarrow> sep_distinct xs \<and> sep_distinct ys \<and> sepsum_list xs ## sepsum_list ys"
  by (auto simp: ss)

lemma sepsum_append[simp]: "sep_distinct (xs@ys) \<Longrightarrow> sepsum_list (xs@ys) = sepsum_list xs + sepsum_list ys"
  by (induction xs) (auto simp: sep_algebra_simps ss)

lemma sep_distinct_simps[simp]:
  "sep_distinct []"
  "sep_distinct (x#xs) \<longleftrightarrow> x ## sepsum_list xs \<and> sep_distinct xs"
  by (auto simp: ss)

end

subsection \<open>Finite Assertion Families\<close>
interpretation sep_folding: folding "\<lambda>i Q. P i ** Q" \<box> for P
  apply unfold_locales
  apply (intro ext)
  apply (simp add: sep.add_ac)
  done

definition "sep_set_img S P \<equiv> \<up>(finite S) ** sep_folding.F P S"

syntax
  "_SEP_SET_IMG"      :: "pttrn => 'a set => ('b \<Rightarrow> bool) => ('b \<Rightarrow> bool)"  ("(3\<Union>*_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>*x\<in>A. B"   \<rightleftharpoons> "CONST sep_set_img A (\<lambda>x. B)"

print_translation \<open>
  [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax sep_set_img} @{syntax_const "_SEP_SET_IMG"}]
\<close> \<comment> \<open>to avoid eta-contraction of body\<close>

lemma sep_set_img_infinite[simp]: "infinite I \<Longrightarrow> sep_set_img I P = sep_false"
  unfolding sep_set_img_def by auto

lemma sep_set_img_empty[simp]: "sep_set_img {} P = \<box>"
  and sep_set_img_insert_remove: "sep_set_img (insert x S) P = (P x ** sep_set_img (S-{x}) P)"
  and sep_set_img_insert[simp]: "x\<notin>S \<Longrightarrow> sep_set_img (insert x S) P = (P x ** sep_set_img S P)"
  and sep_set_img_remove: "x\<in>S \<Longrightarrow> sep_set_img S P = (P x ** sep_set_img (S-{x}) P)"
  by (auto
    simp: sep_set_img_def sep_algebra_simps pred_lift_extract_simps sep_folding.insert_remove sep_folding.remove
    del: ext intro!: ext)

lemma sep_set_img_cong:
  assumes [simp]: "I=I'"
  assumes P: "\<And>x. finite I' \<Longrightarrow> x\<in>I' \<Longrightarrow> P x = P' x"
  shows "sep_set_img I P = sep_set_img I' P'"
proof -
  {
    assume "finite I'"
    then have "sep_set_img I' P = sep_set_img I' P'" using P
      by induction auto
  }
  then show ?thesis by (cases "finite I'") auto
qed

lemma sep_set_img_cong_strong[cong]:
  assumes [simp]: "I=I'"
  assumes P: "\<And>x. finite I' =simp=> x\<in>I' =simp=> P x = P' x"
  shows "sep_set_img I P = sep_set_img I' P'"
  using assms
  unfolding simp_implies_def
  by (rule sep_set_img_cong)

lemma sep_set_img_union[simp]:
  assumes "S\<^sub>1\<inter>S\<^sub>2={}"
  shows "sep_set_img (S\<^sub>1\<union>S\<^sub>2) P = (sep_set_img S\<^sub>1 P ** sep_set_img S\<^sub>2 P)"
proof -
  {
    assume "finite S\<^sub>1"
    then have ?thesis using assms
      by (induction S\<^sub>1) auto
  }
  then show ?thesis by (cases "finite S\<^sub>1") auto

qed

lemmas sep_set_img_ins[simp] = sep_set_img_union[where S\<^sub>1="{i}", simplified] for i

lemma sep_set_img_map:
  assumes "inj_on f I"
  shows "(\<Union>*i\<in>f`I. A i) = (\<Union>*i\<in>I. A (f i))"
proof (cases "finite I")
  case True
  thus ?thesis using assms apply (induction I)
    by (auto simp: sep_algebra_simps)
next
  case False thus ?thesis
    using assms
    apply simp
    using finite_image_iff sep_set_img_infinite by blast
qed

lemma sep_set_img_unionI':
  assumes NDUP: "\<And>x. \<lbrakk>x\<in>S\<^sub>2 \<rbrakk> \<Longrightarrow> (P x ** P x) = sep_false"
  assumes P: "(sep_set_img S\<^sub>1 P ** sep_set_img S\<^sub>2 P) s"
  shows "sep_set_img (S\<^sub>1\<union>S\<^sub>2) P s"
proof -

  have A: "(P x ** P x ** F) = sep_false" if "x\<in>S\<^sub>2" for x F
    using assms
    by (simp add: sep.mult_commute sep_conj_left_commute that)

  {
    assume "finite S\<^sub>1"
    then have "?thesis" using P
    proof (induction S\<^sub>1 arbitrary: s)
      case empty
      then show ?case by simp
    next
      case (insert x S\<^sub>1)
      then show ?case
        apply (cases "x\<notin>S\<^sub>2")
        apply (auto simp: sep_set_img_remove sep_set_img_insert_remove sep_algebra_simps sep_conj_impl)
        by (simp add: A sep_conj_left_commute)
    qed
  }
  then show ?thesis using P by (cases "finite S\<^sub>1") auto
qed

lemma sep_set_img_pull_EXS: "(\<Union>*x\<in>I. EXS y. f x y) = (EXS Y. \<Union>*x\<in>I. f x (Y x))"
proof -
  {
    assume "finite I"
    then have ?thesis
      apply (induction I)
      apply simp
      apply (rule ext)
      apply (clarsimp simp: sep_algebra_simps; safe)
      subgoal for x F s xa xb
        apply (rule exI[where x="xb(x:=xa)"])
        apply auto
        by (smt sep_set_img_cong)
      subgoal by auto
      done
  }
  then show ?thesis by (cases "finite I") auto
qed

lemma list_conj_eq_sep_set_img: "distinct xs \<Longrightarrow> (\<And>*map P xs) = sep_set_img (List.set xs) P"
  by (induction xs) auto

lemma sep_is_pure_assn_imgI:
  assumes "\<And>i. i\<in>I \<Longrightarrow> sep_is_pure_assn (f i)"
  shows "sep_is_pure_assn (\<Union>*i\<in>I. f i)"
proof (cases "finite I")
  assume "finite I"
  then show ?thesis using assms
    by (induction I) (auto simp: sep_is_pure_assn_conjI)
qed simp

end


(*  File:       Pairwise_Majority_Rule.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Pairwise Majority Rule\<close>

theory Pairwise_Majority_Rule
  imports "Compositional_Structures/Basic_Modules/Condorcet_Module"
          "Compositional_Structures/Defer_One_Loop_Composition"
begin

text
\<open>This is the pairwise majority rule, a voting rule that implements the
Condorcet criterion, i.e., it elects the Condorcet winner if it exists,
otherwise a tie remains between all alternatives.\<close>

subsection \<open>Definition\<close>

fun pairwise_majority_rule :: "'a Electoral_Module" where
  "pairwise_majority_rule A p vs = elector condorcet A p vs"

fun condorcet' :: "'a Electoral_Module" where
"condorcet' A p vs =
  ((min_eliminator condorcet_score) \<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d) A p vs"

fun pairwise_majority_rule' :: "'a Electoral_Module" where
"pairwise_majority_rule' A p vs = iterelect condorcet' A p vs"

subsection \<open>Condorcet Consistency Property\<close>

theorem condorcet_condorcet: "condorcet_consistency pairwise_majority_rule"
proof -
  have
    "condorcet_consistency (elector condorcet)"
    using condorcet_is_dcc dcc_imp_cc_elector
    by metis
  thus ?thesis
    using condorcet_consistency2 electoral_module_def
          pairwise_majority_rule.simps
    by metis
qed

end


theory Tut05
  imports "HOL-IMP.Big_Step"
begin

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "Or b1 b2 = Not (And (Not b1) (Not b2))"

lemma "IF And b1 b2 THEN c1 ELSE c2 \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"
proof(rule allI)+
  fix s t
  show "(IF And b1 b2 THEN c1 ELSE c2, s) \<Rightarrow> t = (IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2, s) \<Rightarrow> t"
  proof
    assume "(IF And b1 b2 THEN c1 ELSE c2, s) \<Rightarrow> t"
    then show "(IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2, s) \<Rightarrow> t"
      by(cases rule: big_step.cases, auto)
  next
    assume "(IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2, s) \<Rightarrow> t"
    then show "(IF And b1 b2 THEN c1 ELSE c2, s) \<Rightarrow> t"
      by(cases rule: big_step.cases, auto)
  qed
qed

lemma while_end: "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> \<not>bval b t"
  by(induction "WHILE b DO c" s t rule: big_step_induct, auto)

lemma "WHILE Or b1 b2 DO c \<sim> WHILE Or b1 b2 DO c;; WHILE b1 DO c"
  using while_end unfolding Or_def by force

fun deskseq :: "com \<Rightarrow> com \<Rightarrow> com" where
  "deskseq SKIP c = c" |
  "deskseq c SKIP = c" |
  "deskseq c1 c2 = c1;;c2"

fun deskif :: "bexp \<Rightarrow> com \<Rightarrow> com \<Rightarrow> com" where
  "deskif _ SKIP SKIP = SKIP" |
  "deskif b c1 c2 = IF b THEN c1 ELSE c2"

fun deskip :: "com \<Rightarrow> com"  where
  "deskip (c1;;c2) = deskseq (deskip c1) (deskip c2)" |
  "deskip (IF b THEN c1 ELSE c2) = deskif b (deskip c1) (deskip c2)" |
  "deskip (WHILE b DO c) = WHILE b DO (deskip c)" |
  "deskip c = c"

lemma deskseq_sim: "deskseq c1 c2 \<sim> c1;;c2"
  by(cases c1; cases c2, auto)

lemma deskif_sim: "deskif b c1 c2 \<sim> IF b THEN c1 ELSE c2"
  by(cases c1; cases c2, auto)

lemma "deskip c \<sim> c"
proof(induction c)
  case (Seq c1 c2)
  then show ?case using deskseq_sim by auto
next
  case (If x1 c1 c2)
  then show ?case using deskif_sim by auto
next
  case (While x1 c)
  then show ?case
    using sim_while_cong_aux by fastforce
qed auto

end


theory Tot_Unimod_graph
  imports Totally_Unimodular
begin

context gram_schmidt_floor
begin

definition Vs where "Vs E \<equiv> \<Union> E"

abbreviation "graph_invar E \<equiv> (\<forall>e\<in>E. \<exists>u v. e = {u, v} \<and> u \<noteq> v) \<and> finite (Vs E)"

definition bipartite where
  "bipartite E \<equiv> graph_invar E \<and> (\<exists> X \<subseteq> Vs E. \<forall> e \<in> E. \<exists> u v.
                                   e = {u, v} \<and> (u \<in> X \<and> v \<in> Vs E - X))"

lemma card_edge:
  assumes "graph_invar E"
  shows "\<forall> e\<in> E. card e = 2"
  by (simp add: assms card_2_iff)

definition set_to_list :: "'b set \<Rightarrow> 'b list"
  where "set_to_list s = (SOME l. set l = s \<and> distinct l)"

lemma  set_set_to_list:
  "finite s \<Longrightarrow> set (set_to_list s) = s"
  unfolding set_to_list_def
  by (metis (mono_tags, lifting) finite_distinct_list someI)

lemma  set_set_to_list_distinct:
  "finite s \<Longrightarrow> distinct (set_to_list s)"
  unfolding set_to_list_def
  by (metis (mono_tags, lifting) finite_distinct_list someI)

definition edges_list :: "'b set set \<Rightarrow> ('b set) list" where
  "edges_list E = set_to_list E"

lemma edges_list_el_in_E:
  assumes "k < card E"
  shows "edges_list E ! k \<in> E"
proof -
  have "finite E"
    by (metis assms(1) card.infinite not_less_zero)
  have "set (edges_list E) = E"
    unfolding edges_list_def using set_set_to_list
    using \<open>finite E\<close> by blast
  have "edges_list E ! k \<in> set (edges_list E)"
    by (metis \<open>set (edges_list E) = E\<close> assms card_length not_less nth_mem order_trans_rules(23))
  show ?thesis
    using \<open>edges_list E ! k \<in> set (edges_list E)\<close> \<open>set (edges_list E) = E\<close> by blast
qed

lemma distinct_edges_list:
  assumes "finite E"
  shows "distinct (edges_list E)"
  unfolding edges_list_def
  using set_set_to_list_distinct assms
  by blast

definition vertices_list :: "'b set set \<Rightarrow> 'b list" where
  "vertices_list E = set_to_list (Vs E)"

lemma vert_list_el_in_VsE:
  assumes "k < card (Vs E)"
  shows "vertices_list E ! k \<in> Vs E"
proof -
  have "finite (Vs E)"
    by (metis assms(1) card.infinite not_less_zero)
  have "set (vertices_list E) = Vs E"
    unfolding vertices_list_def using set_set_to_list
    using \<open>finite (Vs E)\<close> by blast
  then have "vertices_list E ! k \<in> set (vertices_list E)"
    by (metis assms card_length not_less nth_mem order_trans_rules(23))
  then show ?thesis
    using \<open>set (vertices_list E) = Vs E\<close> by blast
qed

lemma distinct_vert_list:
  assumes "finite (Vs E)"
  shows "distinct (vertices_list E)"
  unfolding vertices_list_def
  using set_set_to_list_distinct assms
  by blast

lemma diff_verts:
  assumes "i < card (Vs E)"
  assumes "j < card (Vs E)"
  assumes "i \<noteq> j"
  shows "vertices_list E ! i \<noteq> vertices_list E ! j"
proof -
  have "finite (Vs E)"
    by (metis assms(1) card.infinite less_nat_zero_code)
  have "distinct (vertices_list E)"
    by (simp add: \<open>finite (Vs E)\<close> distinct_vert_list)
  then show ?thesis
    unfolding vertices_list_def
    by (metis \<open>finite (Vs E)\<close> assms distinct_card nth_eq_iff_index_eq set_set_to_list)
qed

definition insidence_mat :: "'b set set  \<Rightarrow> 'a mat" where
  "insidence_mat E = mat (card (Vs E)) (card E)
          (\<lambda>(i,j). if (vertices_list E) ! i \<in> (edges_list E) ! j then 1 else 0)"

lemma dim_col_insidence_mat:
  shows "dim_col (insidence_mat E) = card E"
  unfolding insidence_mat_def by auto

lemma dim_row_insidence_mat:
  shows "dim_row (insidence_mat E) = (card (Vs E))"
  unfolding insidence_mat_def by auto

lemma one_then_in_edge:
  assumes "i < card (Vs E)"
  assumes "j < card E"
  assumes "(insidence_mat E) $$ (i,j) = 1"
  shows "(vertices_list E) ! i \<in> (edges_list E) ! j"
  using assms
proof -
  have "(insidence_mat E) $$ (i,j) = (if (vertices_list E) ! i \<in> (edges_list E) ! j then 1 else 0)"
    unfolding insidence_mat_def using assms(1-2)
    by fastforce
  then show ?thesis
    using assms(3) field.one_not_zero by presburger
qed

lemma zeo_then_notin_edge:
  assumes "i < card (Vs E)"
  assumes "j < card E"
  assumes "(insidence_mat E) $$ (i,j) = 0"
  shows "(vertices_list E) ! i \<notin> (edges_list E) ! j"
  using assms
proof -
  have "(insidence_mat E) $$ (i,j) = (if (vertices_list E) ! i \<in> (edges_list E) ! j then 1 else 0)"
    unfolding insidence_mat_def using assms(1-2)
    by fastforce
  then show ?thesis
    using assms(3) field.one_not_zero
    by presburger
qed

lemma elems_insidence_one_zero:
  assumes "i < card (Vs E)"
  assumes "j < card E"
  shows "(insidence_mat E) $$ (i,j) = 0 \<or> (insidence_mat E) $$ (i,j) = 1"
  unfolding insidence_mat_def
  by (simp add: assms(1) assms(2))

lemma at_most_two_ones:
  assumes "graph_invar E"
  assumes "k < card E"
  shows "\<exists> i < (card (Vs E)). \<exists> j < card (Vs E). i \<noteq> j \<and>
              (insidence_mat E) $$ (i, k) = 1 \<and> (insidence_mat E) $$ (j, k) = 1 \<and>
              (\<forall> t < card (Vs E). (t\<noteq>i \<and> t \<noteq> j) \<longrightarrow> B $$ (t,k) = 0)"
  oops

lemma at_most_two_ones2:
  assumes "graph_invar E"
  assumes "k < card E"
  shows "\<exists> i < (card (Vs E)). \<exists> j < card (Vs E). i \<noteq> j \<and>
              col (insidence_mat E) k = unit_vec (card (Vs E)) i + unit_vec (card (Vs E)) j"
  oops

lemma at_most_two_ones2:
  assumes "graph_invar E"
  assumes "k < card E"
  assumes "i < (card (Vs E))"
  assumes "j < (card (Vs E))"
  assumes "i \<noteq> j"
  assumes " (insidence_mat E) $$ (i, k) = 1 \<and> (insidence_mat E) $$ (j, k) = 1"
  shows "(\<forall> t < card (Vs E). (t\<noteq>i \<and> t \<noteq> j) \<longrightarrow> (insidence_mat E) $$ (t,k) = 0)"
proof safe
  fix t
  assume asm: "t < card (Vs E)" "t \<noteq> i" "t \<noteq> j"
  show "(insidence_mat E) $$ (t,k) = 0"
  proof(rule ccontr)
    assume "(insidence_mat E) $$ (t, k) \<noteq> 0"
    then have "(insidence_mat E) $$ (t, k) = 1"
      using asm(1) assms(2) gram_schmidt_floor.elems_insidence_one_zero by blast
    then have 1: "(vertices_list E) ! t \<in> (edges_list E) ! k"
      using asm(1) assms(2) gram_schmidt_floor.one_then_in_edge by blast
    have 2: "(vertices_list E) ! i \<in> (edges_list E) ! k"
      using assms(2) assms(3) assms(6) gram_schmidt_floor.one_then_in_edge by blast
    have 3: "(vertices_list E) ! j \<in> (edges_list E) ! k"
      using assms(2) assms(4) assms(6) gram_schmidt_floor.one_then_in_edge by blast
    have "card ((edges_list E) ! k) \<noteq> 2"
    proof(cases "infinite ((edges_list E) ! k)")
      case True
      then show ?thesis
        by simp
    next
      case False
      have "{(vertices_list E) ! i, (vertices_list E) ! j, (vertices_list E) ! t} \<subseteq>
            (edges_list E) ! k"
        by (simp add: 1 2 3)
      then show ?thesis
        using diff_verts
        by (metis 1 2 3 asm assms(3-5) card_2_iff')
    qed
    have "(edges_list E) ! k \<in> E" using edges_list_el_in_E
      using assms(2) by blast
    then show False
      using card_edge[of E] \<open>card (edges_list E ! k) \<noteq> 2\<close> assms(1) by fastforce
  qed
qed

lemma dim_row_mat_less_card_I:
  assumes "finite I"
  shows "dim_row (submatrix A I J) \<le> card I"
proof -
  have "{i. i < dim_row A \<and> i \<in> I} \<subseteq> I" by auto
  then have "card {i. i < dim_row A \<and> i \<in> I} \<le> card I"
    using assms card_mono by blast
  then show ?thesis
    by (simp add: dim_submatrix(1))
qed

lemma exist_index_in_submat:
  assumes "B = submatrix A I UNIV"
  assumes "j < dim_row B"
  shows "\<exists> i < dim_row A. i \<in> I \<and> row B j = row A i  \<and> i = pick I j"
proof -
  have "(pick I j) < dim_row A"
    by (metis assms(1) assms(2) dim_submatrix(1) pick_le)
  moreover have "(pick I j) \<in> I"
    apply(cases "finite I")
    using  dim_row_mat_less_card_I pick_in_set_le
     apply (metis assms(1) assms(2) order_trans_rules(22))
    using pick_in_set_inf by auto
  ultimately show ?thesis
    by (metis (no_types, lifting) assms dim_submatrix(1) row_submatrix_UNIV)
qed

lemma submatrix_not_more_than_two:
  assumes "graph_invar E"
  assumes "k < dim_col B"
  assumes "i < dim_row B"
  assumes "j < dim_row B"
  assumes "i \<noteq> j"
  assumes "B = submatrix (insidence_mat E) I J"
  assumes "B $$ (i, k) = 1 \<and> B $$ (j, k) = 1"
  shows "(\<forall> t < dim_row B. (t\<noteq>i \<and> t \<noteq> j) \<longrightarrow> B $$ (t,k) = 0)"
proof safe
  fix t
  assume asm: "t < dim_row B" "t \<noteq> i" "t \<noteq> j"
  obtain i1 where i1: "row (insidence_mat E) i1 =
        row (submatrix (insidence_mat E) I UNIV) i \<and>
        i1 < dim_row (insidence_mat E) \<and>
        i1 = pick I i"
    using exist_index_in_submat
    by (metis (no_types, lifting) assms(3,6) dim_submatrix(1) exist_index_in_submat)
  obtain j1 where j1: "row (insidence_mat E) j1 =
        row (submatrix (insidence_mat E) I UNIV) j \<and>
        j1 < dim_row (insidence_mat E) \<and>
        j1 = pick I j"
    using exist_index_in_submat
    by (metis (no_types, lifting) assms(4,6) dim_submatrix(1) exist_index_in_submat)
  obtain t1 where t1: "row (insidence_mat E) t1 =
        row (submatrix (insidence_mat E) I UNIV) t \<and>
        t1 < dim_row (insidence_mat E) \<and>
        t1 = pick I t"
    using exist_index_in_submat
    by (metis (no_types, lifting) asm(1) assms(6) dim_submatrix(1) exist_index_in_submat)
  have "dim_col B = card {i. i < dim_col (insidence_mat E) \<and> i \<in> J}"
    using assms(6) dim_submatrix(2) by blast
  then obtain k1 where k1: "col (insidence_mat E) k1 =
         col (submatrix (insidence_mat E) UNIV J) k \<and>
         k1 < dim_col (insidence_mat E) \<and>
         k1 = pick J k"
    using pick_le col_submatrix_UNIV
    by (metis (no_types, lifting) Collect_cong \<open>k < dim_col B\<close>)
  have "k1 < card E"
    using dim_col_insidence_mat k1 by metis
  have "i1 < (card (Vs E))"
    using dim_row_insidence_mat i1 by metis
  have "j1 < (card (Vs E))"
    using dim_row_insidence_mat j1 by metis
  have "pick I i \<noteq> pick I j"
    by (metis assms(3-6) diff_is_0_eq diff_less_mono dim_row_mat_less_card_I less_irrefl not_less
        not_less_iff_gr_or_eq not_less_zero pick_mono_inf pick_mono_le)
  then have "i1 \<noteq> j1"
    using i1 j1 by blast
  have "(insidence_mat E) $$ (pick I i, pick J k) = B  $$ (i,k)"
    by (metis (no_types, lifting) assms(2,3,6) dim_submatrix(1-2) submatrix_index)
  then have "(insidence_mat E) $$ (i1, k1) = 1"
    using assms(7) i1 k1 by presburger
  have "(insidence_mat E) $$ (pick I j, pick J k) = B  $$ (j,k)"
    by (metis (no_types, lifting) assms(2,4,6) dim_submatrix(1-2) submatrix_index)
  then have "(insidence_mat E) $$ (j1, k1) = 1"
    using assms(7) j1 k1 by presburger
  then have 1: "(\<forall> t < card (Vs E). (t\<noteq>i1 \<and> t \<noteq> j1) \<longrightarrow> (insidence_mat E) $$ (t,k1) = 0)"
    by (meson \<open>i1 < card (Vs E)\<close> \<open>i1 \<noteq> j1\<close> \<open>insidence_mat E $$ (i1, k1) = 1\<close> \<open>j1 < card (Vs E)\<close>
        \<open>k1 < card E\<close> assms(1) gram_schmidt_floor.at_most_two_ones2)
  have "pick I t \<noteq> pick I i"
    by (metis asm(1,2) assms(3,6) diff_is_0_eq diff_less_mono dim_row_mat_less_card_I less_irrefl
        not_less not_less_iff_gr_or_eq not_less_zero pick_mono_inf pick_mono_le)
  have "pick I t \<noteq> pick I j"
    by (metis asm(1,3) assms(4,6) diff_is_0_eq diff_less_mono dim_row_mat_less_card_I less_irrefl
        not_less not_less_iff_gr_or_eq not_less_zero pick_mono_inf pick_mono_le)
  then have "(insidence_mat E) $$ (t1, k1) = 0"
    by (metis 1 \<open>pick I t \<noteq> pick I i\<close> dim_row_insidence_mat i1 j1 t1)
  show "B $$ (t,k) = 0"
    by (metis (no_types, lifting) \<open>insidence_mat E $$ (t1, k1) = 0\<close> asm(1) assms(2,6)
        dim_submatrix(1-2) k1 submatrix_index t1)
qed

lemma submatrix_insidence_zero_or_one:
  assumes "graph_invar E"
  assumes "k < dim_col B"
  assumes "i < dim_row B"
  assumes "B = submatrix (insidence_mat E) I J"
  shows "B $$ (i, k) = 1 \<or> B $$ (i, k) = 0"
proof -
  have 1: "B $$ (i, k) = (insidence_mat E) $$ (pick I i, pick J k)"
    by (metis (no_types, lifting) assms(2-4) dim_submatrix(1-2) submatrix_index)
  have "pick I i < card (Vs E)"
    by (metis (no_types, lifting) assms(3,4) dim_submatrix(1) exist_index_in_submat
        gram_schmidt_floor.dim_row_insidence_mat)
  have "pick J k < card E"
    by (metis assms(2,4) dim_col_insidence_mat dim_submatrix(2) pick_le)
  have "(insidence_mat E) $$ (pick I i, pick J k) = 1 \<or>
        (insidence_mat E) $$ (pick I i, pick J k) = 0"
    using \<open>pick I i < card (Vs E)\<close> \<open>pick J k < card E\<close> elems_insidence_one_zero by blast
  then show ?thesis
    using 1 by presburger
qed

lemma bipartite_submatrix_det_unimod:
  assumes "bipartite E"
  assumes "B = submatrix (insidence_mat E) I J"
  shows "det B \<in> {-1, 0, 1}" using assms(2)
proof(induct "dim_row B" arbitrary: B I J rule: less_induct)
  case less
  show ?case
  proof(cases "dim_row B \<noteq> dim_col B")
    case True
    then show ?thesis
      unfolding Determinant.det_def
      by (meson insertCI)
  next
    case False
    have 1: "dim_row B = dim_col B" using False by auto
    then show ?thesis
    proof(cases "carrier class_ring = {\<zero>\<^bsub>class_ring\<^esub> ::'a}")
      case True
      have "carrier class_ring = {\<zero>\<^bsub>class_ring\<^esub> ::'a}"
        using True by fast
      then have "det B = 0"
        by auto
      then show ?thesis
        by blast
    next
      case False
      show ?thesis
      proof(cases "\<exists> j < dim_col B. col B j = 0\<^sub>v (dim_row B)")
        case True
        obtain j where " j < dim_col B \<and> col B j = 0\<^sub>v (dim_row B)"
          using True by blast
        have 2:"B \<in> carrier_mat (dim_row B) (dim_row B)"
          by (metis "1" carrier_matI)
        have "0\<^sub>v (dim_row B) \<in> (set (cols B))"
          by (metis True cols_length cols_nth in_set_conv_nth)
        have 3:"\<zero>\<^bsub>module_vec TYPE('a) (dim_row B)\<^esub>\<in> set (cols B)"
          by (metis \<open>0\<^sub>v (dim_row B) \<in> set (cols B)\<close> module_vec_simps(2))
        have 4:"Module.module class_ring (module_vec TYPE('a) (dim_row B))"
          using vec_module by blast
        have 5:" carrier class_ring \<noteq> {\<zero>\<^bsub>class_ring\<^esub> ::'a}" using False
          by simp
        have "module.lin_dep class_ring
     (module_vec TYPE('a) (dim_row B))
     (set (cols B))"
          using module.zero_lin_dep[OF 4 3 5]
          by fastforce
        then have "det B = 0"
          using idom_vec.lin_dep_cols_imp_det_0[OF 2]
          by blast
        then show ?thesis
          by force
      next
        case False
        show ?thesis
        proof(cases "\<exists>j<dim_col B. \<exists> i < dim_row B. col B j = unit_vec (dim_row B) i")
          case True
          have 2:"B \<in> carrier_mat (dim_row B) (dim_row B)"
            by (metis "1" carrier_matI)
          obtain j i where i_j:"j<dim_col B \<and> i < dim_row B \<and> col B j = unit_vec (dim_row B) i"
            using True by auto
          have 3: "j < dim_row B" using i_j
            using "1" by presburger
          have 10: "det B = (\<Sum>k<dim_row B. B $$ (k,j) * cofactor B k j)"
            using laplace_expansion_column[OF 2 3]
            by presburger
          have "\<forall>k<dim_row B. k \<noteq> i \<longrightarrow> B $$ (k,j) = 0"
          proof safe
            fix k
            assume asm: "k < dim_row B" "k\<noteq>i"
            have "B $$ (k,j) = col B j $ k"
              by (metis asm(1) i_j index_col)
            have "unit_vec (dim_row B) i $ k = 0"
              unfolding unit_vec_def
              by (simp add: i_j asm)
            show "B $$ (k, j) = 0"
              by (metis \<open>B $$ (k, j) = col B j $v k\<close> \<open>unit_vec (dim_row B) i $v k = 0\<close> i_j)
          qed
          then have "(\<Sum>k \<in> {0..<dim_row B}. B $$ (k,j) * cofactor B k j) =
               B $$ (i,j) * cofactor B i j"
            by (metis (mono_tags, lifting) atLeast0LessThan only_one_nonzero_is_sum
                finite_atLeastLessThan i_j lessThan_iff vector_space_over_itself.scale_eq_0_iff)
          then have 13: "det B = B $$ (i,j) * cofactor B i j"
            by (metis 10 atLeast0LessThan)
          have 8:"cofactor B i j = (-1)^(i+j) * det (mat_delete B i j)"
            using Determinant.cofactor_def by blast
          have 9:"mat_delete B i j = submatrix (insidence_mat E) (I - {pick I i}) (J - {pick J j})"
            using mat_delete_is_submatrix i_j less(2) by blast
          have 11: "dim_row ( submatrix (insidence_mat E) (I - {pick I i}) (J - {pick J j})) <
                    dim_row B"
            by (metis "9" bot_nat_0.not_eq_extremum diff_less i_j less_nat_zero_code
                less_one mat_delete_dim(1))
          have "det (submatrix (insidence_mat E) (I - {pick I i}) (J - {pick J j})) \<in> {-1, 0, 1}"
            using 11 less(1) by presburger
          then have "det (mat_delete B i j) \<in> {-1, 0, 1}"
            using "9" by presburger
          then have 12: "cofactor B i j \<in> {-1, 0, 1}"
            by (smt (verit, ccfv_SIG) 8 insert_iff mult_cancel_right2 mult_minus1 nat_pow_distrib
                singletonD square_eq_1_iff vector_space_over_itself.scale_eq_0_iff)
          have "B $$ (i,j) = col B j $ i"
            by (metis i_j index_col)
          have "unit_vec (dim_row B) i $ i = 1"
            unfolding unit_vec_def
            by (simp add: i_j)
          then have "B $$ (i,j) = 1"
            by (simp add: \<open>B $$ (i, j) = col B j $v i\<close> i_j)
          then show ?thesis
            by (metis 12 13 mult_cancel_right2)
        next
          case False
          show ?thesis
          proof(cases "dim_row B = 0")
            case True
            have "det B = 1" using det_dim_zero
              by (metis "1" True carrier_mat_triv)
            then show ?thesis by auto
          next
            case False
            have 4:"dim_row B > 0" using False by auto
            have 5:"\<forall> k < dim_col B. \<exists> i < dim_row B. \<exists> j < dim_row B.
                    B $$ (i, k) = 1 \<and> B $$ (j, k) = 1 \<and> i\<noteq>j"
              apply safe
              apply (rule ccontr)
            proof -
              fix k
              assume "k < dim_col B"
              assume asm_not: "\<not> (\<exists>i<dim_row B. \<exists>j<dim_row B.
                               B $$ (i, k) = 1 \<and> B $$ (j, k) = 1 \<and> i \<noteq> j)"
              have "col B k \<noteq> 0\<^sub>v (dim_row B)"
                using `\<not> (\<exists>j<dim_col B. col B j = 0\<^sub>v (dim_row B))`
                using \<open>k < dim_col B\<close> by blast
              have "\<exists> i < dim_row B. B $$ (i, k) = 1"
              proof(rule ccontr)
                assume "\<not> (\<exists>i<dim_row B. B $$ (i, k) = 1)"
                then have "\<forall>i<dim_row B. B $$ (i, k) = 0"
                  by (metis \<open>k < dim_col B\<close> assms(1) bipartite_def
                      gram_schmidt_floor.submatrix_insidence_zero_or_one less.prems)
                then have "\<forall>i<dim_row B. col B k $ i = 0"
                  by (metis \<open>k < dim_col B\<close> index_col)
                then have "col B k = 0\<^sub>v (dim_row B)"
                  unfolding zero_vec_def
                  by (metis Matrix.zero_vec_def dim_col dim_vec eq_vecI index_zero_vec(1))
                then show False
                  using `col B k \<noteq> 0\<^sub>v (dim_row B)` by auto
              qed
              then obtain i where i: "i < dim_row B \<and> B $$ (i, k) = 1" by auto
              have 13: "\<forall> j < dim_row B. i \<noteq> j \<longrightarrow>  B $$ (j, k) = 0"
              proof safe
                fix j
                assume asm: "j < dim_row B" "i \<noteq> j"
                show " B $$ (j, k) = 0"
                proof(rule ccontr)
                  assume "B $$ (j, k) \<noteq> 0"
                  then have "B $$ (j, k) = 1"
                    using submatrix_insidence_zero_or_one
                    by (metis \<open>k < dim_col B\<close> asm(1) assms(1) bipartite_def less.prems)
                  then show False
                    using asm_not i asm(1) asm(2) by blast
                qed
              qed
              have "col B k = unit_vec (dim_row B) i"
              proof
                show 14: "dim_vec (col B k) = dim_vec (unit_vec (dim_row B) i)"
                  by (metis dim_col index_unit_vec(3))
                fix ia
                assume "ia < dim_vec (unit_vec (dim_row B) i)"
                then show "col B k $v ia = unit_vec (dim_row B) i $v ia"
                  by (metis 13 14 i \<open>k < dim_col B\<close> dim_col index_col index_unit_vec(1))
              qed
              then show False using `\<not> (\<exists>j<dim_col B. \<exists>i<dim_row B. col B j = unit_vec (dim_row B) i)`
                using \<open>i < dim_row B \<and> B $$ (i, k) = 1\<close> \<open>k < dim_col B\<close> by blast
            qed
            obtain X where X: "graph_invar E \<and>
                               X \<subseteq> Vs E \<and> (\<forall> e \<in> E. \<exists> u v.  e = {u, v} \<and> (u \<in> X \<and> v \<in> Vs E - X))"
              using assms(1) unfolding bipartite_def by auto
            let ?u = "vec (dim_row B)
                      (\<lambda> i. if (vertices_list E) ! pick I i \<in> X then (1::'a)  else -1)"
            define u where "u =?u"
            have "\<forall> i < dim_row B. ?u $ i = 1 \<or> ?u $ i = -1"
              by simp
            then have 32:"?u \<noteq> 0\<^sub>v (dim_row B)"
              by (metis "4" class_field.neg_1_not_0 class_field.zero_not_one index_zero_vec(1))
            have "\<forall> t < dim_col B. col B t \<bullet> ?u = 0"
            proof safe
              fix t
              assume t: "t < dim_col B"
              obtain i j where i_j: "B $$ (i,t) = 1"
                "B $$ (j, t) = 1"
                "i < dim_row B"
                "j < dim_row B" "i \<noteq> j"
                using 5 t by blast
              have 6:"graph_invar E"
                by (meson X)
              have "\<forall>k < dim_row B. (k \<noteq> i \<and> k \<noteq> j) \<longrightarrow> B $$ (k,t) = 0"
                using submatrix_not_more_than_two[OF 6 t i_j(3) i_j(4) i_j(5) less(2)] using  i_j
                by blast
              then have 15: "\<forall>k < dim_row B. (k \<noteq> i \<and> k \<noteq> j) \<longrightarrow> col B t $ k = 0"
                by (metis index_col t)
              have 21: "col B t \<bullet> ?u = sum (\<lambda> k. (col B t $ k) * (?u $ k)) {0..<dim_row B}"
                unfolding scalar_prod_def
                by (metis dim_vec)
              have 19: "sum (\<lambda> k. (col B t $ k) * (?u $ k)) {0..<dim_row B} =
                        (col B t $ i) * (?u $ i) + (col B t $ j) * (?u $ j)"
              proof -
                have 17: "sum (\<lambda> k. (col B t $ k) * (?u $ k)) {0..<dim_row B} =
                      sum (\<lambda> k. (col B t $ k) * (?u $ k)) ({0..<dim_row B} - {i,j})
                       + sum (\<lambda> k. (col B t $ k) * (?u $ k)) {i,j}"
                  by (meson atLeastLessThan_iff empty_subsetI finite_atLeastLessThan i_j(3) i_j(4)
                      insert_subset sum.subset_diff zero_order(1))
                have 16: "\<forall> k \<in> ({0..<dim_row B} - {i,j}). (col B t $ k) * (?u $ k) = 0"
                  by (metis Diff_iff 15 atLeastLessThan_iff insertCI
                      vector_space_over_itself.scale_eq_0_iff)
                have 18: "sum (\<lambda> k. (col B t $ k) * (?u $ k)) ({0..<dim_row B} - {i,j}) = 0"
                  by (metis (no_types, lifting) R.add.finprod_all1 16)
                have "sum (\<lambda> k. (col B t $ k) * (?u $ k)) {i,j} =
                      (col B t $ i) * (?u $ i) + (col B t $ j) * (?u $ j)"
                  by (meson i_j(5) sum_two_elements)
                then show ?thesis
                  using R.show_l_zero 17 18 by presburger
              qed
              have 20: "(col B t $ i) = 1 \<and> (col B t $ j) = 1"
                by (metis i_j(1) i_j(2) i_j(3) i_j(4) index_col t)
              have 30: "col B t \<bullet> ?u = (?u $ i) + (?u $ j)"
                using 19 20 21 cring_simprules(12) by presburger
              have "pick J t < card E"
                by (metis dim_submatrix(2) gram_schmidt_floor.dim_col_insidence_mat
                    less(2) pick_le t)
              have "insidence_mat E $$ (pick I i, pick J t) = 1"
                by (metis (no_types, lifting) dim_submatrix(1) dim_submatrix(2) i_j(1) i_j(3)
                    less(2) submatrix_index t)
              then have 23: "vertices_list E ! pick I i \<in> edges_list E! pick J t"
                by (metis (no_types, lifting) \<open>pick J t < card E\<close> dim_submatrix(1) i_j(3) less(2)
                    exist_index_in_submat gram_schmidt_floor.dim_row_insidence_mat one_then_in_edge)
              have "insidence_mat E $$ (pick I j, pick J t) = 1"
                by (metis (no_types, lifting) dim_submatrix(1) dim_submatrix(2) i_j(2) i_j(4)
                    less(2) submatrix_index t)
              then have 24: "vertices_list E ! pick I j \<in> edges_list E! pick J t"
                by (metis (no_types, lifting) \<open>pick J t < card E\<close> dim_submatrix(1)
                    exist_index_in_submat gram_schmidt_floor.dim_row_insidence_mat
                    gram_schmidt_floor.one_then_in_edge i_j(4) less(2))
              have 22: "(edges_list E! pick J t) \<in> E"
                using edges_list_el_in_E
                using \<open>pick J t < card E\<close> by blast
              have 27: "vertices_list E ! pick I i \<noteq> vertices_list E ! pick I j"
                by (smt (verit, ccfv_SIG) diff_verts dim_row_mat_less_card_I dim_submatrix(1)
                    exist_index_in_submat gram_schmidt_floor.dim_row_insidence_mat i_j(3-5)
                    le_neq_implies_less less(2) less_or_eq_imp_le not_less order_trans_rules(23)
                    pick_eq_iff_inf pick_mono_le)
              then have 25: "edges_list E! pick J t =
                         {vertices_list E ! pick I i, vertices_list E ! pick I j}"
                using 6 22 23 24 by fastforce
              have 29: "(?u $ i) + (?u $ j) = 0"
              proof(cases "vertices_list E ! pick I i \<in> X")
                case True
                have 26: "(?u $ i) = 1"
                  by (simp add: True i_j(3))
                have "vertices_list E ! pick I j \<notin> X"
                  using True 25 22 X insert_absorb by fastforce
                then have "?u $ j = -1"
                  by (simp add: i_j(4))
                then show ?thesis
                  using 26 by linarith
              next
                case False
                have 28: "(?u $ i) = - 1"
                  by (simp add: False i_j(3))
                have "vertices_list E ! pick I j \<in> X"
                  using False 22 X 23 27 24 by force
                then have "?u $ j = 1"
                  by (simp add: i_j(4))
                then show ?thesis
                  using 28 by linarith
              qed
              show "col B t \<bullet> ?u = 0"
                using 29 30 by presburger
            qed
            then have "\<forall> t < dim_row B\<^sup>T. row B\<^sup>T t \<bullet> ?u = 0"
              by (metis Matrix.col_transpose Matrix.transpose_transpose index_transpose_mat(2))
            then have 31: "B\<^sup>T *\<^sub>v ?u = 0\<^sub>v (dim_row B\<^sup>T)"
              unfolding mult_mat_vec_def zero_vec_def
              by (metis (no_types, lifting) dim_vec eq_vecI index_transpose_mat(2) index_vec)
            have 3: "\<exists>v. v \<in> carrier_vec (dim_row B\<^sup>T) \<and>
                        v \<noteq> 0\<^sub>v (dim_row B\<^sup>T) \<and> B\<^sup>T *\<^sub>v v = 0\<^sub>v (dim_row B\<^sup>T)"
              by (metis "1" 31 32 index_transpose_mat(2) vec_carrier)
            have 2: "B\<^sup>T \<in> carrier_mat (dim_row B) (dim_row B)" using 1
              by auto
            then have "det B\<^sup>T = 0"
              using det_0_iff_vec_prod_zero[OF 2] using 3 1
              by (metis index_transpose_mat(2))
            then have "det B = 0"
              by (metis "2" Determinant.det_transpose Matrix.transpose_transpose)
            then show ?thesis
              by blast
          qed
        qed
      qed
    qed
  qed
qed

lemma bipartite_tot_unimod:
  assumes "bipartite E"
  shows "tot_unimodular (insidence_mat E)"
proof -
  have "(\<forall> B. (\<exists> I J. submatrix (insidence_mat E) I J = B) \<longrightarrow> det B \<in> {-1, 0, 1})"
    by (meson assms bipartite_submatrix_det_unimod)
  then show ?thesis
    using tot_unimodular_def by blast
qed

lemma matching_polyh_int:
  assumes "bipartite E"
  shows "gram_schmidt_floor.int_polyh (card E)
            (gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))))"
proof -
  have 4:"tot_unimodular (insidence_mat E)"
    using bipartite_tot_unimod assms by auto
  have 1:"1\<^sub>v (card (Vs E)) \<in> \<int>\<^sub>v"
    using gram_schmidt.one_vec_int by blast
  have 2:"(insidence_mat E) \<in> carrier_mat (card (Vs E)) (card E)"
    using dim_col_insidence_mat dim_row_insidence_mat by blast
  then show "gram_schmidt_floor.int_polyh (card E)
            (gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))))"
    using gram_schmidt_floor.tot_unimod_then_int_polyhedron[OF 2 4]
    using "1" one_carrier_vec by blast
qed

definition perfect_mathing_polyhedron where
  "perfect_mathing_polyhedron A b = {x. x \<in> carrier_vec n \<and> A *\<^sub>v x = b \<and> x \<ge> 0\<^sub>v n}"

lemma perfect_mathing_polyhedron_face:
  assumes "A \<in> carrier_mat nr n"
  assumes "b \<in> carrier_vec nr"
  assumes "(perfect_mathing_polyhedron A b) \<noteq> {}"
  shows "face (pos_polyhedron A b) (perfect_mathing_polyhedron A b)"
proof -
  have 1:"(A, b) = sub_system (A @\<^sub>r - 1\<^sub>m n) (b @\<^sub>v 0\<^sub>v n) {0..<nr}"
  proof
    have "A = submatrix (A @\<^sub>r - 1\<^sub>m n) {0..<nr} UNIV"

    oops
  have "{x. x \<in> carrier_vec n \<and> A *\<^sub>v x = b \<and> x \<ge> 0\<^sub>v n} =
              {x. A *\<^sub>v x = b \<and> x \<in> (pos_polyhedron A b)}"
    unfolding pos_polyhedron_def
    by fast
  then have "(perfect_mathing_polyhedron A b) =
           {x. A *\<^sub>v x = b \<and> x \<in> (pos_polyhedron A b)}"
    unfolding perfect_mathing_polyhedron_def by auto
  have "pos_polyhedron A b = polyhedron (A @\<^sub>r - 1\<^sub>m n) (b @\<^sub>v 0\<^sub>v n)"
    using assms(1) assms(2) pos_polyh_is_polyh by presburger
  have 2: "(A @\<^sub>r - 1\<^sub>m n) \<in> carrier_mat (nr+n) n"
    by (meson assms(1) carrier_append_rows one_carrier_mat uminus_carrier_mat)
  have 3: "(b @\<^sub>v 0\<^sub>v n) \<in> carrier_vec (nr+n)"
    by (simp add: assms(2))
  then have "face (polyhedron (A @\<^sub>r - 1\<^sub>m n) (b @\<^sub>v 0\<^sub>v n)) (perfect_mathing_polyhedron A b)"
    using char_face2[OF 2 3 1]
    using \<open>perfect_mathing_polyhedron A b = {x. A *\<^sub>v x = b \<and> x \<in> pos_polyhedron A b}\<close>
      \<open>pos_polyhedron A b = local.polyhedron (A @\<^sub>r - 1\<^sub>m n) (b @\<^sub>v 0\<^sub>v n)\<close> assms(3) by presburger
  then show ?thesis
    using \<open>pos_polyhedron A b = local.polyhedron (A @\<^sub>r - 1\<^sub>m n) (b @\<^sub>v 0\<^sub>v n)\<close> by presburger
qed

lemma face_int_polyhedron_int_matrix:
   fixes A :: "'a  mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
 assumes "(A', b') = sub_system A b I'"
 assumes " F = {x.  x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A *\<^sub>v x \<le> b}"
  assumes "A \<in> \<int>\<^sub>m"
  assumes "b \<in> \<int>\<^sub>v"
  shows "((A' @\<^sub>r (-A')) @\<^sub>r A) \<in> \<int>\<^sub>m" "((b' @\<^sub>v (-b')) @\<^sub>v b) \<in> \<int>\<^sub>v"
proof -
  have "A' \<in> \<int>\<^sub>m"
    by (metis assms(4) assms(6) prod.simps(1) sub_system_def submatrix_int_mat)
  then show "((A' @\<^sub>r (-A')) @\<^sub>r A) \<in> \<int>\<^sub>m"
    by (metis assms(1) assms(4) assms(6) b carrier_mat_triv gram_schmidt.append_int_mat_is_int gram_schmidt.face_is_polyhedron'(3) minus_in_Ints_mat_iff uminus_carrier_iff_mat)
  have "b' \<in> \<int>\<^sub>v"
    using assms(4) unfolding sub_system_def
    using subvec_int_int
    using assms(7) by blast
  then show "((b' @\<^sub>v (-b')) @\<^sub>v b) \<in> \<int>\<^sub>v"
    by (meson append_int_vec_is_int assms(7) carrier_vec_dim_vec minus_in_Ints_vec_iff)
qed

lemma face_is_int_polyhedron:
   fixes A :: "'a mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes "face P F"
 assumes "A \<in> \<int>\<^sub>m"
  assumes "b \<in> \<int>\<^sub>v"
  obtains A' b' where "F = polyhedron A' b'" "dim_row A' = dim_vec b'" "dim_col A' = n"
                      "A' \<in> \<int>\<^sub>m" "b' \<in> \<int>\<^sub>v"
proof -
  obtain  A' b' I'  where  A'_b': "(A', b') = sub_system A b I'"
                      " F = {x.  A' *\<^sub>v x = b' \<and> x \<in> P}"
    using char_face1[of A nr b F]
    using A P_def assms(4) b by blast
  have 1: "F = {x \<in> carrier_vec n. A' *\<^sub>v x = b' \<and> A *\<^sub>v x \<le> b}"
    using A'_b'(2) unfolding P_def polyhedron_def by auto
  show ?thesis
    using face_is_polyhedron''[OF assms(1) assms(2) A'_b'(1) 1 ]
      face_int_polyhedron_int_matrix[OF assms(1) assms(2) A'_b'(1) 1 assms(5) assms(6)]
    using that by presburger
qed

lemma int_poly_face_int:
 fixes A :: "'a mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "int_polyh P"
  assumes "face P F"
  assumes "A \<in> \<int>\<^sub>m"
  assumes "b \<in> \<int>\<^sub>v"
  shows "int_polyh F"
proof -
  have "P = integer_hull P"
    using assms(4) gram_schmidt_floor.int_polyh_def by blast
  have "P \<subseteq> carrier_vec n" unfolding P_def polyhedron_def
    by blast
  then have "(\<forall> F. face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v))"
  using P_int_then_face_int \<open>P = integer_hull P\<close> by presburger
  have "(\<forall> F'. face F F' \<longrightarrow> (\<exists> x \<in> F'. x \<in> \<int>\<^sub>v))"
    using P_def P_int_then_face_int \<open>P = integer_hull P\<close> \<open>P \<subseteq> carrier_vec n\<close>
      assms(1) assms(5) b face_trans by presburger
  obtain A' b'  where "F = polyhedron A' b'" "dim_row A' = dim_vec b'" "dim_col A' = n"
                      "A' \<in> \<int>\<^sub>m" "b' \<in> \<int>\<^sub>v" using face_is_int_polyhedron
    by (metis P_def assms(1) assms(5) assms(6) assms(7) b)

  then have "F = integer_hull F" using face_iff_int_polyh
    using \<open>\<forall>F'. face F F' \<longrightarrow> (\<exists>x\<in>F'. x \<in> \<int>\<^sub>v)\<close> carrier_vec_dim_vec by blast
  then show ?thesis unfolding int_polyh_def by auto
qed

lemma perfect_mathing_polyhedron_integral:
  assumes "bipartite E"
  shows "gram_schmidt_floor.int_polyh (card E)
            (gram_schmidt_floor.perfect_mathing_polyhedron (card E)
        (insidence_mat E) (1\<^sub>v (card (Vs E))))"
proof -
  have "gram_schmidt_floor.int_polyh (card E)
            (gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))))"
    using assms gram_schmidt_floor.matching_polyh_int by blast
  have "\<forall> F. gram_schmidt.face (card E) (gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E)))) F
           \<longrightarrow> gram_schmidt_floor.int_polyh (card E) F"
  proof safe
    fix F
    assume asm: "gram_schmidt.face (card E) (gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E)))) F"
    have "gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))) =
                  gram_schmidt.polyhedron (card E) ((insidence_mat E) @\<^sub>r - 1\<^sub>m (card E))
           ((1\<^sub>v (card (Vs E))) @\<^sub>v 0\<^sub>v (card E))"
      using gram_schmidt_floor.pos_polyh_is_polyh
      by (metis gram_schmidt_floor.insidence_mat_def mat_carrier one_carrier_vec)
    have 1:"(insidence_mat E) @\<^sub>r - 1\<^sub>m (card E) \<in> \<int>\<^sub>m"
      using assms bipartite_tot_unimod dim_col_insidence_mat gram_schmidt_floor.tot_unimod_append_minus_one totally_unimod_mat_int by blast
    have 2: "(1\<^sub>v (card (Vs E))) @\<^sub>v 0\<^sub>v (card E) \<in> \<int>\<^sub>v"
      by (simp add: append_int_vec_is_int carrier_dim_vec gram_schmidt.one_vec_int gram_schmidt.zero_vec_is_int)
    have 3: "gram_schmidt_floor.int_polyh (card E) (gram_schmidt.polyhedron (card E)
       ((insidence_mat E) @\<^sub>r - 1\<^sub>m (card E)) ((1\<^sub>v (card (Vs E))) @\<^sub>v 0\<^sub>v (card E)))"
      using \<open>gram_schmidt_floor.int_polyh (card E) (gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))))\<close> \<open>gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))) = gram_schmidt.polyhedron (card E) (insidence_mat E @\<^sub>r - 1\<^sub>m (card E)) (1\<^sub>v (card (Vs E)) @\<^sub>v 0\<^sub>v (card E))\<close> by force
    have 4: "gram_schmidt.face (card E) (gram_schmidt.polyhedron (card E) ((insidence_mat E) @\<^sub>r - 1\<^sub>m (card E))
           ((1\<^sub>v (card (Vs E))) @\<^sub>v 0\<^sub>v (card E))) F"
      using asm \<open>gram_schmidt_floor.pos_polyhedron (card E) (insidence_mat E) (1\<^sub>v (card (Vs E))) = gram_schmidt.polyhedron (card E) (insidence_mat E @\<^sub>r - 1\<^sub>m (card E)) (1\<^sub>v (card (Vs E)) @\<^sub>v 0\<^sub>v (card E))\<close> by force
    have 5: "(insidence_mat E) @\<^sub>r - 1\<^sub>m (card E) \<in> carrier_mat ((card (Vs E)) + (card E)) (card E)"
      by (simp add: insidence_mat_def)
    have 6: "((1\<^sub>v (card (Vs E))) @\<^sub>v 0\<^sub>v (card E)) \<in> carrier_vec ((card (Vs E)) + (card E))"
      by simp
    show "gram_schmidt_floor.int_polyh (card E) F"
      using gram_schmidt_floor.int_poly_face_int[OF 5 6 3 4 1 2] by auto
  qed
  then show ?thesis using gram_schmidt_floor.perfect_mathing_polyhedron_face
    by (metis Union_disjoint Union_empty carrier_matI dim_col_insidence_mat dim_row_insidence_mat gram_schmidt.convex_hull_empty(1) gram_schmidt.integer_hull_def gram_schmidt_floor.int_polyh_def mem_simps(2) one_carrier_vec)
qed

end
end


\<^marker>\<open>creator "Johannes Hölzl"\<close>
chapter \<open>MDP Semantics for PGCL\<close>
theory MDP_Semantics
  imports PGCL
begin

paragraph \<open>Summary\<close>

text \<open>This theory provides an operational interpretation of pGCL running times as MDPs,
      and proves its equivalence to pGCL's the denotational expectation running
         transformer semantics.\<close>

paragraph \<open>Main Lemmas\<close>

text \<open>
  \<^item> ert_eq_Ert: the equivalence of pGCL's the denotational expectation running
         transformer semantics and an operational interpretation of pGCL running times as MDPs.\<close>

section \<open>Operational Semantics of pGCL\<close>

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

fun K :: "('a pgcl \<times> 'a) \<Rightarrow> ('a pgcl \<times> 'a) pmf set"
where
  "K (Empty, s) = \<lless>Empty, s\<ggreater>"
| "K (Skip, s) = \<lless>Empty, s\<ggreater>"
| "K (Halt, s) = \<lless>Halt, s\<ggreater>"
| "K (Assign u, s) = map_pmf (\<lambda>s'. (Empty, s')) ` {u s}"
| "K (Seq c\<^sub>1 c\<^sub>2, s) = map_pmf (apfst (\<lambda>Empty \<Rightarrow> c\<^sub>2 | Halt \<Rightarrow> Halt | c' \<Rightarrow> Seq c' c\<^sub>2)) ` K (c\<^sub>1, s)"
| "K (Par c\<^sub>1 c\<^sub>2, s) = \<lless>c\<^sub>1, s\<ggreater> \<union> \<lless>c\<^sub>2, s\<ggreater>"
| "K (If g c\<^sub>1 c\<^sub>2, s) = (if g s then \<lless>c\<^sub>1, s\<ggreater> else \<lless>c\<^sub>2, s\<ggreater>)"
| "K (While g c, s) = (if g s then \<lless>Seq c (While g c), s\<ggreater> else \<lless>Empty, s\<ggreater>)"

interpretation Markov_Decision_Process K
proof
  show "K s \<noteq> {}" for s :: "'a pgcl \<times> 'a"
    by (induction s rule: K.induct) auto
qed

abbreviation Estep :: "('a pgcl \<Rightarrow> 'a \<Rightarrow> ennreal) \<Rightarrow> 'a pgcl \<Rightarrow> 'a \<Rightarrow> ennreal"
where
  "Estep F c s \<equiv> (\<Squnion>D\<in>K (c, s). \<integral>\<^sup>+(c', s'). F c' s' \<partial>measure_pmf D)"

context
  fixes f :: "'a \<Rightarrow> ennreal"
begin

primrec cost :: "'a pgcl \<Rightarrow> 'a \<Rightarrow> ennreal \<Rightarrow> ennreal"
where
  "cost Empty       s _ = f s"
| "cost Skip        _ x = 1 + x"
| "cost Halt        _ _ = 0"
| "cost (Assign _)  _ x = 1 + x"
| "cost (Seq c1 _)  s x = (if c1 = Empty then x else cost c1 s x)"
| "cost (Par _ _ )  s x = x"
| "cost (If _ _ _)  _ x = 1 + x"
| "cost (While g c) _ x = 1 + x"

lemma sup_continuous_cost[order_continuous_intros]: "sup_continuous (cost c s)"
  by (induction c arbitrary: s)
     (auto intro: order_continuous_intros simp: cost.simps[abs_def])

\<comment> \<open>The following measurability proof is very ugly it should be much simpler...\<close>
declare [[inductive_internals]]
inductive_set rF_ranges where
  "{Empty} \<in> rF_ranges "
| "{Skip} \<in> rF_ranges"
| "{Halt} \<in> rF_ranges"
| "{Assign f | f. True} \<in> rF_ranges"
| "X \<in> rF_ranges \<Longrightarrow> {Seq c1 c2 | c1 c2. c1 \<in> X} \<in> rF_ranges"
| "{Par c1 c2 | c1 c2. True} \<in> rF_ranges"
| "{If g c1 c2 | g c1 c2. True} \<in> rF_ranges "
| "{While g c | g c. True} \<in> rF_ranges "

lemma empty_in_rF_ranges: "X \<in> rF_ranges \<Longrightarrow> Empty \<in> X \<longleftrightarrow> X = {Empty}"
  by (induction rule: rF_ranges.induct) auto

lemma cover_rF_ranges: "c \<in> \<Union>rF_ranges"
  by (induction c) (insert rF_ranges.intros, blast+)

lemma countable_rF_ranges: "countable rF_ranges"
  unfolding rF_ranges_def rF_rangesp_def lfp_Collect[OF rF_rangesp.mono]
  apply (intro countable_lfp)
  unfolding Collect_disj_eq singleton_conv Setcompr_eq_image
  apply auto []
  apply (intro sup_continuous_sup sup_continuous_const, auto simp: sup_continuous_def)
  done

lemma measurable_cost':
  "(\<lambda>x. cost (fst x) (fst (snd x)) (snd (snd x))) \<in> (count_space UNIV \<Otimes>\<^sub>M count_space UNIV \<Otimes>\<^sub>M borel) \<rightarrow>\<^sub>M borel"
  (is "?p cost \<in> ?M \<rightarrow>\<^sub>M borel")
proof (rule measurable_piecewise_restrict[of "vimage fst ` rF_ranges"]; clarsimp?)
  show "countable (vimage fst ` rF_ranges)"
    by (intro countable_image countable_rF_ranges)
  show "\<exists>x\<in>rF_ranges. \<omega> \<in> x" for \<omega> :: "'a pgcl"
    using cover_rF_ranges by auto

  let ?P = "\<lambda>X. restrict_space ?M (vimage fst X)"
  have *: "(\<And>c s x. c \<in> X \<Longrightarrow> cost c s x = f' c s x) \<Longrightarrow> ?p f' \<in> ?M \<rightarrow>\<^sub>M borel \<Longrightarrow> ?p cost \<in> ?P X \<rightarrow>\<^sub>M borel" for f' X
    apply (subst measurable_cong[where g="?p f'"])
    apply (simp add: space_restrict_space)
    apply (rule measurable_restrict_space1)
    apply assumption
    done

  show "?p cost \<in> ?P X \<rightarrow>\<^sub>M borel" if "X \<in> rF_ranges" for X
    using that
  proof induction
    case 1 then show ?case
      by (rule *[of _ "\<lambda>c s x. f s"]) (auto intro: measurable_compose)
  next
    case 3 then show ?case
      by (rule *[of _ "\<lambda>\<omega>. 0"]) auto
  next
    case (5 X)
    show ?case
    proof cases
      assume "Empty \<in> X"
      then have [simp]: "X = {Empty}"
        by (simp add: empty_in_rF_ranges 5)
      show ?case
        by (rule *[of _ "\<lambda>c s x. x"]) auto
    next
      assume X: "Empty \<notin> X"
      show ?thesis
      proof (rule measurable_cong[THEN iffD2, OF _ measurable_compose[OF _ "5.IH"]])
        show "(\<lambda>x. (left (fst x), snd x)) \<in> ?P {Seq c1 c2 |c1 c2. c1 \<in> X} \<rightarrow>\<^sub>M ?P X"
          by (intro measurable_restrict_space2)
             (auto simp: space_restrict_space intro: measurable_compose intro!: measurable_Pair measurable_restrict_space1)
      qed (auto simp: space_restrict_space X)
    qed
  next
    case 6 then show ?case
      by (rule *[of _ "\<lambda>c s x. x"]) auto
  qed (rule *[of _ "\<lambda>c s x. 1 + x"]; auto)+
qed

lemma measurable_cost[measurable (raw)]:
  "g \<in> M \<rightarrow>\<^sub>M count_space UNIV \<Longrightarrow> h \<in> M \<rightarrow>\<^sub>M count_space UNIV \<Longrightarrow> j \<in> M \<rightarrow>\<^sub>M borel \<Longrightarrow> (\<lambda>x. cost (g x) (h x) (j x)) \<in> M \<rightarrow>\<^sub>M borel"
  using measurable_compose[OF _ measurable_cost', of "\<lambda>x. (g x, h x, j x)" M] by simp

lemma sup_continuous_cost_stream: "sup_continuous (\<lambda>F. \<lambda>((c, s)##\<omega>) \<Rightarrow> cost c s (F \<omega>))"
  unfolding stream.case_eq_if[abs_def] prod.case_eq_if
  by (intro order_continuous_intros sup_continuous_cost[THEN sup_continuous_compose])

lemma measurable_cost_stream[measurable]:
  "F \<in> St \<rightarrow>\<^sub>M borel \<Longrightarrow> (\<lambda>((c, s)##\<omega>) \<Rightarrow> cost c s (F \<omega>)) \<in> St \<rightarrow>\<^sub>M borel"
  apply measurable
  apply (rule measurable_ident_subsets[where M'="stream_space (count_space UNIV \<Otimes>\<^sub>M count_space UNIV)"])
  apply (simp add: space_stream_space space_pair_measure)
  apply (intro sets_stream_space_mono)
  apply (auto simp: space_pair_measure intro: measurable_compose[OF measurable_shd])
  done

definition r :: "('a pgcl \<times> 'a) stream \<Rightarrow> ennreal"
where
  "r = lfp (\<lambda>F. \<lambda>((c, s)##\<omega>) \<Rightarrow> cost c s (F \<omega>))"

lemma r_Stream: "r ((c, s) ## \<omega>) = cost c s (r \<omega>)"
  unfolding r_def by (subst lfp_unfold[OF sup_continuous_mono[OF sup_continuous_cost_stream]]) auto

lemma measurable_r[measurable]: "r \<in> St \<rightarrow>\<^sub>M borel"
  unfolding r_def by (rule borel_measurable_lfp[OF sup_continuous_cost_stream]) measurable

definition cost_step :: "('a pgcl \<Rightarrow> 'a \<Rightarrow> ennreal) \<Rightarrow> ('a pgcl \<Rightarrow> 'a \<Rightarrow> ennreal)"
where
  "cost_step F c s = cost c s (Estep F c s)"

lemma cost_step_alt: "cost_step F c s = Estep (\<lambda>c' s'. cost c s (F c' s')) c s"
  by (induction c arbitrary: s F) (auto simp: split_beta' cost_step_def nn_integral_add SUP_image)

lemma cost_step_Empty[simp]: "cost_step F Empty s = f s"
  by (simp add: cost_step_def)

lemma cost_step_Halt[simp]: "cost_step F Halt s = 0"
  by (simp add: cost_step_def)

lemma cost_step_Seq: "cost_step F (Seq c d) s =
    (if c = Empty then F d s else cost_step (\<lambda>c. F (case c of Empty \<Rightarrow> d | Halt \<Rightarrow> Halt | _ \<Rightarrow> Seq c d)) c s)"
  by (auto simp add: split_beta' cost_step_def SUP_image
           intro!: arg_cong[where f="cost _ _"] SUP_cong nn_integral_cong arg_cong[where f="\<lambda>x. F x _"]
           split: pgcl.split)

lemma cost_step_While[simp]: "cost_step F (While g c) s = 1 + F (if g s then Seq c (While g c) else Empty) s"
  by (simp add: cost_step_def)

lemma sup_continuous_cost_step: "sup_continuous cost_step"
  unfolding cost_step_def[abs_def]
  by (auto simp: prod.case_eq_if intro!: order_continuous_intros sup_continuous_compose[OF sup_continuous_cost])

end

lemma cost_mono: "(d = Empty \<Longrightarrow> f s \<le> g s) \<Longrightarrow> (d \<noteq> Empty \<Longrightarrow> d \<noteq> Halt \<Longrightarrow> F \<le> G) \<Longrightarrow> cost f d s F \<le> cost g d s G"
  by (induction d) auto

lemma cost_step_mono: "(c = Empty \<Longrightarrow> f s \<le> g s) \<Longrightarrow>
  (\<And>D c' s'. c \<noteq> Halt \<Longrightarrow> c \<noteq> Empty \<Longrightarrow> D \<in> K (c, s) \<Longrightarrow> (c', s') \<in> D \<Longrightarrow> F c' s' \<le> G c' s') \<Longrightarrow>
  cost_step f F c s \<le> cost_step g G c s"
  by (auto simp: cost_step_def intro!: cost_mono SUP_subset_mono nn_integral_mono_AE AE_pmfI)

abbreviation Ert :: "('a \<Rightarrow> ennreal) \<Rightarrow> 'a pgcl \<Rightarrow> ('a \<Rightarrow> ennreal)"
where
  "Ert f c s \<equiv> E_sup (c, s) (\<lambda>\<omega>. r f ((c, s) ## \<omega>))"

lemma mono_Ert: "mono Ert"
  unfolding r_def
  by (intro monoI le_funI E_sup_mono lfp_mono[THEN le_funD])
     (auto intro!: cost_mono split: stream.split dest: le_funD)

lemma Ert_Stream: "Ert f c s = cost_step f (\<lambda>c' s'. E_sup (c', s') (\<lambda>\<omega>. r f ((c', s') ## \<omega>))) c s"
proof -
  have *: "F \<in> St \<rightarrow>\<^sub>M borel \<Longrightarrow> E_sup x (\<lambda>\<omega>. cost f c s (F \<omega>)) = cost f c s (E_sup x F)"
    for F and x :: "'a pgcl \<times> 'a"
    by (induction c arbitrary: x F) (auto simp: E_sup_add_right E_sup_const)
  show ?thesis
    by (subst E_sup_iterate)
       (auto intro!: SUP_cong nn_integral_cong_AE AE_pmfI simp: cost_step_alt r_Stream[of f c] *)
qed

lemma Ert_eq_abs: "Ert f = lfp (cost_step f)"
  unfolding r_def
proof (rule lfp_transfer_bounded[where \<alpha>="\<lambda>F. (\<lambda>c s. E_sup (c, s) (\<lambda>\<omega>. F ((c, s) ## \<omega>)))"])
  fix F :: "('a pgcl \<times> 'a) stream \<Rightarrow> ennreal" assume F[measurable]: "F \<in> St \<rightarrow>\<^sub>M borel"
  have *: "E_sup x (\<lambda>\<omega>. cost f c s (F (x ## \<omega>))) = cost f c s (E_sup x (\<lambda>\<omega>. F (x ## \<omega>)))"
    for c s x by (induction c arbitrary: s x) (simp_all add: E_sup_add_right E_sup_const)
  show "(\<lambda>c s. E_sup (c, s) (\<lambda>\<omega>. case (c, s) ## \<omega> of (c, s) ## \<omega> \<Rightarrow> cost f c s (F \<omega>))) =
    cost_step f (\<lambda>c s. E_sup (c, s) (\<lambda>\<omega>. F ((c, s) ## \<omega>)))"
    by (subst E_sup_iterate)
       (auto intro!: SUP_cong nn_integral_cong_AE AE_pmfI * simp: cost_step_alt[abs_def])
next
  show "(\<lambda>c s. E_sup (c::'a pgcl, s) (\<lambda>\<omega>. (\<Squnion>i. C i) ((c, s) ## \<omega>))) =
      (\<Squnion>i. (\<lambda>c s. E_sup (c, s) (\<lambda>\<omega>. C i ((c, s) ## \<omega>))))"
    if C: "incseq C" and [measurable]: "\<And>i. C i \<in> St \<rightarrow>\<^sub>M borel" for C
    by (simp add: fun_eq_iff mono_compose[OF C] E_sup_SUP SUP_image)
qed (auto intro: sup_continuous_cost_step sup_continuous_cost_stream simp: SUP_apply[abs_def] le_fun_def E_sup_const)

lemma Ert_eq: "Ert f c s = lfp (cost_step f) c s"
  using Ert_eq_abs[of f] by (auto simp: fun_eq_iff)

lemma Ert_induct[consumes 1, case_names step]:
  assumes "P c s y"
  assumes *:
    "\<And>F c s y. P c s y \<Longrightarrow> (\<And>c s y. P c s y \<Longrightarrow> F c s \<le> y) \<Longrightarrow> (\<And>c s. F c s \<le> Ert f c s) \<Longrightarrow>
      cost_step f F c s \<le> y"
  shows "Ert f c s \<le> y"
  using `P c s y`
  unfolding Ert_eq
proof (induction arbitrary: s c y rule: lfp_ordinal_induct[OF sup_continuous_mono[OF sup_continuous_cost_step[where f=f]]])
  have **: "lfp (cost_step f) = Ert f"
    by (intro ext Ert_eq[symmetric])
  case (1 F) then show ?case
    unfolding ** cost_step_def[symmetric] by (intro *) (auto simp: le_fun_def)
qed (auto intro: SUP_least)

lemma Ert_Empty[simp]: "Ert f Empty s = f s"
  by (simp add: r_Stream E_sup_const)

lemma Ert_Halt[simp]: "Ert f Halt s = 0"
  by (simp add: r_Stream E_sup_const)

lemma Ert_Seq: "Ert f (Seq a b) s = Ert (Ert f b) a s"
proof (rule antisym)
  show "Ert f (Seq a b) s \<le> Ert (Ert f b) a s"
  proof (coinduction arbitrary: a s rule: Ert_induct)
    case (step F a s) with step(2)[of Halt] show ?case
      by (rewrite in "_ \<le> \<hole>"  Ert_Stream)
         (auto simp add: cost_step_Seq intro!: cost_step_mono split: pgcl.split)
  qed
  show "Ert (Ert f b) a s \<le> Ert f (Seq a b) s"
  proof (coinduction arbitrary: a s rule: Ert_induct)
    case (step F a s) with step(2)[of Empty] step(2)[of Halt] show ?case
      by (rewrite in "_ \<le> \<hole>"  Ert_Stream)
         (auto simp add: cost_step_Seq intro!: cost_step_mono split: pgcl.split)
   qed
qed

lemma Ert_While: "Ert f (While g c) s = lfp (\<lambda>F s. 1 + (if g s then Ert F c s else f s)) s"
proof (rule antisym)
  let ?f = "\<lambda>F s. 1 + (if g s then F c s else f s)"
  have single: "Ert f (While g c) s = ?f (Ert (Ert f (While g c))) s" for s
    by (rewrite Ert_Stream) (simp add: Ert_Seq)
  then have "lfp (\<lambda>F. ?f (Ert F)) \<le> Ert f (While g c)"
    by (intro lfp_lowerbound) simp
  then show "lfp (\<lambda>F. ?f (Ert F)) s \<le> Ert f (While g c) s"
    by (simp add: le_fun_def)

  have w: "mono (\<lambda>F. cost_step (?f F) F)"
    by (auto simp: mono_def le_fun_def intro!: cost_step_mono)

  let ?w = "lfp (\<lambda>F. cost_step (?f F) F)"
  have w_unfold: "?w d s = cost_step (?f ?w) ?w d s" for d s
    by (subst lfp_unfold[OF w]) simp

  have [simp]: "?w Empty s = ?f ?w s" for s
    by (subst w_unfold) simp

  have [simp]: "?w Halt s = 0" for s
    by (subst w_unfold) simp

  define d where "d = c"
  define t where "t = Seq d (While g c)"
  then have "(t = While g c \<and> d = c \<and> g s) \<or> t = Seq d (While g c)"
    by auto
  then have "Ert f t s \<le> (if t = While g c then 1 else 0) + ?w d s"
  proof (coinduction arbitrary: t d s rule: Ert_induct)
    case (step F t d s)
    have [simp]: "\<not> g s \<Longrightarrow> F (While g c) s \<le> 1 + f s" "g s \<Longrightarrow> F (While g c) s \<le> 1 + ?w c s" for s
      using step(3)[of "While g c" s] by (auto simp: single intro: step)
    have "F (case d of Empty \<Rightarrow> While g c | Halt \<Rightarrow> Halt | _ \<Rightarrow> Seq d (While g c)) s \<le> ?w d s" for d s
      using step(3)[of Halt s] by (auto intro: step split: pgcl.split)
    with step(1) show ?case
      by safe (auto intro!: cost_step_mono simp: step cost_step_Seq w_unfold[of d s])
  qed
  also have "?w = lfp (\<lambda>F. Ert (?f F))"
    unfolding Ert_eq by (rule lfp_lfp[symmetric]) (auto intro!: cost_step_mono simp: le_fun_def)
  finally have "Ert f (While g c) s \<le> 1 + (if g s then \<dots> c s else f s)"
    unfolding t_def d_def by (rewrite Ert_Stream) simp
  also have "\<dots> = lfp (\<lambda>F. ?f (Ert F)) s"
    by (rewrite lfp_rolling[symmetric, of ?f, OF _ mono_Ert]) (auto simp: mono_def le_fun_def)
  finally show "Ert f (While g c) s \<le> \<dots>"
    .
qed

lemma ert_eq_Ert: "ert c f s = Ert f c s"
proof (induction c arbitrary: s f)
  case Skip then show ?case
    by (subst Ert_Stream) (auto simp: cost_step_def)
next
  case (Assign f) then show ?case
    by (subst Ert_Stream) (auto simp: cost_step_def)
next
  case (Par c1 c2) then show ?case
    by (subst Ert_Stream) (auto simp: cost_step_def ac_simps)
next
  case (If g c1 c2) then show ?case
    by (subst Ert_Stream) (auto simp: cost_step_def)
next
  case (Seq c1 c2) then show ?case
    by (simp add: Ert_Seq)
qed (auto simp: Ert_While cong del: if_cong)

end


(*  Title:      HOL/HOLCF/Algebraic.thy
    Author:     Brian Huffman
*)

section \<open>Algebraic deflations\<close>

theory Algebraic
imports Universal Map_Functions
begin

default_sort bifinite

subsection \<open>Type constructor for finite deflations\<close>

typedef 'a fin_defl = "{d::'a \<rightarrow> 'a. finite_deflation d}"
by (fast intro: finite_deflation_bottom)

instantiation fin_defl :: (bifinite) below
begin

definition below_fin_defl_def:
  "below \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"

instance ..
end

instance fin_defl :: (bifinite) po
using type_definition_fin_defl below_fin_defl_def
by (rule typedef_po)

lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
using Rep_fin_defl by simp

lemma deflation_Rep_fin_defl: "deflation (Rep_fin_defl d)"
using finite_deflation_Rep_fin_defl
by (rule finite_deflation_imp_deflation)

interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
by (rule finite_deflation_Rep_fin_defl)

lemma fin_defl_belowI:
  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
unfolding below_fin_defl_def
by (rule Rep_fin_defl.belowI)

lemma fin_defl_belowD:
  "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
unfolding below_fin_defl_def
by (rule Rep_fin_defl.belowD)

lemma fin_defl_eqI:
  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
apply (rule below_antisym)
apply (rule fin_defl_belowI, simp)
apply (rule fin_defl_belowI, simp)
done

lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
unfolding below_fin_defl_def .

lemma Abs_fin_defl_mono:
  "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
    \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
unfolding below_fin_defl_def
by (simp add: Abs_fin_defl_inverse)

lemma (in finite_deflation) compact_belowI:
  assumes "\<And>x. compact x \<Longrightarrow> d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
by (rule belowI, rule assms, erule subst, rule compact)

lemma compact_Rep_fin_defl [simp]: "compact (Rep_fin_defl a)"
using finite_deflation_Rep_fin_defl
by (rule finite_deflation_imp_compact)

subsection \<open>Defining algebraic deflations by ideal completion\<close>

typedef 'a defl = "{S::'a fin_defl set. below.ideal S}"
by (rule below.ex_ideal)

instantiation defl :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_defl x \<subseteq> Rep_defl y"

instance ..
end

instance defl :: (bifinite) po
using type_definition_defl below_defl_def
by (rule below.typedef_ideal_po)

instance defl :: (bifinite) cpo
using type_definition_defl below_defl_def
by (rule below.typedef_ideal_cpo)

definition
  defl_principal :: "'a fin_defl \<Rightarrow> 'a defl" where
  "defl_principal t = Abs_defl {u. u \<sqsubseteq> t}"

lemma fin_defl_countable: "\<exists>f::'a fin_defl \<Rightarrow> nat. inj f"
proof -
  obtain f :: "'a compact_basis \<Rightarrow> nat" where inj_f: "inj f"
    using compact_basis.countable ..
  have *: "\<And>d. finite (f ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x})"
    apply (rule finite_imageI)
    apply (rule finite_vimageI)
    apply (rule Rep_fin_defl.finite_fixes)
    apply (simp add: inj_on_def Rep_compact_basis_inject)
    done
  have range_eq: "range Rep_compact_basis = {x. compact x}"
    using type_definition_compact_basis by (rule type_definition.Rep_range)
  have "inj (\<lambda>d. set_encode
    (f ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x}))"
    apply (rule inj_onI)
    apply (simp only: set_encode_eq *)
    apply (simp only: inj_image_eq_iff inj_f)
    apply (drule_tac f="image Rep_compact_basis" in arg_cong)
    apply (simp del: vimage_Collect_eq add: range_eq set_eq_iff)
    apply (rule Rep_fin_defl_inject [THEN iffD1])
    apply (rule below_antisym)
    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
    apply (drule_tac x=z in spec, simp)
    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
    apply (drule_tac x=z in spec, simp)
    done
  thus ?thesis by - (rule exI)
qed

interpretation defl: ideal_completion below defl_principal Rep_defl
using type_definition_defl below_defl_def
using defl_principal_def fin_defl_countable
by (rule below.typedef_ideal_completion)

text \<open>Algebraic deflations are pointed\<close>

lemma defl_minimal: "defl_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
apply (induct x rule: defl.principal_induct, simp)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def)
apply (simp add: Abs_fin_defl_inverse finite_deflation_bottom)
done

instance defl :: (bifinite) pcpo
by intro_classes (fast intro: defl_minimal)

lemma inst_defl_pcpo: "\<bottom> = defl_principal (Abs_fin_defl \<bottom>)"
by (rule defl_minimal [THEN bottomI, symmetric])

subsection \<open>Applying algebraic deflations\<close>

definition
  cast :: "'a defl \<rightarrow> 'a \<rightarrow> 'a"
where
  "cast = defl.extension Rep_fin_defl"

lemma cast_defl_principal:
  "cast\<cdot>(defl_principal a) = Rep_fin_defl a"
unfolding cast_def
apply (rule defl.extension_principal)
apply (simp only: below_fin_defl_def)
done

lemma deflation_cast: "deflation (cast\<cdot>d)"
apply (induct d rule: defl.principal_induct)
apply (rule adm_subst [OF _ adm_deflation], simp)
apply (simp add: cast_defl_principal)
apply (rule finite_deflation_imp_deflation)
apply (rule finite_deflation_Rep_fin_defl)
done

lemma finite_deflation_cast:
  "compact d \<Longrightarrow> finite_deflation (cast\<cdot>d)"
apply (drule defl.compact_imp_principal, clarify)
apply (simp add: cast_defl_principal)
apply (rule finite_deflation_Rep_fin_defl)
done

interpretation cast: deflation "cast\<cdot>d"
by (rule deflation_cast)

declare cast.idem [simp]

lemma compact_cast [simp]: "compact d \<Longrightarrow> compact (cast\<cdot>d)"
apply (rule finite_deflation_imp_compact)
apply (erule finite_deflation_cast)
done

lemma cast_below_cast: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
apply (induct A rule: defl.principal_induct, simp)
apply (induct B rule: defl.principal_induct, simp)
apply (simp add: cast_defl_principal below_fin_defl_def)
done

lemma compact_cast_iff: "compact (cast\<cdot>d) \<longleftrightarrow> compact d"
apply (rule iffI)
apply (simp only: compact_def cast_below_cast [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
apply (erule compact_cast)
done

lemma cast_below_imp_below: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<Longrightarrow> A \<sqsubseteq> B"
by (simp only: cast_below_cast)

lemma cast_eq_imp_eq: "cast\<cdot>A = cast\<cdot>B \<Longrightarrow> A = B"
by (simp add: below_antisym cast_below_imp_below)

lemma cast_strict1 [simp]: "cast\<cdot>\<bottom> = \<bottom>"
apply (subst inst_defl_pcpo)
apply (subst cast_defl_principal)
apply (rule Abs_fin_defl_inverse)
apply (simp add: finite_deflation_bottom)
done

lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
by (rule cast.below [THEN bottomI])

subsection \<open>Deflation combinators\<close>

definition
  "defl_fun1 e p f =
    defl.extension (\<lambda>a.
      defl_principal (Abs_fin_defl
        (e oo f\<cdot>(Rep_fin_defl a) oo p)))"

definition
  "defl_fun2 e p f =
    defl.extension (\<lambda>a.
      defl.extension (\<lambda>b.
        defl_principal (Abs_fin_defl
          (e oo f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo p))))"

lemma cast_defl_fun1:
  assumes ep: "ep_pair e p"
  assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
  shows "cast\<cdot>(defl_fun1 e p f\<cdot>A) = e oo f\<cdot>(cast\<cdot>A) oo p"
proof -
  have 1: "\<And>a. finite_deflation (e oo f\<cdot>(Rep_fin_defl a) oo p)"
    apply (rule ep_pair.finite_deflation_e_d_p [OF ep])
    apply (rule f, rule finite_deflation_Rep_fin_defl)
    done
  show ?thesis
    by (induct A rule: defl.principal_induct, simp)
       (simp only: defl_fun1_def
                   defl.extension_principal
                   defl.extension_mono
                   defl.principal_mono
                   Abs_fin_defl_mono [OF 1 1]
                   monofun_cfun below_refl
                   Rep_fin_defl_mono
                   cast_defl_principal
                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
qed

lemma cast_defl_fun2:
  assumes ep: "ep_pair e p"
  assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
                finite_deflation (f\<cdot>a\<cdot>b)"
  shows "cast\<cdot>(defl_fun2 e p f\<cdot>A\<cdot>B) = e oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo p"
proof -
  have 1: "\<And>a b. finite_deflation
      (e oo f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo p)"
    apply (rule ep_pair.finite_deflation_e_d_p [OF ep])
    apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
    done
  show ?thesis
    apply (induct A rule: defl.principal_induct, simp)
    apply (induct B rule: defl.principal_induct, simp)
    by (simp only: defl_fun2_def
                   defl.extension_principal
                   defl.extension_mono
                   defl.principal_mono
                   Abs_fin_defl_mono [OF 1 1]
                   monofun_cfun below_refl
                   Rep_fin_defl_mono
                   cast_defl_principal
                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
qed

end


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

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

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil

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

fun swap :: "int => int => int Tree => int Tree" where
"swap y z (Node p x2 q) =
   (if (x2 = y) then Node (swap y z p) z (swap y z q) else
      (if (x2 = z) then Node (swap y z p) y (swap y z q) else
         Node (swap y z p) x2 (swap y z q)))"
| "swap y z (Nil) = Nil"

fun flatten0 :: "'a Tree => 'a list" where
"flatten0 (Node p z q) =
   x (flatten0 p) (x (cons2 z (nil2)) (flatten0 q))"
| "flatten0 (Nil) = nil2"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

theorem property0 :
  "((elem a (flatten0 p)) ==>
      ((elem b (flatten0 p)) ==>
         ((elem a (flatten0 (swap a b p))) &
            (elem b (flatten0 (swap a b p))))))"
  oops

end


theory PhiSem_OO_Class_Algebra
  imports PhiSem_Base
begin

section \<open>Algebraic Model of Class dependency\<close>

datatype 'members class_algebra =
  Class (name: string) (parents: \<open>'members class_algebra list\<close>) (members: 'members)

text \<open>If two classes having the same name but different parents or members,
  they are merely two different classes having the same name.

  If two classes having the identical parents and members but different names,
  they are still two different classes despite of similarity.

  The name may be used as a syntactical identifier in language implementations, but the equity of
    the names in the semantics never means the equity of the classes.

  The member is generic, which may contain types of fields, table of virtual functions.
\<close>

hide_const (open) name parents members

fun self_and_parents_of :: "'a class_algebra \<Rightarrow> 'a class_algebra set"
  where \<open>self_and_parents_of (Class name parents fields) =
            insert (Class name parents fields) (\<Union> (self_and_parents_of ` set parents))\<close>

instantiation class_algebra :: (type) order begin

definition \<open>less_eq_class_algebra C1 C2 \<longleftrightarrow> C2 \<in> self_and_parents_of C1\<close>
definition \<open>less_class_algebra (C1::'a class_algebra) C2 \<longleftrightarrow> C1 \<le> C2 \<and> C1 \<noteq> C2\<close>

instance proof
  fix x y z :: \<open>'a class_algebra\<close>

  have \<open>\<And>x y S'. x \<in> self_and_parents_of y \<Longrightarrow> x \<noteq> y
            \<Longrightarrow> size_class_algebra S' x < size_class_algebra S' y\<close>
  subgoal for x y S'
  apply (induct y arbitrary: x)
  subgoal for name parents fields x
    apply clarsimp
    subgoal for z
      apply (cases \<open>x = z\<close>)
       apply (metis not_add_less1 not_less_eq size_list_estimation)
      by (simp add: less_Suc_eq size_list_estimation trans_less_add1) . . .
  then have t1: \<open>\<And>x y. y \<in> self_and_parents_of x \<and> x \<in> self_and_parents_of y \<Longrightarrow> x = y\<close>
    by (metis order_less_asym)
  then  show \<open>(x < y) = (x \<le> y \<and> \<not> y \<le> x)\<close>
    apply (simp_all add: less_eq_class_algebra_def less_class_algebra_def)
    by blast

  show \<open> x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y\<close>
    by (simp add: less_eq_class_algebra_def less_class_algebra_def t1)

  show \<open>x \<le> x\<close>
    by (cases x; simp add: less_eq_class_algebra_def less_class_algebra_def)

  show \<open>x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z\<close>
    unfolding less_eq_class_algebra_def less_class_algebra_def
    by (induct x, auto)
qed
end

lemma [simp]: \<open>Class name (x # L) members \<noteq> x\<close>
proof
  assume A: \<open>Class name (x # L) members = x\<close>
  then have t: \<open>\<And>S. size_class_algebra S (Class name (x # L) members) = size_class_algebra S x\<close> by simp
  then show False
    by (metis A add_Suc_right class_algebra.size(2) list.set_intros(1) not_add_less1 not_less_eq size_list_estimation)
qed

lemma prop_subclass_1[intro]: \<open>Class name (x#L) members < x\<close>
  unfolding less_class_algebra_def less_eq_class_algebra_def by simp

lemma subclass_1[intro]: \<open>Class name (x#L) members \<le> x\<close>
  unfolding less_class_algebra_def less_eq_class_algebra_def by simp

lemma subclass_0[intro]: \<open>x \<le> x\<close> for x :: \<open>'a class_algebra\<close> by simp

(* TODO: Give more automation for evaluating the inheritance.

 lemma [intro]: \<open>Class name L \<le> x \<Longrightarrow> Class name (y#L) \<le> x\<close>
  unfolding less_class_def less_eq_class_def apply simp*)

lemma self_and_parents_of__finite:
  \<open>finite (self_and_parents_of x)\<close>
  by (induct x; simp)

(*I'm thinking if we use product or addition.*)
definition inherited_members_of :: \<open>'m class_algebra \<Rightarrow> 'm::comm_monoid_mult\<close>
  where \<open>inherited_members_of cls = prod class_algebra.members (self_and_parents_of cls)\<close>

type_synonym "class" = \<open>(field_name \<rightharpoonup> TY nosep) class_algebra\<close>

setup \<open>Sign.mandatory_path "class"\<close>

abbreviation fields_of :: \<open>class \<Rightarrow> field_name \<rightharpoonup> TY nosep\<close>
  where \<open>fields_of \<equiv> inherited_members_of\<close>

setup \<open>Sign.parent_path\<close>

end


section \<open>The Dynamic Representation of a Language\<close>

theory Semantics
  imports Main Behaviour Inf begin

text \<open>
The definition of programming languages is separated into two parts: an abstract semantics and a concrete program representation.
\<close>

definition finished :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
  "finished r x = (\<nexists>y. r x y)"

lemma finished_star:
  assumes "finished r x"
  shows "r\<^sup>*\<^sup>* x y \<Longrightarrow> x = y"
proof (induction y rule: rtranclp_induct)
  case base
  then show ?case by simp
next
  case (step y z)
  then show ?case
    using assms by (auto simp: finished_def)
qed

locale semantics =
  fixes
    step :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infix "\<rightarrow>" 50) and
    final :: "'state \<Rightarrow> bool"
  assumes
    final_finished: "final s \<Longrightarrow> finished step s"
begin

text \<open>
The semantics locale represents the semantics as an abstract machine.
It is expressed by a transition system with a transition relation @{term step}---usually written as an infix @{text \<rightarrow>} arrow---and final states @{term final}.
\<close>

lemma finished_step:
  "step s s' \<Longrightarrow> \<not>finished step s"
by (auto simp add: finished_def)

abbreviation eval :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infix "\<rightarrow>\<^sup>*" 50) where
  "eval \<equiv> step\<^sup>*\<^sup>*"

abbreviation inf_step :: "'state \<Rightarrow> bool" where
  "inf_step \<equiv> inf step"

notation
  inf_step ("'(\<rightarrow>\<^sup>\<infinity>')" [] 50) and
  inf_step ("_ \<rightarrow>\<^sup>\<infinity>" [55] 50)

lemma finished_inf: "s \<rightarrow>\<^sup>\<infinity> \<Longrightarrow> \<not> finished step s"
  using inf.cases finished_step by metis

lemma eval_deterministic:
  assumes
    deterministic: "\<And>x y z. step x y \<Longrightarrow> step x z \<Longrightarrow> y = z"
  shows "s1 \<rightarrow>\<^sup>* s2 \<Longrightarrow> s1 \<rightarrow>\<^sup>* s3 \<Longrightarrow> finished step s2 \<Longrightarrow> finished step s3 \<Longrightarrow> s2 = s3"
proof(induction s1 arbitrary: s3 rule: converse_rtranclp_induct)
  case base
  then show ?case by (simp add: finished_star)
next
  case (step y z)
  then show ?case
    by (metis converse_rtranclpE deterministic finished_step)
qed

subsection \<open>Behaviour of a dynamic execution\<close>

inductive behaves :: "'state \<Rightarrow> 'state behaviour \<Rightarrow> bool" (infix "\<Down>" 50) where
  state_terminates:
    "s1 \<rightarrow>\<^sup>* s2 \<Longrightarrow> finished step s2 \<Longrightarrow> final s2 \<Longrightarrow> s1 \<Down> (Terminates s2)" |
  state_diverges:
    "s1 \<rightarrow>\<^sup>\<infinity> \<Longrightarrow> s1 \<Down> Diverges" |
  state_goes_wrong:
    "s1 \<rightarrow>\<^sup>* s2 \<Longrightarrow> finished step s2 \<Longrightarrow> \<not> final s2 \<Longrightarrow> s1 \<Down> (Goes_wrong s2)"

text \<open>
Even though the @{term step} transition relation in the @{locale semantics} locale need not be deterministic, if it happens to be, then the behaviour of a program becomes deterministic too.
\<close>

lemma behaves_deterministic:
  assumes
    deterministic: "\<And>x y z. step x y \<Longrightarrow> step x z \<Longrightarrow> y = z"
  shows "s \<Down> b1 \<Longrightarrow> s \<Down> b2 \<Longrightarrow> b1 = b2"
proof (induction s b1 rule: behaves.induct)
  case (state_terminates s1 s2)
  show ?case using state_terminates.prems state_terminates.hyps
  proof (induction s1 b2 rule: behaves.induct)
    case (state_terminates s1 s3)
    then show ?case
      using eval_deterministic deterministic by simp
  next
    case (state_diverges s1)
    then show ?case
      using deterministic star_inf[THEN finished_inf] by simp
  next
    case (state_goes_wrong s1 s3)
    then show ?case
      using eval_deterministic deterministic by blast
  qed
next
  case (state_diverges s1)
  show ?case using state_diverges.prems state_diverges.hyps
  proof (induction s1 b2 rule: behaves.induct)
    case (state_terminates s1 s2)
    then show ?case
      using deterministic star_inf[THEN finished_inf] by simp
  next
    case (state_diverges s1)
    then show ?case by simp
  next
    case (state_goes_wrong s1 s2)
    then show ?case
      using deterministic star_inf[THEN finished_inf] by simp
  qed
next
  case (state_goes_wrong s1 s2)
  show ?case using state_goes_wrong.prems state_goes_wrong.hyps
  proof (induction s1 b2)
    case (state_terminates s1 s3)
    then show ?case
      using eval_deterministic deterministic by blast
  next
    case (state_diverges s1)
    then show ?case
      using deterministic star_inf[THEN finished_inf] by simp
  next
    case (state_goes_wrong s1 s3)
    then show ?case
      using eval_deterministic deterministic by simp
  qed
qed

end

end