theory Positions3
  imports Lexer3 LexicalVals3
begin

section \<open>An alternative definition for POSIX values by Okui \& Suzuki\<close>

section \<open>Positions in Values\<close>

fun
  at :: "'a val \<Rightarrow> nat list \<Rightarrow> 'a 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"
| "at (Recv l v) ps = at v ps"

fun Pos :: "'a val \<Rightarrow> (nat list) set"
where
  "Pos (Void) = {[]}"
| "Pos (Atm 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)}"
| "Pos (Recv l v) = {[]} \<union> {ps . ps \<in> Pos v}"

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 :: "'a 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 (Recv l v) p = pflat_len v p"
  and   "pflat_len v [] = intlen (flat v)"
  apply (auto simp add: pflat_len_def Pos_empty)
  by (metis at.simps(7) neq_Nil_conv)

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 \<open>Orderings\<close>

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 \<open>POSIX Ordering of Values According to Okui \& Suzuki\<close>

definition PosOrd:: "'a val \<Rightarrow> nat list \<Rightarrow> 'a 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:: "'a val \<Rightarrow> 'a 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:: "'a val \<Rightarrow> 'a 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

(*
  :\<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_trans partial_preordering_def apply blast
using PosOrd_assym ordering_axioms_def 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)
  by (smt (verit) PosOrd_ex_eq_def PosOrd_irrefl PosOrd_trans)

lemma PosOrd_ex_eq2:
  shows "v1 :\<sqsubset>val v2 \<longleftrightarrow> (v1 :\<sqsubseteq>val v2 \<and> v1 \<noteq> v2)"
  using PosOrd_ordering
  using PosOrd_ex_eq_def PosOrd_irrefl by blast

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 (metis partial_preordering.trans)

lemma PosOrdeq_antisym:
  assumes "v1 :\<sqsubseteq>val v2" "v2 :\<sqsubseteq>val v1"
  shows "v1 = v2"
using assms PosOrd_ordering
  by (metis ordering.eq_iff)

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_Rec_eq:
  assumes "flat v1 = flat v2"
  shows "Recv l v1 :\<sqsubset>val Recv l v2 \<longleftrightarrow> v1 :\<sqsubset>val v2"
unfolding PosOrd_ex_def PosOrd_def2
  using assms
  apply(auto)
  apply (simp add: pflat_len_simps(10))
  apply (metis pflat_len_simps(9))
  by (metis pflat_len_simps(10) pflat_len_simps(9))

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_Stars_equalsI:
  assumes "flats vs1 = flats vs2" "length vs1 = length vs2"
  and     "list_all2 (\<lambda>v1 v2. v1 :\<sqsubseteq>val v2) vs1 vs2"
  shows "Stars vs1 :\<sqsubseteq>val Stars vs2"
  using assms(3) assms(2,1)
  apply(induct rule: list_all2_induct)
  apply (simp add: PosOrdeq_refl)
  apply(case_tac "Stars (x # xs) = Stars (y # ys)")
  apply (simp add: PosOrdeq_refl)
  apply(case_tac "x = y")
   apply(subgoal_tac "Stars xs :\<sqsubset>val Stars ys")
  apply (simp add: PosOrd_StarsI2 PosOrd_ex_eq_def)
  apply (simp add: PosOrd_ex_eq2)
  by (meson PosOrd_StarsI PosOrd_ex_eq_def)

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 \<open>The Posix Value is smaller than any other lexical value\<close>

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_Atom c v)
  have "v \<in> LV (Atom c) [c]" by fact
  then have "v = Atm c"
    by (simp add: LV_simps)
  then show "Atm c :\<sqsubseteq>val v"
    by (simp add: PosOrd_ex_eq_def)
next
  case (Posix_Plus1 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 (Plus r1 r2) s" by fact
  then have "\<turnstile> v2 : Plus 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_Plus2 s r2 v r1 v2)
  have as1: "s \<in> r2 \<rightarrow> v" by fact
  have as2: "s \<notin> lang r1" by fact
  have IH: "\<And>v2. v2 \<in> LV r2 s \<Longrightarrow> v :\<sqsubseteq>val v2" by fact
  have "v2 \<in> LV (Plus r1 r2) s" by fact
  then have "\<turnstile> v2 : Plus 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
       using Prf_flat_lang by blast
     then show "Right v :\<sqsubseteq>val v2" by simp
  qed
next
  case (Posix_Times 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> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by fact
  have "v3 \<in> LV (Times 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 Prf_flat_lang 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> lang r \<and> s\<^sub>4 \<in> lang (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_elims)
  by (metis NonEmpty Prf.intros(6) list.set_intros(1) list.set_intros(2) neq_Nil_conv)
  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 Prf_flat_lang 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 (metis flat.simps(7) flat_Stars val.inject(5))
      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)
next
  case (Posix_NTimes2 vs r n v2)
  have IH: "\<forall>v\<in>set vs. [] \<in> r \<rightarrow> v \<and> (\<forall>x. x \<in> LV r [] \<longrightarrow> v :\<sqsubseteq>val x)" by fact
  then have "flats vs = []"
    by (metis Posix.Posix_NTimes2 Posix1(2) flat_Stars)
  have "v2 \<in> LV (NTimes r n) []" by fact
    then obtain vs' where eq: "v2 = Stars vs'" and "length vs' = n" and as: "\<forall>v \<in> set vs'. v \<in> LV r [] \<and> flat v = []"
      unfolding LV_def by (auto elim!: Prf_elims)
  then have "Stars vs :\<sqsubseteq>val Stars vs'"
    apply(rule_tac PosOrd_Stars_equalsI)
    apply (simp add: \<open>flats vs = []\<close>)
    using Posix_NTimes2.hyps(2) apply blast
    using IH apply(simp add: list_all2_iff)
    apply(auto)
    using Posix_NTimes2.hyps(2) apply blast
    by (meson in_set_zipE)
  then show "Stars vs :\<sqsubseteq>val v2" using eq by simp
next
  case (Posix_NTimes1 s1 r v s2 n vs)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> NTimes r n \<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 (NTimes r n) 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> lang r \<and> s\<^sub>4 \<in> lang (NTimes r n))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v2 \<in> LV (NTimes r (n + 1)) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v2 = Stars (v3a # vs3)"
    "\<turnstile> v3a : r" "\<turnstile> Stars vs3 : NTimes r n"
    "flat (Stars (v3a # vs3)) = s1 @ s2"
  | (Empty) "v2 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf_elims)
  apply(case_tac vs1)
  apply(simp add: as1(1) cond2 flats_empty)
   apply(simp)
  using Prf.simps apply fastforce
  done
  then show "Stars (v # vs) :\<sqsubseteq>val v2"
    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 Prf_flat_lang 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 (NTimes r n) 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 (metis flat.simps(7) flat_Stars val.inject(5))
      then show "Stars (v # vs) :\<sqsubseteq>val v2" unfolding NonEmpty by blast
    next
      case Empty
      have "v2 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v2"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
  qed
next
  case (Posix_Upto1 s1 r v s2 n vs v3)
    have "s1 \<in> r \<rightarrow> v" "s2 \<in> Upto r n \<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 (Upto r n) 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> lang r \<and> s\<^sub>4 \<in> lang (Upto r n))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (Upto r (n + 1)) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<turnstile> v3a : r" "\<turnstile> Stars vs3 : Upto r n"
    "flat (Stars (v3a # vs3)) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf_elims)
  apply(case_tac vs)
   apply(auto)
  by (simp add: Prf.intros(8))
  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 Prf_flat_lang 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 (Upto r n) 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 (metis flat.simps(7) flat_Stars val.inject(5))
      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_Upto2 r n v2)
    have "v2 \<in> LV (Upto r n) []" 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)
