theory Positions
  imports "Spec" "Lexer"
begin

section {* Positions in Values *}

fun
  at :: "val \<Rightarrow> nat list \<Rightarrow> val"
where
  "at v [] = v"
| "at (Left v) (0#ps)= at v ps"
| "at (Right v) (Suc 0#ps)= at v ps"
| "at (Seq v1 v2) (0#ps)= at v1 ps"
| "at (Seq v1 v2) (Suc 0#ps)= at v2 ps"
| "at (Stars vs) (n#ps)= at (nth vs n) ps"

fun Pos :: "val \<Rightarrow> (nat list) set"
where
  "Pos (Void) = {[]}"
| "Pos (Char c) = {[]}"
| "Pos (Left v) = {[]} \<union> {0#ps | ps. ps \<in> Pos v}"
| "Pos (Right v) = {[]} \<union> {1#ps | ps. ps \<in> Pos v}"
| "Pos (Seq v1 v2) = {[]} \<union> {0#ps | ps. ps \<in> Pos v1} \<union> {1#ps | ps. ps \<in> Pos v2}"
| "Pos (Stars []) = {[]}"
| "Pos (Stars (v#vs)) = {[]} \<union> {0#ps | ps. ps \<in> Pos v} \<union> {Suc n#ps | n ps. n#ps \<in> Pos (Stars vs)}"

lemma Pos_stars:
  "Pos (Stars vs) = {[]} \<union> (\<Union>n < length vs. {n#ps | ps. ps \<in> Pos (vs ! n)})"
apply(induct vs)
apply(auto simp add: insert_ident less_Suc_eq_0_disj)
done

lemma Pos_empty:
  shows "[] \<in> Pos v"
by (induct v rule: Pos.induct)(auto)

abbreviation
  "intlen vs \<equiv> int (length vs)"

definition pflat_len :: "val \<Rightarrow> nat list => int"
where
  "pflat_len v p \<equiv> (if p \<in> Pos v then intlen (flat (at v p)) else -1)"

lemma pflat_len_simps:
  shows "pflat_len (Seq v1 v2) (0#p) = pflat_len v1 p"
  and   "pflat_len (Seq v1 v2) (Suc 0#p) = pflat_len v2 p"
  and   "pflat_len (Left v) (0#p) = pflat_len v p"
  and   "pflat_len (Left v) (Suc 0#p) = -1"
  and   "pflat_len (Right v) (Suc 0#p) = pflat_len v p"
  and   "pflat_len (Right v) (0#p) = -1"
  and   "pflat_len (Stars (v#vs)) (Suc n#p) = pflat_len (Stars vs) (n#p)"
  and   "pflat_len (Stars (v#vs)) (0#p) = pflat_len v p"
  and   "pflat_len v [] = intlen (flat v)"
by (auto simp add: pflat_len_def Pos_empty)

lemma pflat_len_Stars_simps:
  assumes "n < length vs"
  shows "pflat_len (Stars vs) (n#p) = pflat_len (vs!n) p"
using assms
apply(induct vs arbitrary: n p)
apply(auto simp add: less_Suc_eq_0_disj pflat_len_simps)
done

lemma pflat_len_outside:
  assumes "p \<notin> Pos v1"
  shows "pflat_len v1 p = -1 "
using assms by (simp add: pflat_len_def)

section {* Orderings *}

definition prefix_list:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<sqsubseteq>pre _" [60,59] 60)
where
  "ps1 \<sqsubseteq>pre ps2 \<equiv> \<exists>ps'. ps1 @ps' = ps2"

definition sprefix_list:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<sqsubset>spre _" [60,59] 60)
where
  "ps1 \<sqsubset>spre ps2 \<equiv> ps1 \<sqsubseteq>pre ps2 \<and> ps1 \<noteq> ps2"

inductive lex_list :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" ("_ \<sqsubset>lex _" [60,59] 60)
where
  "[] \<sqsubset>lex (p#ps)"
| "ps1 \<sqsubset>lex ps2 \<Longrightarrow> (p#ps1) \<sqsubset>lex (p#ps2)"
| "p1 < p2 \<Longrightarrow> (p1#ps1) \<sqsubset>lex (p2#ps2)"

lemma lex_irrfl:
  fixes ps1 ps2 :: "nat list"
  assumes "ps1 \<sqsubset>lex ps2"
  shows "ps1 \<noteq> ps2"
using assms
by(induct rule: lex_list.induct)(auto)

lemma lex_simps [simp]:
  fixes xs ys :: "nat list"
  shows "[] \<sqsubset>lex ys \<longleftrightarrow> ys \<noteq> []"
  and   "xs \<sqsubset>lex [] \<longleftrightarrow> False"
  and   "(x # xs) \<sqsubset>lex (y # ys) \<longleftrightarrow> (x < y \<or> (x = y \<and> xs \<sqsubset>lex ys))"
by (auto simp add: neq_Nil_conv elim: lex_list.cases intro: lex_list.intros)

lemma lex_trans:
  fixes ps1 ps2 ps3 :: "nat list"
  assumes "ps1 \<sqsubset>lex ps2" "ps2 \<sqsubset>lex ps3"
  shows "ps1 \<sqsubset>lex ps3"
using assms
by (induct arbitrary: ps3 rule: lex_list.induct)
   (auto elim: lex_list.cases)

lemma lex_trichotomous:
  fixes p q :: "nat list"
  shows "p = q \<or> p \<sqsubset>lex q \<or> q \<sqsubset>lex p"
apply(induct p arbitrary: q)
apply(auto elim: lex_list.cases)
apply(case_tac q)
apply(auto)
done

section {* POSIX Ordering of Values According to Okui & Suzuki *}

definition PosOrd:: "val \<Rightarrow> nat list \<Rightarrow> val \<Rightarrow> bool" ("_ \<sqsubset>val _ _" [60, 60, 59] 60)
where
  "v1 \<sqsubset>val p v2 \<equiv> pflat_len v1 p > pflat_len v2 p \<and>
                   (\<forall>q \<in> Pos v1 \<union> Pos v2. q \<sqsubset>lex p \<longrightarrow> pflat_len v1 q = pflat_len v2 q)"

lemma PosOrd_def2:
  shows "v1 \<sqsubset>val p v2 \<longleftrightarrow>
         pflat_len v1 p > pflat_len v2 p \<and>
         (\<forall>q \<in> Pos v1. q \<sqsubset>lex p \<longrightarrow> pflat_len v1 q = pflat_len v2 q) \<and>
         (\<forall>q \<in> Pos v2. q \<sqsubset>lex p \<longrightarrow> pflat_len v1 q = pflat_len v2 q)"
unfolding PosOrd_def
apply(auto)
done

definition PosOrd_ex:: "val \<Rightarrow> val \<Rightarrow> bool" ("_ :\<sqsubset>val _" [60, 59] 60)
where
  "v1 :\<sqsubset>val v2 \<equiv> \<exists>p. v1 \<sqsubset>val p v2"

definition PosOrd_ex_eq:: "val \<Rightarrow> val \<Rightarrow> bool" ("_ :\<sqsubseteq>val _" [60, 59] 60)
where
  "v1 :\<sqsubseteq>val v2 \<equiv> v1 :\<sqsubset>val v2 \<or> v1 = v2"

lemma PosOrd_trans:
  assumes "v1 :\<sqsubset>val v2" "v2 :\<sqsubset>val v3"
  shows "v1 :\<sqsubset>val v3"
proof -
  from assms obtain p p'
    where as: "v1 \<sqsubset>val p v2" "v2 \<sqsubset>val p' v3" unfolding PosOrd_ex_def by blast
  then have pos: "p \<in> Pos v1" "p' \<in> Pos v2" unfolding PosOrd_def pflat_len_def
    by (smt not_int_zless_negative)+
  have "p = p' \<or> p \<sqsubset>lex p' \<or> p' \<sqsubset>lex p"
    by (rule lex_trichotomous)
  moreover
    { assume "p = p'"
      with as have "v1 \<sqsubset>val p v3" unfolding PosOrd_def pflat_len_def
      by (smt Un_iff)
      then have " v1 :\<sqsubset>val v3" unfolding PosOrd_ex_def by blast
    }
  moreover
    { assume "p \<sqsubset>lex p'"
      with as have "v1 \<sqsubset>val p v3" unfolding PosOrd_def pflat_len_def
      by (smt Un_iff lex_trans)
      then have " v1 :\<sqsubset>val v3" unfolding PosOrd_ex_def by blast
    }
  moreover
    { assume "p' \<sqsubset>lex p"
      with as have "v1 \<sqsubset>val p' v3" unfolding PosOrd_def
      by (smt Un_iff lex_trans pflat_len_def)
      then have "v1 :\<sqsubset>val v3" unfolding PosOrd_ex_def by blast
    }
  ultimately show "v1 :\<sqsubset>val v3" by blast
qed

lemma PosOrd_irrefl:
  assumes "v :\<sqsubset>val v"
  shows "False"
using assms unfolding PosOrd_ex_def PosOrd_def
by auto

lemma PosOrd_assym:
  assumes "v1 :\<sqsubset>val v2"
  shows "\<not>(v2 :\<sqsubset>val v1)"
using assms
using PosOrd_irrefl PosOrd_trans by blast

text {*
  :\<sqsubseteq>val and :\<sqsubset>val are partial orders.
*}

lemma PosOrd_ordering:
  shows "ordering (\<lambda>v1 v2. v1 :\<sqsubseteq>val v2) (\<lambda> v1 v2. v1 :\<sqsubset>val v2)"
unfolding ordering_def PosOrd_ex_eq_def
apply(auto)
using PosOrd_irrefl apply blast
using PosOrd_assym apply blast
using PosOrd_trans by blast

lemma PosOrd_order:
  shows "class.order (\<lambda>v1 v2. v1 :\<sqsubseteq>val v2) (\<lambda> v1 v2. v1 :\<sqsubset>val v2)"
using PosOrd_ordering
apply(simp add: class.order_def class.preorder_def class.order_axioms_def)
unfolding ordering_def
by blast

lemma PosOrd_ex_eq2:
  shows "v1 :\<sqsubset>val v2 \<longleftrightarrow> (v1 :\<sqsubseteq>val v2 \<and> v1 \<noteq> v2)"
using PosOrd_ordering
unfolding ordering_def
by auto

lemma PosOrdeq_trans:
  assumes "v1 :\<sqsubseteq>val v2" "v2 :\<sqsubseteq>val v3"
  shows "v1 :\<sqsubseteq>val v3"
using assms PosOrd_ordering
unfolding ordering_def
by blast

lemma PosOrdeq_antisym:
  assumes "v1 :\<sqsubseteq>val v2" "v2 :\<sqsubseteq>val v1"
  shows "v1 = v2"
using assms PosOrd_ordering
unfolding ordering_def
by blast

lemma PosOrdeq_refl:
  shows "v :\<sqsubseteq>val v"
unfolding PosOrd_ex_eq_def
by auto

lemma PosOrd_shorterE:
  assumes "v1 :\<sqsubset>val v2"
  shows "length (flat v2) \<le> length (flat v1)"
using assms unfolding PosOrd_ex_def PosOrd_def
apply(auto)
apply(case_tac p)
apply(simp add: pflat_len_simps)
apply(drule_tac x="[]" in bspec)
apply(simp add: Pos_empty)
apply(simp add: pflat_len_simps)
done

lemma PosOrd_shorterI:
  assumes "length (flat v2) < length (flat v1)"
  shows "v1 :\<sqsubset>val v2"
unfolding PosOrd_ex_def PosOrd_def pflat_len_def
using assms Pos_empty by force

lemma PosOrd_spreI:
  assumes "flat v' \<sqsubset>spre flat v"
  shows "v :\<sqsubset>val v'"
using assms
apply(rule_tac PosOrd_shorterI)
unfolding prefix_list_def sprefix_list_def
by (metis append_Nil2 append_eq_conv_conj drop_all le_less_linear)

lemma pflat_len_inside:
  assumes "pflat_len v2 p < pflat_len v1 p"
  shows "p \<in> Pos v1"
using assms
unfolding pflat_len_def
by (auto split: if_splits)

lemma PosOrd_Left_Right:
  assumes "flat v1 = flat v2"
  shows "Left v1 :\<sqsubset>val Right v2"
unfolding PosOrd_ex_def
apply(rule_tac x="[0]" in exI)
apply(auto simp add: PosOrd_def pflat_len_simps assms)
done

lemma PosOrd_LeftE:
  assumes "Left v1 :\<sqsubset>val Left v2" "flat v1 = flat v2"
  shows "v1 :\<sqsubset>val v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
apply(frule pflat_len_inside)
apply(auto simp add: pflat_len_simps)
by (metis lex_simps(3) pflat_len_simps(3))

lemma PosOrd_LeftI:
  assumes "v1 :\<sqsubset>val v2" "flat v1 = flat v2"
  shows  "Left v1 :\<sqsubset>val Left v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
