theory Verification2
  imports Language2
begin

record store =
  s_f\<^sub>A :: nat
  s_f\<^sub>B :: nat
  s_i\<^sub>A :: nat
  s_i\<^sub>B :: nat
  s_fmax :: nat
  s_A :: "nat list"

type_synonym program = "(store \<times> store) llist set"

datatype var = f\<^sub>A | f\<^sub>B | i\<^sub>A | i\<^sub>B | fmax

primrec deref :: "var \<Rightarrow> store \<Rightarrow> nat" where
  "deref f\<^sub>A s = s_f\<^sub>A s"
| "deref f\<^sub>B s = s_f\<^sub>B s"
| "deref i\<^sub>A s = s_i\<^sub>A s"
| "deref i\<^sub>B s = s_i\<^sub>B s"
| "deref fmax s = s_fmax s"

datatype expr = Const nat
              | Var var
              | ALen
              | Lookup expr
              | BinOp "nat \<Rightarrow> nat \<Rightarrow> nat" expr expr
              | Fun "nat \<Rightarrow> nat" expr

primrec eval_expr :: "expr \<Rightarrow> store \<Rightarrow> nat" where
  "eval_expr (Const c) s = c"
| "eval_expr (Var v) s = deref v s"
| "eval_expr ALen s = length (s_A s)"
| "eval_expr (Lookup x) s = s_A s ! eval_expr x s"
| "eval_expr (BinOp f x y) s = f (eval_expr x s) (eval_expr y s)"
| "eval_expr (Fun f x) s = f (eval_expr x s)"

datatype bool_expr = BTrue ("\<one>")
                   | BFalse ("\<zero>")
                   | BDisj bool_expr bool_expr (infixl "\<oplus>" 65)
                   | BConj bool_expr bool_expr (infixl "\<otimes>" 70)
                   | BImpl bool_expr bool_expr (infixl "\<rightharpoonup>" 60)
                   | BIff bool_expr bool_expr
                   | BNot bool_expr
                   | BExpr1 "nat \<Rightarrow> bool" expr
                   | BExpr2 "nat \<Rightarrow> nat \<Rightarrow> bool" expr expr
                   | BArray "nat \<Rightarrow> nat list \<Rightarrow> bool" expr

primrec eval_bool_expr :: "bool_expr \<Rightarrow> store \<Rightarrow> bool" where
  "eval_bool_expr BTrue s = True"
| "eval_bool_expr BFalse s = False"
| "eval_bool_expr (BDisj x y) s = (eval_bool_expr x s \<or> eval_bool_expr y s)"
| "eval_bool_expr (BConj x y) s = (eval_bool_expr x s \<and> eval_bool_expr y s)"
| "eval_bool_expr (BImpl x y) s = (eval_bool_expr x s \<longrightarrow> eval_bool_expr y s)"
| "eval_bool_expr (BIff x y) s = (eval_bool_expr x s \<longleftrightarrow> eval_bool_expr y s)"
| "eval_bool_expr (BNot x) s = (\<not> eval_bool_expr x s)"
| "eval_bool_expr (BExpr1 f x) s = f (eval_expr x s)"
| "eval_bool_expr (BExpr2 f x y) s = f (eval_expr x s) (eval_expr y s)"
| "eval_bool_expr (BArray p x) s = p (eval_expr x s) (s_A s)"

(* no_notation residual_l (infixl "\<leftarrow>" 60) *)

primrec assign :: "var \<Rightarrow> expr \<Rightarrow> store \<Rightarrow> store" (infix "\<leftarrow>" 67) where
  "(f\<^sub>A \<leftarrow> e) s = store.make (eval_expr e s) (s_f\<^sub>B s) (s_i\<^sub>A s) (s_i\<^sub>B s) (s_fmax s) (s_A s)"
| "(f\<^sub>B \<leftarrow> e) s = store.make (s_f\<^sub>A s) (eval_expr e s) (s_i\<^sub>A s) (s_i\<^sub>B s) (s_fmax s) (s_A s)"
| "(i\<^sub>A \<leftarrow> e) s = store.make (s_f\<^sub>A s) (s_f\<^sub>B s) (eval_expr e s) (s_i\<^sub>B s) (s_fmax s) (s_A s)"
| "(i\<^sub>B \<leftarrow> e) s = store.make (s_f\<^sub>A s) (s_f\<^sub>B s) (s_i\<^sub>A s) (eval_expr e s) (s_fmax s) (s_A s)"
| "(fmax \<leftarrow> e) s = store.make (s_f\<^sub>A s) (s_f\<^sub>B s) (s_i\<^sub>A s) (s_i\<^sub>B s) (eval_expr e s) (s_A s)"

primrec e_subst :: "expr \<Rightarrow> expr \<Rightarrow> var \<Rightarrow> expr" where
  "e_subst (Const c) e v = Const c"
| "e_subst (Var v') e v = (if v = v' then e else Var v')"
| "e_subst ALen e v = ALen"
| "e_subst (Lookup x) e v = Lookup (e_subst x e v)"
| "e_subst (BinOp f x y) e v = BinOp f (e_subst x e v) (e_subst y e v)"
| "e_subst (Fun f x) e v = Fun f (e_subst x e v)"

primrec be_subst :: "bool_expr \<Rightarrow> expr \<Rightarrow> var \<Rightarrow> bool_expr" ("_[_\<bar>_]") where
  "be_subst BTrue e v = BTrue"
| "be_subst BFalse e v = BFalse"
| "be_subst (BDisj x y) e v = BDisj (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BConj x y) e v = BConj (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BImpl x y) e v = BImpl (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BIff x y) e v = BIff (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BNot x) e v = BNot (x[e\<bar>v])"
| "be_subst (BExpr1 f x) e v = BExpr1 f (e_subst x e v)"
| "be_subst (BExpr2 f x y) e v = BExpr2 f (e_subst x e v) (e_subst y e v)"
| "be_subst (BArray p x) e v = BArray p (e_subst x e v)"

lemma [simp]: "eval_expr e ((x\<^sub>v \<leftarrow> E) s) = eval_expr (e_subst e E x\<^sub>v) s"
proof (induct e)
  case (Const c)
  show ?case by simp
next
  case (Var v)
  show ?case
    apply (cases x\<^sub>v)
    apply (simp_all add: store.defs)
    apply (cases v, simp_all)
    apply (cases v, simp_all)
    apply (cases v, simp_all)
    apply (cases v, simp_all)
    by (cases v, simp_all)
next
  case ALen
  thus ?case
    by simp
next
  case (Lookup x)
  thus ?case
    by simp
next
  case (BinOp f x y)
  thus ?case
    by simp
next
  case (Fun f x)
  thus ?case
    by simp
qed

lemma assign_eval_bool: "eval_bool_expr (Q[E\<bar>x\<^sub>v]) s \<longleftrightarrow> eval_bool_expr Q ((x\<^sub>v \<leftarrow> E) s)"
proof (induct Q)
  case BTrue
  thus ?case
    by simp
next
  case BFalse
  thus ?case
    by simp
next
  case (BDisj Q1 Q2)
  thus ?case
    by auto
next
  case (BConj Q1 Q2)
  thus ?case
    by simp
next
  case (BImpl Q1 Q2)
  thus ?case
    by simp
next
  case (BIff Q1 Q2)
  thus ?case
    by simp
next
  case (BNot Q)
  thus ?case
    by simp
next
  case (BExpr1 f x)
  thus ?case
    by simp
next
  case (BExpr2 f x y)
  thus ?case
    by simp
next
  case (BArray p x)
  thus ?case
    by auto
qed

definition test :: "bool_expr \<Rightarrow> program" where
  "test P \<equiv> Language2.test (eval_bool_expr P)"

definition sequential_composition :: "program \<Rightarrow> program \<Rightarrow> program" (infixr ";" 52) where
  "X; Y \<equiv> X\<cdot>Y"

definition parallel_composition :: "program \<Rightarrow> program \<Rightarrow> program"
  ("parallel { _ } meanwhile { _ }" [51,51] 55) where
  "parallel { X } meanwhile { Y } \<equiv> X \<parallel> Y"

definition while_loop :: "bool_expr \<Rightarrow> program \<Rightarrow> program" ("while _ { _ }" [51] 55) where
  "while B { P } \<equiv> (test B ; P)\<^sup>\<star>; test (BNot B)"

definition quintuple :: "store rel \<Rightarrow> store rel \<Rightarrow> bool_expr \<Rightarrow> program \<Rightarrow> bool_expr \<Rightarrow> bool"
  ("_, //_ //\<turnstile> \<lbrace>_\<rbrace>// _// \<lbrace>_\<rbrace>" [20,20,20,20,20] 1000) where
  "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace> \<equiv> (X \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G))"

definition preserve :: "bool_expr \<Rightarrow> store rel" where
  "preserve P = {(\<sigma>, \<sigma>'). eval_bool_expr P \<sigma>  \<longrightarrow> eval_bool_expr P \<sigma>'}"

lemma relcomp_elem: "(\<sigma>,\<tau>) \<in> R O S \<longleftrightarrow> (\<exists>\<gamma>. (\<sigma>,\<gamma>) \<in> R \<and> (\<gamma>,\<tau>) \<in> S)"
  by auto

lemma preservation': "eval_bool_expr P \<sigma> \<Longrightarrow> (\<sigma>, \<tau>) \<in> {(\<sigma>, \<sigma>'). eval_bool_expr P \<sigma> \<longrightarrow> eval_bool_expr P \<sigma>'} ^^ n \<Longrightarrow> eval_bool_expr P \<tau>"
proof (induct n arbitrary: \<tau>)
  case 0 thus ?case by simp
next
  case (Suc n)
  from Suc(2) and Suc(3) show ?case
    apply (simp add: relcomp_elem)
    apply (erule exE)
    apply (erule conjE)
    by (metis Suc.hyps)
qed