next
  case (Posix_From2 vs r n)
  then show "Stars vs :\<sqsubseteq>val v2"
    apply(simp add: LV_def)
      apply(auto)
    apply(erule Prf_elims)
     apply(auto)
    apply(rule PosOrd_Stars_equalsI)
    apply (metis Posix1(2) flats_empty)
      apply(simp)
    apply(auto simp add: list_all2_iff)
    apply (meson set_zip_leftD set_zip_rightD)
    done
next
  case (Posix_From1 s1 r v s2 n vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> From r (n - 1) \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flats 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 (From r (n - 1)) 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> lang r \<and> s\<^sub>4 \<in> lang (From r (n - 1)))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (From r n) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<turnstile> v3a : r" "\<turnstile> Stars vs3 : From r (n - 1)"
    "flats (v3a # vs3) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
             apply(auto)
  apply(case_tac vs1)
   apply(auto intro: Prf.intros)
   apply(case_tac vs2)
    apply(auto intro: Prf.intros)
    apply (simp add: as1(1) cond2 flats_empty)
  apply (simp add: Prf.intros)
  apply(case_tac vs)
   apply(auto)
  by (metis Posix_From1.hyps(6) Prf.intros(10) Suc_le_eq Suc_pred less_Suc_eq_le)
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flats (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 (z3) Prf_flat_lang append.right_neutral append_eq_append_conv2 flat.simps(7) flat_Stars)
      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 (From r (n - 1)) 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
        by (metis PosOrd_StarsI PosOrd_StarsI2 flat.simps(7) flat_Stars val.inject(5))
      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_From3 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> lang r \<and> s\<^sub>4 \<in> lang (Star r))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (From r 0) (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 (z3) Prf_flat_lang append.right_neutral 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
        by (metis PosOrd_StarsI PosOrd_StarsI2 flat.simps(7) flat_Stars val.inject(5))
      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_Rec s r v l v2)
  then show "Recv l v :\<sqsubseteq>val v2"
    by (smt (verit, del_insts) LV_def LV_simps(6) PosOrd_Rec_eq PosOrd_ex_eq_def Posix1(2) mem_Collect_eq)
next
  case (Posix_Cset c cs v)
  have "v \<in> LV (Charset cs) [c]" by fact
  then have "v = Atm c \<or> False"
    apply(case_tac "c \<in> cs")
    by(auto simp add: LV_simps)
  then show "Atm c :\<sqsubseteq>val v"
    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> lang r" using assms(1) unfolding LV_def
    using Prf_flat_lang 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 Prf_flat_lang 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>! v\<^sub>m\<^sub>i\<^sub>n \<in> LV r s. \<forall>v \<in> LV r s. v\<^sub>m\<^sub>i\<^sub>n :\<sqsubseteq>val v"
using Least_existence[OF assms] assms
using PosOrdeq_antisym by blast

lemma Least_existence2:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>!vmin \<in> LV r s. lexer r s = Some vmin \<and> (\<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v)"
using Least_existence[OF assms] assms
using PosOrdeq_antisym
using PosOrd_Posix PosOrd_ex_eq2 lexer_correctness(1)
  by (metis (mono_tags, lifting))

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 PosOrd_partial:
  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 PosOrd_wf:
  shows "wf {(v1, v2). v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s}"
proof -
  have "finite {(v1, v2). v1 \<in> LV r s \<and> v2 \<in> LV r s}"
    by (simp add: LV_finite)
  moreover
  have "{(v1, v2). v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s} \<subseteq> {(v1, v2). v1 \<in> LV r s \<and> v2 \<in> LV r s}"
    by auto
  ultimately have "finite {(v1, v2). v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s}"
    using finite_subset by blast
  moreover
  have "acyclicP (\<lambda>v1 v2. v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s)"
    unfolding acyclic_def
    by (smt (verit, ccfv_threshold) PosOrd_irrefl PosOrd_trans tranclp_trans_induct tranclp_unfold)
  ultimately show "wf {(v1, v2). v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s}"
    using finite_acyclic_wf by blast
qed

unused_thms

end


theory prop_49
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun butlast :: "'a list => 'a list" where
  "butlast (Nil2) = Nil2"
  | "butlast (Cons2 y (Nil2)) = Nil2"
  | "butlast (Cons2 y (Cons2 x2 x3)) =
       Cons2 y (butlast (Cons2 x2 x3))"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun butlastConcat :: "'a list => 'a list => 'a list" where
  "butlastConcat x (Nil2) = butlast x"
  | "butlastConcat x (Cons2 z x2) = append x (butlast (Cons2 z x2))"
  (*hipster butlast append butlastConcat *)
(*hipster butlast append*)(*
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes butlast.simps append.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes butlast.simps append.simps)

lemma unknown [thy_expl]: "butlast (append x x) = append x (butlast x)"
oops

lemma lemma_ab [thy_expl]: "butlastConcat Nil2 x = butlast x"
by (hipster_induct_schemes butlast.simps append.simps)

lemma lemma_ac [thy_expl]: "append x (butlast x) = butlastConcat x x"
by (hipster_induct_schemes butlast.simps append.simps)*)
(*
hipster butlast butlastConcat append
*)
(*hipster butlastConcat butlast append*)

setup\<open>Hip_Tac_Ops.set_metis_to @{context} 3000\<close>
setup\<open>Hip_Tac_Ops.set_metis_filter @{context} (K false)\<close>

  theorem x0 :
    "(butlast (append xs ys)) = (butlastConcat xs ys)"
    by (hipster_induct_schemes butlastConcat.simps butlast.simps append.simps list.exhaust)

end


theory First
  imports Complex_Main "HOL-Library.Code_Target_Nat"
begin

text \<open>
  First task :

  https://imomath.com/srb/zadaci/2018_bmo_shortlist.pdf ,problem A3
------------------------------------------------------------------
  Show that for every positive integer n we have:
             k
     (2n+1-k)    n
  \<Sum> (------) \<le> 2   , k \<in> {0..n}
     ( k+1  )
------------------------------------------------------------------
  Idea for solving :

    - show that every sum member is less or equal to binomial coefficient
      for appropriate N and K

    - substitute sum members with their binomial coefficient.. sum of them
      is equal to 2^n
\<close>

(*  Define factorial using primitive recursion  *)
primrec fact :: "nat \<Rightarrow> nat" where
   "fact 0 = 1"
|  "fact (Suc n) = fact n * (Suc n)"

value "fact 4"

(*  Define binomial coefficient  *)
definition binom_coef :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "binom_coef n k = fact n div (fact k * fact (n-k))"

value "binom_coef 5 2"

(*  Proof for binomial symmetry  *)
lemma binomial_symmetry [simp]:
  fixes n k :: nat
  assumes "n \<ge> k"
  shows "binom_coef n k = binom_coef n (n-k)"
  using assms
  unfolding binom_coef_def
  by (simp add: mult.commute)

(*  Proof for sum of binomial coefficients  *)
lemma binomial_sum [simp]:
  fixes n :: nat
  shows "\<forall>n.(\<Sum> k \<in> {0..n} . binom_coef n k) = 2^n"
  by simp

(*  Proof for lemma_1 *)
lemma lemma_1 [simp]:
  fixes n :: nat
  shows "\<forall>k \<in> {0..n}. (binom_coef n k \<ge> ((2*n+1-k) / (k+1))^k)"
  by simp

(*  Proof  *)
lemma Final:
  fixes n :: int
  assumes "n > 0"
  shows "\<forall>n. (\<Sum> k \<in> {0..n}. ((2*n+1-k) / (k+1))^k ) \<le> 2^n"
  using assms
  using lemma_1
  by simp

text \<open>

  Isabelle can prove this using only a few lines below

  lemma
    fixes n :: int
    assumes "n > 0"
    shows "\<forall>n. (\<Sum> k \<in> {0..n}. ((2*n+1-k) / (k+1))^k ) \<le> 2^n"
    using assms
    by metis
\<close>

end


theory utp_expr_funcs
  imports utp_expr_insts