by (metis less_numeral_extra(3) lex_simps(3) pflat_len_simps(3))

lemma PosOrd_Left_eq:
  assumes "flat v1 = flat v2"
  shows "Left v1 :\<sqsubset>val Left v2 \<longleftrightarrow> v1 :\<sqsubset>val v2"
using assms PosOrd_LeftE PosOrd_LeftI
by blast

lemma PosOrd_RightE:
  assumes "Right v1 :\<sqsubset>val Right v2" "flat v1 = flat v2"
  shows "v1 :\<sqsubset>val v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
apply(frule pflat_len_inside)
apply(auto simp add: pflat_len_simps)
by (metis lex_simps(3) pflat_len_simps(5))

lemma PosOrd_RightI:
  assumes "v1 :\<sqsubset>val v2" "flat v1 = flat v2"
  shows  "Right v1 :\<sqsubset>val Right v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
by (metis lex_simps(3) nat_neq_iff pflat_len_simps(5))

lemma PosOrd_Right_eq:
  assumes "flat v1 = flat v2"
  shows "Right v1 :\<sqsubset>val Right v2 \<longleftrightarrow> v1 :\<sqsubset>val v2"
using assms PosOrd_RightE PosOrd_RightI
by blast

lemma PosOrd_SeqI1:
  assumes "v1 :\<sqsubset>val w1" "flat (Seq v1 v2) = flat (Seq w1 w2)"
  shows "Seq v1 v2 :\<sqsubset>val Seq w1 w2"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(rule_tac x="0#p" in exI)
apply(subst PosOrd_def)
apply(rule conjI)
apply(simp add: pflat_len_simps)
apply(rule ballI)
apply(rule impI)
apply(simp only: Pos.simps)
apply(auto)[1]
apply(simp add: pflat_len_simps)
apply(auto simp add: pflat_len_simps)
using assms(2)
apply(simp)
apply(metis length_append of_nat_add)
done

lemma PosOrd_SeqI2:
  assumes "v2 :\<sqsubset>val w2" "flat v2 = flat w2"
  shows "Seq v v2 :\<sqsubset>val Seq v w2"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(rule_tac x="Suc 0#p" in exI)
apply(subst PosOrd_def)
apply(rule conjI)
apply(simp add: pflat_len_simps)
apply(rule ballI)
apply(rule impI)
apply(simp only: Pos.simps)
apply(auto)[1]
apply(simp add: pflat_len_simps)
using assms(2)
apply(simp)
apply(auto simp add: pflat_len_simps)
done

lemma PosOrd_Seq_eq:
  assumes "flat v2 = flat w2"
  shows "(Seq v v2) :\<sqsubset>val (Seq v w2) \<longleftrightarrow> v2 :\<sqsubset>val w2"
using assms
apply(auto)
prefer 2
apply(simp add: PosOrd_SeqI2)
apply(simp add: PosOrd_ex_def)
apply(auto)
apply(case_tac p)
apply(simp add: PosOrd_def pflat_len_simps)
apply(case_tac a)
apply(simp add: PosOrd_def pflat_len_simps)
apply(clarify)
apply(case_tac nat)
prefer 2
apply(simp add: PosOrd_def pflat_len_simps pflat_len_outside)
apply(rule_tac x="list" in exI)
apply(auto simp add: PosOrd_def2 pflat_len_simps)
apply(smt Collect_disj_eq lex_list.intros(2) mem_Collect_eq pflat_len_simps(2))
apply(smt Collect_disj_eq lex_list.intros(2) mem_Collect_eq pflat_len_simps(2))
done

lemma PosOrd_StarsI:
  assumes "v1 :\<sqsubset>val v2" "flats (v1#vs1) = flats (v2#vs2)"
  shows "Stars (v1#vs1) :\<sqsubset>val Stars (v2#vs2)"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(subst PosOrd_def)
apply(rule_tac x="0#p" in exI)
apply(simp add: pflat_len_Stars_simps pflat_len_simps)
using assms(2)
apply(simp add: pflat_len_simps)
apply(auto simp add: pflat_len_Stars_simps pflat_len_simps)
by (metis length_append of_nat_add)

lemma PosOrd_StarsI2:
  assumes "Stars vs1 :\<sqsubset>val Stars vs2" "flats vs1 = flats vs2"
  shows "Stars (v#vs1) :\<sqsubset>val Stars (v#vs2)"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(subst PosOrd_def)
apply(case_tac p)
apply(simp add: pflat_len_simps)
apply(rule_tac x="Suc a#list" in exI)
apply(auto simp add: pflat_len_Stars_simps pflat_len_simps assms(2))
done

lemma PosOrd_Stars_appendI:
  assumes "Stars vs1 :\<sqsubset>val Stars vs2" "flat (Stars vs1) = flat (Stars vs2)"
  shows "Stars (vs @ vs1) :\<sqsubset>val Stars (vs @ vs2)"
using assms
apply(induct vs)
apply(simp)
apply(simp add: PosOrd_StarsI2)
done

lemma PosOrd_StarsE2:
  assumes "Stars (v # vs1) :\<sqsubset>val Stars (v # vs2)"
  shows "Stars vs1 :\<sqsubset>val Stars vs2"
using assms
apply(subst (asm) PosOrd_ex_def)
apply(erule exE)
apply(case_tac p)
apply(simp)
apply(simp add: PosOrd_def pflat_len_simps)
apply(subst PosOrd_ex_def)
apply(rule_tac x="[]" in exI)
apply(simp add: PosOrd_def pflat_len_simps Pos_empty)
apply(simp)
apply(case_tac a)
apply(clarify)
apply(auto simp add: pflat_len_simps PosOrd_def pflat_len_def split: if_splits)[1]
apply(clarify)
apply(simp add: PosOrd_ex_def)
apply(rule_tac x="nat#list" in exI)
apply(auto simp add: PosOrd_def pflat_len_simps)[1]
apply(case_tac q)
apply(simp add: PosOrd_def pflat_len_simps)
apply(clarify)
apply(drule_tac x="Suc a # lista" in bspec)
apply(simp)
apply(auto simp add: PosOrd_def pflat_len_simps)[1]
apply(case_tac q)
apply(simp add: PosOrd_def pflat_len_simps)
apply(clarify)
apply(drule_tac x="Suc a # lista" in bspec)
apply(simp)
apply(auto simp add: PosOrd_def pflat_len_simps)[1]
done

lemma PosOrd_Stars_appendE:
  assumes "Stars (vs @ vs1) :\<sqsubset>val Stars (vs @ vs2)"
  shows "Stars vs1 :\<sqsubset>val Stars vs2"
using assms
apply(induct vs)
apply(simp)
apply(simp add: PosOrd_StarsE2)
done

lemma PosOrd_Stars_append_eq:
  assumes "flats vs1 = flats vs2"
  shows "Stars (vs @ vs1) :\<sqsubset>val Stars (vs @ vs2) \<longleftrightarrow> Stars vs1 :\<sqsubset>val Stars vs2"
using assms
apply(rule_tac iffI)
apply(erule PosOrd_Stars_appendE)
apply(rule PosOrd_Stars_appendI)
apply(auto)
done

lemma PosOrd_almost_trichotomous:
  shows "v1 :\<sqsubset>val v2 \<or> v2 :\<sqsubset>val v1 \<or> (length (flat v1) = length (flat v2))"
apply(auto simp add: PosOrd_ex_def)
apply(auto simp add: PosOrd_def)
apply(rule_tac x="[]" in exI)
apply(auto simp add: Pos_empty pflat_len_simps)
apply(drule_tac x="[]" in spec)
apply(auto simp add: Pos_empty pflat_len_simps)
done

section {* The Posix Value is smaller than any other Value *}

lemma Posix_PosOrd:
  assumes "s \<in> r \<rightarrow> v1" "v2 \<in> LV r s"
  shows "v1 :\<sqsubseteq>val v2"
using assms
proof (induct arbitrary: v2 rule: Posix.induct)
  case (Posix_ONE v)
  have "v \<in> LV ONE []" by fact
  then have "v = Void"
    by (simp add: LV_simps)
  then show "Void :\<sqsubseteq>val v"
    by (simp add: PosOrd_ex_eq_def)
next
  case (Posix_CHAR c v)
  have "v \<in> LV (CHAR c) [c]" by fact
  then have "v = Char c"
    by (simp add: LV_simps)
  then show "Char c :\<sqsubseteq>val v"
    by (simp add: PosOrd_ex_eq_def)
next
  case (Posix_ALT1 s r1 v r2 v2)
  have as1: "s \<in> r1 \<rightarrow> v" by fact
  have IH: "\<And>v2. v2 \<in> LV r1 s \<Longrightarrow> v :\<sqsubseteq>val v2" by fact
  have "v2 \<in> LV (ALT r1 r2) s" by fact
  then have "\<Turnstile> v2 : ALT r1 r2" "flat v2 = s"
    by(auto simp add: LV_def prefix_list_def)
  then consider
    (Left) v3 where "v2 = Left v3" "\<Turnstile> v3 : r1" "flat v3 = s"
  | (Right) v3 where "v2 = Right v3" "\<Turnstile> v3 : r2" "flat v3 = s"
  by (auto elim: Prf.cases)
  then show "Left v :\<sqsubseteq>val v2"
  proof(cases)
     case (Left v3)
     have "v3 \<in> LV r1 s" using Left(2,3)
       by (auto simp add: LV_def prefix_list_def)
     with IH have "v :\<sqsubseteq>val v3" by simp
     moreover
     have "flat v3 = flat v" using as1 Left(3)
       by (simp add: Posix1(2))
     ultimately have "Left v :\<sqsubseteq>val Left v3"
       by (simp add: PosOrd_ex_eq_def PosOrd_Left_eq)
     then show "Left v :\<sqsubseteq>val v2" unfolding Left .
  next
     case (Right v3)
     have "flat v3 = flat v" using as1 Right(3)
       by (simp add: Posix1(2))
     then have "Left v :\<sqsubseteq>val Right v3"
       unfolding PosOrd_ex_eq_def
       by (simp add: PosOrd_Left_Right)
     then show "Left v :\<sqsubseteq>val v2" unfolding Right .
  qed
next
  case (Posix_ALT2 s r2 v r1 v2)
  have as1: "s \<in> r2 \<rightarrow> v" by fact
  have as2: "s \<notin> L r1" by fact
  have IH: "\<And>v2. v2 \<in> LV r2 s \<Longrightarrow> v :\<sqsubseteq>val v2" by fact
  have "v2 \<in> LV (ALT r1 r2) s" by fact
  then have "\<Turnstile> v2 : ALT r1 r2" "flat v2 = s"
    by(auto simp add: LV_def prefix_list_def)
  then consider
    (Left) v3 where "v2 = Left v3" "\<Turnstile> v3 : r1" "flat v3 = s"
  | (Right) v3 where "v2 = Right v3" "\<Turnstile> v3 : r2" "flat v3 = s"
  by (auto elim: Prf.cases)
  then show "Right v :\<sqsubseteq>val v2"
  proof (cases)
    case (Right v3)
     have "v3 \<in> LV r2 s" using Right(2,3)
       by (auto simp add: LV_def prefix_list_def)
     with IH have "v :\<sqsubseteq>val v3" by simp
     moreover
     have "flat v3 = flat v" using as1 Right(3)
       by (simp add: Posix1(2))
     ultimately have "Right v :\<sqsubseteq>val Right v3"
        by (auto simp add: PosOrd_ex_eq_def PosOrd_RightI)
     then show "Right v :\<sqsubseteq>val v2" unfolding Right .
  next
     case (Left v3)
     have "v3 \<in> LV r1 s" using Left(2,3) as2
       by (auto simp add: LV_def prefix_list_def)
     then have "flat v3 = flat v \<and> \<Turnstile> v3 : r1" using as1 Left(3)
       by (simp add: Posix1(2) LV_def)
     then have "False" using as1 as2 Left
       by (auto simp add: Posix1(2) L_flat_Prf1)
     then show "Right v :\<sqsubseteq>val v2" by simp
  qed