lemma preservation: "eval_bool_expr P \<sigma> \<Longrightarrow> (\<sigma>, \<tau>) \<in> (preserve P)\<^sup>* \<Longrightarrow> eval_bool_expr P \<tau>"
  apply (simp add: preserve_def)
  apply (drule rtrancl_imp_relpow)
  apply (erule exE)+
  apply (rule preservation')
  by simp_all

lemma test_guar: "test P \<subseteq> guar G"
  by (metis test_def test_in_guar)

lemma preimp_mono: "G \<subseteq> R \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> R \<rightharpoondown> X \<subseteq> G \<rightharpoondown> Y"
  by (metis order_trans preimp_antitone preimp_iso)

lemma Rely_antitone: "G\<^sup>* \<subseteq> R\<^sup>* \<Longrightarrow> R \<rhd> X \<subseteq> G \<rhd> X"
  apply (auto simp add: Rely_def)
  apply (rename_tac x y)
  apply (rule_tac x = y in bexI)
  apply simp_all
  by (metis rely_antitone)

lemma Rely_mono: "G\<^sup>* \<subseteq> R\<^sup>* \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> R \<rhd> X \<subseteq> G \<rhd> Y"
  apply (rule order_trans[where y = "G \<rhd> X"])
  apply (rule Rely_antitone)
  apply simp
  apply (rule prog_rely_iso)
  by auto

lemma l_prod_mono: "X \<subseteq> Y \<Longrightarrow> Z \<subseteq> W \<Longrightarrow> X \<cdot> Z \<subseteq> Y \<cdot> W"
  by (metis seq.mult_isol_var)

lemma guar_mono: "G\<^sup>* \<subseteq> G'\<^sup>* \<Longrightarrow> guar G \<subseteq> guar G'"
  by (auto simp add: guar_def) (metis contra_subsetD)

lemma evaluate_tests [simp]: "test P \<subseteq> test Q \<longleftrightarrow> (\<forall>s. eval_bool_expr P s \<longrightarrow> eval_bool_expr Q s)"
  by (auto simp add: test_def Language2.test_def)

lemma preimp_zero [simp]: "({} \<rightharpoondown> x) = UNIV"
  by (simp add: preimp_def)

lemma preimp_zero_right: "X \<noteq> {} \<Longrightarrow> X \<rightharpoondown> {} = {}"
  by (auto simp add: preimp_def l_prod_def)

abbreviation "\<T> \<equiv> test"

abbreviation "\<P> \<equiv> preserve"

abbreviation "\<F> \<equiv> FIN"

(* ------------------------------------------------------------------------
   Assignment
   ------------------------------------------------------------------------ *)

definition assign_prog :: "var \<Rightarrow> expr \<Rightarrow> (store \<times> store) llist set" (infix ":=" 67) where
  "v := E \<equiv> {(\<sigma>,\<sigma>') # sng (\<sigma>',\<sigma>') |\<sigma> \<sigma>'. \<sigma>' = (v \<leftarrow> E) \<sigma>}"

lemma FIN_test1: "xs \<in> FIN \<cdot> t \<Longrightarrow> x # xs \<in> FIN \<cdot> t"
  by (auto simp add: FIN_def l_prod_def) (metis lappend_code(2) lfinite_LCons)

lemma FIN_test2: "x # xs \<in> t \<Longrightarrow> x # xs \<in> FIN \<cdot> t"
  by (auto simp add: FIN_def l_prod_def) (metis lappend_code(1) lfinite_code(1))

lemma rely_elem1: "env (R\<^sup>*) x \<and> x \<in> X \<Longrightarrow> x \<in> R \<rhd> X"
  by (auto simp add: Rely_def rely_def)

lemma refine_assignment:
  "v := E \<subseteq> \<T> (Q[E\<bar>v]) \<rightharpoondown> (\<P> (Q[E\<bar>v]) \<rhd> \<F> \<cdot> \<T> Q \<inter> guar {(\<sigma>, (v \<leftarrow> E) \<sigma>)|\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>})"
proof (simp only: subset_iff, clarify)
  let ?G = "{(\<sigma>, (v \<leftarrow> E) \<sigma>)|\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>}"

  fix w
  assume "w \<in> v := E"

  then obtain \<sigma> \<sigma>'
  where w_def: "w = (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>')" and \<sigma>'_assign: "\<sigma>' = (v \<leftarrow> E) \<sigma>"
    by (auto simp add: assign_prog_def)

  have "{(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') |\<tau>. eval_bool_expr (Q[E\<bar>v]) \<tau>} \<subseteq> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
  proof (simp only: subset_iff, clarify)
    fix \<tau> assume "eval_bool_expr (Q[E\<bar>v]) \<tau>"

    have "test Q \<noteq> {}"
      by (auto simp add: test_def Language2.test_def) (metis `eval_bool_expr (Q[E\<bar>v]) \<tau>` assign_eval_bool)
    then obtain Q_inhab where "Q_inhab \<in> test Q"
      by (metis all_not_in_conv)

    hence "lfinite Q_inhab"
      by (auto simp add: test_def Language2.test_def)

    show "(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') \<in> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
    proof (cases "(\<tau>, \<sigma>) \<in> (preserve (Q[E\<bar>v]))\<^sup>*")
      assume [simp]: "(\<tau>, \<sigma>) \<in> (preserve (Q[E\<bar>v]))\<^sup>*"
      hence "eval_bool_expr (Q[E\<bar>v]) \<sigma>"
        by (metis `eval_bool_expr (Q[E\<bar>v]) \<tau>` preservation)

      show "(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') \<in> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
        apply (rule rely_elem1)
        apply auto
        apply (rule FIN_test1)
        apply (rule FIN_test1)
        apply (rule FIN_test2)
        apply (simp add: test_def Language2.test_def)
        apply (metis \<sigma>'_assign `eval_bool_expr (Q[E\<bar>v]) \<sigma>` assign_eval_bool)
        apply (rule r_into_rtrancl )
        by (simp add: \<sigma>'_assign `eval_bool_expr (Q[E\<bar>v]) \<sigma>`)
    next
      assume \<tau>\<sigma>: "(\<tau>, \<sigma>) \<notin> (preserve (Q[E\<bar>v]))\<^sup>*"

      show "(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') \<in> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
        apply (auto simp add: Rely_def)
        apply (rule_tac x = "(\<tau>, \<tau>) # (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # Q_inhab" in bexI)
        apply (simp add: rely_def)
        apply (rule disjI1)
        apply (rule_tac x = "LNil" in exI)
        apply (rule_tac x = \<tau> in exI)
        apply (rule_tac x = \<tau> in exI)
        apply (rule_tac x = \<sigma> in exI)
        apply (simp_all add: \<tau>\<sigma>)
        apply auto
        apply (simp add: \<open>lfinite Q_inhab\<close>)
        apply (metis FIN_def FIN_test1 LCons_in_l_prod `Q_inhab \<in> test Q` lfinite_LCons lfinite_code(1) mem_Collect_eq)
        apply (rule subsetD[of "test Q"])
        by (simp_all add: test_guar `Q_inhab \<in> test Q`)
    qed
  qed
  hence "{sng (\<sigma>, \<sigma>) |\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>} \<cdot> {w} \<subseteq> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
    apply (simp add: w_def)
    apply (subst fin_l_prod)
    by (auto simp add: fin_l_prod FIN_def)
  thus "w \<in> test (Q[E\<bar>v]) \<rightharpoondown> (preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G)"
    by (simp only: preimp_elem_var test_def Language2.test_def)
qed

lemma assignment_rule:
  assumes "R\<^sup>* \<subseteq> (\<P> (Q[E\<bar>v]))\<^sup>*"
  and "{(\<sigma>, (v \<leftarrow> E) \<sigma>)|\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>}\<^sup>* \<subseteq> G\<^sup>*"
  and "test P \<subseteq> test (Q[E\<bar>v])"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> v := E \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (rule subset_trans[OF refine_assignment[where Q = Q]])
  apply (rule preimp_mono[OF assms(3)])
  apply (rule Rely_mono[OF assms(1)])
  apply (rule Int_mono[OF order_refl])
  by (rule guar_mono[OF assms(2)])

(* ------------------------------------------------------------------------
   Sequential Composition
   ------------------------------------------------------------------------ *)

lemma tests_finite: "test P \<subseteq> \<F>"
  by (simp add: test_def tests_finite)

lemma test_preimp: "test P \<cdot> (test P \<rightharpoondown> X) \<subseteq> X"
  by (metis preimp_galois_3 tests_finite)

lemma test_inter_guar [simp]: "test P \<inter> guar G = test P"
  by (simp add: test_def)

lemma refine_sequential: "(test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test S \<inter> guar G)) \<cdot> (test S \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)) \<le> (test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G))"
  apply (subst preimp_galois_2[symmetric, OF tests_finite])
  apply (simp only: l_prod_assoc[symmetric])
  apply (rule subset_trans[OF l_prod_isol[OF test_preimp]])
  apply (simp only: guar_lprod test_inter_guar)
  apply (rule subset_trans[OF rely_l_prod_var])
  defer
  apply (simp only: l_prod_assoc)
  apply (rule subset_trans[OF prog_rely_iso[OF l_prod_isor[OF test_preimp]]])
  apply (rule subset_trans[OF prog_rely_iso[OF rely_l_prod_var2]])
  defer
  apply (rule subset_trans[OF rely_idem])
  apply (simp only: l_prod_assoc[symmetric] guar_lprod[symmetric])
  apply (rule subset_trans[OF prog_rely_iso[OF l_prod_isol[OF inter_isol[OF FIN_FIN]]]])
  by (rule order_refl)

lemma sequential_rule: "R, G \<turnstile> \<lbrace>P\<rbrace> x \<lbrace>S\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>S\<rbrace> y \<lbrace>Q\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> x \<cdot> y \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst subset_trans[where B = "(test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test S \<inter> guar G)) \<cdot> (test S \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G))"])
  apply (rule l_prod_mono)
  apply simp_all
  by (rule refine_sequential)

(* ------------------------------------------------------------------------
   If Statement
   ------------------------------------------------------------------------ *)

lemma one_test_pre: "test P \<cdot> X = {(\<sigma>,\<sigma>) # x |\<sigma> x. eval_bool_expr P \<sigma> \<and> x \<in> X}"
  apply (subst fin_l_prod)
  apply (metis tests_finite)
  apply (simp add: test_def)
  apply (auto simp add: Language2.test_def)
  by (metis lappend_code(1) lappend_code(2))

lemma two_tests_pre: "test P \<cdot> test S \<cdot> X = {(\<sigma>,\<sigma>) # (\<sigma>',\<sigma>') # x |\<sigma> \<sigma>' x. eval_bool_expr P \<sigma> \<and> eval_bool_expr S \<sigma>' \<and> x \<in> X}"
  apply (subst fin_l_prod)
  apply (metis tests_finite)
  apply (subst fin_l_prod)
  apply (simp add: test_def Language2.test_def FIN_def)
  apply (metis lfinite_LCons lfinite_code(1) lfinite_lappend)
  apply (auto simp add: test_def Language2.test_def)
  by (metis lappend_code(1) lappend_code(2))

lemma rely_cons_eq: "rely R (x # xs) (y # ys) \<Longrightarrow> x = y"
  apply (auto simp add: rely_def)
  apply (metis (erased, hide_lams) lappend_code(1) lappend_code(2) lhd_LCons llist.exhaust)
  by (metis (erased, hide_lams) lappend_code(1) lappend_code(2) lhd_LCons llist.exhaust)

definition fpres :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> bool" where
  "fpres x y \<equiv> lfinite x = lfinite y"

lemma rely_fpres_def: "rely R x y \<equiv> (\<exists>z \<sigma> \<sigma>' \<tau> \<tau>' \<tau>'' x' y'. x = z \<frown> ((\<sigma>,\<sigma>') # (\<tau>,\<tau>') # x')
                                       \<and> y = z \<frown> ((\<sigma>,\<sigma>') # (\<tau>,\<tau>'') # y')
                                       \<and> (\<sigma>',\<tau>) \<notin> (R\<^sup>*)
                                       \<and> lfinite z
                                       \<and> fpres x' y'
                                       \<and> env (R\<^sup>*) (z \<frown> ((\<sigma>,\<sigma>') # LNil))) \<or> x = y"
  by (simp add: fpres_def rely_def)

lemma rely_cons_lem: "rely R ((\<gamma>', \<gamma>') # x) ((\<gamma>', \<gamma>') # y) \<Longrightarrow> rely R ((\<gamma>, \<gamma>) # (\<gamma>', \<gamma>') # x) ((\<gamma>, \<gamma>) # (\<gamma>', \<gamma>') # y)"
  apply (cases "(\<gamma>, \<gamma>') \<in> R\<^sup>*")
  apply (auto simp add: rely_fpres_def)
  apply (rule_tac x = "(\<gamma>, \<gamma>) # z" in exI)
  apply (rule_tac x = \<sigma> in exI)
  apply (rule_tac x = \<sigma>' in exI)
  apply (rule_tac x = \<tau> in exI)
  apply (rule_tac x = \<tau>' in exI)
  apply (rule_tac x = \<tau>'' in exI)
  apply (rule_tac x = x' in exI)
  apply (intro conjI)
  apply simp
  apply (rule_tac x = y' in exI)
  apply simp
  apply (metis env_lem1 prod.sel(1) prod.sel(2))
  apply (rule_tac x = LNil in exI)
  apply (rule_tac x = \<gamma> in exI)
  apply (rule_tac x = \<gamma> in exI)
  apply (rule_tac x = \<gamma>' in exI)
  apply (rule_tac x = \<gamma>' in exI)
  apply (rule_tac x = \<gamma>' in exI)
  apply (rule_tac x = x in exI)
  apply simp_all
  apply (rule_tac x = y in exI)
  apply simp
  apply (simp add: fpres_def)
  by (metis lfinite_code(2) lfinite_lappend)

lemma stutter_1: "x \<in> FIN \<cdot> test Q \<inter> guar G \<Longrightarrow> rely R x ((\<sigma>', \<sigma>') # t') \<Longrightarrow> rely R ((\<sigma>, \<sigma>) # x) ((\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t')"
  apply (cases x)
  apply simp
  defer
  apply simp
  apply (frule rely_cons_eq)
  apply simp
  apply (metis rely_cons_lem)
proof -
  assume "rely R LNil ((\<sigma>', \<sigma>') # t')"
  hence False by (simp add: LNil_eq_lappend_iff rely_def)
  thus "rely R (sng (\<sigma>, \<sigma>)) ((\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t')" by meson
qed

lemma double_test1:
  assumes "\<And>t. t \<in> test P \<cdot> x \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test S \<cdot> test P \<cdot> x"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from assms(2)
  obtain \<sigma> \<sigma>' t'
  where "t = (\<sigma>,\<sigma>) # (\<sigma>',\<sigma>') # t'" and "t' \<in> x" and "eval_bool_expr S \<sigma>" and "eval_bool_expr P \<sigma>'"
    by (simp add: two_tests_pre) metis

  hence "(\<sigma>',\<sigma>') # t' \<in> test P \<cdot> x"
    by (simp add: one_test_pre)

  hence "(\<sigma>',\<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    by (metis assms(1))

  hence "(\<sigma>,\<sigma>) # (\<sigma>',\<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    apply (simp add: Rely_def)
    apply (erule bexE)
    apply (rule_tac x = "(\<sigma>,\<sigma>) # x" in bexI)
    apply (rule stutter_1)
    apply simp_all
    by (metis FIN_test1)

  thus ?thesis
    by (metis `t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'`)
qed

lemma double_test2: "test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<le> test S \<cdot> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (auto simp add: subset_iff preimp_def)
  apply (rule_tac x = x in exI)
  apply auto
  by (metis double_test1)

lemma mumble_lem1': "(\<sigma>',\<sigma>) \<in> R\<^sup>* \<Longrightarrow> rely R ((\<sigma>', \<sigma>') # x) ((\<sigma>', \<sigma>') # (\<sigma>, \<sigma>) # y) \<Longrightarrow> rely R x ((\<sigma>, \<sigma>) # y)"
  apply (simp add: rely_fpres_def)
  apply auto
  apply (subgoal_tac "\<exists>z'. z = (\<sigma>', \<sigma>') # z'")
  apply (erule exE)+
  apply simp
  apply (rule_tac x = z' in exI)
  apply (rule_tac x = \<sigma>'' in exI)
  apply (rule_tac x = \<sigma>''' in exI)
  apply (rule_tac x = \<tau> in exI)
  apply (rule_tac x = \<tau>' in exI)
  apply (rule_tac x = \<tau>'' in exI)
  apply (rule_tac x = x' in exI)
  apply simp
  apply (rule_tac x = y' in exI)
  apply simp
  apply (metis env_tl)
  apply (subgoal_tac "z = LNil \<or> (\<exists>\<gamma> \<gamma>' z''. z = (\<gamma>, \<gamma>') # z'')")
  apply (erule disjE)
  apply simp
  apply (erule exE)+
  apply simp
  by (metis llist.exhaust prod.collapse)

lemma mumble_lem1: "(\<sigma>',\<sigma>) \<in> R\<^sup>*  \<Longrightarrow> x \<in> FIN \<cdot> test Q \<inter> guar G \<Longrightarrow> rely R x ((\<sigma>', \<sigma>') # (\<sigma>, \<sigma>) # t') \<Longrightarrow> rely R (ltl x) ((\<sigma>, \<sigma>) # t')"
  apply (cases x)
  apply simp
  defer
  apply simp
  apply (frule rely_cons_eq)
  apply simp
  apply (metis mumble_lem1')
  by (smt LNil_eq_lappend_iff llist.distinct(1) rely_def)

lemma double_tests: "test P \<cdot> test Q = {(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # LNil |\<sigma> \<sigma>'. eval_bool_expr P \<sigma> \<and> eval_bool_expr Q \<sigma>'}"
  apply (auto simp add: test_def Language2.test_def l_prod_def)
  apply (metis lappend_code(1) lappend_code(2) lfinite_LCons lfinite_code(1))
  by (metis lappend_code(1) lappend_code(2) lfinite_LCons lfinite_code(1))

lemma triple_tests: "test P \<cdot> test Q \<cdot> test S = {(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # (\<sigma>'', \<sigma>'') # LNil |\<sigma> \<sigma>' \<sigma>''. eval_bool_expr P \<sigma> \<and> eval_bool_expr Q \<sigma>' \<and> eval_bool_expr S \<sigma>''}"
  apply (auto simp add: test_def Language2.test_def l_prod_def)
  by (metis lappend_code(1) lappend_code(2) lfinite_LCons lfinite_code(1))+

lemma preimp_2_l_prod: "Z \<subseteq> FIN \<Longrightarrow> Y \<subseteq> FIN \<Longrightarrow> X \<le> Y \<rightharpoondown> Z \<rightharpoondown> W \<longleftrightarrow> X \<le> Z \<cdot> Y \<rightharpoondown> W"
proof -
  assume a1: "Y \<subseteq> FIN"
  assume a2: "Z \<subseteq> FIN"
  hence "\<And>x\<^sub>1. FIN \<rightharpoondown> x\<^sub>1 \<subseteq> Z \<rightharpoondown> x\<^sub>1" by (simp add: preimp_antitone)
  hence "Z \<cdot> Y \<subseteq> FIN" using a1 a2 by (metis (no_types) FIN_FIN order_refl order_trans preimp_galois_2)
  thus "(X \<subseteq> Y \<rightharpoondown> Z \<rightharpoondown> W) = (X \<subseteq> Z \<cdot> Y \<rightharpoondown> W)" using a1 a2 by (metis (no_types) l_prod_assoc preimp_galois_2)
qed

lemma test2_conj':
  assumes "\<And>t. t \<in> test (P \<otimes> B) \<cdot> X \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test P \<cdot> test B \<cdot> X"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from `t \<in> test P \<cdot> test B \<cdot> X`
  obtain \<sigma> \<sigma>' t'
  where t_def: "t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>'" and "t' \<in> X"
    by (simp add: two_tests_pre) metis

  from `test Q \<noteq> {}`
  obtain \<sigma>''
  where "eval_bool_expr Q \<sigma>''"
    by (auto simp add: test_def Language2.test_def)
  hence "sng (\<sigma>'', \<sigma>'') \<in> test Q"
    by (auto simp add: test_def Language2.test_def)

  {
    assume "(\<sigma>, \<sigma>') \<notin> (preserve P)\<^sup>*"

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (auto simp add: Rely_def)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'', \<sigma>'')" in bexI)
      apply (rule rely_antitone[OF `R\<^sup>* \<subseteq> (preserve P)\<^sup>*`])
      apply (simp add: rely_def)
      apply (rule disjI1)
      apply (rule_tac x = LNil in exI)
      apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
      apply (rule_tac x = \<sigma>' in exI)
      apply simp
      prefer 2
      apply (metis FIN_test1 FIN_test2 Int_iff `sng (\<sigma>'', \<sigma>'') \<in> test Q` guar_LCons_eq guar_singleton rtrancl.rtrancl_refl)
      sorry

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  moreover
  {
    assume "(\<sigma>, \<sigma>') \<in> (preserve P)\<^sup>*"

    from preservation[OF `eval_bool_expr P \<sigma>` this] and `eval_bool_expr B \<sigma>'`
    have "sng (\<sigma>', \<sigma>') \<in> test (P \<otimes> B)"
      by (simp add: test_def Language2.test_def)

    hence "(\<sigma>', \<sigma>') # t' \<in> test (P \<otimes> B) \<cdot> X"
      by (metis LCons_in_l_prod `t' \<in> X`)

    hence "(\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis assms(1))

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (simp add: Rely_def)
      apply (erule bexE)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # x" in bexI)
      apply (metis stutter_1)
      apply auto
      by (metis FIN_test1)

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  ultimately show ?thesis by blast
qed

lemma llength_ge_1: "llength x > 1 \<Longrightarrow> \<exists>x1 x2 x3. x = x1 # x2 # x3"
  by (metis eSuc_enat iless_Suc_eq less_imp_le llength_LCons llength_eq_0 llist.collapse(2) neq_iff one_eSuc zero_enat_def)

lemma post_ltl: "llength x > 1 \<Longrightarrow> x \<in> \<F> \<cdot> \<T> Q \<Longrightarrow> ltl x \<in> \<F> \<cdot> \<T> Q"
  apply (drule llength_ge_1)
  apply (erule exE)+
  apply simp
  apply (auto simp add: FIN_def l_prod_def test_def Language2.test_def)
  by (metis lappend_code(1) lfinite.simps llist.distinct(1) llist.sel(3) ltl_lappend)

lemma [simp]: "xa = x21 # x22 \<frown> ((\<sigma>', \<sigma>'') # (\<tau>, \<tau>') # x') \<Longrightarrow> z = x21 # x22 \<Longrightarrow> llength x22 + eSuc (eSuc (llength x')) \<noteq> 0"
  apply (cases x22)
  apply simp_all
  by (simp add: plus_enat_eq_0_conv)

lemma eSuc_0_llength_lem: "xa = z \<frown> ((\<sigma>', \<sigma>'') # (\<tau>, \<tau>') # x') \<Longrightarrow> eSuc 0 < llength xa"
  apply (cases z)
  by simp_all

lemma guar_ltl: "x \<in> guar G \<Longrightarrow> ltl x \<in> guar G"
  by (cases x) simp_all

lemma test2_conj'_opp_lem:
  "(\<sigma>, \<sigma>) # (\<sigma>, \<sigma>) # x \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G \<Longrightarrow> (\<sigma>, \<sigma>) # x \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  apply (auto simp add: Rely_def)
  apply (rule_tac x = "ltl xa" in bexI)
  apply (meson Int_iff mumble_lem1 rtrancl.rtrancl_refl)
  apply auto
  apply (rule post_ltl)
  apply simp_all
  apply (simp add: rely_def)
  apply (erule disjE)
  prefer 2
  apply (simp_all add: one_eSuc)
  apply (erule exE)+
  apply (erule conjE)+
  apply (erule exE)+
  apply (meson eSuc_0_llength_lem)
  by (metis guar_ltl)

lemma test2_conj'_opp:
  assumes "\<And>t. t \<in> test P \<cdot> test B \<cdot> X \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test (P \<otimes> B) \<cdot> X"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from `t \<in> test (P \<otimes> B) \<cdot> X`
  obtain \<sigma> t'
  where t_def: "t = (\<sigma>, \<sigma>) # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>" and "t' \<in> X"
    by (auto simp add: test_def Language2.test_def l_prod_def)

  from `test Q \<noteq> {}`
  obtain \<sigma>'
  where "eval_bool_expr Q \<sigma>'"
    by (auto simp add: test_def Language2.test_def)
  hence "sng (\<sigma>', \<sigma>') \<in> test Q"
    by (auto simp add: test_def Language2.test_def)

  from `eval_bool_expr P \<sigma>` and `eval_bool_expr B \<sigma>` and `t' \<in> X`
  have "(\<sigma>, \<sigma>) # (\<sigma>, \<sigma>) # t' \<in> test P \<cdot> test B \<cdot> X"
    apply (simp only: l_prod_assoc)
    apply (rule LCons_in_l_prod)
    apply (simp add: test_def Language2.test_def)
    apply (rule LCons_in_l_prod)
    apply (simp add: test_def Language2.test_def)
    by simp

  hence "(\<sigma>, \<sigma>) # (\<sigma>, \<sigma>) # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    using assms(1) by blast

  hence "(\<sigma>, \<sigma>) # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    using test2_conj'_opp_lem by blast

  then show ?thesis
    using t_def by blast
qed

lemma [simp]: "\<F> \<cdot> {} = {}"
  by (auto simp add: l_prod_def FIN_def)

lemma [simp]: "\<T> P \<cdot> {} = {}"
  by (auto simp add: l_prod_def test_def Language2.test_def)

lemma [simp]: "R \<rhd> {} = {}"
  by (auto simp add: Rely_def)

lemma test2_conj_var:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test (P \<otimes> B) \<noteq> {}"
  shows "test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (cases "test Q = {}")
  apply simp
  apply (cases "test P = {}")
  apply simp
  apply (cases "test B = {}")
  apply simp
  apply (subst preimp_zero_right)
  apply (rule assms(2))
  apply (subst preimp_zero_right)
  apply (metis FIN_l_prod empty_subsetI preimp_galois_2 preimp_zero_right subset_antisym)
  apply simp
  apply (simp add: preimp_def subset_iff)
  apply (intro allI impI)
  apply (erule exE)+
  apply (rule_tac x = x in exI)
  apply auto
  by (metis (mono_tags, hide_lams) all_not_in_conv assms(1) test2_conj')

lemma test2_conj:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (simp add: preimp_def subset_iff)
  apply (intro allI impI)
  apply (erule exE)+
  apply (rule_tac x = x in exI)
  apply auto
  apply (rule test2_conj')
  apply auto
  apply (metis assms(1) contra_subsetD)
  by (metis assms(2))

lemma test2_conj_opp:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (simp add: preimp_def subset_iff)
  apply (intro allI impI)
  apply (erule exE)+
  apply (rule_tac x = x in exI)
  apply auto
  apply (rule test2_conj'_opp)
  apply auto
  apply (metis assms(1) contra_subsetD)
  by (metis assms(2))

lemma test2_conj_eq:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) = test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  by (simp add: assms(1) assms(2) subset_antisym test2_conj test2_conj_opp)

lemma empty_test_pair:
  assumes "test (P \<otimes> B) = {}"
  and "test Q \<noteq> {}"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  shows "test P \<cdot> test B \<cdot> X \<subseteq> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof (auto simp add: subset_iff)
  fix t
  assume "t \<in> test P \<cdot> test B \<cdot> X"

  then obtain \<sigma> \<sigma>' t'
  where "t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>'" and "t' \<in> X"
    by (simp add: two_tests_pre) metis

  from `eval_bool_expr B \<sigma>'` and assms(1) have "\<not> eval_bool_expr P \<sigma>'"
    by (auto simp add: Language2.test_def test_def)

  from `test Q \<noteq> {}`
  obtain \<sigma>''
  where "eval_bool_expr Q \<sigma>''"
    by (auto simp add: Language2.test_def test_def)
  hence "sng (\<sigma>'', \<sigma>'') \<in> test Q"
    by (auto simp add: Language2.test_def test_def)

  hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    apply (auto simp add: Rely_def)
    apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'', \<sigma>'')" in bexI)
    apply (rule rely_antitone[OF assms(3)])
    apply (auto simp add: rely_def)
    apply (rule_tac x = LNil in exI)
    apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
    apply (rule_tac x = \<sigma>' in exI)
    apply (rule_tac x = \<sigma>' in exI)
    apply (rule_tac x = \<sigma>' in exI)
    apply (rule_tac x = "sng (\<sigma>'', \<sigma>'')" in exI)
    apply (intro conjI)
    apply simp
    apply (rule_tac x = "t'" in exI)
    apply simp_all
    apply (intro conjI)
    apply (metis `\<not> eval_bool_expr P \<sigma>'` `eval_bool_expr P \<sigma>` preservation)
    prefer 2
    apply (metis FIN_test1 FIN_test2)
    sorry

  thus "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    by (metis `t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'`)
qed

lemma "test P = {} \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace>"
  by (auto simp add: quintuple_def)

lemma zero_rule: "R, G \<turnstile> \<lbrace>P\<rbrace> {} \<lbrace>Q\<rbrace>"
  by (simp add: quintuple_def)

lemma conj_empty: "test (P \<otimes> B) = {} \<Longrightarrow> test (P \<otimes> (BNot B)) = test P"
  by (auto simp add: test_def Language2.test_def)

lemma conj_empty2: "test (P \<otimes> BNot B) = {} \<Longrightarrow> test (P \<otimes> B) = test P"
  by (auto simp add: test_def Language2.test_def)

lemma test_to_precondition_var: "test (P \<otimes> B) \<noteq> {} \<Longrightarrow> R\<^sup>* \<subseteq> (preserve P)\<^sup>* \<Longrightarrow> R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (simp only: l_prod_assoc[symmetric])
  apply (subst preimp_galois_2)
  apply (simp add: tests_finite)
  apply (rule subset_trans[OF _ test2_conj_var])
  by simp_all

lemma test_to_precondition: "test Q \<noteq> {} \<Longrightarrow> R\<^sup>* \<subseteq> (preserve P)\<^sup>* \<Longrightarrow> R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (simp only: l_prod_assoc[symmetric])
  apply (subst preimp_galois_2)
  apply (simp add: tests_finite)
  apply (rule subset_trans[OF _ test2_conj])
  by simp_all

lemma FIN_l_prod_ex: "z \<in> FIN \<cdot> X \<Longrightarrow> \<exists>z'. z' \<in> X"
  by (auto simp add: FIN_def l_prod_def)

lemma test_conj_leq1: "test (P \<otimes> B) \<subseteq> test P"
  by (auto simp add: test_def Language2.test_def)

lemma test_conj_leq2: "test (B \<otimes> P) \<subseteq> test P"
  by (auto simp add: test_def Language2.test_def)

lemma test_conj_2:
  assumes "\<And>t. t \<in> test P \<cdot> X \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test P \<cdot> test B \<cdot> X"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from assms(2)
  obtain \<sigma> \<sigma>' t'
  where t_def: "t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>'" and "t' \<in> X"
    by (simp add: two_tests_pre) metis

  hence "(\<sigma>, \<sigma>) # t' \<in> test P \<cdot> X"
    apply -
    apply (rule LCons_in_l_prod)
    by (auto simp add: test_def Language2.test_def)

  hence "(\<sigma>, \<sigma>) # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    by (metis assms(1))

  then obtain \<sigma>'' where "sng (\<sigma>'', \<sigma>'')  \<in> test Q"
    apply (auto simp add: Rely_def)
    apply (drule FIN_l_prod_ex)
    by (auto simp add: Language2.test_def test_def)

  {
    assume "(\<sigma>, \<sigma>') \<notin> (preserve P)\<^sup>*"

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (auto simp add: Rely_def)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'', \<sigma>'')" in bexI)
      apply (rule rely_antitone[OF `R\<^sup>* \<subseteq> (preserve P)\<^sup>*`])
      apply (simp add: rely_def)
      apply (rule disjI1)
      apply (rule_tac x = LNil in exI)
      apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
      apply (rule_tac x = \<sigma>' in exI)
      apply simp
      prefer 2
      apply (metis FIN_test1 FIN_test2 Int_iff `sng (\<sigma>'', \<sigma>'') \<in> test Q` guar_LCons_eq guar_singleton rtrancl.rtrancl_refl)
      sorry

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  moreover
  {
    assume "(\<sigma>, \<sigma>') \<in> (preserve P)\<^sup>*"

    from preservation[OF `eval_bool_expr P \<sigma>` this] and `eval_bool_expr B \<sigma>'`
    have "sng (\<sigma>', \<sigma>') \<in> test (P \<otimes> B)"
      by (simp add: test_def Language2.test_def)

    hence "(\<sigma>', \<sigma>') # t' \<in> test (P \<otimes> B) \<cdot> X"
      by (metis LCons_in_l_prod `t' \<in> X`)

    also have "... \<subseteq> test P \<cdot> X"
      by (metis l_prod_isol test_conj_leq1)

    finally have "(\<sigma>', \<sigma>') # t' \<in> test P \<cdot> X" .

    hence "(\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis assms(1))

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (simp add: Rely_def)
      apply (erule bexE)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # x" in bexI)
      apply (metis stutter_1)
      apply auto
      by (metis FIN_test1)

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  ultimately show ?thesis by blast
qed

lemma test_conj_3:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  shows "test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (simp add: subset_iff)
  apply (simp add: preimp_def)
  apply auto
  apply (rule_tac x = x in exI)
  apply (simp add: subset_iff)
  apply (intro allI impI)
  apply (rule test_conj_2)
  apply auto
  by (metis assms contra_subsetD)

lemma choice_rule:
  assumes "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace>"
  and "R, G \<turnstile> \<lbrace>P\<rbrace> Y \<lbrace>Q\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> X \<union> Y \<lbrace>Q\<rbrace>"
  using assms
  by (simp add: quintuple_def)

lemma if_rule:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  and "R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace>"
  and "R, G \<turnstile> \<lbrace>P \<otimes> (BNot B)\<rbrace> Y \<lbrace>Q\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<union> test (BNot B) \<cdot> Y \<lbrace>Q\<rbrace>"
  apply (rule choice_rule)
  apply (rule test_to_precondition)
  apply (simp_all add: assms)
  apply (rule test_to_precondition)
  by (simp_all add: assms)

lemma if_rule_var:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test (P \<otimes> B) \<noteq> {}"
  and "test (P \<otimes> BNot B) \<noteq> {}"
  and "R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace>"
  and "R, G \<turnstile> \<lbrace>P \<otimes> (BNot B)\<rbrace> Y \<lbrace>Q\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<union> test (BNot B) \<cdot> Y \<lbrace>Q\<rbrace>"
  apply (rule choice_rule)
  apply (rule test_to_precondition_var)
  apply (simp_all add: assms)
  apply (rule test_to_precondition_var)
  by (simp_all add: assms)

definition "skip \<equiv> {LNil}"

lemma remove_Rely: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> R \<rhd> Y"
  by (metis Rely_ext Un_subset_iff sup.absorb1)

lemma skip_rule: "R, G \<turnstile> \<lbrace>P\<rbrace> skip \<lbrace>P\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (rule remove_Rely)
  apply (simp add: skip_def)
  apply auto
  apply (metis (erased, hide_lams) FIN_def contra_subsetD empty_subsetI insert_subset l_prod_isol lfinite_LNil mem_Collect_eq seq.mult.left_neutral)
  by (metis contra_subsetD test_def test_in_guar)

lemma star_inductl_one_skip: "skip \<union> x \<cdot> y \<subseteq> y \<Longrightarrow> x\<^sup>\<star> \<subseteq> y"
  apply (rule seq.star_inductl_one[rule_format])
  by (simp add: skip_def)

lemma refine_skip [simp]: "skip \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"
  using skip_rule
  by (simp add: quintuple_def)

lemma star_rule:
  assumes "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>P\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> X\<^sup>\<star> \<lbrace>P\<rbrace>"
  using assms
proof (simp add: quintuple_def)
  assume "X \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"

  moreover have "(test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G))\<^sup>\<star> \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"
    by (rule star_inductl_one_skip[rule_format]) (simp add: refine_sequential)

  ultimately show "X\<^sup>\<star> \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"
    by (metis (erased, hide_lams) inf.absorb2 inf_commute seq.star_ext seq.star_iso)
qed

lemma while_lem1:
  assumes "R\<^sup>* \<subseteq> (preserve I)\<^sup>*"
  and "test (BNot P \<otimes> I) \<noteq> {}"
  shows "test I \<cdot> test (BNot P) \<subseteq> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
proof -
  from assms(2) obtain \<sigma>''
  where "sng (\<sigma>'', \<sigma>'') \<in> test (BNot P \<otimes> I)"
    by (smt Collect_empty_eq mem_Collect_eq test_def Language2.test_def)

  {
    fix t
    assume "t \<in> test I \<cdot> test (BNot P)"

    then obtain \<sigma> \<sigma>'
    where t_def: "t = (\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>')" and "eval_bool_expr I \<sigma>" and "eval_bool_expr (BNot P) \<sigma>'"
      by (simp add: double_tests) blast

    {
      assume "(\<sigma>, \<sigma>') \<in> (preserve I)\<^sup>*"

      hence "eval_bool_expr I \<sigma>'"
        by (metis `eval_bool_expr I \<sigma>` preservation)

      hence "eval_bool_expr (BNot P \<otimes> I) \<sigma>'"
        by (metis `eval_bool_expr (BNot P) \<sigma>'` eval_bool_expr.simps(4))

      hence "sng (\<sigma>', \<sigma>') \<in> test (BNot P \<otimes> I)"
        by (simp add: test_def Language2.test_def)

      hence "(\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>') \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        apply (auto simp add: Rely_def)
        apply (rule_tac x = "(\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>')" in bexI)
        apply (rule rely_refl)
        apply auto
        by (metis FIN_test1 FIN_test2)

      hence "t \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        by (simp add: t_def)
    }
    moreover
    {
      assume "(\<sigma>, \<sigma>') \<notin> (preserve I)\<^sup>*"

      hence "(\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>') \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        apply (auto simp add: Rely_def)
        apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'',\<sigma>'')" in bexI)
        apply (simp add: rely_def)
        apply (rule_tac x = LNil in exI)
        apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
        apply (rule_tac x = \<sigma>' in exI)
        apply simp_all
        apply (metis assms(1) contra_subsetD)
        by (metis FIN_test1 FIN_test2 `sng (\<sigma>'', \<sigma>'') \<in> test (BNot P \<otimes> I)`)

      hence "t \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        by (simp add: t_def)
    }
    ultimately have "t \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G" by blast
  }
  thus ?thesis
    by blast
qed

lemma "test P \<noteq> {} \<longleftrightarrow> (\<exists>\<sigma>. eval_bool_expr P \<sigma>)"
  by (auto simp add: test_def Language2.test_def)

lemma while_rule:
  assumes "R\<^sup>* \<subseteq> (preserve I)\<^sup>*"
  and "test (BNot P \<otimes> I) \<noteq> {}"
  and "test (I \<otimes> P) \<noteq> {}"
  and "R, G \<turnstile> \<lbrace>I \<otimes> P\<rbrace> X \<lbrace>I\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>I\<rbrace> (test P \<cdot> X)\<^sup>\<star> \<cdot> test (BNot P) \<lbrace>(BNot P) \<otimes> I\<rbrace>"
  apply (simp add: quintuple_def)
  apply (rule seq.star_inductl[rule_format])
  apply simp
  apply (intro conjI)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (rule while_lem1[OF assms(1) assms(2)])
  using assms(4)
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (subst l_prod_assoc)
  apply (subst l_prod_assoc[symmetric])
  apply (subst preimp_galois_2)
  apply (simp add: tests_finite)
  apply (rule subset_trans[OF _ test2_conj_var[OF assms(1) assms(3)]])
  apply (rule subset_trans)
  prefer 2
  apply (rule refine_sequential[where S = "I"])
  by (metis l_prod_isol)

(* ------------------------------------------------------------------------
   Parallel Rule
   ------------------------------------------------------------------------ *)

lemma weakening:
  assumes "test P' \<subseteq> test P"
  and "test Q \<subseteq> test Q'"
  and "R'\<^sup>* \<subseteq> R\<^sup>*"
  and "G\<^sup>* \<subseteq> G'\<^sup>*"
  and "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace>"
  shows "R', G' \<turnstile> \<lbrace>P'\<rbrace> X \<lbrace>Q'\<rbrace>"
  using assms
  apply (simp only: quintuple_def)
  apply (erule_tac subset_trans)
  apply (rule preimp_mono)
  apply simp
  apply (rule Rely_mono)
  apply simp
  by (metis guar_mono inf_mono l_prod_isor)

(* ------------------------------------------------------------------------
   Parallel Rule
   ------------------------------------------------------------------------ *)

lemma parallel_rule:
  assumes "(R \<union> G\<^sub>1)\<^sup>* \<subseteq> (R\<^sub>2)\<^sup>*"
  and "(R \<union> G\<^sub>2)\<^sup>* \<subseteq> R\<^sub>1\<^sup>*"
  and "(G\<^sub>1 \<union> G\<^sub>2)\<^sup>* \<subseteq> G\<^sup>*"
  and "R\<^sub>1, G\<^sub>1 \<turnstile> \<lbrace>P\<^sub>1\<rbrace> X \<lbrace>Q\<^sub>1\<rbrace>"
  and "R\<^sub>2, G\<^sub>2 \<turnstile> \<lbrace>P\<^sub>2\<rbrace> Y \<lbrace>Q\<^sub>2\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<^sub>1 \<otimes> P\<^sub>2\<rbrace> X \<parallel> Y \<lbrace>Q\<^sub>1 \<otimes> Q\<^sub>2\<rbrace>"
  sorry

lemma parallel_statement_rule:
  assumes "(R \<union> G\<^sub>1)\<^sup>* \<subseteq> (R\<^sub>2)\<^sup>*"
  and "(R \<union> G\<^sub>2)\<^sup>* \<subseteq> R\<^sub>1\<^sup>*"
  and "(G\<^sub>1 \<union> G\<^sub>2)\<^sup>* \<subseteq> G\<^sup>*"
  and "test P \<subseteq> test (P\<^sub>1 \<otimes> P\<^sub>2)"
  and "test (Q\<^sub>1 \<otimes> Q\<^sub>2) \<subseteq> test Q"
  and "R\<^sub>1, G\<^sub>1 \<turnstile> \<lbrace>P\<^sub>1\<rbrace> X \<lbrace>Q\<^sub>1\<rbrace>"
  and "R\<^sub>2, G\<^sub>2 \<turnstile> \<lbrace>P\<^sub>2\<rbrace> Y \<lbrace>Q\<^sub>2\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> parallel { X } meanwhile { Y } \<lbrace>Q\<rbrace>"
  sorry

lemma preimp_dist: "(X \<union> Y) \<rightharpoondown> Z \<le> (X \<rightharpoondown> Z) \<union> (Y \<rightharpoondown> Z)"
  by (auto simp add: preimp_def)

lemma preimp_dist_var: "(X \<rightharpoondown> Z) \<inter> (Y \<rightharpoondown> Z) \<le> (X \<union> Y) \<rightharpoondown> Z"
 apply (auto simp add: preimp_def)
 apply (rule_tac x = "Xa \<inter> Xaa" in exI)
  by (meson Int_iff dual_order.trans inf_le1 inf_le2 l_prod_isor)

lemma skip_preimp [simp]: "{LNil} \<rightharpoondown> X = X"
  by (auto simp add: preimp_def)

lemma preimp_star1: "X\<^sup>\<star> \<rightharpoondown> Y \<subseteq> X \<rightharpoondown> Y"
  by (rule preimp_mono) (auto simp add: seq.star_ext)

lemma preimp_star2: "X \<subseteq> \<F> \<Longrightarrow> X \<cdot> (X\<^sup>\<star> \<rightharpoondown> Y) \<subseteq> Y"
  by (simp add: preimp_galois_2 preimp_star1)

lemma Rely_preimp: "R \<rhd> (P \<rightharpoondown> Q) \<le> P \<rightharpoondown> (R \<rhd> Q)"
  apply (auto simp add: preimp_def Rely_continuous)
  apply (rule_tac x = "R \<rhd> Xa" in exI)
  apply auto
  by (meson prog_rely_iso rely_l_prod_var2 subsetCE)

end


theory Graph_Auxiliaries
  imports
    Set_Auxiliaries List_Auxiliaries
    Graph_Theory.Digraph Graph_Theory.Arc_Walk Graph_Theory.Vertex_Walk
begin

section\<open>Graph Auxiliaries\<close>

lemma last_vwalk_arcs_last_p:
  assumes "snd (last (vwalk_arcs p)) = v" "(vwalk_arcs p) \<noteq> []"
  shows "last p = v"
  using assms
proof(induction p)
  case Nil
  then show ?case
    by simp
next
  case (Cons a p)
  then show ?case
  proof(cases "p = []")
    case True
    then have "vwalk_arcs (a#p) = []"
      by simp
    then show ?thesis
      using Cons
      by auto
  next
    case False
    then have 1: "p \<noteq> []"
      by simp
    then have 2: "vwalk_arcs (a#p) = (a, hd p)#vwalk_arcs p"
      using vwalk_arcs_Cons
      by auto
    then show ?thesis
    proof(cases "vwalk_arcs p = []")
      case True
      then have 3: "(last (vwalk_arcs (a#p))) = (a, hd p)"
        using 2
        by simp
      have "last p = hd p" using True 1
        by (metis hd_rev list.distinct(1) list.exhaust rev_singleton_conv vwalk_arcs_Cons)
      then show ?thesis
        using 3 Cons False
        by auto
    next
      case False
      then have "snd (last (vwalk_arcs (a#p))) = snd (last (vwalk_arcs p))"
        by (simp add: 2)
      then have "snd (last (vwalk_arcs p)) = v"
        using Cons
        by simp
      then have 3: "last p = v"
        using Cons False
        by simp
      have "p \<noteq> []"
        by (simp add: 1)
      then have "last (a#p) = last p"
        by auto
      then show ?thesis
        using 3
        by simp
    qed
  qed
qed

lemma hd_vwalk_arcs_last_p:
  assumes "fst (hd (vwalk_arcs p)) = v" "(vwalk_arcs p) \<noteq> []"
  shows "hd p = v"
  using assms
proof(induction p)
  case Nil
  then show ?case
    by simp
next
  case (Cons a p)
  then show ?case
  proof(cases "p = []")
    case True
    then have "vwalk_arcs (a#p) = []"
      by simp
    then show ?thesis
      using Cons
      by auto
  next
    case False
    then have 1: "p\<noteq> []"
      by simp
    then have 2: "vwalk_arcs (a#p) = (a, hd p)#vwalk_arcs p"
      using vwalk_arcs_Cons
      by auto
    then have "fst (hd (vwalk_arcs (a#p))) = a"
      by simp
    then show ?thesis
      using Cons
      by simp
  qed
qed

lemma vwalk_arcs_empty_length_p:
  assumes "vwalk_arcs p = []"
  shows "length p \<le> 1"
  using assms vwalk_arcs_Cons by(induction p; fastforce)

lemma length_C_vwalk_arcs_not_empty:
  assumes "length C > 1"
  shows "vwalk_arcs C \<noteq> []"
  using assms vwalk_arcs_empty_length_p by fastforce

lemma vwalk_sublist_in_arcs:
  assumes "sublist [a, b] Cy"
  shows "(a, b) \<in> set (vwalk_arcs Cy)"
  using assms
  by (induction Cy; simp add: sublist_def)
     (metis in_set_vwalk_arcs_append1 list.set_intros(1) vwalk_arcs.simps(3))

lemma vwalk_arcs_from_length_1:
  assumes "length C = 1"
  shows "vwalk_arcs C = []"
  using assms
  by (metis length_1_set_L list.set_intros(1) vwalk_arcs.simps(1) vwalk_arcs.simps(2)
      vwalk_to_vpath.cases)

lemma at_least_two_nodes_vwalk_arcs_awalk_verts:
  assumes "length C > 1" "head G' = snd" "tail G' = fst"
  shows "(pre_digraph.awalk_verts G' u (vwalk_arcs C)) = C"
  using assms
proof(induction C arbitrary: u)
  case Nil
  then show ?case
    by auto
next
  case (Cons a C)
  then have 1: "vwalk_arcs (a#C) = (a, hd C) # vwalk_arcs C"
    by auto
  then show ?case
  proof(cases "length C > 1")
    case True
    then have 2: "pre_digraph.awalk_verts G' (hd C) (vwalk_arcs C) = C"
      using Cons
      by simp
    have "pre_digraph.awalk_verts G' u (vwalk_arcs (a#C)) =
      tail G' (a, hd C) # (pre_digraph.awalk_verts G' (head G' (a, hd C)) (vwalk_arcs C))"
      using 1
      by (simp add: pre_digraph.awalk_verts.simps(2))
    then have "pre_digraph.awalk_verts G' u (vwalk_arcs (a#C))
      = a # (pre_digraph.awalk_verts G' (head G' (a, hd C)) (vwalk_arcs C))"
      using assms
      by fastforce
    then have "pre_digraph.awalk_verts G' u (vwalk_arcs (a#C))
      = a # (pre_digraph.awalk_verts G' (hd C) (vwalk_arcs C))"
      using assms
      by fastforce
    then show ?thesis
      using 2
      by simp
  next
    case False
    then have lC: "length C = 1"
      using Cons linorder_neqE_nat
      by auto
    then have hd_C: "C = [hd C]"
      by (metis "1" list.sel(1) neq_Nil_conv vwalk_arcs.simps(2) vwalk_arcs_Cons
          vwalk_arcs_from_length_1)
    then have "vwalk_arcs (a#C) = (a, hd C) #[]"
      using 1 lC vwalk_arcs_from_length_1
      by auto
    then have 2: "pre_digraph.awalk_verts G' u (vwalk_arcs (a#C))
      = pre_digraph.awalk_verts G' u [(a, hd C)]"
      by argo
    then have 3: "... = (tail G' (a, hd C)) # (pre_digraph.awalk_verts G' (head G' (a, hd C)) [])"
      by (simp add: pre_digraph.awalk_verts.simps(2))
    then have 4: "... =  (tail G' (a, hd C)) # [(head G' (a, hd C))]"
      by (simp add: pre_digraph.awalk_verts.simps)
    then have 5: "... = a #  [(head G' (a, hd C))]"
      using assms
      by fastforce
    then have 6: "... = a # [(hd C)]"
      using assms
      by auto
    then show ?thesis
      using assms 2 3 4 5 6 hd_C
      by argo
  qed
qed

lemma arc_to_ends_G':
  assumes "head G' = snd" "tail G' = fst"
  shows "arc_to_ends G' e = e"
  using arc_to_ends_def assms by (simp add: arc_to_ends_def)

lemma arcs_ends_G':
  assumes "head G' = snd" "tail G' = fst"
  shows "arcs_ends G' = arcs G'"
  using arcs_ends_def arc_to_ends_G' assms by(auto simp add: arcs_ends_def arc_to_ends_G')

lemma if_edge_then_cycle_length_geq_2:
  assumes "(u, v) \<in> set (vwalk_arcs C)"
  shows "length C \<ge> 2"
proof(rule ccontr)
  assume "\<not> 2 \<le> length C"
  then have length_C: "length C = 1 \<or> length C = 0"
    by linarith
  then have "vwalk_arcs C = []"
    using vwalk_arcs_from_length_1
    by auto
  then show False
    using assms
    by simp
qed

lemma sublist_for_edges:
  assumes "(u, v) \<in> set (vwalk_arcs C)"
  shows "sublist [u, v] C"
  using assms
proof(induction C)
  case Nil
  then show ?case
    by auto
next
  case (Cons a C)
  then have length_C: "length C \<ge> 1"
    using if_edge_then_cycle_length_geq_2
    by fastforce
  then show ?case
  proof(cases "u = a \<and> v = hd C")
    case True
    then have "[]@[u,v] @ (tl C) = (a#C)"
      by (metis Cons.prems append_Cons append_self_conv2 list.collapse list.distinct(1)
          list.set_cases vwalk_arcs.simps(2))
    then show ?thesis
      using sublist_def by metis
  next
    case False
    then have "(u,v) \<in> set (vwalk_arcs C)"
      using Cons
      by (metis prod.inject set_ConsD vwalk_arcs.simps(1) vwalk_arcs.simps(2) vwalk_arcs_Cons)
    then have "sublist [u, v] C"
      using Cons
      by auto
    then show ?thesis
      by (simp add: sublist_cons)
  qed
qed

lemma in_sublist_impl_in_list:
  assumes "sublist a b" "x \<in> set a"
  shows "x \<in> set b"
  using assms by (metis append_Cons append_assoc in_set_conv_decomp sublist_def)

lemma empty_arcs_impl_no_cycle:
  assumes "arcs G = {}"
  shows  "\<not>(\<exists>p. pre_digraph.cycle G p)"
proof(rule ccontr)
  assume "\<not>\<not>(\<exists>p. pre_digraph.cycle G p)"
  then obtain p where 1: "pre_digraph.cycle G p"
    by auto
  then have 0: "p \<noteq> []"
    using pre_digraph.cycle_def
    by fastforce
  then have "\<exists>u. pre_digraph.awalk G u p u"
    using 1 pre_digraph.cycle_def
    by metis
  then obtain u where 2: "pre_digraph.awalk G u p u"
    by auto
  then have "set p \<subseteq> arcs G"
    using pre_digraph.awalk_def
    by fast
  then have "p = []"
    using assms
    by simp
  then show False
    using 0
    by simp
qed

lemma pre_digraph_cas_edge:
  assumes  "head G = snd" "tail G = fst"
  shows "pre_digraph.cas G v [(v, u), (u, v)] v"
  using assms  by(simp add: pre_digraph.cas.simps)

lemma edge_cycle:
  assumes "(u, v) \<in> arcs G" "(v, u) \<in> arcs G" "u \<noteq> v" "tail G = fst" "head G = snd" "wf_digraph G"
  shows "pre_digraph.cycle G [(v, u), (u, v)]"
  using assms pre_digraph_cas_edge
  unfolding pre_digraph.cycle_def pre_digraph.awalk_def wf_digraph_def pre_digraph.awalk_verts_def
  by fastforce

lemma arcs_subset_eq_verts_times_verts:
  assumes "head G = snd" "tail G = fst" "wf_digraph G"
  shows "arcs G \<subseteq> (verts G) \<times> (verts G)"
  using assms unfolding wf_digraph_def by auto

lemma not_wf_digraph_not_arcs_empty:
  assumes "\<not> wf_digraph G"
  shows "arcs G \<noteq> {}"
  using assms unfolding wf_digraph_def by auto

lemma distinct_awalk_verts_vwalk_arcs:
  assumes "head G = snd" "tail G = fst" "distinct (tl p)" "length p \<ge> 2"
  shows "distinct (tl (pre_digraph.awalk_verts G u (vwalk_arcs p)))"
  using assms at_least_two_nodes_vwalk_arcs_awalk_verts
  by (metis leD le_antisym less_one nat_neq_iff num.distinct(1) one_eq_numeral_iff
      one_le_numeral zero_less_numeral)

lemma awalk_empty_list:
  assumes "u \<in> verts G"
  shows "pre_digraph.awalk G u [] u"
  using assms unfolding pre_digraph.awalk_def by(auto simp add: pre_digraph.cas.simps)

lemma cas_vwalk_length_at_least_2:
  assumes "vwalk p G" "head G = snd" "tail G = fst" "length p \<ge> 2"
  shows "pre_digraph.cas G (hd p) (vwalk_arcs p) (last p)"
  using assms by(induction p)(auto simp add:  pre_digraph.cas.simps Suc_leI)

lemma awalk_vwalk_length_at_least_2:
  assumes "vwalk p G" "head G = snd" "tail G = fst" "length p \<ge> 2"
  shows "pre_digraph.awalk G (hd p) (vwalk_arcs p) (last p)"
  using assms
  unfolding pre_digraph.awalk_def vwalk_def
  by(auto simp add: pre_digraph.cas.simps arcs_ends_G' cas_vwalk_length_at_least_2 assms)

lemma last_pre_digraph_cas:
  assumes "pre_digraph.cas G u (p) v" "p\<noteq> []" "head G = snd" "tail G = fst"
  shows "snd (last p) = v"
  using assms by(induction p arbitrary: u)(auto simp add: pre_digraph.cas.simps)

lemma hd_pre_digraph_cas:
  assumes "pre_digraph.cas G u (p) v" "p\<noteq> []" "head G = snd" "tail G = fst"
  shows "fst (hd p) = u"
  using assms by(induction p arbitrary: u)(auto simp add: pre_digraph.cas.simps)

lemma hd_first_edge:
  assumes "length c \<ge> 2"
  shows "fst (hd (vwalk_arcs c)) = hd c"
  using assms by (metis Suc_1 Suc_le_lessD hd_vwalk_arcs_last_p length_C_vwalk_arcs_not_empty)

lemma tail_last_edge:
  assumes "length c \<ge> 2"
  shows "snd (last (vwalk_arcs c))= last c"
  using assms by (metis Suc_1 last_vwalk_arcs_last_p not_less_eq_eq vwalk_arcs_empty_length_p)

lemma hd_last_cycle:
  assumes "length c \<ge> 2" "pre_digraph.cycle G (vwalk_arcs c)" "head G = snd" "tail G = fst"
  shows "hd c = last c"
  using assms hd_first_edge hd_pre_digraph_cas last_pre_digraph_cas tail_last_edge
  unfolding pre_digraph.cycle_def pre_digraph.awalk_def by fastforce

end


theory Chapter16_2_Expression
imports Chapter16_1_Type
begin

datatype expr =
  Var var
| Lam type expr
| Appl expr expr
| Triv
| Pair expr expr
| ProjL expr
| ProjR expr
| Abort type expr
| Case expr expr expr
| InL type type expr
| InR type type expr
| Fix type expr
| Fold type expr
| Unfold expr

primrec insert :: "var => expr => expr"
where "insert n (Var v) = Var (incr n v)"
    | "insert n (Lam t e) = Lam t (insert (next n) e)"
    | "insert n (Appl e1 e2) = Appl (insert n e1) (insert n e2)"
    | "insert n Triv = Triv"
    | "insert n (Pair e1 e2) = Pair (insert n e1) (insert n e2)"
    | "insert n (ProjL e) = ProjL (insert n e)"
    | "insert n (ProjR e) = ProjR (insert n e)"
    | "insert n (Abort t e) = Abort t (insert n e)"
    | "insert n (Case et el er) = Case (insert n et) (insert (next n) el) (insert (next n) er)"
    | "insert n (InL t1 t2 e) = InL t1 t2 (insert n e)"
    | "insert n (InR t1 t2 e) = InR t1 t2 (insert n e)"
    | "insert n (Fix t e) = Fix t (insert (next n) e)"
    | "insert n (Fold t e) = Fold t (insert n e)"
    | "insert n (Unfold e) = Unfold (insert n e)"

primrec subst :: "expr => var => expr => expr"
where "subst e' n (Var v) = (if v = n then e' else Var (subr n v))"
    | "subst e' n (Lam t e) = Lam t (subst (insert first e') (next n) e)"
    | "subst e' n (Appl e1 e2) = Appl (subst e' n e1) (subst e' n e2)"
    | "subst e' n Triv = Triv"
    | "subst e' n (Pair e1 e2) = Pair (subst e' n e1) (subst e' n e2)"
    | "subst e' n (ProjL e) = ProjL (subst e' n e)"
    | "subst e' n (ProjR e) = ProjR (subst e' n e)"
    | "subst e' n (Abort t e) = Abort t (subst e' n e)"
    | "subst e' n (Case et el er) =
                      Case (subst e' n et)
                           (subst (insert first e') (next n) el)
                           (subst (insert first e') (next n) er)"
    | "subst e' n (InL t1 t2 e) = InL t1 t2 (subst e' n e)"
    | "subst e' n (InR t1 t2 e) = InR t1 t2 (subst e' n e)"
    | "subst e' n (Fix t e) = Fix t (subst (insert first e') (next n) e)"
    | "subst e' n (Fold t e) = Fold t (subst e' n e)"
    | "subst e' n (Unfold e) = Unfold (subst e' n e)"

lemma [simp]: "subst e' n (insert n e) = e"
by (induction e arbitrary: n e', simp_all)

end


section {* Lists: extra functions and properties *}

theory List_extra
imports
  Main
  "~~/src/HOL/Library/Sublist"
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/Prefix_Order"
begin

subsection {* Extra list functions *}

text {*
The following variant of the standard @{text nth} function returns
@{text "\<bottom>"} if the index is out of range.
*}

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>\<^sub>l" [90, 0] 91)
where
  "[]\<langle>i\<rangle>\<^sub>l = None"
| "(x # xs)\<langle>i\<rangle>\<^sub>l = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>\<^sub>l)"

fun sequence :: "'a option list \<Rightarrow> 'a list option" where
"sequence [] = Some []" |
"sequence (f # fs) = do { x \<leftarrow> f; xs \<leftarrow> sequence fs; Some (x # xs) }"

abbreviation "mapM f \<equiv> sequence \<circ> map f"

abbreviation "list_sum xs \<equiv> foldr (op +) xs 0"

subsection {* List lemmas *}

lemma map_nth_Cons_atLeastLessThan:
  "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n - 1]"
proof -
  have "nth xs = nth (x # xs) \<circ> Suc"
    by auto
  hence "map (nth xs) [m..<n - 1] = map (nth (x # xs) \<circ> Suc) [m..<n - 1]"
    by simp
  also have "... = map (nth (x # xs)) (map Suc [m..<n - 1])"
    by simp
  also have "... = map (nth (x # xs)) [Suc m..<n]"
    by (metis Suc_diff_1 le_0_eq length_upt list.simps(8) list.size(3) map_Suc_upt not_less upt_0)
  finally show ?thesis ..
qed

lemma nth_el_appendl[simp]: "i < length xs \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = xs\<langle>i\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
done

lemma nth_el_appendr[simp]: "length xs \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = ys\<langle>i - length xs\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
done

lemma sorted_last [simp]: "\<lbrakk> x \<in> set xs; sorted xs \<rbrakk> \<Longrightarrow> x \<le> last xs"
  apply (induct xs)
  apply (auto)
  apply (metis last_in_set sorted_Cons)+
done

lemma sorted_map: "\<lbrakk> sorted xs; mono f \<rbrakk> \<Longrightarrow> sorted (map f xs)"
  by (simp add: monoD sorted_equals_nth_mono)

lemma prefix_length_eq:
  "\<lbrakk> length xs = length ys; prefix xs ys \<rbrakk> \<Longrightarrow> xs = ys"
  by (metis not_equal_is_parallel parallel_def)

lemma prefix_Cons_elim [elim]:
  assumes "prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "prefix xs ys'"
  using assms
  by (metis Sublist.Cons_prefix_Cons prefix_code(1) prefix_order.eq_iff prefixes.cases)

lemma prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   prefix xs ys"
  apply (induct xs arbitrary:ys)
  apply (simp_all)
  apply (erule prefix_Cons_elim)
  apply (auto)
  apply (metis image_insert insertI1 insert_Diff_if singletonE)
done

lemma prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   prefix (map f xs) (map f ys) \<longleftrightarrow> prefix xs ys"
  by (metis map_prefixI prefix_map_inj)

lemma strict_prefix_Cons_elim [elim]:
  assumes "strict_prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "strict_prefix xs ys'"
  using assms
  by (metis Sublist.strict_prefixE' Sublist.strict_prefixI' append_Cons)

lemma strict_prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); strict_prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   strict_prefix xs ys"
  apply (induct xs arbitrary:ys)
  apply (auto)
  using prefix_bot.bot.not_eq_extremum apply fastforce
  apply (erule strict_prefix_Cons_elim)
  apply (auto)
  apply (metis (hide_lams, full_types) image_insert insertI1 insert_Diff_if singletonE)
done

lemma strict_prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   strict_prefix (map f xs) (map f ys) \<longleftrightarrow> strict_prefix xs ys"
  by (metis inj_on_map_eq_map map_prefixI prefix_map_inj prefix_order.less_le)

lemma prefix_drop:
  "\<lbrakk> drop (length xs) ys = zs; prefix xs ys \<rbrakk>
   \<Longrightarrow> ys = xs @ zs"
  by (metis append_eq_conv_conj prefix_def)

lemma list_append_prefixD [dest]: "x @ y \<le> z \<Longrightarrow> x \<le> z"
  using append_prefixD less_eq_list_def by blast

lemma listsum_update:
  fixes xs :: "'a::ring list"
  assumes "i < length xs"
  shows "list_sum (xs[i := v]) = list_sum xs - xs ! i + v"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by (simp)
next
  case (Cons a xs)
  then show ?case
  proof (cases i)
    case 0
    thus ?thesis
      by (simp add: add.commute)
  next
    case (Suc i')
    with Cons show ?thesis
      by (auto)
  qed
qed

subsection {* Minus on lists *}

instantiation list :: (type) minus
begin

text {* We define list minus so that if the second list is not a prefix of the first, then an arbitrary
        list longer than the combined length is produced. Thus we can always determined from the output
        whether the minus is defined or not. *}

definition "xs - ys = (if (prefix ys xs) then drop (length ys) xs else [])"

instance ..
end

lemma minus_cancel [simp]: "xs - xs = []"
  by (simp add: minus_list_def)

lemma append_minus [simp]: "(xs @ ys) - xs = ys"
  by (simp add: minus_list_def)

lemma minus_right_nil [simp]: "xs - [] = xs"
  by (simp add: minus_list_def)

lemma list_concat_minus_list_concat: "(s @ t) - (s @ z) = t - z"
  by (simp add: minus_list_def)

lemma length_minus_list: "y \<le> x \<Longrightarrow> length(x - y) = length(x) - length(y)"
  by (simp add: less_eq_list_def minus_list_def)

lemma length_gt_zero_butlast_concat:
  assumes "length ys > 0"
  shows "butlast (xs @ ys) = xs @ (butlast ys)"
  using assms by (metis butlast_append length_greater_0_conv)

lemma length_eq_zero_butlast_concat:
  assumes "length ys = 0"
  shows "butlast (xs @ ys) = butlast xs"
  using assms by (metis append_Nil2 length_0_conv)

lemma butlast_single_element:
  shows "butlast [e] = []"
  by (metis butlast.simps(2))

lemma last_single_element:
  shows "last [e] = e"
  by (metis last.simps)

lemma length_zero_last_concat:
  assumes "length t = 0"
  shows "last (s @ t) = last s"
  by (metis append_Nil2 assms length_0_conv)

lemma length_gt_zero_last_concat:
  assumes "length t > 0"
  shows "last (s @ t) = last t"
  by (metis assms last_append length_greater_0_conv)

subsection {* Interleaving operations *}

fun interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
"interleave [] ys = {ys}" |
"interleave (x # xs) (y # ys) = (Cons x) ` (interleave xs (y # ys))
                              \<union> (Cons y) ` (interleave (x # xs) ys)" |
"interleave xs [] = {xs}"

lemma interleave_finite [simp]:
  "finite (interleave xs ys)"
  apply (induct xs arbitrary: ys)
  apply (simp)
  apply (induct_tac ys)
  apply (auto)
done

lemma interleave_right_nil [simp]:
  "interleave xs [] = {xs}"
  by (induct xs, auto)

lemma interleave_headE [elim!]:
  "\<lbrakk> z # zs \<in> interleave xs ys
   ; \<And> xs'. xs = z # xs' \<Longrightarrow> P
   ; \<And> ys'. ys = z # ys' \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (induct xs)
  apply (auto)
  apply (induct ys)
  apply (auto)
done

lemma interleave_member:
  "\<lbrakk> zs \<in> interleave xs ys; z \<in> set zs \<rbrakk> \<Longrightarrow> z \<in> set xs \<or> z \<in> set ys"
  apply (induct xs arbitrary: zs)
  apply (auto)
  apply (induct ys)
  apply (auto)
oops

(* FIXME: What happens if no progress can be made? *)
fun intersync :: "'a set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
"intersync s (x # xs) (y # ys)
  = (case (x = y , x \<in> s , y \<in> s) of
          (True  , True   , _      ) \<Rightarrow> Cons x ` intersync s xs ys |
          (True  , False  , _      ) \<Rightarrow> ((Cons x ` intersync s xs (y # ys))
                                         \<union> (Cons y ` intersync s (x # xs) ys)) |
          (False , True   , True   ) \<Rightarrow> {[]} |
          (False , True   , False  ) \<Rightarrow> Cons y ` intersync s (x # xs) ys |
          (False , False  , True   ) \<Rightarrow> Cons x ` intersync s xs (y # ys) |
          (False , False  , False  ) \<Rightarrow> ((Cons x ` intersync s xs (y # ys))
                                         \<union> (Cons y ` intersync s (x # xs) ys)))" |
"intersync s [] (y # ys) =
   (if (y \<in> s) then {[]} else Cons y ` intersync s [] ys)" |
"intersync s (x # xs) [] =
   (if (x \<in> s) then {[]} else Cons x ` intersync s xs [])" |
"intersync s [] [] = {[]}"

(* FIXME: We should be able to prove this property... *)
lemma intersync_empty_interleave:
  "intersync {} xs ys = interleave xs ys"
oops

subsection {* Sorting of lists *}

definition is_sorted_list_of_set :: "('a::ord) set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set A xs = ((\<forall> i<length(xs) - 1. xs!i < xs!(i + 1)) \<and> set(xs) = A)"

lemma sorted_distinct [intro]: "\<lbrakk> sorted (xs); distinct(xs) \<rbrakk> \<Longrightarrow> (\<forall> i<length xs - 1. xs!i < xs!(i + 1))"
  apply (induct xs)
  apply (auto)
  apply (metis Suc_mono distinct.simps(2) length_Cons lessI less_SucI less_le nth_Cons_Suc nth_eq_iff_index_eq sorted_equals_nth_mono)
done

lemma sorted_is_sorted_list_of_set:
  assumes "is_sorted_list_of_set A xs"
  shows "sorted(xs)" and "distinct(xs)"
using assms proof (induct xs arbitrary: A)
  show "sorted []"
    by auto
next
  show "distinct []"
    by auto
next
  fix A :: "'a set"
  case (Cons x xs) note hyps = this
  assume isl: "is_sorted_list_of_set A (x # xs)"
  hence srt: "(\<forall>i<length xs - Suc 0. xs ! i < xs ! Suc i)"
    using less_diff_conv by (auto simp add: is_sorted_list_of_set_def)
  with hyps(1) have srtd: "sorted xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "sorted (x # xs)"
    apply (auto simp add: is_sorted_list_of_set_def)
    apply (metis length_pos_if_in_set less_imp_le nth_Cons_0 sorted.simps sorted_many sorted_single)
  done
  from srt hyps(2) have "distinct xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "distinct (x # xs)"
  proof -
    have "(\<forall>n. \<not> n < length (x # xs) - 1 \<or> (x # xs) ! n < (x # xs) ! (n + 1)) \<and> set (x # xs) = A"
      by (meson \<open>is_sorted_list_of_set A (x # xs)\<close> is_sorted_list_of_set_def)
  then show ?thesis
      by (metis Nat.add_0_right One_nat_def \<open>distinct xs\<close> \<open>sorted (x # xs)\<close> add_Suc_right diff_Suc_Suc diff_zero distinct.simps(2) insert_iff length_pos_if_in_set linorder_not_less list.set(2) list.simps(1) list.simps(3) list.size(3) list.size(4) not_less_iff_gr_or_eq nth_Cons_0 nth_Cons_Suc sorted.cases)
  qed
qed

lemma is_sorted_list_of_set_alt_def:
  "is_sorted_list_of_set A xs \<longleftrightarrow> sorted (xs) \<and> distinct (xs) \<and> set(xs) = A"
  apply (auto intro: sorted_is_sorted_list_of_set)
  apply (auto simp add: is_sorted_list_of_set_def)
  apply (metis Nat.add_0_right One_nat_def add_Suc_right sorted_distinct)
done

(*
lemma sorted_alt_def:
  "(\<forall> i<(length xs) - 1. xs!i < xs!(i + 1)) \<longleftrightarrow> sorted (xs) \<and> distinct (xs)"
  apply (auto)
  sledgehammer
oops
*)

definition sorted_list_of_set_alt :: "('a::ord) set \<Rightarrow> 'a list" where
"sorted_list_of_set_alt A =
  (if (A = {}) then [] else (THE xs. is_sorted_list_of_set A xs))"

lemma is_sorted_list_of_set:
  "finite A \<Longrightarrow> is_sorted_list_of_set A (sorted_list_of_set A)"
  apply (simp add: is_sorted_list_of_set_def)
  apply (metis One_nat_def add.right_neutral add_Suc_right sorted_distinct sorted_list_of_set)
done

lemma sorted_list_of_set_other_def:
  "finite A \<Longrightarrow> sorted_list_of_set(A) = (THE xs. sorted(xs) \<and> distinct(xs) \<and> set xs = A)"
  apply (rule sym)
  apply (rule the_equality)
  apply (auto)
  apply (simp add: sorted_distinct_set_unique)
done

lemma sorted_list_of_set_alt [simp]:
  "finite A \<Longrightarrow> sorted_list_of_set_alt(A) = sorted_list_of_set(A)"
  apply (rule sym)
  apply (auto simp add: sorted_list_of_set_alt_def is_sorted_list_of_set_alt_def sorted_list_of_set_other_def)
done

text {* Greatest common prefix *}

fun gcp :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"gcp [] ys = []" |
"gcp (x # xs) (y # ys) = (if (x = y) then x # gcp xs ys else [])" |
"gcp _ _ = []"

lemma gcp_right [simp]: "gcp xs [] = []"
  by (induct xs, auto)

lemma gcp_append [simp]: "gcp (xs @ ys) (xs @ zs) = xs @ gcp ys zs"
  by (induct xs, auto)

lemma gcp_lb1: "prefix (gcp xs ys) xs"
  apply (induct xs arbitrary: ys, auto)
  apply (case_tac ys, auto)
done

lemma gcp_lb2: "prefix (gcp xs ys) ys"
  apply (induct ys arbitrary: xs, auto)
  apply (case_tac xs, auto)
done

interpretation prefix_semilattice: semilattice_inf gcp prefix strict_prefix
proof
  fix xs ys :: "'a list"
  show "prefix (gcp xs ys) xs"
    by (induct xs arbitrary: ys, auto, case_tac ys, auto)
  show "prefix (gcp xs ys) ys"
    by (induct ys arbitrary: xs, auto, case_tac xs, auto)
next
  fix xs ys zs :: "'a list"
  assume "prefix xs ys" "prefix xs zs"
  thus "prefix xs (gcp ys zs)"
    by (simp add: prefix_def, auto)
qed

text {* Extra laws to do with prefix and order *}

lemma lexord_append:
  assumes "(xs\<^sub>1 @ ys\<^sub>1, xs\<^sub>2 @ ys\<^sub>2) \<in> lexord R" "length(xs\<^sub>1) = length(xs\<^sub>2)"
  shows "(xs\<^sub>1, xs\<^sub>2) \<in> lexord R \<or> (xs\<^sub>1 = xs\<^sub>2 \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
using assms
proof (induct xs\<^sub>2 arbitrary: xs\<^sub>1)
  case (Cons x\<^sub>2 xs\<^sub>2') note hyps = this
  from hyps(3) obtain x\<^sub>1 xs\<^sub>1' where xs\<^sub>1: "xs\<^sub>1 = x\<^sub>1 # xs\<^sub>1'" "length(xs\<^sub>1') = length(xs\<^sub>2')"
    by (auto, metis Suc_length_conv)
  with hyps(2) have xcases: "(x\<^sub>1, x\<^sub>2) \<in> R \<or> (xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
    by (auto)
  show ?case
  proof (cases "(x\<^sub>1, x\<^sub>2) \<in> R")
    case True with xs\<^sub>1 show ?thesis
      by (auto)
  next
    case False
    with xcases have "(xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
      by (auto)
    with hyps(1) xs\<^sub>1 have dichot: "(xs\<^sub>1', xs\<^sub>2') \<in> lexord R \<or> (xs\<^sub>1' = xs\<^sub>2' \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
      by (auto)
    have "x\<^sub>1 = x\<^sub>2"
      using False hyps(2) xs\<^sub>1(1) by auto
    with dichot xs\<^sub>1 show ?thesis
      by (simp)
  qed
next
  case Nil thus ?case
    by auto
qed

lemma strict_prefix_lexord_rel:
  "strict_prefix xs ys \<Longrightarrow> (xs, ys) \<in> lexord R"
  by (metis Sublist.strict_prefixE' lexord_append_rightI)

lemma strict_prefix_lexord_left:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix xs' xs"
  shows "(xs', ys) \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma prefix_lexord_right:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix ys ys'"
  shows "(xs, ys') \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma lexord_eq_length:
  assumes "(xs, ys) \<in> lexord R" "length xs = length ys"
  shows "\<exists> i. (xs!i, ys!i) \<in> R \<and> i < length xs \<and> (\<forall> j<i. xs!j = ys!j)"
using assms proof (induct xs arbitrary: ys)
  case (Cons x xs) note hyps = this
  then obtain y ys' where ys: "ys = y # ys'" "length ys' = length xs"
    by (metis Suc_length_conv)
  show ?case
  proof (cases "(x, y) \<in> R")
    case True with ys show ?thesis
      by (rule_tac x="0" in exI, simp)
  next
    case False
    with ys hyps(2) have xy: "x = y" "(xs, ys') \<in> lexord R"
      by auto
    with hyps(1,3) ys obtain i where "(xs!i, ys'!i) \<in> R" "i < length xs" "(\<forall> j<i. xs!j = ys'!j)"
      by force
    with xy ys show ?thesis
      apply (rule_tac x="Suc i" in exI)
      apply (auto simp add: less_Suc_eq_0_disj)
    done
  qed
next
  case Nil thus ?case by (auto)
qed

lemma lexord_intro_elems:
  assumes "length xs > i" "length ys > i" "(xs!i, ys!i) \<in> R" "\<forall> j<i. xs!j = ys!j"
  shows "(xs, ys) \<in> lexord R"
using assms proof (induct i arbitrary: xs ys)
  case 0 thus ?case
    by (auto, metis lexord_cons_cons list.exhaust nth_Cons_0)
next
  case (Suc i) note hyps = this
  then obtain x' y' xs' ys' where "xs = x' # xs'" "ys = y' # ys'"
    by (metis Suc_length_conv Suc_lessE)
  moreover with hyps(5) have "\<forall>j<i. xs' ! j = ys' ! j"
    by (auto)
  ultimately show ?case using hyps
    by (auto)
qed

text {* Extra lemmas about @{term prefix} and @{term strict_prefix} *}

lemma prefix_concat_minus:
  assumes "prefix xs ys"
  shows "xs @ (ys - xs) = ys"
  using assms by (metis minus_list_def prefix_drop)

lemma prefix_minus_concat:
  assumes "prefix s t"
  shows "(t - s) @ z = (t @ z) - s"
  using assms by (simp add: Sublist.prefix_length_le minus_list_def)

lemma strict_prefix_minus_not_empty:
  assumes "strict_prefix xs ys"
  shows "ys - xs \<noteq> []"
  using assms by (metis append_Nil2 prefix_concat_minus strict_prefix_def)

lemma strict_prefix_diff_minus:
  assumes "prefix xs ys" and "xs \<noteq> ys"
  shows "(ys - xs) \<noteq> []"
  using assms by (simp add: strict_prefix_minus_not_empty)

lemma prefix_not_empty:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  using Sublist.strict_prefix_simps(1) assms(1) by blast

lemma prefix_not_empty_length_gt_zero:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "length ys > 0"
  using assms prefix_not_empty by auto

lemma butlast_prefix_suffix_not_empty:
  assumes "strict_prefix (butlast xs) ys"
  shows "ys \<noteq> []"
  using assms prefix_not_empty_length_gt_zero by fastforce

lemma length_tl_list_minus_butlast_gt_zero:
  assumes "length s < length t" and "strict_prefix (butlast s) t" and "length s > 0"
  shows "length (tl (t - (butlast s))) > 0"
  using assms
  by (metis Nitpick.size_list_simp(2) butlast_snoc hd_Cons_tl length_butlast length_greater_0_conv length_tl less_trans nat_neq_iff strict_prefix_minus_not_empty prefix_order.dual_order.strict_implies_order prefix_concat_minus)

lemma prefix_and_concat_prefix_is_concat_prefix:
  assumes "prefix s t" "prefix (e @ t) u"
  shows "prefix (e @ s) u"
  using Sublist.same_prefix_prefix assms(1) assms(2) prefix_order.dual_order.trans by blast

lemma list_minus_butlast_eq_butlast_list:
  assumes "length t = length s" and "strict_prefix (butlast s) t"
  shows "t - (butlast s) = [last t]"
  using assms
  by (metis append_butlast_last_id append_eq_append_conv butlast.simps(1) length_butlast less_numeral_extra(3) list.size(3) prefix_order.dual_order.strict_implies_order prefix_concat_minus prefix_length_less)

lemma strict_prefix_eq_exists:
  "strict_prefix s t \<longleftrightarrow> (\<exists>xs . s @ xs = t \<and> (length xs) > 0)"
  by (metis append_minus length_greater_0_conv prefix_def strict_prefix_minus_not_empty strict_prefix_def)

lemma butlast_strict_prefix_eq_butlast:
  assumes "length s = length t" and "strict_prefix (butlast s) t"
  shows "strict_prefix (butlast s) t \<longleftrightarrow> (butlast s) = (butlast t)"
  by (metis append_butlast_last_id append_eq_append_conv assms(1) assms(2) length_0_conv length_butlast strict_prefix_eq_exists)

lemma butlast_eq_if_eq_length_and_prefix:
  assumes "length s > 0" "length z > 0"
          "length s = length z" "strict_prefix (butlast s) t" "strict_prefix (butlast z) t"
  shows   "(butlast s) = (butlast z)"
  using assms by (auto simp add:strict_prefix_eq_exists)

lemma prefix_imp_length_lteq:
  assumes "prefix s t"
  shows "length s \<le> length t"
  using assms by (simp add: Sublist.prefix_length_le)

lemma prefix_imp_length_not_gt:
  assumes "prefix s t"
  shows "\<not> length t < length s"
  using assms by (simp add: Sublist.prefix_length_le leD)

lemma prefix_and_eq_length_imp_eq_list:
  assumes "prefix s t" and "length t = length s"
  shows "s=t"
  using assms by (simp add: prefix_length_eq)

lemma butlast_strict_prefix_length_lt_imp_last_tl_minus_butlast_eq_last:
  assumes "length s > 0" "strict_prefix (butlast s) t" "length s < length t"
  shows "last (tl (t - (butlast s))) = (last t)"
  using assms by (metis last_append last_tl length_tl_list_minus_butlast_gt_zero less_numeral_extra(3) list.size(3) append_minus strict_prefix_eq_exists)

lemma tl_list_minus_butlast_not_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t > length s"
  shows "tl (t - (butlast s)) \<noteq> []"
  using assms length_tl_list_minus_butlast_gt_zero by fastforce

lemma tl_list_minus_butlast_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t = length s"
  shows "tl (t - (butlast s)) = []"
  using assms by (simp add: list_minus_butlast_eq_butlast_list)

lemma concat_minus_list_concat_butlast_eq_list_minus_butlast:
  assumes "prefix (butlast u) s"
  shows "(t @ s) - (t @ (butlast u)) = s - (butlast u)"
  using assms by (metis append_assoc prefix_concat_minus append_minus)

lemma tl_list_minus_butlast_eq_empty:
  assumes "strict_prefix (butlast s) t" and "length s = length t"
  shows "tl (t - (butlast s)) = []"
  using assms by (metis list.sel(3) list_minus_butlast_eq_butlast_list)

(* this can be shown using length_tl, but care is needed when list is empty? *)
lemma prefix_length_tl_minus:
  assumes "strict_prefix s t"
  shows "length (tl (t-s)) = (length (t-s)) - 1"
  by (auto)

lemma length_list_minus:
  assumes "strict_prefix s t"
  shows "length(t - s) = length(t) - length(s)"
  using assms by (simp add: minus_list_def prefix_order.dual_order.strict_implies_order)

lemma butlast_prefix_imp_length_not_gt:
  assumes "length s > 0" "strict_prefix (butlast s) t"
  shows "\<not> (length t < length s)"
  using assms prefix_length_less by fastforce

lemma length_not_gt_iff_eq_length:
  assumes "length s > 0" and "strict_prefix (butlast s) t"
  shows "(\<not> (length s < length t)) = (length s = length t)"
proof -
  have "(\<not> (length s < length t)) = ((length t < length s) \<or> (length s = length t))"
      by (metis not_less_iff_gr_or_eq)
  also have "... = (length s = length t)"
      using assms
      by (simp add:butlast_prefix_imp_length_not_gt)

  finally show ?thesis .
qed

lemma dropWhile_sorted_le_above:
  "\<lbrakk> sorted xs; x \<in> set (dropWhile (\<lambda> x. x \<le> n) xs) \<rbrakk> \<Longrightarrow> x > n"
  apply (induct xs)
  apply (auto)
  apply (rename_tac a xs)
  apply (case_tac "a \<le> n")
  apply (simp_all)
  using sorted_Cons apply blast
  apply (meson dual_order.trans not_less sorted_Cons)
done

lemma set_dropWhile_le:
  "sorted xs \<Longrightarrow> set (dropWhile (\<lambda> x. x \<le> n) xs) = {x\<in>set xs. x > n}"
  apply (induct xs)
  apply (simp)
  apply (rename_tac x xs)
  apply (subgoal_tac "sorted xs")
  apply (simp)
  apply (safe)
  apply (simp_all)
  apply (meson not_less order_trans sorted_Cons)
  using sorted_Cons apply auto
done

lemma set_takeWhile_less_sorted:
  "\<lbrakk> sorted I; x \<in> set I; x < n \<rbrakk> \<Longrightarrow> x \<in> set (takeWhile (\<lambda>x. x < n) I)"
proof (induct I arbitrary: x)
  case Nil thus ?case
    by (simp)
next
  case (Cons a I) thus ?case
    by (auto, (meson le_less_trans sorted_Cons)+)
qed

lemma nth_le_takeWhile_ord: "\<lbrakk> sorted xs; i \<ge> length (takeWhile (\<lambda> x. x \<le> n) xs); i < length xs \<rbrakk> \<Longrightarrow> n \<le> xs ! i"
  apply (induct xs arbitrary: i, auto)
  apply (rename_tac x xs i)
  apply (case_tac "x \<le> n")
  apply (auto simp add: sorted_Cons)
  apply (metis One_nat_def Suc_eq_plus1 le_less_linear le_less_trans less_imp_le list.size(4) nth_mem set_ConsD)
done

lemma length_takeWhile_less:
  "\<lbrakk> a \<in> set xs; \<not> P a \<rbrakk> \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (metis in_set_conv_nth length_takeWhile_le nat_neq_iff not_less set_takeWhileD takeWhile_nth)

lemma nth_length_takeWhile_less:
  "\<lbrakk> sorted xs; distinct xs; (\<exists> a \<in> set xs. a \<ge> n) \<rbrakk> \<Longrightarrow> xs ! length (takeWhile (\<lambda>x. x < n) xs) \<ge> n"
  apply (induct xs, auto)
  using sorted_Cons by blast

text {* Sorting lists according to a relation *}

definition is_sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set_by R A xs = ((\<forall> i<length(xs) - 1. (xs!i, xs!(i + 1)) \<in> R) \<and> set(xs) = A)"

definition sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"sorted_list_of_set_by R A = (THE xs. is_sorted_list_of_set_by R A xs)"

definition fin_set_lexord :: "'a rel \<Rightarrow> 'a set rel" where
"fin_set_lexord R = {(A, B). finite A \<and> finite B \<and>
                             (\<exists> xs ys. is_sorted_list_of_set_by R A xs \<and> is_sorted_list_of_set_by R B ys
                              \<and> (xs, ys) \<in> lexord R)}"

lemma is_sorted_list_of_set_by_mono:
  "\<lbrakk> R \<subseteq> S; is_sorted_list_of_set_by R A xs \<rbrakk> \<Longrightarrow> is_sorted_list_of_set_by S A xs"
  by (auto simp add: is_sorted_list_of_set_by_def)

lemma lexord_mono':
  "\<lbrakk> (\<And> x y. f x y \<longrightarrow> g x y); (xs, ys) \<in> lexord {(x, y). f x y} \<rbrakk> \<Longrightarrow> (xs, ys) \<in> lexord {(x, y). g x y}"
  by (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)

lemma fin_set_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
proof
  assume
    fin: "(xs, ys) \<in> fin_set_lexord {(x, y). f x y}" and
    hyp: "(\<And> x y. f x y \<longrightarrow> g x y)"

  from fin have "finite xs" "finite ys"
    using fin_set_lexord_def by fastforce+

  with fin hyp show "(xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
    apply (auto simp add: fin_set_lexord_def)
    apply (rule_tac x="xsa" in exI)
    apply (auto)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def mem_Collect_eq)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def lexord_mono' mem_Collect_eq)
  done
qed

definition distincts :: "'a set \<Rightarrow> 'a list set" where
"distincts A = {xs \<in> lists A. distinct(xs)}"

lemma tl_element:
  "\<lbrakk> x \<in> set xs; x \<noteq> hd(xs) \<rbrakk> \<Longrightarrow> x \<in> set(tl(xs))"
  by (metis in_set_insert insert_Nil list.collapse list.distinct(2) set_ConsD)

subsection {* Z mathematical tool kit for sequences *}

abbreviation seq_dom :: "'a list \<Rightarrow> nat set" ("dom\<^sub>l") where
"seq_dom xs \<equiv> {0..<length xs}"

abbreviation seq_ran :: "'a list \<Rightarrow> 'a set" ("ran\<^sub>l") where
"seq_ran xs \<equiv> set xs"

definition seq_extract :: "nat set \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "\<upharpoonleft>\<^sub>l" 80) where
"seq_extract A xs = sublist xs A"

lemma seq_extract_Nil [simp]: "A \<upharpoonleft>\<^sub>l [] = []"
  by (simp add: seq_extract_def)

lemma seq_extract_Cons:
  "A \<upharpoonleft>\<^sub>l (x # xs) = (if 0 \<in> A then [x] else []) @ {j. Suc j \<in> A} \<upharpoonleft>\<^sub>l xs"
  by (simp add: seq_extract_def sublist_Cons)

lemma seq_extract_empty [simp]: "{} \<upharpoonleft>\<^sub>l xs = []"
  by (simp add: seq_extract_def)

lemma seq_extract_ident [simp]: "{0..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
  unfolding list_eq_iff_nth_eq
  by (auto simp add: seq_extract_def length_sublist atLeast0LessThan)

lemma seq_extract_split:
  assumes "i \<le> length xs"
  shows "{0..<i} \<upharpoonleft>\<^sub>l xs @ {i..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
using assms
proof (induct xs arbitrary: i)
  case Nil thus ?case by (simp add: seq_extract_def)
next
  case (Cons x xs) note hyp = this
  have "{j. Suc j < i} = {0..<i - 1}"
    by (auto)
  moreover have "{j. i \<le> Suc j \<and> j < length xs} = {i - 1..<length xs}"
    by (auto)
  ultimately show ?case
    using hyp by (force simp add: seq_extract_def sublist_Cons)
qed

lemma seq_extract_append:
  "A \<upharpoonleft>\<^sub>l (xs @ ys) = (A \<upharpoonleft>\<^sub>l xs) @ ({j. j + length xs \<in> A} \<upharpoonleft>\<^sub>l ys)"
  by (simp add: seq_extract_def sublist_append)

lemma seq_extract_range: "A \<upharpoonleft>\<^sub>l xs = (A \<inter> dom\<^sub>l(xs)) \<upharpoonleft>\<^sub>l xs"
  apply (auto simp add: seq_extract_def sublist_def)
  apply (metis (no_types, lifting) atLeastLessThan_iff filter_cong in_set_zip nth_mem set_upt)
done

lemma seq_extract_out_of_range:
  "A \<inter> dom\<^sub>l(xs) = {} \<Longrightarrow> A \<upharpoonleft>\<^sub>l xs = []"
  by (metis seq_extract_def seq_extract_range sublist_empty)

lemma seq_extract_length [simp]:
  "length (A \<upharpoonleft>\<^sub>l xs) = card (A \<inter> dom\<^sub>l(xs))"
proof -
  have "{i. i < length(xs) \<and> i \<in> A} = (A \<inter> {0..<length(xs)})"
    by (auto)
  thus ?thesis
    by (simp add: seq_extract_def length_sublist)
qed

lemma seq_extract_Cons_atLeastLessThan:
  assumes "m < n"
  shows "{m..<n} \<upharpoonleft>\<^sub>l (x # xs) = (if (m = 0) then x # ({0..<n-1} \<upharpoonleft>\<^sub>l xs) else {m-1..<n-1} \<upharpoonleft>\<^sub>l xs)"
proof -
  have "{j. Suc j < n} = {0..<n - Suc 0}"
    by (auto)
  moreover have "{j. m \<le> Suc j \<and> Suc j < n} = {m - Suc 0..<n - Suc 0}"
    by (auto)

  ultimately show ?thesis using assms
    by (auto simp add: seq_extract_Cons)
qed

lemma seq_extract_singleton:
  assumes "i < length xs"
  shows "{i} \<upharpoonleft>\<^sub>l xs = [xs ! i]"
  using assms
  apply (induct xs arbitrary: i)
  apply (auto simp add: seq_extract_Cons)
  apply (rename_tac xs i)
  apply (subgoal_tac "{j. Suc j = i} = {i - 1}")
  apply (auto)
done

lemma seq_extract_as_map:
  assumes "m < n" "n \<le> length xs"
  shows "{m..<n} \<upharpoonleft>\<^sub>l xs = map (nth xs) [m..<n]"
using assms proof (induct xs arbitrary: m n)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  have "[m..<n] = m # [m+1..<n]"
    using Cons.prems(1) upt_eq_Cons_conv by blast
  moreover have "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n-1]"
    by (simp add: map_nth_Cons_atLeastLessThan)
  ultimately show ?case
    using Cons upt_rec
    by (auto simp add: seq_extract_Cons_atLeastLessThan)
qed

lemma seq_append_as_extract:
  "xs = ys @ zs \<longleftrightarrow> (\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
proof
  assume xs: "xs = ys @ zs"
  moreover have "ys = {0..<length ys} \<upharpoonleft>\<^sub>l (ys @ zs)"
    by (simp add: seq_extract_append)
  moreover have "zs = {length ys..<length ys + length zs} \<upharpoonleft>\<^sub>l (ys @ zs)"
  proof -
    have "{length ys..<length ys + length zs} \<inter> {0..<length ys} = {}"
      by auto
    moreover have s1: "{j. j < length zs} = {0..<length zs}"
      by auto
    ultimately show ?thesis
      by (simp add: seq_extract_append seq_extract_out_of_range)
  qed
  ultimately show "(\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
    by (rule_tac x="length ys" in exI, auto)
next
  assume "\<exists>i\<le>length xs. ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length xs} \<upharpoonleft>\<^sub>l xs"
  thus "xs = ys @ zs"
    by (auto simp add: seq_extract_split)
qed

definition seq_filter :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a list" (infix "\<restriction>\<^sub>l" 80) where
"seq_filter xs A = filter (\<lambda> x. x \<in> A) xs"

lemma seq_filter_Cons_in [simp]:
  "x \<in> cs \<Longrightarrow> (x # xs) \<restriction>\<^sub>l cs = x # (xs \<restriction>\<^sub>l cs)"
  by (simp add: seq_filter_def)

lemma seq_filter_Cons_out [simp]:
  "x \<notin> cs \<Longrightarrow> (x # xs) \<restriction>\<^sub>l cs = (xs \<restriction>\<^sub>l cs)"
  by (simp add: seq_filter_def)

lemma seq_filter_Nil [simp]: "[] \<restriction>\<^sub>l A = []"
  by (simp add: seq_filter_def)

lemma seq_filter_empty [simp]: "xs \<restriction>\<^sub>l {} = []"
  by (simp add: seq_filter_def)

lemma seq_filter_append: "(xs @ ys) \<restriction>\<^sub>l A = (xs \<restriction>\<^sub>l A) @ (ys \<restriction>\<^sub>l A)"
  by (simp add: seq_filter_def)

subsection {* Distributed Concatenation *}

definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow>  'c) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c)" where
[simp]: "uncurry f = (\<lambda>(x, y). f x y)"

definition dist_concat ::
  "'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<^sup>\<frown>" 100) where
"dist_concat ls1 ls2 = (uncurry (op @) ` (ls1 \<times> ls2))"

lemma dist_concat_left_empty [simp]:
  "{} \<^sup>\<frown> ys = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_right_empty [simp]:
  "xs \<^sup>\<frown> {} = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_insert [simp]:
"insert l ls1 \<^sup>\<frown> ls2 = ((op @ l) ` ( ls2)) \<union> (ls1 \<^sup>\<frown> ls2)"
  by (auto simp add: dist_concat_def)
end