begin

syntax \<comment> \<open> Polymorphic constructs \<close>
  "_uceil"      :: "logic \<Rightarrow> logic" ("\<lceil>_\<rceil>\<^sub>u")
  "_ufloor"     :: "logic \<Rightarrow> logic" ("\<lfloor>_\<rfloor>\<^sub>u")
  "_umin"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("min\<^sub>u'(_, _')")
  "_umax"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("max\<^sub>u'(_, _')")
  "_ugcd"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("gcd\<^sub>u'(_, _')")

translations
  \<comment> \<open> Type-class polymorphic constructs \<close>
  "min\<^sub>u(x, y)"  == "CONST bop (CONST min) x y"
  "max\<^sub>u(x, y)"  == "CONST bop (CONST max) x y"
  "gcd\<^sub>u(x, y)"  == "CONST bop (CONST gcd) x y"
  "\<lceil>x\<rceil>\<^sub>u" == "CONST uop CONST ceiling x"
  "\<lfloor>x\<rfloor>\<^sub>u" == "CONST uop CONST floor x"

syntax \<comment> \<open> Lists / Sequences \<close>
  "_ucons"      :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixr "#\<^sub>u" 65)
  "_unil"       :: "('a list, '\<alpha>) uexpr" ("\<langle>\<rangle>")
  "_ulist"      :: "args => ('a list, '\<alpha>) uexpr"    ("\<langle>(_)\<rangle>")
  "_uappend"    :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" (infixr "^\<^sub>u" 80)
  "_udconcat"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixr "\<^sup>\<frown>\<^sub>u" 90)
  "_ulast"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("last\<^sub>u'(_')")
  "_ufront"     :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("front\<^sub>u'(_')")
  "_uhead"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("head\<^sub>u'(_')")
  "_utail"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("tail\<^sub>u'(_')")
  "_utake"      :: "(nat, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("take\<^sub>u'(_,/ _')")
  "_udrop"      :: "(nat, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("drop\<^sub>u'(_,/ _')")
  "_ufilter"    :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" (infixl "\<restriction>\<^sub>u" 75)
  "_uextract"   :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" (infixl "\<upharpoonleft>\<^sub>u" 75)
  "_uelems"     :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" ("elems\<^sub>u'(_')")
  "_usorted"    :: "('a list, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" ("sorted\<^sub>u'(_')")
  "_udistinct"  :: "('a list, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" ("distinct\<^sub>u'(_')")
  "_uupto"      :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("\<langle>_.._\<rangle>")
  "_uupt"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("\<langle>_..<_\<rangle>")
  "_umap"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("map\<^sub>u")
  "_uzip"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("zip\<^sub>u")

translations
  "x #\<^sub>u ys" == "CONST bop (#) x ys"
  "\<langle>\<rangle>"       == "\<guillemotleft>[]\<guillemotright>"
  "\<langle>x, xs\<rangle>"  == "x #\<^sub>u \<langle>xs\<rangle>"
  "\<langle>x\<rangle>"      == "x #\<^sub>u \<guillemotleft>[]\<guillemotright>"
  "x ^\<^sub>u y"   == "CONST bop (@) x y"
  "A \<^sup>\<frown>\<^sub>u B" == "CONST bop (\<^sup>\<frown>) A B"
  "last\<^sub>u(xs)" == "CONST uop CONST last xs"
  "front\<^sub>u(xs)" == "CONST uop CONST butlast xs"
  "head\<^sub>u(xs)" == "CONST uop CONST hd xs"
  "tail\<^sub>u(xs)" == "CONST uop CONST tl xs"
  "drop\<^sub>u(n,xs)" == "CONST bop CONST drop n xs"
  "take\<^sub>u(n,xs)" == "CONST bop CONST take n xs"
  "elems\<^sub>u(xs)" == "CONST uop CONST set xs"
  "sorted\<^sub>u(xs)" == "CONST uop CONST sorted xs"
  "distinct\<^sub>u(xs)" == "CONST uop CONST distinct xs"
  "xs \<restriction>\<^sub>u A"   == "CONST bop CONST seq_filter xs A"
  "A \<upharpoonleft>\<^sub>u xs"   == "CONST bop (\<upharpoonleft>\<^sub>l) A xs"
  "\<langle>n..k\<rangle>" == "CONST bop CONST upto n k"
  "\<langle>n..<k\<rangle>" == "CONST bop CONST upt n k"
  "map\<^sub>u f xs" == "CONST bop CONST map f xs"
  "zip\<^sub>u xs ys" == "CONST bop CONST zip xs ys"

syntax \<comment> \<open> Sets \<close>
  "_ufinite"    :: "logic \<Rightarrow> logic" ("finite\<^sub>u'(_')")
  "_uempset"    :: "('a set, '\<alpha>) uexpr" ("{}\<^sub>u")
  "_uset"       :: "args => ('a set, '\<alpha>) uexpr" ("{(_)}\<^sub>u")
  "_uunion"     :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" (infixl "\<union>\<^sub>u" 65)
  "_uinter"     :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" (infixl "\<inter>\<^sub>u" 70)
  "_uinsert"    :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("insert\<^sub>u")
  "_uimage"     :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_\<lparr>_\<rparr>\<^sub>u" [10,0] 10)
  "_usubset"    :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<subset>\<^sub>u" 50)
  "_usubseteq"  :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<subseteq>\<^sub>u" 50)
  "_uconverse"  :: "logic \<Rightarrow> logic" ("(_\<^sup>~)" [1000] 999)
  "_ucarrier"   :: "type \<Rightarrow> logic" ("[_]\<^sub>T")
  "_uid"        :: "type \<Rightarrow> logic" ("id[_]")
  "_uproduct"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixr "\<times>\<^sub>u" 80)
  "_urelcomp"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixr ";\<^sub>u" 75)

translations
  "finite\<^sub>u(x)" == "CONST uop (CONST finite) x"
  "{}\<^sub>u"      == "\<guillemotleft>{}\<guillemotright>"
  "insert\<^sub>u x xs" == "CONST bop CONST insert x xs"
  "{x, xs}\<^sub>u" == "insert\<^sub>u x {xs}\<^sub>u"
  "{x}\<^sub>u"     == "insert\<^sub>u x \<guillemotleft>{}\<guillemotright>"
  "A \<union>\<^sub>u B"   == "CONST bop (\<union>) A B"
  "A \<inter>\<^sub>u B"   == "CONST bop (\<inter>) A B"
  "f\<lparr>A\<rparr>\<^sub>u"     == "CONST bop CONST image f A"
  "A \<subset>\<^sub>u B"   == "CONST bop (\<subset>) A B"
  "f \<subset>\<^sub>u g"   <= "CONST bop (\<subset>\<^sub>p) f g"
  "f \<subset>\<^sub>u g"   <= "CONST bop (\<subset>\<^sub>f) f g"
  "A \<subseteq>\<^sub>u B"   == "CONST bop (\<subseteq>) A B"
  "f \<subseteq>\<^sub>u g"   <= "CONST bop (\<subseteq>\<^sub>p) f g"
  "f \<subseteq>\<^sub>u g"   <= "CONST bop (\<subseteq>\<^sub>f) f g"
  "P\<^sup>~"        == "CONST uop CONST converse P"
  "['a]\<^sub>T"     == "\<guillemotleft>CONST set_of TYPE('a)\<guillemotright>"
  "id['a]"    == "\<guillemotleft>CONST Id_on (CONST set_of TYPE('a))\<guillemotright>"
  "A \<times>\<^sub>u B"    == "CONST bop CONST Product_Type.Times A B"
  "A ;\<^sub>u B"    == "CONST bop CONST relcomp A B"

syntax \<comment> \<open> Partial functions \<close>
  "_umap_plus"  :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<oplus>\<^sub>u" 85)
  "_umap_minus" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<ominus>\<^sub>u" 85)