next
  case (Posix_SEQ s1 r1 v1 s2 r2 v2 v3)
  have "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" by fact+
  then have as1: "s1 = flat v1" "s2 = flat v2" by (simp_all add: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r1 s1 \<Longrightarrow> v1 :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV r2 s2 \<Longrightarrow> v2 :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by fact
  have "v3 \<in> LV (SEQ r1 r2) (s1 @ s2)" by fact
  then obtain v3a v3b where eqs:
    "v3 = Seq v3a v3b" "\<Turnstile> v3a : r1" "\<Turnstile> v3b : r2"
    "flat v3a @ flat v3b = s1 @ s2"
    by (force simp add: prefix_list_def LV_def elim: Prf.cases)
  with cond have "flat v3a \<sqsubseteq>pre s1" unfolding prefix_list_def
    by (smt L_flat_Prf1 append_eq_append_conv2 append_self_conv)
  then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat v3b = s2)" using eqs
    by (simp add: sprefix_list_def append_eq_conv_conj)
  then have q2: "v1 :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat v3b = s2)"
    using PosOrd_spreI as1(1) eqs by blast
  then have "v1 :\<sqsubset>val v3a \<or> (v3a \<in> LV r1 s1 \<and> v3b \<in> LV r2 s2)" using eqs(2,3)
    by (auto simp add: LV_def)
  then have "v1 :\<sqsubset>val v3a \<or> (v1 :\<sqsubseteq>val v3a \<and> v2 :\<sqsubseteq>val v3b)" using IH1 IH2 by blast
  then have "Seq v1 v2 :\<sqsubseteq>val Seq v3a v3b" using eqs q2 as1
    unfolding  PosOrd_ex_eq_def by (auto simp add: PosOrd_SeqI1 PosOrd_Seq_eq)
  then show "Seq v1 v2 :\<sqsubseteq>val v3" unfolding eqs by blast
next
  case (Posix_STAR1 s1 r v s2 vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> STAR r \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flat (Stars vs)" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (STAR r) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (STAR r) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : STAR r"
    "flat (Stars (v3a # vs3)) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
  apply(auto)
  apply(case_tac vs)
  apply(auto intro: Prf.intros)
  done
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flat (Stars (v3a # vs3)) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        by (smt L_flat_Prf1 append_Nil2 append_eq_append_conv2 flat.simps(7))
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (STAR r) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
    qed
next
  case (Posix_STAR2 r v2)
  have "v2 \<in> LV (STAR r) []" by fact
  then have "v2 = Stars []"
    unfolding LV_def by (auto elim: Prf.cases)
  then show "Stars [] :\<sqsubseteq>val v2"
  by (simp add: PosOrd_ex_eq_def)
qed

lemma Posix_PosOrd_reverse:
  assumes "s \<in> r \<rightarrow> v1"
  shows "\<not>(\<exists>v2 \<in> LV r s. v2 :\<sqsubset>val v1)"
using assms
by (metis Posix_PosOrd less_irrefl PosOrd_def
    PosOrd_ex_eq_def PosOrd_ex_def PosOrd_trans)

lemma PosOrd_Posix:
  assumes "v1 \<in> LV r s" "\<forall>v\<^sub>2 \<in> LV r s. \<not> v\<^sub>2 :\<sqsubset>val v1"
  shows "s \<in> r \<rightarrow> v1"
proof -
  have "s \<in> L r" using assms(1) unfolding LV_def
    using L_flat_Prf1 by blast
  then obtain vposix where vp: "s \<in> r \<rightarrow> vposix"
    using lexer_correct_Some by blast
  with assms(1) have "vposix :\<sqsubseteq>val v1" by (simp add: Posix_PosOrd)
  then have "vposix = v1 \<or> vposix :\<sqsubset>val v1" unfolding PosOrd_ex_eq2 by auto
  moreover
    { assume "vposix :\<sqsubset>val v1"
      moreover
      have "vposix \<in> LV r s" using vp
         using Posix_LV by blast
      ultimately have "False" using assms(2) by blast
    }
  ultimately show "s \<in> r \<rightarrow> v1" using vp by blast
qed

lemma Least_existence:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>vmin \<in> LV r s. \<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v"
proof -
  from assms
  obtain vposix where "s \<in> r \<rightarrow> vposix"
  unfolding LV_def
  using L_flat_Prf1 lexer_correct_Some by blast
  then have "\<forall>v \<in> LV r s. vposix :\<sqsubseteq>val v"
    by (simp add: Posix_PosOrd)
  then show "\<exists>vmin \<in> LV r s. \<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v"
    using Posix_LV \<open>s \<in> r \<rightarrow> vposix\<close> by blast
qed

lemma Least_existence1:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>!vmin \<in> LV r s. \<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v"
using Least_existence[OF assms] assms
using PosOrdeq_antisym by blast

lemma Least_existence1_pre:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>!vmin \<in> LV r s. \<forall>v \<in> (LV r s \<union> {v'. flat v' \<sqsubset>spre s}). vmin :\<sqsubseteq>val v"
using Least_existence[OF assms] assms
apply -
apply(erule bexE)
apply(rule_tac a="vmin" in ex1I)
apply(auto)[1]
apply (metis PosOrd_Posix PosOrd_ex_eq2 PosOrd_spreI PosOrdeq_antisym Posix1(2))
apply(auto)[1]
apply(simp add: PosOrdeq_antisym)
done

lemma
  shows "partial_order_on UNIV {(v1, v2). v1 :\<sqsubseteq>val v2}"
apply(simp add: partial_order_on_def)
apply(simp add: preorder_on_def refl_on_def)
apply(simp add: PosOrdeq_refl)
apply(auto)
apply(rule transI)
apply(auto intro: PosOrdeq_trans)[1]
apply(rule antisymI)
apply(simp add: PosOrdeq_antisym)
done

lemma
 "wf {(v1, v2). v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s}"
apply(rule finite_acyclic_wf)
prefer 2
apply(simp add: acyclic_def)
apply(induct_tac rule: trancl.induct)
apply(auto)[1]
oops

unused_thms

end


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

section \<open>Complete Tests\<close>

theory Complete_Tests

imports Tests

begin

class complete_tests = tests + Sup + Inf +
  assumes sup_test: "test_set A \<longrightarrow> Sup A = --Sup A"
  assumes sup_upper: "test_set A \<and> x \<in> A \<longrightarrow> x \<le> Sup A"
  assumes sup_least: "test_set A \<and> (\<forall>x\<in>A . x \<le> -y) \<longrightarrow> Sup A \<le> -y"
begin

lemma Sup_isotone:
  "test_set B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
  by (metis sup_least sup_test sup_upper test_set_closed subset_eq)

lemma mult_right_dist_sup:
  assumes "test_set A"
    shows "Sup A * -p = Sup { x * -p | x . x \<in> A }"
proof -
  have 1: "test_set { x * -p | x . x \<in> A }"
    by (simp add: assms mult_right_dist_test_set)
  have 2: "Sup { x * -p | x . x \<in> A } \<le> Sup A * -p"
    by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_sup_left_isotone sub_mult_closed sup_test sup_least sup_upper test_set_def)
  have "\<forall>x\<in>A . x \<le> --(--Sup { x * -p | x . x \<in> A } \<squnion> --p)"
  proof
    fix x
    assume 3: "x \<in> A"
    hence "x * -p \<squnion> --p \<le> Sup { x * -p | x . x \<in> A } \<squnion> --p"
      using 1 by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_inf_left_isotone sub_mult_closed sup_upper test_set_def sup_test)
    thus "x \<le> --(--Sup { x * -p | x . x \<in> A } \<squnion> --p)"
      using 1 3 by (smt (z3) assms tests_dual.inf_closed sub_comm test_set_def sup_test sub_mult_closed tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_left_isotone tests_dual.inf_absorb tests_dual.inf_less_eq_cases_3)
  qed
  hence "Sup A \<le> --(--Sup { x * -p | x . x \<in> A } \<squnion> --p)"
    by (simp add: assms sup_least)
  hence "Sup A * -p \<le> Sup { x * -p | x . x \<in> A }"
    using 1 by (smt (z3) assms sup_test tests_dual.sba_dual.shunting tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.sub_sup_demorgan)
  thus ?thesis
    using 1 2 by (smt (z3) assms sup_test tests_dual.sba_dual.sub_sup_closed tests_dual.antisymmetric tests_dual.inf_demorgan tests_dual.inf_idempotent)
qed

lemma mult_left_dist_sup:
  assumes "test_set A"
  shows "-p * Sup A = Sup { -p * x | x . x \<in> A }"
proof -
  have 1: "Sup A * -p = Sup { x * -p | x . x \<in> A }"
    by (simp add: assms mult_right_dist_sup)
  have 2: "-p * Sup A = Sup A * -p"
    by (metis assms sub_comm sup_test)
  have "{ -p * x | x . x \<in> A } = { x * -p | x . x \<in> A }"
    by (metis assms test_set_def tests_dual.sub_commutative)
  thus ?thesis
    using 1 2 by simp
qed

definition Sum :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "Sum f \<equiv> Sup { f n | n::nat . True }"

lemma Sum_test:
  "test_seq t \<Longrightarrow> Sum t = --Sum t"
  using Sum_def sup_test test_seq_test_set by auto

lemma Sum_upper:
  "test_seq t \<Longrightarrow> t x \<le> Sum t"
  using Sum_def sup_upper test_seq_test_set by auto

lemma Sum_least:
  "test_seq t \<Longrightarrow> (\<forall>n . t n \<le> -p) \<Longrightarrow> Sum t \<le> -p"
  using Sum_def sup_least test_seq_test_set by force

lemma mult_right_dist_Sum:
  "test_seq t \<Longrightarrow> (\<forall>n . t n * -p \<le> -q) \<Longrightarrow> Sum t * -p \<le> -q"
  by (smt (verit, del_insts) CollectD Sum_def sup_least sup_test test_seq_test_set test_set_def tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_closed)

lemma mult_left_dist_Sum:
  "test_seq t \<Longrightarrow> (\<forall>n . -p * t n \<le> -q) \<Longrightarrow> -p * Sum t \<le> -q"
  by (smt (verit, del_insts) Sum_def mem_Collect_eq mult_left_dist_sup sub_mult_closed sup_least test_seq_test_set test_set_def)

lemma pSum_below_Sum:
  "test_seq t \<Longrightarrow> pSum t m \<le> Sum t"
  using Sum_test Sum_upper nat_test_def pSum_below_sum test_seq_def mult_right_dist_Sum by auto

lemma pSum_sup:
  assumes "test_seq t"
    shows "pSum t m = Sup { t i | i . i \<in> {..<m} }"
proof -
  have 1: "test_set { t i | i . i \<in> {..<m} }"
    using assms test_seq_test_set test_set_def by auto
  have "\<forall>y\<in>{ t i | i . i \<in> {..<m} } . y \<le> --pSum t m"
    using assms pSum_test pSum_upper by force
  hence 2: "Sup { t i | i . i \<in> {..<m} } \<le> --pSum t m"
    using 1 by (simp add: sup_least)
  have "pSum t m \<le> Sup { t i | i . i \<in> {..<m} }"
  proof (induct m)
    case 0
    show ?case
      by (smt (verit, ccfv_SIG) Collect_empty_eq empty_iff lessThan_0 pSum.simps(1) sup_test test_set_def tests_dual.top_greatest)
  next
    case (Suc n)
    have 4: "test_set {t i |i. i \<in> {..<n}}"
      using assms test_seq_def test_set_def by auto
    have 5: "test_set {t i |i. i < Suc n}"
      using assms test_seq_def test_set_def by force
    hence 6: "Sup {t i |i. i < Suc n} = --Sup {t i |i. i < Suc n}"
      using sup_test by auto
    hence "\<forall>x\<in>{t i |i. i \<in> {..<n}} . x \<le> --Sup {t i |i. i < Suc n}"
      using 5 less_Suc_eq sup_upper by fastforce
    hence 7: "Sup {t i |i. i \<in> {..<n}} \<le> --Sup {t i |i. i < Suc n}"
      using 4 by (simp add: sup_least)
    have "t n \<in> {t i |i. i < Suc n}"
      by auto
    hence "t n \<le> Sup {t i |i. i < Suc n}"
      using 5 by (simp add: sup_upper)
    hence "pSum t n \<squnion> t n \<le> Sup {t i |i. i <Suc n}"
      using Suc 4 6 7 by (smt assms tests_dual.greatest_lower_bound test_seq_def pSum_test tests_dual.sba_dual.transitive sup_test)
    thus ?case
      by simp
  qed
  thus ?thesis
    using 1 2 by (smt assms tests_dual.antisymmetric sup_test pSum_test)
qed

definition Prod :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "Prod f \<equiv> Inf { f n | n::nat . True }"

lemma Sum_range:
  "Sum f = Sup (range f)"
  by (simp add: Sum_def image_def)

lemma Prod_range:
  "Prod f = Inf (range f)"
  by (simp add: Prod_def image_def)

end

end


(*  Title:      HOL/UNITY/Follows.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section{*The Follows Relation of Charpentier and Sivilotte*}

theory Follows
imports SubstAx ListOrder "~~/src/HOL/Library/Multiset"
begin

definition Follows :: "['a => 'b::{order}, 'a => 'b::{order}] => 'a program set" (infixl "Fols" 65) where
   "f Fols g == Increasing g \<inter> Increasing f Int
                Always {s. f s \<le> g s} Int
                (\<Inter>k. {s. k \<le> g s} LeadsTo {s. k \<le> f s})"

(*Does this hold for "invariant"?*)
lemma mono_Always_o:
     "mono h ==> Always {s. f s \<le> g s} \<subseteq> Always {s. h (f s) \<le> h (g s)}"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: monoD)
done

lemma mono_LeadsTo_o:
     "mono (h::'a::order => 'b::order)
      ==> (\<Inter>j. {s. j \<le> g s} LeadsTo {s. j \<le> f s}) \<subseteq>
          (\<Inter>k. {s. k \<le> h (g s)} LeadsTo {s. k \<le> h (f s)})"
apply auto
apply (rule single_LeadsTo_I)
apply (drule_tac x = "g s" in spec)
apply (erule LeadsTo_weaken)
apply (blast intro: monoD order_trans)+
done

lemma Follows_constant [iff]: "F \<in> (%s. c) Fols (%s. c)"
by (simp add: Follows_def)

lemma mono_Follows_o: "mono h ==> f Fols g \<subseteq> (h o f) Fols (h o g)"
by (auto simp add: Follows_def mono_Increasing_o [THEN [2] rev_subsetD]
                   mono_Always_o [THEN [2] rev_subsetD]
                   mono_LeadsTo_o [THEN [2] rev_subsetD, THEN INT_D])

lemma mono_Follows_apply:
     "mono h ==> f Fols g \<subseteq> (%x. h (f x)) Fols (%x. h (g x))"
apply (drule mono_Follows_o)
apply (force simp add: o_def)
done

lemma Follows_trans:
     "[| F \<in> f Fols g;  F \<in> g Fols h |] ==> F \<in> f Fols h"
apply (simp add: Follows_def)
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: order_trans LeadsTo_Trans)
done