translations
  "f \<oplus>\<^sub>u g"   => "(f :: ((_, _) pfun, _) uexpr) + g"
  "f \<ominus>\<^sub>u g"   => "(f :: ((_, _) pfun, _) uexpr) - g"

syntax \<comment> \<open> Sum types \<close>
  "_uinl"       :: "logic \<Rightarrow> logic" ("inl\<^sub>u'(_')")
  "_uinr"       :: "logic \<Rightarrow> logic" ("inr\<^sub>u'(_')")

translations
  "inl\<^sub>u(x)" == "CONST uop CONST Inl x"
  "inr\<^sub>u(x)" == "CONST uop CONST Inr x"

subsection \<open> Lifting set collectors \<close>

text \<open> We provide syntax for various types of set collectors, including intervals and the Z-style
  set comprehension which is purpose built as a new lifted definition. \<close>

syntax
  "_uset_atLeastAtMost" :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" ("(1{_.._}\<^sub>u)")
  "_uset_atLeastLessThan" :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" ("(1{_..<_}\<^sub>u)")
  "_uset_compr" :: "pttrn \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('b set, '\<alpha>) uexpr" ("(1{_ :/ _ |/ _ \<bullet>/ _}\<^sub>u)")
  "_uset_compr_nset" :: "pttrn \<Rightarrow> (bool, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('b set, '\<alpha>) uexpr" ("(1{_ |/ _ \<bullet>/ _}\<^sub>u)")

lift_definition ZedSetCompr ::
  "('a set, '\<alpha>) uexpr \<Rightarrow> ('a \<Rightarrow> (bool, '\<alpha>) uexpr \<times> ('b, '\<alpha>) uexpr) \<Rightarrow> ('b set, '\<alpha>) uexpr"
is "\<lambda> A PF b. { snd (PF x) b | x. x \<in> A b \<and> fst (PF x) b}" .

translations
  "{x..y}\<^sub>u" == "CONST bop CONST atLeastAtMost x y"
  "{x..<y}\<^sub>u" == "CONST bop CONST atLeastLessThan x y"
  "{x | P \<bullet> F}\<^sub>u" == "CONST ZedSetCompr (CONST lit CONST UNIV) (\<lambda> x. (P, F))"
  "{x : A | P \<bullet> F}\<^sub>u" == "CONST ZedSetCompr A (\<lambda> x. (P, F))"

subsection \<open> Lifting limits \<close>

text \<open> We also lift the following functions on topological spaces for taking function limits,
  and describing continuity. \<close>

definition ulim_left :: "'a::order_topology \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b::t2_space" where
[uexpr_defs]: "ulim_left = (\<lambda> p f. Lim (at_left p) f)"

definition ulim_right :: "'a::order_topology \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b::t2_space" where
[uexpr_defs]: "ulim_right = (\<lambda> p f. Lim (at_right p) f)"

definition ucont_on :: "('a::topological_space \<Rightarrow> 'b::topological_space) \<Rightarrow> 'a set \<Rightarrow> bool" where
[uexpr_defs]: "ucont_on = (\<lambda> f A. continuous_on A f)"

syntax
  "_ulim_left"  :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("lim\<^sub>u'(_ \<rightarrow> _\<^sup>-')'(_')")
  "_ulim_right" :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("lim\<^sub>u'(_ \<rightarrow> _\<^sup>+')'(_')")
  "_ucont_on"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "cont-on\<^sub>u" 90)

translations
  "lim\<^sub>u(x \<rightarrow> p\<^sup>-)(e)" == "CONST bop CONST ulim_left p (\<lambda> x \<bullet> e)"
  "lim\<^sub>u(x \<rightarrow> p\<^sup>+)(e)" == "CONST bop CONST ulim_right p (\<lambda> x \<bullet> e)"
  "f cont-on\<^sub>u A"     == "CONST bop CONST continuous_on A f"

lemma uset_minus_empty [simp]: "x - {}\<^sub>u = x"
  by (simp add: uexpr_defs, transfer, simp)

lemma uinter_empty_1 [simp]: "x \<inter>\<^sub>u {}\<^sub>u = {}\<^sub>u"
  by (transfer, simp)

lemma uinter_empty_2 [simp]: "{}\<^sub>u \<inter>\<^sub>u x = {}\<^sub>u"
  by (transfer, simp)

lemma uunion_empty_1 [simp]: "{}\<^sub>u \<union>\<^sub>u x = x"
  by (transfer, simp)

lemma uunion_insert [simp]: "(bop insert x A) \<union>\<^sub>u B = bop insert x (A \<union>\<^sub>u B)"
  by (transfer, simp)

lemma ulist_filter_empty [simp]: "x \<restriction>\<^sub>u {}\<^sub>u = \<langle>\<rangle>"
  by (transfer, simp)

lemma tail_cons [simp]: "tail\<^sub>u(\<langle>x\<rangle> ^\<^sub>u xs) = xs"
  by (transfer, simp)

lemma uconcat_units [simp]: "\<langle>\<rangle> ^\<^sub>u xs = xs" "xs ^\<^sub>u \<langle>\<rangle> = xs"
  by (transfer, simp)+

end


(*
  File: Order_Thms.thy
  Author: Bohua Zhan

  Setup for proof steps related to ordering.
*)

section \<open>Setup for ordering\<close>

theory Order_Thms
  imports Logic_Thms HOL.Rat
begin

ML_file \<open>util_arith.ML\<close>
setup \<open>Consts.add_const_data ("NUMC", UtilArith.is_numc)\<close>

subsection \<open>Results in class order or preorder\<close>

setup \<open>add_forward_prfstep_cond @{thm order.trans} [with_filt (not_type_filter "a" natT)]\<close>
setup \<open>add_forward_prfstep_cond @{thm order.strict_trans} [with_filt (not_type_filter "a" natT)]\<close>
setup \<open>add_forward_prfstep_cond @{thm order_le_less_trans} [with_filt (not_type_filter "x" natT)]\<close>
setup \<open>add_forward_prfstep_cond @{thm order_less_le_trans} [with_filt (not_type_filter "x" natT)]\<close>
setup \<open>add_resolve_prfstep @{thm order.irrefl}\<close>
setup \<open>add_forward_prfstep_cond @{thm Orderings.le_neq_trans} [with_cond "?a \<noteq> ?b"]\<close>
setup \<open>add_forward_prfstep_cond @{thm Orderings.order_antisym} [with_filt (order_filter "x" "y"), with_cond "?x \<noteq> ?y"]\<close>

subsection \<open>Rewriting of negation, in linorder\<close>

setup \<open>fold add_gen_prfstep [
  ("not_less",
   [WithProp @{term_pat "\<not> (?x::(?'a::linorder)) < ?y"},
    GetFact (@{term_pat "?y \<le> (?x::(?'a::linorder))"}, equiv_forward_th @{thm linorder_not_less}),
    WithScore 1]),
  ("not_le",
   [WithProp @{term_pat "\<not> (?x::(?'a::linorder)) \<le> ?y"},
    GetFact (@{term_pat "?y < (?x::(?'a::linorder))"}, equiv_forward_th @{thm linorder_not_le}),
    WithScore 1])]
\<close>

subsection \<open>Properties of max and min (in linorder)\<close>

setup \<open>add_rewrite_rule @{thm min.commute}\<close>
setup \<open>add_rewrite_rule @{thm min.idem}\<close>
setup \<open>add_forward_prfstep_cond @{thm min.cobounded1} [with_term "min ?a ?b"]\<close>
setup \<open>add_forward_prfstep_cond @{thm min.cobounded2} [with_term "min ?a ?b"]\<close>
setup \<open>add_backward2_prfstep @{thm min.boundedI}\<close>
setup \<open>add_backward2_prfstep @{thm min.mono}\<close>
setup \<open>add_rewrite_rule @{thm min.absorb1}\<close>
setup \<open>add_rewrite_rule @{thm min.absorb2}\<close>

setup \<open>add_rewrite_rule @{thm max.commute}\<close>
setup \<open>add_rewrite_rule @{thm max.idem}\<close>
setup \<open>add_forward_prfstep_cond @{thm max.cobounded1} [with_term "max ?a ?b"]\<close>
setup \<open>add_forward_prfstep_cond @{thm max.cobounded2} [with_term "max ?a ?b"]\<close>
setup \<open>add_backward2_prfstep @{thm max.boundedI}\<close>
setup \<open>add_backward2_prfstep @{thm max.mono}\<close>
setup \<open>add_rewrite_rule @{thm max.absorb1}\<close>
setup \<open>add_rewrite_rule @{thm max.absorb2}\<close>

subsection \<open>Min\<close>

setup \<open>add_backward_prfstep @{thm Min_in}\<close>
setup \<open>add_backward_prfstep @{thm Min_le}\<close>
setup \<open>add_backward2_prfstep @{thm Min_eqI}\<close>

subsection \<open>Existence of numbers satisfying inequalities\<close>

theorem exists_ge [resolve]: "\<exists>k. k \<ge> (i::('a::order))" by auto
setup \<open>fold add_resolve_prfstep [@{thm lt_ex}, @{thm gt_ex}]\<close>
setup \<open>add_backward_prfstep @{thm dense}\<close>

end


section \<open>Relations interpreted as Directed Graphs\<close>
theory Digraph_Basic
imports
  "Automatic_Refinement.Misc"
  "Automatic_Refinement.Refine_Util"
  "HOL-Library.Omega_Words_Fun"
begin

text \<open>
  This theory contains some basic graph theory on directed graphs which are
  modeled as a relation between nodes.

  The theory here is very fundamental, and
  also used by non-directly graph-related applications like the theory of
  tail-recursion in the Refinement Framework. Thus, we decided to put it
  in the basic theories of the refinement framework.
\<close>

text \<open>Directed graphs are modeled as a relation on nodes\<close>
type_synonym 'v digraph = "('v\<times>'v) set"

locale digraph = fixes E :: "'v digraph"

subsection \<open>Paths\<close>
text \<open>Path are modeled as list of nodes, the last node of a path is not included
  into the list. This formalization allows for nice concatenation and splitting
  of paths.\<close>
inductive path :: "'v digraph \<Rightarrow> 'v \<Rightarrow> 'v list \<Rightarrow> 'v \<Rightarrow> bool" for E where
  path0: "path E u [] u"
| path_prepend: "\<lbrakk> (u,v)\<in>E; path E v l w \<rbrakk> \<Longrightarrow> path E u (u#l) w"

lemma path1: "(u,v)\<in>E \<Longrightarrow> path E u [u] v"
  by (auto intro: path.intros)

lemma path_empty_conv[simp]:
  "path E u [] v \<longleftrightarrow> u=v"
  by (auto intro: path0 elim: path.cases)

inductive_cases path_uncons: "path E u (u'#l) w"
inductive_simps path_cons_conv: "path E u (u'#l) w"

lemma path_no_edges[simp]: "path {} u p v \<longleftrightarrow> (u=v \<and> p=[])"
  by (cases p) (auto simp: path_cons_conv)

lemma path_conc:
  assumes P1: "path E u la v"
  assumes P2: "path E v lb w"
  shows "path E u (la@lb) w"
  using P1 P2 apply induct
  by (auto intro: path.intros)

lemma path_append:
  "\<lbrakk> path E u l v; (v,w)\<in>E \<rbrakk> \<Longrightarrow> path E u (l@[v]) w"
  using path_conc[OF _ path1] .

lemma path_unconc:
  assumes "path E u (la@lb) w"
  obtains v where "path E u la v" and "path E v lb w"
  using assms
  thm path.induct
  apply (induct u "la@lb" w arbitrary: la lb rule: path.induct)
  apply (auto intro: path.intros elim!: list_Cons_eq_append_cases)
  done

lemma path_conc_conv:
  "path E u (la@lb) w \<longleftrightarrow> (\<exists>v. path E u la v \<and> path E v lb w)"
  by (auto intro: path_conc elim: path_unconc)

lemma (in -) path_append_conv: "path E u (p@[v]) w \<longleftrightarrow> (path E u p v \<and> (v,w)\<in>E)"
  by (simp add: path_cons_conv path_conc_conv)

lemmas path_simps = path_empty_conv path_cons_conv path_conc_conv

lemmas path_trans[trans] = path_prepend path_conc path_append
lemma path_from_edges: "\<lbrakk>(u,v)\<in>E; (v,w)\<in>E\<rbrakk> \<Longrightarrow> path E u [u] v"
  by (auto simp: path_simps)

lemma path_edge_cases[case_names no_use split]:
  assumes "path (insert (u,v) E) w p x"
  obtains
    "path E w p x"
  | p1 p2 where "path E w p1 u" "path (insert (u,v) E) v p2 x"
  using assms
  apply induction
  apply simp
  apply (clarsimp)
  apply (metis path_simps path_cons_conv)
  done

lemma path_edge_rev_cases[case_names no_use split]:
  assumes "path (insert (u,v) E) w p x"
  obtains
    "path E w p x"
  | p1 p2 where "path (insert (u,v) E) w p1 u" "path E v p2 x"
  using assms
  apply (induction p arbitrary: x rule: rev_induct)
  apply simp
  apply (clarsimp simp: path_cons_conv path_conc_conv)
  apply (metis path_simps path_append_conv)
  done

lemma path_mono:
  assumes S: "E\<subseteq>E'"
  assumes P: "path E u p v"
  shows "path E' u p v"
  using P
  apply induction
  apply simp
  using S
  apply (auto simp: path_cons_conv)
  done

lemma path_is_rtrancl:
  assumes "path E u l v"
  shows "(u,v)\<in>E\<^sup>*"
  using assms
  by induct auto

lemma rtrancl_is_path:
  assumes "(u,v)\<in>E\<^sup>*"
  obtains l where "path E u l v"
  using assms
  by induct (auto intro: path0 path_append)

lemma path_is_trancl:
  assumes "path E u l v"
  and "l\<noteq>[]"
  shows "(u,v)\<in>E\<^sup>+"
  using assms
  apply induct
  apply auto []
  apply (case_tac l)
  apply auto
  done

lemma trancl_is_path:
  assumes "(u,v)\<in>E\<^sup>+"
  obtains l where "l\<noteq>[]" and "path E u l v"
  using assms
  by induct (auto intro: path0 path_append)