subsection{*Destruction rules*}

lemma Follows_Increasing1: "F \<in> f Fols g ==> F \<in> Increasing f"
by (simp add: Follows_def)

lemma Follows_Increasing2: "F \<in> f Fols g ==> F \<in> Increasing g"
by (simp add: Follows_def)

lemma Follows_Bounded: "F \<in> f Fols g ==> F \<in> Always {s. f s \<le> g s}"
by (simp add: Follows_def)

lemma Follows_LeadsTo:
     "F \<in> f Fols g ==> F \<in> {s. k \<le> g s} LeadsTo {s. k \<le> f s}"
by (simp add: Follows_def)

lemma Follows_LeadsTo_pfixLe:
     "F \<in> f Fols g ==> F \<in> {s. k pfixLe g s} LeadsTo {s. k pfixLe f s}"
apply (rule single_LeadsTo_I, clarify)
apply (drule_tac k="g s" in Follows_LeadsTo)
apply (erule LeadsTo_weaken)
 apply blast
apply (blast intro: pfixLe_trans prefix_imp_pfixLe)
done

lemma Follows_LeadsTo_pfixGe:
     "F \<in> f Fols g ==> F \<in> {s. k pfixGe g s} LeadsTo {s. k pfixGe f s}"
apply (rule single_LeadsTo_I, clarify)
apply (drule_tac k="g s" in Follows_LeadsTo)
apply (erule LeadsTo_weaken)
 apply blast
apply (blast intro: pfixGe_trans prefix_imp_pfixGe)
done

lemma Always_Follows1:
     "[| F \<in> Always {s. f s = f' s}; F \<in> f Fols g |] ==> F \<in> f' Fols g"

apply (simp add: Follows_def Increasing_def Stable_def, auto)
apply (erule_tac [3] Always_LeadsTo_weaken)
apply (erule_tac A = "{s. x \<le> f s}" and A' = "{s. x \<le> f s}"
       in Always_Constrains_weaken, auto)
apply (drule Always_Int_I, assumption)
apply (force intro: Always_weaken)
done

lemma Always_Follows2:
     "[| F \<in> Always {s. g s = g' s}; F \<in> f Fols g |] ==> F \<in> f Fols g'"
apply (simp add: Follows_def Increasing_def Stable_def, auto)
apply (erule_tac [3] Always_LeadsTo_weaken)
apply (erule_tac A = "{s. x \<le> g s}" and A' = "{s. x \<le> g s}"
       in Always_Constrains_weaken, auto)
apply (drule Always_Int_I, assumption)
apply (force intro: Always_weaken)
done

subsection{*Union properties (with the subset ordering)*}

(*Can replace "Un" by any sup.  But existing max only works for linorders.*)

lemma increasing_Un:
    "[| F \<in> increasing f;  F \<in> increasing g |]
     ==> F \<in> increasing (%s. (f s) \<union> (g s))"
apply (simp add: increasing_def stable_def constrains_def, auto)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (blast dest!: bspec)
done

lemma Increasing_Un:
    "[| F \<in> Increasing f;  F \<in> Increasing g |]
     ==> F \<in> Increasing (%s. (f s) \<union> (g s))"
apply (auto simp add: Increasing_def Stable_def Constrains_def
                      stable_def constrains_def)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (blast dest!: bspec)
done

lemma Always_Un:
     "[| F \<in> Always {s. f' s \<le> f s}; F \<in> Always {s. g' s \<le> g s} |]
      ==> F \<in> Always {s. f' s \<union> g' s \<le> f s \<union> g s}"
by (simp add: Always_eq_includes_reachable, blast)