lemma path_nth_conv: "path E u p v \<longleftrightarrow> (let p'=p@[v] in
  u=p'!0 \<and>
  (\<forall>i<length p' - 1. (p'!i,p'!Suc i)\<in>E))"
  apply (induct p arbitrary: v rule: rev_induct)
  apply (auto simp: path_conc_conv path_cons_conv nth_append)
  done

lemma path_mapI:
  assumes "path E u p v"
  shows "path (pairself f ` E) (f u) (map f p) (f v)"
  using assms
  apply induction
  apply (simp)
  apply (force simp: path_cons_conv)
  done

lemma path_restrict:
  assumes "path E u p v"
  shows "path (E \<inter> set p \<times> insert v (set (tl p))) u p v"
  using assms
proof induction
  print_cases
  case (path_prepend u v p w)
  from path_prepend.IH have "path (E \<inter> set (u#p) \<times> insert w (set p)) v p w"
    apply (rule path_mono[rotated])
    by (cases p) auto
  thus ?case using \<open>(u,v)\<in>E\<close>
    by (cases p) (auto simp add: path_cons_conv)
qed auto

lemma path_restrict_closed:
  assumes CLOSED: "E``D \<subseteq> D"
  assumes I: "v\<in>D" and P: "path E v p v'"
  shows "path (E\<inter>D\<times>D) v p v'"
  using P CLOSED I
  by induction (auto simp: path_cons_conv)

lemma path_set_induct:
  assumes "path E u p v" and "u\<in>I" and "E``I \<subseteq> I"
  shows "set p \<subseteq> I"
  using assms
  by (induction rule: path.induct) auto

lemma path_nodes_reachable: "path E u p v \<Longrightarrow> insert v (set p) \<subseteq> E\<^sup>*``{u}"
  apply (auto simp: in_set_conv_decomp path_cons_conv path_conc_conv)
  apply (auto dest!: path_is_rtrancl)
  done

lemma path_nodes_edges: "path E u p v \<Longrightarrow> set p \<subseteq> fst`E"
  by (induction rule: path.induct) auto

lemma path_tl_nodes_edges:
  assumes "path E u p v"
  shows "set (tl p) \<subseteq> fst`E \<inter> snd`E"
proof -
  from path_nodes_edges[OF assms] have "set (tl p) \<subseteq> fst`E"
    by (cases p) auto

  moreover have "set (tl p) \<subseteq> snd`E"
    using assms
    apply (cases)
    apply simp
    apply simp
    apply (erule path_set_induct[where I = "snd`E"])
    apply auto
    done
  ultimately show ?thesis
    by auto
qed

lemma path_loop_shift:
  assumes P: "path E u p u"
  assumes S: "v\<in>set p"
  obtains p' where "set p' = set p" "path E v p' v"
proof -
  from S obtain p1 p2 where [simp]: "p = p1@v#p2" by (auto simp: in_set_conv_decomp)
  from P obtain v' where A: "path E u p1 v" "(v, v') \<in> E" "path E v' p2 u"
    by (auto simp: path_simps)
  hence "path E v (v#p2@p1) v" by (auto simp: path_simps)
  thus ?thesis using that[of "v#p2@p1"] by auto
qed

lemma path_hd:
  assumes "p \<noteq> []" "path E v p w"
  shows "hd p = v"
  using assms
  by (auto simp: path_cons_conv neq_Nil_conv)

lemma path_last_is_edge:
  assumes "path E x p y"
  and "p \<noteq> []"
  shows "(last p, y) \<in> E"
  using assms
  by (auto simp: neq_Nil_rev_conv path_simps)

lemma path_member_reach_end:
  assumes P: "path E x p y"
  and v: "v \<in> set p"
  shows "(v,y) \<in> E\<^sup>+"
  using assms
  by (auto intro!: path_is_trancl simp: in_set_conv_decomp path_simps)

lemma path_tl_induct[consumes 2, case_names single step]:
  assumes P: "path E x p y"
  and NE: "x \<noteq> y"
  and S: "\<And>u. (x,u) \<in> E \<Longrightarrow> P x u"
  and ST: "\<And>u v. \<lbrakk>(x,u) \<in> E\<^sup>+; (u,v) \<in> E; P x u\<rbrakk> \<Longrightarrow> P x v"
  shows "P x y \<and> (\<forall> v \<in> set (tl p). P x v)"
proof -
  from P NE have "p \<noteq> []" by auto
  thus ?thesis using P
  proof (induction p arbitrary: y rule: rev_nonempty_induct)
    case (single u) hence "(x,y) \<in> E" by (simp add: path_cons_conv)
    with S show ?case by simp
  next
    case (snoc u us) hence "path E x us u" by (simp add: path_append_conv)
    with snoc path_is_trancl have
      "P x u" "(x,u) \<in> E\<^sup>+" "\<forall>v \<in> set (tl us). P x v"
      by simp_all
    moreover with snoc have "\<forall>v \<in> set (tl (us@[u])). P x v" by simp
    moreover from snoc have "(u,y) \<in> E" by (simp add: path_append_conv)
    ultimately show ?case by (auto intro: ST)
  qed
qed

lemma path_restrict_tl:
  "\<lbrakk> u\<notin>R; path (E \<inter> UNIV \<times> -R) u p v \<rbrakk> \<Longrightarrow> path (rel_restrict E R) u p v"
  apply (induction p arbitrary: u)
  apply (auto simp: path_simps rel_restrict_def)
  done

lemma path1_restr_conv: "path (E\<inter>UNIV \<times> -R) u (x#xs) v
  \<longleftrightarrow> (\<exists>w. w\<notin>R \<and> x=u \<and> (u,w)\<in>E \<and> path (rel_restrict E R) w xs v)"
proof -
  have 1: "rel_restrict E R \<subseteq> E \<inter> UNIV \<times> - R" by (auto simp: rel_restrict_def)

  show ?thesis
    by (auto simp: path_simps intro: path_restrict_tl path_mono[OF 1])
qed

lemma dropWhileNot_path:
  assumes "p \<noteq> []"
  and "path E w p x"
  and "v \<in> set p"
  and "dropWhile ((\<noteq>) v) p = c"
  shows "path E v c x"
  using assms
proof (induction arbitrary: w c rule: list_nonempty_induct)
  case (single p) thus ?case by (auto simp add: path_simps)
next
  case (cons p ps) hence [simp]: "w = p" by (simp add: path_cons_conv)
  show ?case
  proof (cases "p=v")
    case True with cons show ?thesis by simp
  next
    case False with cons have "c = dropWhile ((\<noteq>) v) ps" by simp
    moreover from cons.prems obtain y where "path E y ps x"
      using path_uncons by metis
    moreover from cons.prems False have "v \<in> set ps" by simp
    ultimately show ?thesis using cons.IH by metis
  qed
qed

lemma takeWhileNot_path:
  assumes "p \<noteq> []"
  and "path E w p x"
  and "v \<in> set p"
  and "takeWhile ((\<noteq>) v) p = c"
  shows "path E w c v"
  using assms
proof (induction arbitrary: w c rule: list_nonempty_induct)
  case (single p) thus ?case by (auto simp add: path_simps)
next
  case (cons p ps) hence [simp]: "w = p" by (simp add: path_cons_conv)
  show ?case
  proof (cases "p=v")
    case True with cons show ?thesis by simp
  next
    case False with cons obtain c' where
      "c' = takeWhile ((\<noteq>) v) ps" and
      [simp]: "c = p#c'"
      by simp_all
    moreover from cons.prems obtain y where
      "path E y ps x" and "(w,y) \<in> E"
      using path_uncons by metis+
    moreover from cons.prems False have "v \<in> set ps" by simp
    ultimately have "path E y c' v" using cons.IH by metis
    with \<open>(w,y) \<in> E\<close> show ?thesis by (auto simp add: path_cons_conv)
  qed
qed

subsection \<open>Infinite Paths\<close>
definition ipath :: "'q digraph \<Rightarrow> 'q word \<Rightarrow> bool"
  \<comment> \<open>Predicate for an infinite path in a digraph\<close>
  where "ipath E r \<equiv> \<forall>i. (r i, r (Suc i))\<in>E"

lemma ipath_conc_conv:
  "ipath E (u \<frown> v) \<longleftrightarrow> (\<exists>a. path E a u (v 0) \<and> ipath E v)"
  apply (auto simp: conc_def ipath_def path_nth_conv nth_append)
  apply (metis add_Suc_right diff_add_inverse not_add_less1)
  by (metis Suc_diff_Suc diff_Suc_Suc not_less_eq)

lemma ipath_iter_conv:
  assumes "p\<noteq>[]"
  shows "ipath E (p\<^sup>\<omega>) \<longleftrightarrow> (path E (hd p) p (hd p))"
proof (cases p)
  case Nil thus ?thesis using assms by simp
next
  case (Cons u p') hence PLEN: "length p > 0" by simp
  show ?thesis proof
    assume "ipath E (iter (p))"
    hence "\<forall>i. (iter (p) i, iter (p) (Suc i)) \<in> E"
      unfolding ipath_def by simp
    hence "(\<forall>i<length p. (p!i,(p@[hd p])!Suc i)\<in>E)"
      apply (simp add: assms)
      apply safe
      apply (drule_tac x=i in spec)
      apply simp
      apply (case_tac "Suc i = length p")
      apply (simp add: Cons)
      apply (simp add: nth_append)
      done
    thus "path E (hd p) p (hd p)"
      by (auto simp: path_nth_conv Cons nth_append nth_Cons')
  next
    assume "path E (hd p) p (hd p)"
    thus "ipath E (iter p)"
      apply (auto simp: path_nth_conv ipath_def assms Let_def)
      apply (drule_tac x="i mod length p" in spec)
      apply (auto simp: nth_append assms split: if_split_asm)
      apply (metis less_not_refl mod_Suc)
      by (metis PLEN diff_self_eq_0 mod_Suc nth_Cons_0 mod_less_divisor)
  qed
qed

lemma ipath_to_rtrancl:
  assumes R: "ipath E r"
  assumes I: "i1\<le>i2"
  shows "(r i1,r i2)\<in>E\<^sup>*"
  using I
proof (induction i2)
  case (Suc i2)
  show ?case proof (cases "i1=Suc i2")
    assume "i1\<noteq>Suc i2"
    with Suc have "(r i1,r i2)\<in>E\<^sup>*" by auto
    also from R have "(r i2,r (Suc i2))\<in>E" unfolding ipath_def by auto
    finally show ?thesis .
  qed simp
qed simp

lemma ipath_to_trancl:
  assumes R: "ipath E r"
  assumes I: "i1<i2"
  shows "(r i1,r i2)\<in>E\<^sup>+"
proof -
  from R have "(r i1,r (Suc i1))\<in>E"
    by (auto simp: ipath_def)
  also have "(r (Suc i1),r i2)\<in>E\<^sup>*"
    using ipath_to_rtrancl[OF R,of "Suc i1" i2] I by auto
  finally (rtrancl_into_trancl2) show ?thesis .
qed

lemma run_limit_two_connectedI:
  assumes A: "ipath E r"
  assumes B: "a \<in> limit r" "b\<in>limit r"
  shows "(a,b)\<in>E\<^sup>+"
proof -
  from B have "{a,b} \<subseteq> limit r" by simp
  with A show ?thesis
    by (metis ipath_to_trancl two_in_limit_iff)
qed

lemma ipath_subpath:
  assumes P: "ipath E r"
  assumes LE: "l\<le>u"
  shows "path E (r l) (map r [l..<u]) (r u)"
  using LE
proof (induction "u-l" arbitrary: u l)
  case (Suc n)
  note IH=Suc.hyps(1)
  from \<open>Suc n = u-l\<close> \<open>l\<le>u\<close> obtain u' where [simp]: "u=Suc u'"
    and A: "n=u'-l" "l \<le> u'"
    by (cases u) auto

  note IH[OF A]
  also from P have "(r u',r u)\<in>E"
    by (auto simp: ipath_def)
  finally show ?case using \<open>l \<le> u'\<close> by (simp add: upt_Suc_append)
qed auto

lemma ipath_restrict_eq: "ipath (E \<inter> (E\<^sup>*``{r 0} \<times> E\<^sup>*``{r 0})) r \<longleftrightarrow> ipath E r"
  unfolding ipath_def
  by (auto simp: relpow_fun_conv rtrancl_power)
lemma ipath_restrict: "ipath E r \<Longrightarrow> ipath (E \<inter> (E\<^sup>*``{r 0} \<times> E\<^sup>*``{r 0})) r"
  by (simp add: ipath_restrict_eq)

lemma ipathI[intro?]: "\<lbrakk>\<And>i. (r i, r (Suc i)) \<in> E\<rbrakk> \<Longrightarrow> ipath E r"
  unfolding ipath_def by auto

lemma ipathD: "ipath E r \<Longrightarrow> (r i, r (Suc i)) \<in> E"
  unfolding ipath_def by auto

lemma ipath_in_Domain: "ipath E r \<Longrightarrow> r i \<in> Domain E"
  unfolding ipath_def by auto

lemma ipath_in_Range: "\<lbrakk>ipath E r; i\<noteq>0\<rbrakk> \<Longrightarrow> r i \<in> Range E"
  unfolding ipath_def by (cases i) auto

lemma ipath_suffix: "ipath E r \<Longrightarrow> ipath E (suffix i r)"
  unfolding suffix_def ipath_def by auto

subsection \<open>Strongly Connected Components\<close>

text \<open>A strongly connected component is a maximal mutually connected set
  of nodes\<close>
definition is_scc :: "'q digraph \<Rightarrow> 'q set \<Rightarrow> bool"
  where "is_scc E U \<longleftrightarrow> U\<times>U\<subseteq>E\<^sup>* \<and> (\<forall>V. V\<supset>U \<longrightarrow> \<not> (V\<times>V\<subseteq>E\<^sup>*))"

lemma scc_non_empty[simp]: "\<not>is_scc E {}" unfolding is_scc_def by auto

lemma scc_non_empty'[simp]: "is_scc E U \<Longrightarrow> U\<noteq>{}" unfolding is_scc_def by auto

lemma is_scc_closed:
  assumes SCC: "is_scc E U"
  assumes MEM: "x\<in>U"
  assumes P: "(x,y)\<in>E\<^sup>*" "(y,x)\<in>E\<^sup>*"
  shows "y\<in>U"
proof -
  from SCC MEM P have "insert y U \<times> insert y U \<subseteq> E\<^sup>*"
    unfolding is_scc_def
    apply clarsimp
    apply rule
    apply clarsimp_all
    apply (erule disjE1)
    apply clarsimp
    apply (metis in_mono mem_Sigma_iff rtrancl_trans)
    apply auto []
    apply (erule disjE1)
    apply clarsimp
    apply (metis in_mono mem_Sigma_iff rtrancl_trans)
    apply auto []
    done
  with SCC show ?thesis unfolding is_scc_def by blast
qed

lemma is_scc_connected:
  assumes SCC: "is_scc E U"
  assumes MEM: "x\<in>U" "y\<in>U"
  shows "(x,y)\<in>E\<^sup>*"
  using assms unfolding is_scc_def by auto

text \<open>In the following, we play around with alternative characterizations, and
  prove them all equivalent .\<close>

text \<open>A common characterization is to define an equivalence relation
  ,,mutually connected'' on nodes, and characterize the SCCs as its
  equivalence classes:\<close>

definition mconn :: "('a\<times>'a) set \<Rightarrow> ('a \<times> 'a) set"
  \<comment> \<open>Mutually connected relation on nodes\<close>
  where "mconn E = E\<^sup>* \<inter> (E\<inverse>)\<^sup>*"

lemma mconn_pointwise:
   "mconn E = {(u,v). (u,v)\<in>E\<^sup>* \<and> (v,u)\<in>E\<^sup>*}"
  by (auto simp add: mconn_def rtrancl_converse)

text \<open>\<open>mconn\<close> is an equivalence relation:\<close>
lemma mconn_refl[simp]: "Id\<subseteq>mconn E"
  by (auto simp add: mconn_def)

lemma mconn_sym: "mconn E = (mconn E)\<inverse>"
  by (auto simp add: mconn_pointwise)

lemma mconn_trans: "mconn E O mconn E = mconn E"
  by (auto simp add: mconn_def)

lemma mconn_refl': "refl (mconn E)"
  by (auto intro: refl_onI simp: mconn_pointwise)

lemma mconn_sym': "sym (mconn E)"
  by (auto intro: symI simp: mconn_pointwise)

lemma mconn_trans': "trans (mconn E)"
  by (metis mconn_def trans_Int trans_rtrancl)

lemma mconn_equiv: "equiv UNIV (mconn E)"
  using mconn_refl' mconn_sym' mconn_trans'
  by (rule equivI)

lemma is_scc_mconn_eqclasses: "is_scc E U \<longleftrightarrow> U \<in> UNIV // mconn E"
  \<comment> \<open>The strongly connected components are the equivalence classes of the
    mutually-connected relation on nodes\<close>
proof
  assume A: "is_scc E U"
  then obtain x where "x\<in>U" unfolding is_scc_def by auto
  hence "U = mconn E `` {x}" using A
    unfolding mconn_pointwise is_scc_def
    apply clarsimp
    apply rule
    apply auto []
    apply clarsimp
    by (metis A is_scc_closed)
  thus "U \<in> UNIV // mconn E"
    by (auto simp: quotient_def)
next
  assume "U \<in> UNIV // mconn E"
  thus "is_scc E U"
    by (auto simp: is_scc_def mconn_pointwise quotient_def)
qed

(* For presentation in the paper *)
lemma "is_scc E U \<longleftrightarrow> U \<in> UNIV // (E\<^sup>* \<inter> (E\<inverse>)\<^sup>*)"
  unfolding is_scc_mconn_eqclasses mconn_def by simp

text \<open>We can also restrict the notion of "reachability" to nodes
  inside the SCC
\<close>

lemma find_outside_node:
  assumes "(u,v)\<in>E\<^sup>*"
  assumes "(u,v)\<notin>(E\<inter>U\<times>U)\<^sup>*"
  assumes "u\<in>U" "v\<in>U"
  shows "\<exists>u'. u'\<notin>U \<and> (u,u')\<in>E\<^sup>* \<and> (u',v)\<in>E\<^sup>*"
  using assms
  apply (induction)
  apply auto []
  apply clarsimp
  by (metis IntI mem_Sigma_iff rtrancl.simps)

lemma is_scc_restrict1:
  assumes SCC: "is_scc E U"
  shows "U\<times>U\<subseteq>(E\<inter>U\<times>U)\<^sup>*"
  using assms
  unfolding is_scc_def
  apply clarsimp
  apply (rule ccontr)
  apply (drule (2) find_outside_node[rotated])
  apply auto []
  by (metis is_scc_closed[OF SCC] mem_Sigma_iff rtrancl_trans subsetD)

lemma is_scc_restrict2:
  assumes SCC: "is_scc E U"
  assumes "V\<supset>U"
  shows "\<not> (V\<times>V\<subseteq>(E\<inter>V\<times>V)\<^sup>*)"
  using assms
  unfolding is_scc_def
  apply clarsimp
  using rtrancl_mono[of "E \<inter> V \<times> V" "E"]
  apply clarsimp
  apply blast
  done

lemma is_scc_restrict3:
  assumes SCC: "is_scc E U"
  shows "((E\<^sup>*``((E\<^sup>*``U) - U)) \<inter> U = {})"
  apply auto
  by (metis assms is_scc_closed is_scc_connected rtrancl_trans)

lemma is_scc_alt_restrict_path:
  "is_scc E U \<longleftrightarrow> U\<noteq>{} \<and>
    (U\<times>U \<subseteq> (E\<inter>U\<times>U)\<^sup>*) \<and> ((E\<^sup>*``((E\<^sup>*``U) - U)) \<inter> U = {})"
  apply rule
  apply (intro conjI)
  apply simp
  apply (blast dest: is_scc_restrict1)
  apply (blast dest: is_scc_restrict3)

  unfolding is_scc_def
  apply rule
  apply clarsimp
  apply (metis (full_types) Int_lower1 in_mono mem_Sigma_iff rtrancl_mono_mp)
  apply blast
  done

lemma is_scc_pointwise:
  "is_scc E U \<longleftrightarrow>
    U\<noteq>{}
  \<and> (\<forall>u\<in>U. \<forall>v\<in>U. (u,v)\<in>(E\<inter>U\<times>U)\<^sup>*)
  \<and> (\<forall>u\<in>U. \<forall>v. (v\<notin>U \<and> (u,v)\<in>E\<^sup>*) \<longrightarrow> (\<forall>u'\<in>U. (v,u')\<notin>E\<^sup>*))"
  \<comment> \<open>Alternative, pointwise characterization\<close>
  unfolding is_scc_alt_restrict_path
  by blast

lemma is_scc_unique:
  assumes SCC: "is_scc E scc" "is_scc E scc'"
  and v: "v \<in> scc" "v \<in> scc'"
  shows "scc = scc'"
proof -
  from SCC have "scc = scc' \<or> scc \<inter> scc' = {}"
    using quotient_disj[OF mconn_equiv]
    by (simp add: is_scc_mconn_eqclasses)
  with v show ?thesis by auto
qed

lemma is_scc_ex1:
  "\<exists>!scc. is_scc E scc \<and> v \<in> scc"
proof (rule ex1I, rule conjI)
  let ?scc = "mconn E `` {v}"
  have "?scc \<in> UNIV // mconn E" by (auto intro: quotientI)
  thus "is_scc E ?scc" by (simp add: is_scc_mconn_eqclasses)
  moreover show "v \<in> ?scc" by (blast intro: refl_onD[OF mconn_refl'])
  ultimately show "\<And>scc. is_scc E scc \<and> v \<in> scc \<Longrightarrow> scc = ?scc"
    by (metis is_scc_unique)
qed

lemma is_scc_ex:
  "\<exists>scc. is_scc E scc \<and> v \<in> scc"
  by (metis is_scc_ex1)

lemma is_scc_connected':
  "\<lbrakk>is_scc E scc; x \<in> scc; y \<in> scc\<rbrakk> \<Longrightarrow> (x,y)\<in>(Restr E scc)\<^sup>*"
  unfolding is_scc_pointwise
  by blast

definition scc_of :: "('v\<times>'v) set \<Rightarrow> 'v \<Rightarrow> 'v set"
  where
  "scc_of E v = (THE scc. is_scc E scc \<and> v \<in> scc)"

lemma scc_of_is_scc[simp]:
  "is_scc E (scc_of E v)"
  using is_scc_ex1[of E v]
  by (auto dest!: theI' simp: scc_of_def)

lemma node_in_scc_of_node[simp]:
  "v \<in> scc_of E v"
  using is_scc_ex1[of E v]
  by (auto dest!: theI' simp: scc_of_def)

lemma scc_of_unique:
  assumes "w \<in> scc_of E v"
  shows "scc_of E v = scc_of E w"
proof -
  have "is_scc E (scc_of E v)" by simp
  moreover note assms
  moreover have "is_scc E (scc_of E w)" by simp
  moreover have "w \<in> scc_of E w" by simp
  ultimately show ?thesis using is_scc_unique by metis
qed

end


header "Stack Machine and Compilation"

theory ASM imports AExp begin

subsection "Stack Machine"

text_raw{*\snip{ASMinstrdef}{0}{1}{% *}
datatype instr = LOADI val | LOAD vname | ADD
text_raw{*}%endsnip*}

text_raw{*\snip{ASMstackdef}{1}{2}{% *}
type_synonym stack = "val list"
text_raw{*}%endsnip*}

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

text{* \noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.*}

text_raw{*\snip{ASMexeconedef}{0}{1}{% *}
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk  =  n # stk" |
"exec1 (LOAD x) s stk  =  s(x) # stk" |
"exec1  ADD _ stk  =  (hd2 stk + hd stk) # tl2 stk"
text_raw{*}%endsnip*}

text_raw{*\snip{ASMexecdef}{1}{2}{% *}
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#is) s stk = exec is s (exec1 i s stk)"
text_raw{*}%endsnip*}

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1@is2) s stk = exec is2 s (exec is1 s stk)"
apply(induction is1 arbitrary: stk)
apply (auto)
done

subsection "Compilation"

text_raw{*\snip{ASMcompdef}{0}{2}{% *}
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw{*}%endsnip*}

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = aval a s # stk"
apply(induction a arbitrary: stk)
apply (auto)
done

end