(*Lemma to re-use the argument that one variable increases (progress)
  while the other variable doesn't decrease (safety)*)
lemma Follows_Un_lemma:
     "[| F \<in> Increasing f; F \<in> Increasing g;
         F \<in> Increasing g'; F \<in> Always {s. f' s \<le> f s};
         \<forall>k. F \<in> {s. k \<le> f s} LeadsTo {s. k \<le> f' s} |]
      ==> F \<in> {s. k \<le> f s \<union> g s} LeadsTo {s. k \<le> f' s \<union> g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in IncreasingD)
apply (drule_tac x = "g s" in IncreasingD)
apply (rule LeadsTo_weaken)
apply (rule PSP_Stable)
apply (erule_tac x = "f s" in spec)
apply (erule Stable_Int, assumption, blast+)
done

lemma Follows_Un:
    "[| F \<in> f' Fols f;  F \<in> g' Fols g |]
     ==> F \<in> (%s. (f' s) \<union> (g' s)) Fols (%s. (f s) \<union> (g s))"
apply (simp add: Follows_def Increasing_Un Always_Un del: Un_subset_iff sup.bounded_iff, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_Un_lemma)
(*Weakening is used to exchange Un's arguments*)
apply (blast intro: Follows_Un_lemma [THEN LeadsTo_weaken])
done

subsection{*Multiset union properties (with the multiset ordering)*}

lemma increasing_union:
    "[| F \<in> increasing f;  F \<in> increasing g |]
     ==> F \<in> increasing (%s. (f s) + (g s :: ('a::order) multiset))"
apply (simp add: increasing_def stable_def constrains_def, auto)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (drule bspec, assumption)
apply (blast intro: add_mono order_trans)
done

lemma Increasing_union:
    "[| F \<in> Increasing f;  F \<in> Increasing g |]
     ==> F \<in> Increasing (%s. (f s) + (g s :: ('a::order) multiset))"
apply (auto simp add: Increasing_def Stable_def Constrains_def
                      stable_def constrains_def)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (drule bspec, assumption)
apply (blast intro: add_mono order_trans)
done

lemma Always_union:
     "[| F \<in> Always {s. f' s \<le> f s}; F \<in> Always {s. g' s \<le> g s} |]
      ==> F \<in> Always {s. f' s + g' s \<le> f s + (g s :: ('a::order) multiset)}"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: add_mono)
done

(*Except the last line, IDENTICAL to the proof script for Follows_Un_lemma*)
lemma Follows_union_lemma:
     "[| F \<in> Increasing f; F \<in> Increasing g;
         F \<in> Increasing g'; F \<in> Always {s. f' s \<le> f s};
         \<forall>k::('a::order) multiset.
           F \<in> {s. k \<le> f s} LeadsTo {s. k \<le> f' s} |]
      ==> F \<in> {s. k \<le> f s + g s} LeadsTo {s. k \<le> f' s + g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in IncreasingD)
apply (drule_tac x = "g s" in IncreasingD)
apply (rule LeadsTo_weaken)
apply (rule PSP_Stable)
apply (erule_tac x = "f s" in spec)
apply (erule Stable_Int, assumption, blast)
apply (blast intro: add_mono order_trans)
done

(*The !! is there to influence to effect of permutative rewriting at the end*)
lemma Follows_union:
     "!!g g' ::'b => ('a::order) multiset.
        [| F \<in> f' Fols f;  F \<in> g' Fols g |]
        ==> F \<in> (%s. (f' s) + (g' s)) Fols (%s. (f s) + (g s))"
apply (simp add: Follows_def)
apply (simp add: Increasing_union Always_union, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_union_lemma)
(*now exchange union's arguments*)
apply (simp add: union_commute)
apply (blast intro: Follows_union_lemma)
done

lemma Follows_setsum:
     "!!f ::['c,'b] => ('a::order) multiset.
        [| \<forall>i \<in> I. F \<in> f' i Fols f i;  finite I |]
        ==> F \<in> (%s. \<Sum>i \<in> I. f' i s) Fols (%s. \<Sum>i \<in> I. f i s)"
apply (erule rev_mp)
apply (erule finite_induct, simp)
apply (simp add: Follows_union)
done

(*Currently UNUSED, but possibly of interest*)
lemma Increasing_imp_Stable_pfixGe:
     "F \<in> Increasing func ==> F \<in> Stable {s. h pfixGe (func s)}"
apply (simp add: Increasing_def Stable_def Constrains_def constrains_def)
apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD]
                    prefix_imp_pfixGe)
done

(*Currently UNUSED, but possibly of interest*)
lemma LeadsTo_le_imp_pfixGe:
     "\<forall>z. F \<in> {s. z \<le> f s} LeadsTo {s. z \<le> g s}
      ==> F \<in> {s. z pfixGe f s} LeadsTo {s. z pfixGe g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in spec)
apply (erule LeadsTo_weaken)
 prefer 2
 apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD]
                     prefix_imp_pfixGe, blast)
done

end


(*  Title:      HOL/Lattices_Big.thy
    Author:     Tobias Nipkow, Lawrence C Paulson and Markus Wenzel
                with contributions by Jeremy Avigad
*)

section \<open>Big infimum (minimum) and supremum (maximum) over finite (non-empty) sets\<close>

theory Lattices_Big
  imports Groups_Big Option
begin

subsection \<open>Generic lattice operations over a set\<close>

subsubsection \<open>Without neutral element\<close>

locale semilattice_set = semilattice
begin

interpretation comp_fun_idem f
  by standard (simp_all add: fun_eq_iff left_commute)

definition F :: "'a set \<Rightarrow> 'a"
where
  eq_fold': "F A = the (Finite_Set.fold (\<lambda>x y. Some (case y of None \<Rightarrow> x | Some z \<Rightarrow> f x z)) None A)"

lemma eq_fold:
  assumes "finite A"
  shows "F (insert x A) = Finite_Set.fold f x A"
proof (rule sym)
  let ?f = "\<lambda>x y. Some (case y of None \<Rightarrow> x | Some z \<Rightarrow> f x z)"
  interpret comp_fun_idem "?f"
    by standard (simp_all add: fun_eq_iff commute left_commute split: option.split)
  from assms show "Finite_Set.fold f x A = F (insert x A)"
  proof induct
    case empty then show ?case by (simp add: eq_fold')
  next
    case (insert y B) then show ?case by (simp add: insert_commute [of x] eq_fold')
  qed
qed

lemma singleton [simp]:
  "F {x} = x"
  by (simp add: eq_fold)

lemma insert_not_elem:
  assumes "finite A" and "x \<notin> A" and "A \<noteq> {}"
  shows "F (insert x A) = x \<^bold>* F A"
proof -
  from \<open>A \<noteq> {}\<close> obtain b where "b \<in> A" by blast
  then obtain B where *: "A = insert b B" "b \<notin> B" by (blast dest: mk_disjoint_insert)
  with \<open>finite A\<close> and \<open>x \<notin> A\<close>
    have "finite (insert x B)" and "b \<notin> insert x B" by auto
  then have "F (insert b (insert x B)) = x \<^bold>* F (insert b B)"
    by (simp add: eq_fold)
  then show ?thesis by (simp add: * insert_commute)
qed

lemma in_idem:
  assumes "finite A" and "x \<in> A"
  shows "x \<^bold>* F A = F A"
proof -
  from assms have "A \<noteq> {}" by auto
  with \<open>finite A\<close> show ?thesis using \<open>x \<in> A\<close>
    by (induct A rule: finite_ne_induct) (auto simp add: ac_simps insert_not_elem)
qed

lemma insert [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "F (insert x A) = x \<^bold>* F A"
  using assms by (cases "x \<in> A") (simp_all add: insert_absorb in_idem insert_not_elem)

lemma union:
  assumes "finite A" "A \<noteq> {}" and "finite B" "B \<noteq> {}"
  shows "F (A \<union> B) = F A \<^bold>* F B"
  using assms by (induct A rule: finite_ne_induct) (simp_all add: ac_simps)

lemma remove:
  assumes "finite A" and "x \<in> A"
  shows "F A = (if A - {x} = {} then x else x \<^bold>* F (A - {x}))"
proof -
  from assms obtain B where "A = insert x B" and "x \<notin> B" by (blast dest: mk_disjoint_insert)
  with assms show ?thesis by simp
qed

lemma insert_remove:
  assumes "finite A"
  shows "F (insert x A) = (if A - {x} = {} then x else x \<^bold>* F (A - {x}))"
  using assms by (cases "x \<in> A") (simp_all add: insert_absorb remove)

lemma closed:
  assumes "finite A" "A \<noteq> {}" and elem: "\<And>x y. x \<^bold>* y \<in> {x, y}"
  shows "F A \<in> A"
using \<open>finite A\<close> \<open>A \<noteq> {}\<close> proof (induct rule: finite_ne_induct)
  case singleton then show ?case by simp
next
  case insert with elem show ?case by force
qed

lemma hom_commute:
  assumes hom: "\<And>x y. h (x \<^bold>* y) = h x \<^bold>* h y"
  and N: "finite N" "N \<noteq> {}"
  shows "h (F N) = F (h ` N)"
using N proof (induct rule: finite_ne_induct)
  case singleton thus ?case by simp
next
  case (insert n N)
  then have "h (F (insert n N)) = h (n \<^bold>* F N)" by simp
  also have "\<dots> = h n \<^bold>* h (F N)" by (rule hom)
  also have "h (F N) = F (h ` N)" by (rule insert)
  also have "h n \<^bold>* \<dots> = F (insert (h n) (h ` N))"
    using insert by simp
  also have "insert (h n) (h ` N) = h ` insert n N" by simp
  finally show ?case .
qed

lemma infinite: "\<not> finite A \<Longrightarrow> F A = the None"
  unfolding eq_fold' by (cases "finite (UNIV::'a set)") (auto intro: finite_subset fold_infinite)

end

locale semilattice_order_set = binary?: semilattice_order + semilattice_set
begin

lemma bounded_iff:
  assumes "finite A" and "A \<noteq> {}"
  shows "x \<^bold>\<le> F A \<longleftrightarrow> (\<forall>a\<in>A. x \<^bold>\<le> a)"
  using assms by (induct rule: finite_ne_induct) simp_all

lemma boundedI:
  assumes "finite A"
  assumes "A \<noteq> {}"
  assumes "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  shows "x \<^bold>\<le> F A"
  using assms by (simp add: bounded_iff)

lemma boundedE:
  assumes "finite A" and "A \<noteq> {}" and "x \<^bold>\<le> F A"
  obtains "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  using assms by (simp add: bounded_iff)

lemma coboundedI:
  assumes "finite A"
    and "a \<in> A"
  shows "F A \<^bold>\<le> a"
proof -
  from assms have "A \<noteq> {}" by auto
  from \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>a \<in> A\<close> show ?thesis
  proof (induct rule: finite_ne_induct)
    case singleton thus ?case by (simp add: refl)
  next
    case (insert x B)
    from insert have "a = x \<or> a \<in> B" by simp
    then show ?case using insert by (auto intro: coboundedI2)
  qed
qed

lemma subset_imp:
  assumes "A \<subseteq> B" and "A \<noteq> {}" and "finite B"
  shows "F B \<^bold>\<le> F A"
proof (cases "A = B")
  case True then show ?thesis by (simp add: refl)
next
  case False
  have B: "B = A \<union> (B - A)" using \<open>A \<subseteq> B\<close> by blast
  then have "F B = F (A \<union> (B - A))" by simp
  also have "\<dots> = F A \<^bold>* F (B - A)" using False assms by (subst union) (auto intro: finite_subset)
  also have "\<dots> \<^bold>\<le> F A" by simp
  finally show ?thesis .
qed

end

subsubsection \<open>With neutral element\<close>

locale semilattice_neutr_set = semilattice_neutr
begin

interpretation comp_fun_idem f
  by standard (simp_all add: fun_eq_iff left_commute)

definition F :: "'a set \<Rightarrow> 'a"
where
  eq_fold: "F A = Finite_Set.fold f \<^bold>1 A"

lemma infinite [simp]:
  "\<not> finite A \<Longrightarrow> F A = \<^bold>1"
  by (simp add: eq_fold)

lemma empty [simp]:
  "F {} = \<^bold>1"
  by (simp add: eq_fold)

lemma insert [simp]:
  assumes "finite A"
  shows "F (insert x A) = x \<^bold>* F A"
  using assms by (simp add: eq_fold)

lemma in_idem:
  assumes "finite A" and "x \<in> A"
  shows "x \<^bold>* F A = F A"
proof -
  from assms have "A \<noteq> {}" by auto
  with \<open>finite A\<close> show ?thesis using \<open>x \<in> A\<close>
    by (induct A rule: finite_ne_induct) (auto simp add: ac_simps)
qed

lemma union:
  assumes "finite A" and "finite B"
  shows "F (A \<union> B) = F A \<^bold>* F B"
  using assms by (induct A) (simp_all add: ac_simps)

lemma remove:
  assumes "finite A" and "x \<in> A"
  shows "F A = x \<^bold>* F (A - {x})"
proof -
  from assms obtain B where "A = insert x B" and "x \<notin> B" by (blast dest: mk_disjoint_insert)
  with assms show ?thesis by simp
qed

lemma insert_remove:
  assumes "finite A"
  shows "F (insert x A) = x \<^bold>* F (A - {x})"
  using assms by (cases "x \<in> A") (simp_all add: insert_absorb remove)

lemma subset:
  assumes "finite A" and "B \<subseteq> A"
  shows "F B \<^bold>* F A = F A"
proof -
  from assms have "finite B" by (auto dest: finite_subset)
  with assms show ?thesis by (simp add: union [symmetric] Un_absorb1)
qed

lemma closed:
  assumes "finite A" "A \<noteq> {}" and elem: "\<And>x y. x \<^bold>* y \<in> {x, y}"
  shows "F A \<in> A"
using \<open>finite A\<close> \<open>A \<noteq> {}\<close> proof (induct rule: finite_ne_induct)
  case singleton then show ?case by simp
next
  case insert with elem show ?case by force
qed

end

locale semilattice_order_neutr_set = binary?: semilattice_neutr_order + semilattice_neutr_set
begin

lemma bounded_iff:
  assumes "finite A"
  shows "x \<^bold>\<le> F A \<longleftrightarrow> (\<forall>a\<in>A. x \<^bold>\<le> a)"
  using assms by (induct A) simp_all

lemma boundedI:
  assumes "finite A"
  assumes "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  shows "x \<^bold>\<le> F A"
  using assms by (simp add: bounded_iff)

lemma boundedE:
  assumes "finite A" and "x \<^bold>\<le> F A"
  obtains "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  using assms by (simp add: bounded_iff)

lemma coboundedI:
  assumes "finite A"
    and "a \<in> A"
  shows "F A \<^bold>\<le> a"
proof -
  from assms have "A \<noteq> {}" by auto
  from \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>a \<in> A\<close> show ?thesis
  proof (induct rule: finite_ne_induct)
    case singleton thus ?case by (simp add: refl)
  next
    case (insert x B)
    from insert have "a = x \<or> a \<in> B" by simp
    then show ?case using insert by (auto intro: coboundedI2)
  qed
qed

lemma subset_imp:
  assumes "A \<subseteq> B" and "finite B"
  shows "F B \<^bold>\<le> F A"
proof (cases "A = B")
  case True then show ?thesis by (simp add: refl)
next
  case False
  have B: "B = A \<union> (B - A)" using \<open>A \<subseteq> B\<close> by blast
  then have "F B = F (A \<union> (B - A))" by simp
  also have "\<dots> = F A \<^bold>* F (B - A)" using False assms by (subst union) (auto intro: finite_subset)
  also have "\<dots> \<^bold>\<le> F A" by simp
  finally show ?thesis .
qed

end

subsection \<open>Lattice operations on finite sets\<close>

context semilattice_inf
begin

sublocale Inf_fin: semilattice_order_set inf less_eq less
defines
  Inf_fin ("\<Sqinter>\<^sub>f\<^sub>i\<^sub>n _" [900] 900) = Inf_fin.F ..

end

context semilattice_sup
begin

sublocale Sup_fin: semilattice_order_set sup greater_eq greater
defines
  Sup_fin ("\<Squnion>\<^sub>f\<^sub>i\<^sub>n _" [900] 900) = Sup_fin.F ..

end

subsection \<open>Infimum and Supremum over non-empty sets\<close>

context lattice
begin

lemma Inf_fin_le_Sup_fin [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<le> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA"
proof -
  from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by blast
  with \<open>finite A\<close> have "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<le> a" by (rule Inf_fin.coboundedI)
  moreover from \<open>finite A\<close> \<open>a \<in> A\<close> have "a \<le> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA" by (rule Sup_fin.coboundedI)
  ultimately show ?thesis by (rule order_trans)
qed

lemma sup_Inf_absorb [simp]:
  "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> \<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<squnion> a = a"
  by (rule sup_absorb2) (rule Inf_fin.coboundedI)

lemma inf_Sup_absorb [simp]:
  "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> a \<sqinter> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA = a"
  by (rule inf_absorb1) (rule Sup_fin.coboundedI)

end

context distrib_lattice
begin

lemma sup_Inf1_distrib:
  assumes "finite A"
    and "A \<noteq> {}"
  shows "sup x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup x a|a. a \<in> A}"
using assms by (simp add: image_def Inf_fin.hom_commute [where h="sup x", OF sup_inf_distrib1])
  (rule arg_cong [where f="Inf_fin"], blast)

lemma sup_Inf2_distrib:
  assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
  shows "sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB) = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup a b|a b. a \<in> A \<and> b \<in> B}"
using A proof (induct rule: finite_ne_induct)
  case singleton then show ?case
    by (simp add: sup_Inf1_distrib [OF B])
next
  case (insert x A)
  have finB: "finite {sup x b |b. b \<in> B}"
    by (rule finite_surj [where f = "sup x", OF B(1)], auto)
  have finAB: "finite {sup a b |a b. a \<in> A \<and> b \<in> B}"
  proof -
    have "{sup a b |a b. a \<in> A \<and> b \<in> B} = (\<Union>a\<in>A. \<Union>b\<in>B. {sup a b})"
      by blast
    thus ?thesis by(simp add: insert(1) B(1))
  qed
  have ne: "{sup a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
  have "sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n(insert x A)) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB) = sup (inf x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA)) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB)"
    using insert by simp
  also have "\<dots> = inf (sup x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB)) (sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB))" by(rule sup_inf_distrib2)
  also have "\<dots> = inf (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup x b|b. b \<in> B}) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup a b|a b. a \<in> A \<and> b \<in> B})"
    using insert by(simp add:sup_Inf1_distrib[OF B])
  also have "\<dots> = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n({sup x b |b. b \<in> B} \<union> {sup a b |a b. a \<in> A \<and> b \<in> B})"
    (is "_ = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n?M")
    using B insert
    by (simp add: Inf_fin.union [OF finB _ finAB ne])
  also have "?M = {sup a b |a b. a \<in> insert x A \<and> b \<in> B}"
    by blast
  finally show ?case .
qed

lemma inf_Sup1_distrib:
  assumes "finite A" and "A \<noteq> {}"
  shows "inf x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) = \<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf x a|a. a \<in> A}"
using assms by (simp add: image_def Sup_fin.hom_commute [where h="inf x", OF inf_sup_distrib1])
  (rule arg_cong [where f="Sup_fin"], blast)

lemma inf_Sup2_distrib:
  assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
  shows "inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB) = \<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf a b|a b. a \<in> A \<and> b \<in> B}"
using A proof (induct rule: finite_ne_induct)
  case singleton thus ?case
    by(simp add: inf_Sup1_distrib [OF B])
next
  case (insert x A)
  have finB: "finite {inf x b |b. b \<in> B}"
    by(rule finite_surj[where f = "%b. inf x b", OF B(1)], auto)
  have finAB: "finite {inf a b |a b. a \<in> A \<and> b \<in> B}"
  proof -
    have "{inf a b |a b. a \<in> A \<and> b \<in> B} = (\<Union>a\<in>A. \<Union>b\<in>B. {inf a b})"
      by blast
    thus ?thesis by(simp add: insert(1) B(1))
  qed
  have ne: "{inf a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
  have "inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>n(insert x A)) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB) = inf (sup x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA)) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB)"
    using insert by simp
  also have "\<dots> = sup (inf x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB)) (inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB))" by(rule inf_sup_distrib2)
  also have "\<dots> = sup (\<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf x b|b. b \<in> B}) (\<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf a b|a b. a \<in> A \<and> b \<in> B})"
    using insert by(simp add:inf_Sup1_distrib[OF B])
  also have "\<dots> = \<Squnion>\<^sub>f\<^sub>i\<^sub>n({inf x b |b. b \<in> B} \<union> {inf a b |a b. a \<in> A \<and> b \<in> B})"
    (is "_ = \<Squnion>\<^sub>f\<^sub>i\<^sub>n?M")
    using B insert
    by (simp add: Sup_fin.union [OF finB _ finAB ne])
  also have "?M = {inf a b |a b. a \<in> insert x A \<and> b \<in> B}"
    by blast
  finally show ?case .
qed

end

context complete_lattice
begin

lemma Inf_fin_Inf:
  assumes "finite A" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA = \<Sqinter>A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Inf_fin.eq_fold inf_Inf_fold_inf inf.commute [of b])
qed

lemma Sup_fin_Sup:
  assumes "finite A" and "A \<noteq> {}"
  shows "\<Squnion>\<^sub>f\<^sub>i\<^sub>nA = \<Squnion>A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Sup_fin.eq_fold sup_Sup_fold_sup sup.commute [of b])
qed

end

subsection \<open>Minimum and Maximum over non-empty sets\<close>

context linorder
begin

sublocale Min: semilattice_order_set min less_eq less
  + Max: semilattice_order_set max greater_eq greater
defines
  Min = Min.F and Max = Max.F ..

end

syntax
  "_MIN1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3MIN _./ _)" [0, 10] 10)
  "_MIN"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3MIN _\<in>_./ _)" [0, 0, 10] 10)
  "_MAX1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3MAX _./ _)" [0, 10] 10)
  "_MAX"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3MAX _\<in>_./ _)" [0, 0, 10] 10)

translations
  "MIN x y. f"   \<rightleftharpoons> "MIN x. MIN y. f"
  "MIN x. f"     \<rightleftharpoons> "CONST Min (CONST range (\<lambda>x. f))"
  "MIN x\<in>A. f"   \<rightleftharpoons> "CONST Min ((\<lambda>x. f) ` A)"
  "MAX x y. f"   \<rightleftharpoons> "MAX x. MAX y. f"
  "MAX x. f"     \<rightleftharpoons> "CONST Max (CONST range (\<lambda>x. f))"
  "MAX x\<in>A. f"   \<rightleftharpoons> "CONST Max ((\<lambda>x. f) ` A)"

text \<open>An aside: \<^const>\<open>Min\<close>/\<^const>\<open>Max\<close> on linear orders as special case of \<^const>\<open>Inf_fin\<close>/\<^const>\<open>Sup_fin\<close>\<close>

lemma Inf_fin_Min:
  "Inf_fin = (Min :: 'a::{semilattice_inf, linorder} set \<Rightarrow> 'a)"
  by (simp add: Inf_fin_def Min_def inf_min)

lemma Sup_fin_Max:
  "Sup_fin = (Max :: 'a::{semilattice_sup, linorder} set \<Rightarrow> 'a)"
  by (simp add: Sup_fin_def Max_def sup_max)

context linorder
begin

lemma dual_min:
  "ord.min greater_eq = max"
  by (auto simp add: ord.min_def max_def fun_eq_iff)

lemma dual_max:
  "ord.max greater_eq = min"
  by (auto simp add: ord.max_def min_def fun_eq_iff)

lemma dual_Min:
  "linorder.Min greater_eq = Max"
proof -
  interpret dual: linorder greater_eq greater by (fact dual_linorder)
  show ?thesis by (simp add: dual.Min_def dual_min Max_def)
qed

lemma dual_Max:
  "linorder.Max greater_eq = Min"
proof -
  interpret dual: linorder greater_eq greater by (fact dual_linorder)
  show ?thesis by (simp add: dual.Max_def dual_max Min_def)
qed

lemmas Min_singleton = Min.singleton
lemmas Max_singleton = Max.singleton
lemmas Min_insert = Min.insert
lemmas Max_insert = Max.insert
lemmas Min_Un = Min.union
lemmas Max_Un = Max.union
lemmas hom_Min_commute = Min.hom_commute
lemmas hom_Max_commute = Max.hom_commute

lemma Min_in [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "Min A \<in> A"
  using assms by (auto simp add: min_def Min.closed)

lemma Max_in [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "Max A \<in> A"
  using assms by (auto simp add: max_def Max.closed)

lemma Min_insert2:
  assumes "finite A" and min: "\<And>b. b \<in> A \<Longrightarrow> a \<le> b"
  shows "Min (insert a A) = a"
proof (cases "A = {}")
  case True
  then show ?thesis by simp
next
  case False
  with \<open>finite A\<close> have "Min (insert a A) = min a (Min A)"
    by simp
  moreover from \<open>finite A\<close> \<open>A \<noteq> {}\<close> min have "a \<le> Min A" by simp
  ultimately show ?thesis by (simp add: min.absorb1)
qed

lemma Max_insert2:
  assumes "finite A" and max: "\<And>b. b \<in> A \<Longrightarrow> b \<le> a"
  shows "Max (insert a A) = a"
proof (cases "A = {}")
  case True
  then show ?thesis by simp
next
  case False
  with \<open>finite A\<close> have "Max (insert a A) = max a (Max A)"
    by simp
  moreover from \<open>finite A\<close> \<open>A \<noteq> {}\<close> max have "Max A \<le> a" by simp
  ultimately show ?thesis by (simp add: max.absorb1)
qed

lemma Max_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max ((\<lambda>_. c) ` A) = c"
using Max_in image_is_empty by blast

lemma Min_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Min ((\<lambda>_. c) ` A) = c"
using Min_in image_is_empty by blast

lemma Min_le [simp]:
  assumes "finite A" and "x \<in> A"
  shows "Min A \<le> x"
  using assms by (fact Min.coboundedI)

lemma Max_ge [simp]:
  assumes "finite A" and "x \<in> A"
  shows "x \<le> Max A"
  using assms by (fact Max.coboundedI)

lemma Min_eqI:
  assumes "finite A"
  assumes "\<And>y. y \<in> A \<Longrightarrow> y \<ge> x"
    and "x \<in> A"
  shows "Min A = x"
proof (rule order.antisym)
  from \<open>x \<in> A\<close> have "A \<noteq> {}" by auto
  with assms show "Min A \<ge> x" by simp
next
  from assms show "x \<ge> Min A" by simp
qed

lemma Max_eqI:
  assumes "finite A"
  assumes "\<And>y. y \<in> A \<Longrightarrow> y \<le> x"
    and "x \<in> A"
  shows "Max A = x"
proof (rule order.antisym)
  from \<open>x \<in> A\<close> have "A \<noteq> {}" by auto
  with assms show "Max A \<le> x" by simp
next
  from assms show "x \<le> Max A" by simp
qed

lemma eq_Min_iff:
  "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> m = Min A  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. m \<le> a)"
by (meson Min_in Min_le order.antisym)

lemma Min_eq_iff:
  "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Min A = m  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. m \<le> a)"
by (meson Min_in Min_le order.antisym)

lemma eq_Max_iff:
  "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> m = Max A  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. a \<le> m)"
by (meson Max_in Max_ge order.antisym)

lemma Max_eq_iff:
  "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max A = m  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. a \<le> m)"
by (meson Max_in Max_ge order.antisym)

context
  fixes A :: "'a set"
  assumes fin_nonempty: "finite A" "A \<noteq> {}"
begin

lemma Min_ge_iff [simp]:
  "x \<le> Min A \<longleftrightarrow> (\<forall>a\<in>A. x \<le> a)"
  using fin_nonempty by (fact Min.bounded_iff)

lemma Max_le_iff [simp]:
  "Max A \<le> x \<longleftrightarrow> (\<forall>a\<in>A. a \<le> x)"
  using fin_nonempty by (fact Max.bounded_iff)

lemma Min_gr_iff [simp]:
  "x < Min A \<longleftrightarrow> (\<forall>a\<in>A. x < a)"
  using fin_nonempty  by (induct rule: finite_ne_induct) simp_all

lemma Max_less_iff [simp]:
  "Max A < x \<longleftrightarrow> (\<forall>a\<in>A. a < x)"
  using fin_nonempty by (induct rule: finite_ne_induct) simp_all

lemma Min_le_iff:
  "Min A \<le> x \<longleftrightarrow> (\<exists>a\<in>A. a \<le> x)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_le_iff_disj)

lemma Max_ge_iff:
  "x \<le> Max A \<longleftrightarrow> (\<exists>a\<in>A. x \<le> a)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: le_max_iff_disj)

lemma Min_less_iff:
  "Min A < x \<longleftrightarrow> (\<exists>a\<in>A. a < x)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_less_iff_disj)

lemma Max_gr_iff:
  "x < Max A \<longleftrightarrow> (\<exists>a\<in>A. x < a)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: less_max_iff_disj)

end

lemma Max_eq_if:
  assumes "finite A"  "finite B"  "\<forall>a\<in>A. \<exists>b\<in>B. a \<le> b"  "\<forall>b\<in>B. \<exists>a\<in>A. b \<le> a"
  shows "Max A = Max B"
proof cases
  assume "A = {}" thus ?thesis using assms by simp
next
  assume "A \<noteq> {}" thus ?thesis using assms
    by(blast intro: order.antisym Max_in Max_ge_iff[THEN iffD2])
qed

lemma Min_antimono:
  assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
  shows "Min N \<le> Min M"
  using assms by (fact Min.subset_imp)

lemma Max_mono:
  assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
  shows "Max M \<le> Max N"
  using assms by (fact Max.subset_imp)

lemma mono_Min_commute:
  assumes "mono f"
  assumes "finite A" and "A \<noteq> {}"
  shows "f (Min A) = Min (f ` A)"
proof (rule linorder_class.Min_eqI [symmetric])
  from \<open>finite A\<close> show "finite (f ` A)" by simp
  from assms show "f (Min A) \<in> f ` A" by simp
  fix x
  assume "x \<in> f ` A"
  then obtain y where "y \<in> A" and "x = f y" ..
  with assms have "Min A \<le> y" by auto
  with \<open>mono f\<close> have "f (Min A) \<le> f y" by (rule monoE)
  with \<open>x = f y\<close> show "f (Min A) \<le> x" by simp
qed

lemma mono_Max_commute:
  assumes "mono f"
  assumes "finite A" and "A \<noteq> {}"
  shows "f (Max A) = Max (f ` A)"
proof (rule linorder_class.Max_eqI [symmetric])
  from \<open>finite A\<close> show "finite (f ` A)" by simp
  from assms show "f (Max A) \<in> f ` A" by simp
  fix x
  assume "x \<in> f ` A"
  then obtain y where "y \<in> A" and "x = f y" ..
  with assms have "y \<le> Max A" by auto
  with \<open>mono f\<close> have "f y \<le> f (Max A)" by (rule monoE)
  with \<open>x = f y\<close> show "x \<le> f (Max A)" by simp
qed

lemma finite_linorder_max_induct [consumes 1, case_names empty insert]:
  assumes fin: "finite A"
  and empty: "P {}"
  and insert: "\<And>b A. finite A \<Longrightarrow> \<forall>a\<in>A. a < b \<Longrightarrow> P A \<Longrightarrow> P (insert b A)"
  shows "P A"
using fin empty insert
proof (induct rule: finite_psubset_induct)
  case (psubset A)
  have IH: "\<And>B. \<lbrakk>B < A; P {}; (\<And>A b. \<lbrakk>finite A; \<forall>a\<in>A. a<b; P A\<rbrakk> \<Longrightarrow> P (insert b A))\<rbrakk> \<Longrightarrow> P B" by fact
  have fin: "finite A" by fact
  have empty: "P {}" by fact
  have step: "\<And>b A. \<lbrakk>finite A; \<forall>a\<in>A. a < b; P A\<rbrakk> \<Longrightarrow> P (insert b A)" by fact
  show "P A"
  proof (cases "A = {}")
    assume "A = {}"
    then show "P A" using \<open>P {}\<close> by simp
  next
    let ?B = "A - {Max A}"
    let ?A = "insert (Max A) ?B"
    have "finite ?B" using \<open>finite A\<close> by simp
    assume "A \<noteq> {}"
    with \<open>finite A\<close> have "Max A \<in> A" by auto
    then have A: "?A = A" using insert_Diff_single insert_absorb by auto
    then have "P ?B" using \<open>P {}\<close> step IH [of ?B] by blast
    moreover
    have "\<forall>a\<in>?B. a < Max A" using Max_ge [OF \<open>finite A\<close>] by fastforce
    ultimately show "P A" using A insert_Diff_single step [OF \<open>finite ?B\<close>] by fastforce
  qed
qed

lemma finite_linorder_min_induct [consumes 1, case_names empty insert]:
  "\<lbrakk>finite A; P {}; \<And>b A. \<lbrakk>finite A; \<forall>a\<in>A. b < a; P A\<rbrakk> \<Longrightarrow> P (insert b A)\<rbrakk> \<Longrightarrow> P A"
  by (rule linorder.finite_linorder_max_induct [OF dual_linorder])

lemma finite_ranking_induct[consumes 1, case_names empty insert]:
  fixes f :: "'b \<Rightarrow> 'a"
  assumes "finite S"
  assumes "P {}"
  assumes "\<And>x S. finite S \<Longrightarrow> (\<And>y. y \<in> S \<Longrightarrow> f y \<le> f x) \<Longrightarrow> P S \<Longrightarrow> P (insert x S)"
  shows "P S"
  using \<open>finite S\<close>
proof (induction rule: finite_psubset_induct)
  case (psubset A)
  {
    assume "A \<noteq> {}"
    hence "f ` A \<noteq> {}" and "finite (f ` A)"
      using psubset finite_image_iff by simp+
    then obtain a where "f a = Max (f ` A)" and "a \<in> A"
      by (metis Max_in[of "f ` A"] imageE)
    then have "P (A - {a})"
      using psubset member_remove by blast
    moreover
    have "\<And>y. y \<in> A \<Longrightarrow> f y \<le> f a"
      using \<open>f a = Max (f ` A)\<close> \<open>finite (f ` A)\<close> by simp
    ultimately
    have ?case
      by (metis \<open>a \<in> A\<close> DiffD1 insert_Diff assms(3) finite_Diff psubset.hyps)
  }
  thus ?case
    using assms(2) by blast
qed

lemma Least_Min:
  assumes "finite {a. P a}" and "\<exists>a. P a"
  shows "(LEAST a. P a) = Min {a. P a}"
proof -
  { fix A :: "'a set"
    assume A: "finite A" "A \<noteq> {}"
    have "(LEAST a. a \<in> A) = Min A"
    using A proof (induct A rule: finite_ne_induct)
      case singleton show ?case by (rule Least_equality) simp_all
    next
      case (insert a A)
      have "(LEAST b. b = a \<or> b \<in> A) = min a (LEAST a. a \<in> A)"
        by (auto intro!: Least_equality simp add: min_def not_le Min_le_iff insert.hyps dest!: less_imp_le)
      with insert show ?case by simp
    qed
  } from this [of "{a. P a}"] assms show ?thesis by simp
qed

lemma infinite_growing:
  assumes "X \<noteq> {}"
  assumes *: "\<And>x. x \<in> X \<Longrightarrow> \<exists>y\<in>X. y > x"
  shows "\<not> finite X"
proof
  assume "finite X"
  with \<open>X \<noteq> {}\<close> have "Max X \<in> X" "\<forall>x\<in>X. x \<le> Max X"
    by auto
  with *[of "Max X"] show False
    by auto
qed

end

lemma sum_le_card_Max: "finite A \<Longrightarrow> sum f A \<le> card A * Max (f ` A)"
using sum_bounded_above[of A f "Max (f ` A)"] by simp

lemma card_Min_le_sum: "finite A \<Longrightarrow> card A * Min (f ` A) \<le> sum f A"
using sum_bounded_below[of A "Min (f ` A)" f] by simp

context linordered_ab_semigroup_add
begin

lemma Min_add_commute:
  fixes k
  assumes "finite S" and "S \<noteq> {}"
  shows "Min ((\<lambda>x. f x + k) ` S) = Min(f ` S) + k"
proof -
  have m: "\<And>x y. min x y + k = min (x+k) (y+k)"
    by (simp add: min_def order.antisym add_right_mono)
  have "(\<lambda>x. f x + k) ` S = (\<lambda>y. y + k) ` (f ` S)" by auto
  also have "Min \<dots> = Min (f ` S) + k"
    using assms hom_Min_commute [of "\<lambda>y. y+k" "f ` S", OF m, symmetric] by simp
  finally show ?thesis by simp
qed

lemma Max_add_commute:
  fixes k
  assumes "finite S" and "S \<noteq> {}"
  shows "Max ((\<lambda>x. f x + k) ` S) = Max(f ` S) + k"
proof -
  have m: "\<And>x y. max x y + k = max (x+k) (y+k)"
    by (simp add: max_def order.antisym add_right_mono)
  have "(\<lambda>x. f x + k) ` S = (\<lambda>y. y + k) ` (f ` S)" by auto
  also have "Max \<dots> = Max (f ` S) + k"
    using assms hom_Max_commute [of "\<lambda>y. y+k" "f ` S", OF m, symmetric] by simp
  finally show ?thesis by simp
qed

end

context linordered_ab_group_add
begin

lemma minus_Max_eq_Min [simp]:
  "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - Max S = Min (uminus ` S)"
  by (induct S rule: finite_ne_induct) (simp_all add: minus_max_eq_min)

lemma minus_Min_eq_Max [simp]:
  "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - Min S = Max (uminus ` S)"
  by (induct S rule: finite_ne_induct) (simp_all add: minus_min_eq_max)

end

context complete_linorder
begin

lemma Min_Inf:
  assumes "finite A" and "A \<noteq> {}"
  shows "Min A = Inf A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Min.eq_fold complete_linorder_inf_min [symmetric] inf_Inf_fold_inf inf.commute [of b])
qed

lemma Max_Sup:
  assumes "finite A" and "A \<noteq> {}"
  shows "Max A = Sup A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Max.eq_fold complete_linorder_sup_max [symmetric] sup_Sup_fold_sup sup.commute [of b])
qed

end

lemma disjnt_ge_max: \<^marker>\<open>contributor \<open>Lars Hupel\<close>\<close>
  \<open>disjnt X Y\<close> if \<open>finite Y\<close> \<open>\<And>x. x \<in> X \<Longrightarrow> x > Max Y\<close>
  using that by (auto simp add: disjnt_def) (use Max_less_iff in blast)

subsection \<open>Arg Min\<close>

context ord
begin

definition is_arg_min :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
"is_arg_min f P x = (P x \<and> \<not>(\<exists>y. P y \<and> f y < f x))"

definition arg_min :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b" where
"arg_min f P = (SOME x. is_arg_min f P x)"

definition arg_min_on :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'b" where
"arg_min_on f S = arg_min f (\<lambda>x. x \<in> S)"

end

syntax
  "_arg_min" :: "('b \<Rightarrow> 'a) \<Rightarrow> pttrn \<Rightarrow> bool \<Rightarrow> 'b"
    ("(3ARG'_MIN _ _./ _)" [1000, 0, 10] 10)
translations
  "ARG_MIN f x. P" \<rightleftharpoons> "CONST arg_min f (\<lambda>x. P)"

lemma is_arg_min_linorder: fixes f :: "'a \<Rightarrow> 'b :: linorder"
shows "is_arg_min f P x = (P x \<and> (\<forall>y. P y \<longrightarrow> f x \<le> f y))"
by(auto simp add: is_arg_min_def)

lemma is_arg_min_antimono: fixes f :: "'a \<Rightarrow> ('b::order)"
shows "\<lbrakk> is_arg_min f P x; f y \<le> f x; P y \<rbrakk> \<Longrightarrow> is_arg_min f P y"
by (simp add: order.order_iff_strict is_arg_min_def)

lemma arg_minI:
  "\<lbrakk> P x;
    \<And>y. P y \<Longrightarrow> \<not> f y < f x;
    \<And>x. \<lbrakk> P x; \<forall>y. P y \<longrightarrow> \<not> f y < f x \<rbrakk> \<Longrightarrow> Q x \<rbrakk>
  \<Longrightarrow> Q (arg_min f P)"
apply (simp add: arg_min_def is_arg_min_def)
apply (rule someI2_ex)
 apply blast
apply blast
done

lemma arg_min_equality:
  "\<lbrakk> P k; \<And>x. P x \<Longrightarrow> f k \<le> f x \<rbrakk> \<Longrightarrow> f (arg_min f P) = f k"
  for f :: "_ \<Rightarrow> 'a::order"
apply (rule arg_minI)
  apply assumption
 apply (simp add: less_le_not_le)
by (metis le_less)

lemma wf_linord_ex_has_least:
  "\<lbrakk> wf r; \<forall>x y. (x, y) \<in> r\<^sup>+ \<longleftrightarrow> (y, x) \<notin> r\<^sup>*; P k \<rbrakk>
   \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> (m x, m y) \<in> r\<^sup>*)"
apply (drule wf_trancl [THEN wf_eq_minimal [THEN iffD1]])
apply (drule_tac x = "m ` Collect P" in spec)
by force

lemma ex_has_least_nat: "P k \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> m x \<le> m y)"
  for m :: "'a \<Rightarrow> nat"
apply (simp only: pred_nat_trancl_eq_le [symmetric])
apply (rule wf_pred_nat [THEN wf_linord_ex_has_least])
 apply (simp add: less_eq linorder_not_le pred_nat_trancl_eq_le)
by assumption

lemma arg_min_nat_lemma:
  "P k \<Longrightarrow> P(arg_min m P) \<and> (\<forall>y. P y \<longrightarrow> m (arg_min m P) \<le> m y)"
  for m :: "'a \<Rightarrow> nat"
apply (simp add: arg_min_def is_arg_min_linorder)
apply (rule someI_ex)
apply (erule ex_has_least_nat)
done

lemmas arg_min_natI = arg_min_nat_lemma [THEN conjunct1]

lemma is_arg_min_arg_min_nat: fixes m :: "'a \<Rightarrow> nat"
shows "P x \<Longrightarrow> is_arg_min m P (arg_min m P)"
by (metis arg_min_nat_lemma is_arg_min_linorder)

lemma arg_min_nat_le: "P x \<Longrightarrow> m (arg_min m P) \<le> m x"
  for m :: "'a \<Rightarrow> nat"
by (rule arg_min_nat_lemma [THEN conjunct2, THEN spec, THEN mp])

lemma ex_min_if_finite:
  "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>m\<in>S. \<not>(\<exists>x\<in>S. x < (m::'a::order))"
by(induction rule: finite.induct) (auto intro: order.strict_trans)

lemma ex_is_arg_min_if_finite: fixes f :: "'a \<Rightarrow> 'b :: order"
shows "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>x. is_arg_min f (\<lambda>x. x \<in> S) x"
unfolding is_arg_min_def
using ex_min_if_finite[of "f ` S"]
by auto

lemma arg_min_SOME_Min:
  "finite S \<Longrightarrow> arg_min_on f S = (SOME y. y \<in> S \<and> f y = Min(f ` S))"
unfolding arg_min_on_def arg_min_def is_arg_min_linorder
apply(rule arg_cong[where f = Eps])
apply (auto simp: fun_eq_iff intro: Min_eqI[symmetric])
done

lemma arg_min_if_finite: fixes f :: "'a \<Rightarrow> 'b :: order"
assumes "finite S" "S \<noteq> {}"
shows  "arg_min_on f S \<in> S" and "\<not>(\<exists>x\<in>S. f x < f (arg_min_on f S))"
using ex_is_arg_min_if_finite[OF assms, of f]
unfolding arg_min_on_def arg_min_def is_arg_min_def
by(auto dest!: someI_ex)

lemma arg_min_least: fixes f :: "'a \<Rightarrow> 'b :: linorder"
shows "\<lbrakk> finite S;  S \<noteq> {};  y \<in> S \<rbrakk> \<Longrightarrow> f(arg_min_on f S) \<le> f y"
by(simp add: arg_min_SOME_Min inv_into_def2[symmetric] f_inv_into_f)

lemma arg_min_inj_eq: fixes f :: "'a \<Rightarrow> 'b :: order"
shows "\<lbrakk> inj_on f {x. P x}; P a; \<forall>y. P y \<longrightarrow> f a \<le> f y \<rbrakk> \<Longrightarrow> arg_min f P = a"
apply(simp add: arg_min_def is_arg_min_def)
apply(rule someI2[of _ a])
 apply (simp add: less_le_not_le)
by (metis inj_on_eq_iff less_le mem_Collect_eq)

subsection \<open>Arg Max\<close>

context ord
begin

definition is_arg_max :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
"is_arg_max f P x = (P x \<and> \<not>(\<exists>y. P y \<and> f y > f x))"

definition arg_max :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b" where
"arg_max f P = (SOME x. is_arg_max f P x)"

definition arg_max_on :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'b" where
"arg_max_on f S = arg_max f (\<lambda>x. x \<in> S)"

end

syntax
  "_arg_max" :: "('b \<Rightarrow> 'a) \<Rightarrow> pttrn \<Rightarrow> bool \<Rightarrow> 'a"
    ("(3ARG'_MAX _ _./ _)" [1000, 0, 10] 10)
translations
  "ARG_MAX f x. P" \<rightleftharpoons> "CONST arg_max f (\<lambda>x. P)"

lemma is_arg_max_linorder: fixes f :: "'a \<Rightarrow> 'b :: linorder"
shows "is_arg_max f P x = (P x \<and> (\<forall>y. P y \<longrightarrow> f x \<ge> f y))"
by(auto simp add: is_arg_max_def)

lemma arg_maxI:
  "P x \<Longrightarrow>
    (\<And>y. P y \<Longrightarrow> \<not> f y > f x) \<Longrightarrow>
    (\<And>x. P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> \<not> f y > f x \<Longrightarrow> Q x) \<Longrightarrow>
    Q (arg_max f P)"
apply (simp add: arg_max_def is_arg_max_def)
apply (rule someI2_ex)
 apply blast
apply blast
done

lemma arg_max_equality:
  "\<lbrakk> P k; \<And>x. P x \<Longrightarrow> f x \<le> f k \<rbrakk> \<Longrightarrow> f (arg_max f P) = f k"
  for f :: "_ \<Rightarrow> 'a::order"
apply (rule arg_maxI [where f = f])
  apply assumption
 apply (simp add: less_le_not_le)
by (metis le_less)

lemma ex_has_greatest_nat_lemma:
  "P k \<Longrightarrow> \<forall>x. P x \<longrightarrow> (\<exists>y. P y \<and> \<not> f y \<le> f x) \<Longrightarrow> \<exists>y. P y \<and> \<not> f y < f k + n"
  for f :: "'a \<Rightarrow> nat"
  by (induct n) (force simp: le_Suc_eq)+

lemma ex_has_greatest_nat:
  assumes "P k"
    and "\<forall>y. P y \<longrightarrow> (f:: 'a \<Rightarrow> nat) y < b"
shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f x)"
proof (rule ccontr)
  assume "\<nexists>x. P x \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f x)"
  then have "\<forall>x. P x \<longrightarrow> (\<exists>y. P y \<and> \<not> f y \<le> f x)"
    by auto
  then have "\<exists>y. P y \<and> \<not> f y < f k + (b - f k)"
    using assms ex_has_greatest_nat_lemma[of P k f "b - f k"]
    by blast
  then show "False"
    using assms by auto
qed

lemma arg_max_nat_lemma:
  "\<lbrakk> P k;  \<forall>y. P y \<longrightarrow> f y < b \<rbrakk>
  \<Longrightarrow> P (arg_max f P) \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f (arg_max f P))"
  for f :: "'a \<Rightarrow> nat"
apply (simp add: arg_max_def is_arg_max_linorder)
apply (rule someI_ex)
apply (erule (1) ex_has_greatest_nat)
done

lemmas arg_max_natI = arg_max_nat_lemma [THEN conjunct1]

lemma arg_max_nat_le: "P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> f y < b \<Longrightarrow> f x \<le> f (arg_max f P)"
  for f :: "'a \<Rightarrow> nat"
by (blast dest: arg_max_nat_lemma [THEN conjunct2, THEN spec, of P])

end


subsection\<open>Craig Interpolation using Semantics\<close>

theory Sema_Craig
imports Substitution_Sema
begin

text\<open>Semantic proof of Craig interpolation following Harrison~\cite{harrison2009handbook}.\<close>

(* we don't really need this lemma, sledgehammer would find a proof anyway. But it would be massively ugly. *)
lemma subst_true_false:
  assumes "\<A> \<Turnstile> F"
  shows "\<A> \<Turnstile> ((F[\<top> / n]) \<^bold>\<or> (F[\<bottom> / n]))"
using assms by(cases "\<A> n"; simp add: substitution_lemma fun_upd_idem)

theorem interpolation:
  assumes "\<Turnstile> \<Gamma> \<^bold>\<rightarrow> \<Delta>"
  obtains \<rho> where
    "\<Turnstile> \<Gamma> \<^bold>\<rightarrow> \<rho>" "\<Turnstile> \<rho> \<^bold>\<rightarrow> \<Delta>"
    "atoms \<rho> \<subseteq> atoms \<Gamma>"
    "atoms \<rho> \<subseteq> atoms \<Delta>"
proof(goal_cases)
  let ?as = "atoms \<Gamma> - atoms \<Delta>"
  have fas: "finite ?as" by simp
  from fas assms have "\<exists>\<rho>. ((\<Turnstile> \<Gamma> \<^bold>\<rightarrow> \<rho>) \<and> (\<Turnstile> \<rho> \<^bold>\<rightarrow> \<Delta>) \<and> (atoms \<rho> \<subseteq> atoms \<Gamma>) \<and> (atoms \<rho> \<subseteq> atoms \<Delta>))"
  proof(induction ?as arbitrary: \<Gamma> rule: finite_induct)
    case empty
    from \<open>{} = atoms \<Gamma> - atoms \<Delta>\<close> have "atoms \<Gamma> \<subseteq> atoms \<Delta>" by blast
    with \<open>\<Turnstile> \<Gamma> \<^bold>\<rightarrow> \<Delta>\<close> show ?case by(intro exI[where x=\<Gamma>]) simp
  next
    case (insert a A)
    hence e: "a \<in> atoms \<Gamma>" "a \<notin> atoms \<Delta>" by auto
    define \<Gamma>' where "\<Gamma>' = (\<Gamma>[\<top> / a]) \<^bold>\<or> (\<Gamma>[\<bottom> / a])"
    have su: "atoms \<Gamma>' \<subseteq> atoms \<Gamma>" unfolding \<Gamma>'_def by(cases "a \<in> atoms \<Gamma>"; simp add: subst_atoms)
    from \<open>\<Turnstile> \<Gamma> \<^bold>\<rightarrow> \<Delta>\<close> e have "\<Turnstile> \<Gamma>' \<^bold>\<rightarrow> \<Delta>" by (auto simp add: substitution_lemma \<Gamma>'_def)
    from \<open>a \<triangleright> A = atoms \<Gamma> - atoms \<Delta>\<close> \<open>a \<notin> A\<close> e have "A = atoms \<Gamma>' - atoms \<Delta>" by(simp add: subst_atoms \<Gamma>'_def) blast
    from insert.hyps(3)[OF this \<open>\<Turnstile> \<Gamma>' \<^bold>\<rightarrow> \<Delta>\<close>] obtain \<rho> where \<rho>: "\<Turnstile> \<Gamma>' \<^bold>\<rightarrow> \<rho>" "\<Turnstile> \<rho> \<^bold>\<rightarrow> \<Delta>" "atoms \<rho> \<subseteq> atoms \<Gamma>'" "atoms \<rho> \<subseteq> atoms \<Delta>" by clarify
    have "\<Turnstile> \<Gamma> \<^bold>\<rightarrow> \<rho>" using \<rho>(1) subst_true_false unfolding \<Gamma>'_def by fastforce
    with \<rho> su show ?case by(intro exI[where x=\<rho>]) simp
  qed
  moreover case 1
  ultimately show thesis by blast
qed

text\<open>The above proof is constructive, and it is actually very easy to write a procedure down.\<close>
function interpolate where
"interpolate F H = (
let K = atoms F - atoms H in
  if K = {}
  then F
  else (
    let k = Min K
    in interpolate ((F[\<top> / k]) \<^bold>\<or> (F[\<bottom> / k])) H
  )
)" by pat_completeness simp
(* I tried Inf instead of Min first. Only has downsides. *)

text\<open>Showing termination is slightly technical\dots\<close>
termination interpolate
  apply(relation "measure (\<lambda>(F,H). card (atoms F - atoms H))")
              (* "measure (\<lambda>(F,H). card (atoms F))" also works, but doesn't make things more beautiful *)
   subgoal by simp
  apply (simp add: subst_atoms_simp)
  apply(intro conjI impI)
   apply(intro psubset_card_mono)
    subgoal by simp
   apply(subgoal_tac "Min (atoms F - atoms H) \<notin> atoms H")
    subgoal by blast
   apply (meson atoms_finite Diff_eq_empty_iff Diff_iff Min_in finite_Diff)+
done

text\<open>Surprisingly, @{const interpolate} is even executable,
  despite all the set operations involving @{const atoms}\<close>
lemma "interpolate (And (Atom (0::nat)) (Atom 1)) (Or (Atom 1) (Atom 2)) =
  (\<top> \<^bold>\<and> Atom 1) \<^bold>\<or> (\<bottom> \<^bold>\<and> Atom 1)" by simp
value[code] "simplify_consts (interpolate (And (Atom (0::nat)) (Atom 1)) (Or (Atom 1) (Atom 2)))"
(* and the wikipedia example: *)

theorem nonexistential_interpolation:
  assumes "\<Turnstile> F \<^bold>\<rightarrow> H"
  shows
    "\<Turnstile> F \<^bold>\<rightarrow> interpolate F H" (is "?t1") "\<Turnstile> interpolate F H \<^bold>\<rightarrow> H" (is "?t2")
    "atoms (interpolate F H) \<subseteq> atoms F \<inter> atoms H" (is "?s")
proof -
  let ?as = "atoms F - atoms H"
  have fas: "finite ?as" by simp
  hence "?t1 \<and> ?t2 \<and> ?s" using assms
  proof(induction "card ?as" arbitrary: F H)
    case (Suc n)
    let ?inf = "Min (atoms F - atoms H)"
    define G where "G = (F[\<top> / ?inf]) \<^bold>\<or> (F[\<bottom> / ?inf])"
    have e: "Min (atoms F - atoms H) \<in> atoms F - atoms H" by (metis Min_in Suc.hyps(2) Suc.prems(1) card_empty nat.simps(3))
    with Suc(2) have "n = card (atoms G - atoms H)" unfolding G_def subst_atoms_simp
    proof -
      assume a1: "Suc n = card (atoms F - atoms H)"
      assume "Min (atoms F - atoms H) \<in> atoms F - atoms H"
      hence a2: "Min (atoms F - atoms H) \<in> atoms F \<and> Min (atoms F - atoms H) \<notin> atoms H" by simp
      have "n = card (atoms F - atoms H) - 1"
        using a1 by presburger
      hence "n = card (atoms (F[\<top> / Min (atoms F - atoms H)]) \<union> atoms (F[\<bottom> / Min (atoms F - atoms H)]) - atoms H)"
        using a2 by (metis (full_types) formula.set(2) Diff_insert Diff_insert2 Suc.prems(1) Un_absorb Un_empty_right card_Diff_singleton e subst_atoms top_atoms_simp)
        (* you need to tell sledgehammer about formula.set if you want it to find a proof here\<dots> *)
      thus "n = card (atoms ((F[\<top> / Min (atoms F - atoms H)]) \<^bold>\<or> (F[\<bottom> / Min (atoms F - atoms H)])) - atoms H)" by simp
    qed
    moreover have "finite (atoms G - atoms H)" "\<Turnstile> G \<^bold>\<rightarrow> H" using Suc(3-) e
      by(auto simp: G_def substitution_lemma)
    ultimately have IH: "\<Turnstile> G \<^bold>\<rightarrow> interpolate G H" "\<Turnstile> interpolate G H \<^bold>\<rightarrow> H"
        "atoms (interpolate G H) \<subseteq> atoms G \<inter> atoms H" using Suc by blast+
    moreover have "\<Turnstile> F \<^bold>\<rightarrow> G" unfolding G_def
      using subst_true_false by fastforce
    moreover { (* sledgehammer\<dots> *)
        assume a1: "atoms (interpolate ((F[\<top>/Min (atoms F - atoms H)]) \<^bold>\<or> (F[\<bottom>/Min (atoms F - atoms H)])) H) \<subseteq> atoms (F[\<top>/Min (atoms F - atoms H)]) \<union> atoms (F[\<bottom>/Min (atoms F - atoms H)]) \<and> atoms (interpolate ((F[\<top>/Min (atoms F - atoms H)]) \<^bold>\<or> (F[\<bottom>/Min (atoms F - atoms H)])) H) \<subseteq> atoms H"
        have f2: "atoms ((\<bottom>::'a formula) \<^bold>\<rightarrow> \<bottom>) = atoms \<bottom>"
          by simp
        then have f3: "atoms F - {Min (atoms F - atoms H)} = atoms (F[\<top>/Min (atoms F - atoms H)])"
          by (metis (no_types) DiffD1 Top_def Un_empty_right e formula.simps(91) subst_atoms)
        have "atoms (F[\<bottom>/Min (atoms F - atoms H)]) = atoms (F[\<top>/Min (atoms F - atoms H)])"
          using f2 by (metis (no_types) DiffD1 Top_def e subst_atoms)
        then have "\<not> atoms F \<subseteq> atoms H \<longrightarrow> atoms (interpolate ((F[\<top>/Min (atoms F - atoms H)]) \<^bold>\<or> (F[\<bottom>/Min (atoms F - atoms H)])) H) \<subseteq> atoms F"
          using f3 a1 by blast
    } ultimately show ?case
      by (intro conjI; subst interpolate.simps; simp del: interpolate.simps add: Let_def G_def; blast?)
  qed auto
  thus "?t1" "?t2" "?s" by simp_all
qed
text\<open>So no, the proof is by no means easier this way.
  Admittedly, part of the fuzz is due to @{const Min},
  but replacing atoms with something that returns lists doesn't make it better.\<close>

end


theory deMorgan1
  imports Main

begin

lemma de_morgan_1 : "\<not>(p\<or>q) \<longrightarrow> (\<not>p\<and>\<not>q)"
  apply (rule impI)
  apply (rule conjI)
   apply (rule notI)
   apply (erule notE)
    apply (rule disjI1)
    apply assumption
  apply (rule notI)
   apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

end