section {* Relational operational semantics *}

theory utp_rel_opsem
  imports "../hoare/AlgebraicLaws/Rel&Des/Algebraic_Laws"
begin

fun trel :: "'\<alpha> usubst \<times> '\<alpha> hrel \<Rightarrow> '\<alpha> usubst \<times> '\<alpha> hrel \<Rightarrow> bool" (infix "\<rightarrow>\<^sub>u" 85) where
"(\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q) \<longleftrightarrow> (\<langle>\<sigma>\<rangle>\<^sub>a ;; P) \<sqsubseteq> (\<langle>\<rho>\<rangle>\<^sub>a ;; Q)"

lemma trans_trel:
  "\<lbrakk> (\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q); (\<rho>, Q) \<rightarrow>\<^sub>u (\<phi>, R) \<rbrakk> \<Longrightarrow> (\<sigma>, P) \<rightarrow>\<^sub>u (\<phi>, R)"
  by auto

lemma skip_trel: "(\<sigma>, II) \<rightarrow>\<^sub>u (\<sigma>, II)"
  by simp

lemma assigns_trel: "(\<sigma>, \<langle>\<rho>\<rangle>\<^sub>a) \<rightarrow>\<^sub>u (\<rho> \<circ> \<sigma>, II)"
  by (simp add: assigns_comp)

lemma assign_trel:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "uvar x"
  shows "(\<sigma>, x :== v) \<rightarrow>\<^sub>u (\<sigma>(x \<mapsto>\<^sub>s \<sigma> \<dagger> v), II)"
  by (simp add: assigns_comp subst_upd_comp)

lemma seq_trel:
  assumes "(\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q)"
  shows "(\<sigma>, P ;; R) \<rightarrow>\<^sub>u (\<rho>, Q ;; R)"
  by (metis (no_types, lifting) assms order_refl seqr_assoc seqr_mono trel.simps)

lemma seq_skip_trel:
  "(\<sigma>, II ;; P) \<rightarrow>\<^sub>u (\<sigma>, P)"
  by simp

lemma nondet_left_trel:
  "(\<sigma>, P \<sqinter> Q) \<rightarrow>\<^sub>u (\<sigma>, P)"
  by (metis (no_types, hide_lams) disj_comm disj_upred_def semilattice_sup_class.sup.absorb_iff1 semilattice_sup_class.sup.left_idem seqr_or_distr trel.simps)

lemma nondet_right_trel:
  "(\<sigma>, P \<sqinter> Q) \<rightarrow>\<^sub>u (\<sigma>, Q)"
  by (simp add: seqr_mono)

lemma rcond_true_trel:
  assumes "\<sigma> \<dagger> b = true"
  shows "(\<sigma>, P \<triangleleft> b \<triangleright>\<^sub>r Q) \<rightarrow>\<^sub>u (\<sigma>, P)"
  using assms
  by (simp add: assigns_r_comp usubst aext_true cond_unit_T)

lemma rcond_false_trel:
  assumes "\<sigma> \<dagger> b = false"
  shows "(\<sigma>, P \<triangleleft> b \<triangleright>\<^sub>r Q) \<rightarrow>\<^sub>u (\<sigma>, Q)"
  using assms
  by (simp add: assigns_r_comp usubst aext_false cond_unit_F)

lemma while_true_trel:
  assumes "\<sigma> \<dagger> b = true"
  shows "(\<sigma>, while b do P od) \<rightarrow>\<^sub>u (\<sigma>, P ;; while b do P od)"
  by (metis assms rcond_true_trel while_unfold)

lemma while_false_trel:
  assumes "\<sigma> \<dagger> b = false"
  shows "(\<sigma>, while b do P od) \<rightarrow>\<^sub>u (\<sigma>, II)"
  by (metis assms rcond_false_trel while_unfold)

declare trel.simps [simp del]
end


(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
chapter \<open>Basic Types\<close>
theory OCL_Basic_Types
  imports Main "HOL-Library.FSet" "HOL-Library.Phantom_Type" "Eval_Base.Eval_Base"
begin

(*** Definition *************************************************************)

section \<open>Definition\<close>

text \<open>
  Basic types are parameterized over classes.\<close>

type_synonym 'a enum = "('a, String.literal) phantom"
type_synonym elit = String.literal

datatype ('a :: order) basic_type =
  OclAny
| OclVoid
| Boolean
| Real
| Integer
| UnlimitedNatural
| String
| ObjectType 'a ("\<langle>_\<rangle>\<^sub>\<T>" [0] 1000)
| Enum "'a enum"

inductive basic_subtype (infix "\<sqsubset>\<^sub>B" 65) where
  "OclVoid \<sqsubset>\<^sub>B Boolean"
| "OclVoid \<sqsubset>\<^sub>B UnlimitedNatural"
| "OclVoid \<sqsubset>\<^sub>B String"
| "OclVoid \<sqsubset>\<^sub>B \<langle>\<C>\<rangle>\<^sub>\<T>"
| "OclVoid \<sqsubset>\<^sub>B Enum \<E>"

| "UnlimitedNatural \<sqsubset>\<^sub>B Integer"
| "Integer \<sqsubset>\<^sub>B Real"
| "\<C> < \<D> \<Longrightarrow> \<langle>\<C>\<rangle>\<^sub>\<T> \<sqsubset>\<^sub>B \<langle>\<D>\<rangle>\<^sub>\<T>"

| "Boolean \<sqsubset>\<^sub>B OclAny"
| "Real \<sqsubset>\<^sub>B OclAny"
| "String \<sqsubset>\<^sub>B OclAny"
| "\<langle>\<C>\<rangle>\<^sub>\<T> \<sqsubset>\<^sub>B OclAny"
| "Enum \<E> \<sqsubset>\<^sub>B OclAny"

declare basic_subtype.intros [intro!]

inductive_cases basic_subtype_x_OclAny [elim!]: "\<tau> \<sqsubset>\<^sub>B OclAny"
inductive_cases basic_subtype_x_OclVoid [elim!]: "\<tau> \<sqsubset>\<^sub>B OclVoid"
inductive_cases basic_subtype_x_Boolean [elim!]: "\<tau> \<sqsubset>\<^sub>B Boolean"
inductive_cases basic_subtype_x_Real [elim!]: "\<tau> \<sqsubset>\<^sub>B Real"
inductive_cases basic_subtype_x_Integer [elim!]: "\<tau> \<sqsubset>\<^sub>B Integer"
inductive_cases basic_subtype_x_UnlimitedNatural [elim!]: "\<tau> \<sqsubset>\<^sub>B UnlimitedNatural"
inductive_cases basic_subtype_x_String [elim!]: "\<tau> \<sqsubset>\<^sub>B String"
inductive_cases basic_subtype_x_ObjectType [elim!]: "\<tau> \<sqsubset>\<^sub>B \<langle>\<C>\<rangle>\<^sub>\<T>"
inductive_cases basic_subtype_x_Enum [elim!]: "\<tau> \<sqsubset>\<^sub>B Enum \<E>"

inductive_cases basic_subtype_OclAny_x [elim!]: "OclAny \<sqsubset>\<^sub>B \<sigma>"
inductive_cases basic_subtype_ObjectType_x [elim!]: "\<langle>\<C>\<rangle>\<^sub>\<T> \<sqsubset>\<^sub>B \<sigma>"

lemma basic_subtype_asym:
  "\<tau> \<sqsubset>\<^sub>B \<sigma> \<Longrightarrow> \<sigma> \<sqsubset>\<^sub>B \<tau> \<Longrightarrow> False"
  apply2 (induct rule: basic_subtype.induct) by (auto)

(*** Partial Order of Basic Types *******************************************)

section \<open>Partial Order of Basic Types\<close>

instantiation basic_type :: (order) order
begin

definition "(<) \<equiv> basic_subtype\<^sup>+\<^sup>+"
definition "(\<le>) \<equiv> basic_subtype\<^sup>*\<^sup>*"

(*** Strict Introduction Rules **********************************************)

subsection \<open>Strict Introduction Rules\<close>

lemma type_less_x_OclAny_intro [intro]:
  "\<tau> \<noteq> OclAny \<Longrightarrow> \<tau> < OclAny"
proof -
  have "basic_subtype\<^sup>+\<^sup>+ OclVoid OclAny"
    by (rule_tac ?b="Boolean" in tranclp.trancl_into_trancl; auto)
  moreover have "basic_subtype\<^sup>+\<^sup>+ Integer OclAny"
    by (rule_tac ?b="Real" in tranclp.trancl_into_trancl; auto)
  moreover hence "basic_subtype\<^sup>+\<^sup>+ UnlimitedNatural OclAny"
    by (rule_tac ?b="Integer" in tranclp_into_tranclp2; auto)
  ultimately show "\<tau> \<noteq> OclAny \<Longrightarrow> \<tau> < OclAny"
    unfolding less_basic_type_def
    apply2 (induct \<tau>) by(auto)
qed

lemma type_less_OclVoid_x_intro [intro]:
  "\<tau> \<noteq> OclVoid \<Longrightarrow> OclVoid < \<tau>"
proof -
  have "basic_subtype\<^sup>+\<^sup>+ OclVoid OclAny"
    by (rule_tac ?b="Boolean" in tranclp.trancl_into_trancl; auto)
  moreover have "basic_subtype\<^sup>+\<^sup>+ OclVoid Integer"
    by (rule_tac ?b="UnlimitedNatural" in tranclp.trancl_into_trancl; auto)
  moreover hence "basic_subtype\<^sup>+\<^sup>+ OclVoid Real"
    by (rule_tac ?b="Integer" in tranclp.trancl_into_trancl; auto)
  ultimately show "\<tau> \<noteq> OclVoid \<Longrightarrow> OclVoid < \<tau>"
    unfolding less_basic_type_def
    apply2 (induct \<tau>) by(auto)
qed

lemma type_less_x_Real_intro [intro]:
  "\<tau> = UnlimitedNatural \<Longrightarrow> \<tau> < Real"
  "\<tau> = Integer \<Longrightarrow> \<tau> < Real"
  unfolding less_basic_type_def
  by (rule rtranclp_into_tranclp2, auto)

lemma type_less_x_Integer_intro [intro]:
  "\<tau> = UnlimitedNatural \<Longrightarrow> \<tau> < Integer"
  unfolding less_basic_type_def
  by (rule rtranclp_into_tranclp2, auto)

lemma type_less_x_ObjectType_intro [intro]:
  "\<tau> = \<langle>\<C>\<rangle>\<^sub>\<T> \<Longrightarrow> \<C> < \<D> \<Longrightarrow> \<tau> < \<langle>\<D>\<rangle>\<^sub>\<T>"
  unfolding less_basic_type_def
  using dual_order.order_iff_strict by blast

(*** Strict Elimination Rules ***********************************************)

subsection \<open>Strict Elimination Rules\<close>

lemma type_less_x_OclAny [elim!]:
  "\<tau> < OclAny \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Boolean \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Integer \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Real \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = String \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<E>. \<tau> = Enum \<E> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<C>. \<tau> = \<langle>\<C>\<rangle>\<^sub>\<T> \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

lemma type_less_x_OclVoid [elim!]:
  "\<tau> < OclVoid \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by (auto)

lemma type_less_x_Boolean [elim!]:
  "\<tau> < Boolean \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

lemma type_less_x_Real [elim!]:
  "\<tau> < Real \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Integer \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

lemma type_less_x_Integer [elim!]:
  "\<tau> < Integer \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

lemma type_less_x_UnlimitedNatural [elim!]:
  "\<tau> < UnlimitedNatural \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

lemma type_less_x_String [elim!]:
  "\<tau> < String \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

lemma type_less_x_ObjectType [elim!]:
  "\<tau> < \<langle>\<D>\<rangle>\<^sub>\<T> \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<C>. \<tau> = \<langle>\<C>\<rangle>\<^sub>\<T> \<Longrightarrow> \<C> < \<D> \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct)
  apply auto[1]
  using less_trans by auto

lemma type_less_x_Enum [elim!]:
  "\<tau> < Enum \<E> \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_basic_type_def
  apply2 (induct rule: converse_tranclp_induct) by(auto)

(*** Properties *************************************************************)

subsection \<open>Properties\<close>

lemma basic_subtype_irrefl:
  "\<tau> < \<tau> \<Longrightarrow> False"
  for \<tau> :: "'a basic_type"
  by (cases \<tau>; auto)

lemma tranclp_less_basic_type:
  "(\<tau>, \<sigma>) \<in> {(\<tau>, \<sigma>). \<tau> \<sqsubset>\<^sub>B \<sigma>}\<^sup>+ \<longleftrightarrow> \<tau> < \<sigma>"
  by (simp add: tranclp_unfold less_basic_type_def)

lemma basic_subtype_acyclic:
  "acyclicP basic_subtype"
  apply (rule acyclicI)
  using OCL_Basic_Types.basic_subtype_irrefl
    OCL_Basic_Types.tranclp_less_basic_type by auto

lemma less_le_not_le_basic_type:
  "\<tau> < \<sigma> \<longleftrightarrow> \<tau> \<le> \<sigma> \<and> \<not> \<sigma> \<le> \<tau>"
  for \<tau> \<sigma> :: "'a basic_type"
  unfolding less_basic_type_def less_eq_basic_type_def
  apply (rule iffI; auto)
  apply (metis (mono_tags) basic_subtype_irrefl
      less_basic_type_def tranclp_rtranclp_tranclp)
  by (drule rtranclpD; auto)

lemma antisym_basic_type:
  "\<tau> \<le> \<sigma> \<Longrightarrow> \<sigma> \<le> \<tau> \<Longrightarrow> \<tau> = \<sigma>"
  for \<tau> \<sigma> :: "'a basic_type"
  unfolding less_eq_basic_type_def less_basic_type_def
  by (metis (mono_tags, lifting) less_eq_basic_type_def
      less_le_not_le_basic_type less_basic_type_def rtranclpD)

lemma order_refl_basic_type [iff]:
  "\<tau> \<le> \<tau>"
  for \<tau> :: "'a basic_type"
  by (simp add: less_eq_basic_type_def)

instance
  by standard (auto simp add: less_eq_basic_type_def
        less_le_not_le_basic_type antisym_basic_type)

end

(*** Non-Strict Introduction Rules ******************************************)

subsection \<open>Non-Strict Introduction Rules\<close>

lemma type_less_eq_x_OclAny_intro [intro]:
  "\<tau> \<le> OclAny"
  using order.order_iff_strict by auto

lemma type_less_eq_OclVoid_x_intro [intro]:
  "OclVoid \<le> \<tau>"
  using order.order_iff_strict by auto

lemma type_less_eq_x_Real_intro [intro]:
  "\<tau> = UnlimitedNatural \<Longrightarrow> \<tau> \<le> Real"
  "\<tau> = Integer \<Longrightarrow> \<tau> \<le> Real"
  using order.order_iff_strict by auto

lemma type_less_eq_x_Integer_intro [intro]:
  "\<tau> = UnlimitedNatural \<Longrightarrow> \<tau> \<le> Integer"
  using order.order_iff_strict by auto

lemma type_less_eq_x_ObjectType_intro [intro]:
  "\<tau> = \<langle>\<C>\<rangle>\<^sub>\<T> \<Longrightarrow> \<C> \<le> \<D> \<Longrightarrow> \<tau> \<le> \<langle>\<D>\<rangle>\<^sub>\<T>"
  using order.order_iff_strict by fastforce

(*** Non-Strict Elimination Rules *******************************************)

subsection \<open>Non-Strict Elimination Rules\<close>

lemma type_less_eq_x_OclAny [elim!]:
  "\<tau> \<le> OclAny \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = OclAny \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Boolean \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Integer \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Real \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = String \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<E>. \<tau> = Enum \<E> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<C>. \<tau> = \<langle>\<C>\<rangle>\<^sub>\<T> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_OclVoid [elim!]:
  "\<tau> \<le> OclVoid \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Boolean [elim!]:
  "\<tau> \<le> Boolean \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Boolean \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Real [elim!]:
  "\<tau> \<le> Real \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Integer \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Real \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Integer [elim!]:
  "\<tau> \<le> Integer \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Integer \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_UnlimitedNatural [elim!]:
  "\<tau> \<le> UnlimitedNatural \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = UnlimitedNatural \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_String [elim!]:
  "\<tau> \<le> String \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = String \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_ObjectType [elim!]:
  "\<tau> \<le> \<langle>\<D>\<rangle>\<^sub>\<T> \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<C>. \<tau> = \<langle>\<C>\<rangle>\<^sub>\<T> \<Longrightarrow> \<C> \<le> \<D> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Enum [elim!]:
  "\<tau> \<le> Enum \<E> \<Longrightarrow>
   (\<tau> = OclVoid \<Longrightarrow> P) \<Longrightarrow>
   (\<tau> = Enum \<E> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

(*** Simplification Rules ***************************************************)

subsection \<open>Simplification Rules\<close>

lemma basic_type_less_left_simps [simp]:
  "OclAny < \<sigma> = False"
  "OclVoid < \<sigma> = (\<sigma> \<noteq> OclVoid)"
  "Boolean < \<sigma> = (\<sigma> = OclAny)"
  "Real < \<sigma> = (\<sigma> = OclAny)"
  "Integer < \<sigma> = (\<sigma> = OclAny \<or> \<sigma> = Real)"
  "UnlimitedNatural < \<sigma> = (\<sigma> = OclAny \<or> \<sigma> = Real \<or> \<sigma> = Integer)"
  "String < \<sigma> = (\<sigma> = OclAny)"
  "ObjectType \<C> < \<sigma> = (\<exists>\<D>. \<sigma> = OclAny \<or> \<sigma> = ObjectType \<D> \<and> \<C> < \<D>)"
  "Enum \<E> < \<sigma> = (\<sigma> = OclAny)"
  apply2 (induct \<sigma>) by(auto)

lemma basic_type_less_right_simps [simp]:
  "\<tau> < OclAny = (\<tau> \<noteq> OclAny)"
  "\<tau> < OclVoid = False"
  "\<tau> < Boolean = (\<tau> = OclVoid)"
  "\<tau> < Real = (\<tau> = Integer \<or> \<tau> = UnlimitedNatural \<or> \<tau> = OclVoid)"
  "\<tau> < Integer = (\<tau> = UnlimitedNatural \<or> \<tau> = OclVoid)"
  "\<tau> < UnlimitedNatural = (\<tau> = OclVoid)"
  "\<tau> < String = (\<tau> = OclVoid)"
  "\<tau> < ObjectType \<D> = (\<exists>\<C>. \<tau> = ObjectType \<C> \<and> \<C> < \<D> \<or> \<tau> = OclVoid)"
  "\<tau> < Enum \<E> = (\<tau> = OclVoid)"
  by auto

(*** Upper Semilattice of Basic Types ***************************************)

section \<open>Upper Semilattice of Basic Types\<close>

notation sup (infixl "\<squnion>" 65)

instantiation basic_type :: (semilattice_sup) semilattice_sup
begin

(* We use "case"-style because it works faster *)
fun sup_basic_type where
  "\<langle>\<C>\<rangle>\<^sub>\<T> \<squnion> \<sigma> = (case \<sigma> of OclVoid \<Rightarrow> \<langle>\<C>\<rangle>\<^sub>\<T> | \<langle>\<D>\<rangle>\<^sub>\<T> \<Rightarrow> \<langle>\<C> \<squnion> \<D>\<rangle>\<^sub>\<T> | _ \<Rightarrow> OclAny)"
| "\<tau> \<squnion> \<sigma> = (if \<tau> \<le> \<sigma> then \<sigma> else (if \<sigma> \<le> \<tau> then \<tau> else OclAny))"

lemma sup_ge1_ObjectType:
  "\<langle>\<C>\<rangle>\<^sub>\<T> \<le> \<langle>\<C>\<rangle>\<^sub>\<T> \<squnion> \<sigma>"
  apply2 (induct \<sigma>) apply(simp_all add: basic_subtype.simps
        less_eq_basic_type_def r_into_rtranclp)
  by (metis Nitpick.rtranclp_unfold basic_subtype.intros(8)
        le_imp_less_or_eq r_into_rtranclp sup_ge1)

lemma sup_ge1_basic_type:
  "\<tau> \<le> \<tau> \<squnion> \<sigma>"
  for \<tau> \<sigma> :: "'a basic_type"
  apply2 (induct \<tau>) apply(auto)
  using sup_ge1_ObjectType by auto

lemma sup_commut_basic_type:
  "\<tau> \<squnion> \<sigma> = \<sigma> \<squnion> \<tau>"
  for \<tau> \<sigma> :: "'a basic_type"(*  by (induct \<tau>; induct \<sigma>; auto simp add: sup.commute)*)
  apply2 (induct \<tau>)
          apply2 (induct \<sigma>)
                  apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
                 apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
                apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
               apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
              apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
             apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
            apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
           apply(fastforce simp add: sup.commute)+
          apply2 (induct \<sigma>)
          apply(fastforce simp add: sup.commute)+
  done

instance
  by standard (auto simp add: sup_ge1_basic_type
        sup_commut_basic_type sup_least_basic_type)

end

(*** Code Setup *************************************************************)

section \<open>Code Setup\<close>

code_pred basic_subtype .

fun basic_subtype_fun :: "'a::order basic_type \<Rightarrow> 'a basic_type \<Rightarrow> bool" where
  "basic_subtype_fun OclAny \<sigma> = False"
| "basic_subtype_fun OclVoid \<sigma> = (\<sigma> \<noteq> OclVoid)"
| "basic_subtype_fun Boolean \<sigma> = (\<sigma> = OclAny)"
| "basic_subtype_fun Real \<sigma> = (\<sigma> = OclAny)"
| "basic_subtype_fun Integer \<sigma> = (\<sigma> = Real \<or> \<sigma> = OclAny)"
| "basic_subtype_fun UnlimitedNatural \<sigma> = (\<sigma> = Integer \<or> \<sigma> = Real \<or> \<sigma> = OclAny)"
| "basic_subtype_fun String \<sigma> = (\<sigma> = OclAny)"
| "basic_subtype_fun \<langle>\<C>\<rangle>\<^sub>\<T> \<sigma> = (case \<sigma>
    of \<langle>\<D>\<rangle>\<^sub>\<T> \<Rightarrow> \<C> < \<D>
     | OclAny \<Rightarrow> True
     | _ \<Rightarrow> False)"
| "basic_subtype_fun (Enum _) \<sigma> = (\<sigma> = OclAny)"

lemma less_basic_type_code [code]:
  "(<) = basic_subtype_fun"
proof (intro ext iffI)
  fix \<tau> \<sigma> :: "'a basic_type"
  show "\<tau> < \<sigma> \<Longrightarrow> basic_subtype_fun \<tau> \<sigma>"
    apply (cases \<sigma>; auto)
    using basic_subtype_fun.elims(3) by fastforce
  show "basic_subtype_fun \<tau> \<sigma> \<Longrightarrow> \<tau> < \<sigma>"
    apply (erule basic_subtype_fun.elims, auto)
    by (cases \<sigma>, auto)
qed

lemma less_eq_basic_type_code [code]:
  "(\<le>) = (\<lambda>x y. basic_subtype_fun x y \<or> x = y)"
  unfolding dual_order.order_iff_strict less_basic_type_code
  by auto

end


theory RelyGuarantee2
  imports Language
begin

datatype 'a top = Top | NotTop 'a

abbreviation bind :: "('a \<Rightarrow> 'b top) \<Rightarrow> 'a top \<Rightarrow> 'b top" (infixr "\<hookleftarrow>" 56) where
  "bind f x \<equiv> case x of Top \<Rightarrow> Top | NotTop x \<Rightarrow> f x"

lemma top_left_id: "f \<hookleftarrow> (NotTop x) = f x"
  by auto

lemma top_right_id: "NotTop \<hookleftarrow> x = x"
  by (cases x) auto

lemma top_assoc: "g \<hookleftarrow> f \<hookleftarrow> x = (\<lambda>x. g \<hookleftarrow> (f x)) \<hookleftarrow> x"
  by (cases x) auto

instantiation top :: (ord) ord
begin
  definition less_eq_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> bool" where
    "x \<le> y \<equiv> case y of Top \<Rightarrow> True | NotTop y \<Rightarrow> case x of Top \<Rightarrow> False | NotTop x \<Rightarrow> x \<le> y"

  definition less_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> bool" where
    "less_top x y \<equiv> x \<le> y \<and> \<not> (y \<le> x)"

  instance by default
end

instance top :: (order) order
proof
  fix x y z :: "'a top"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (simp add: less_top_def)
  show "x \<le> x"
    by (cases x) (auto simp add: less_eq_top_def)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    apply (cases x)
    apply (cases y, cases z, (force simp add: less_eq_top_def)+)
    apply (cases y, cases z, (force simp add: less_eq_top_def)+)
    by (cases z, (force simp add: less_eq_top_def)+)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x) (cases y, (force simp add: less_eq_top_def)+)+
qed

lemma NotTop_mono [intro!]: "x \<le> y \<Longrightarrow> NotTop x \<le> NotTop y"
  by (auto simp add: less_eq_top_def)

instantiation top :: (lattice) lattice
begin
  definition sup_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> 'a top" where
    "sup_top x y \<equiv> case x of Top \<Rightarrow> Top | NotTop x \<Rightarrow> (case y of Top \<Rightarrow> Top | NotTop y \<Rightarrow> NotTop (sup x y))"

  definition inf_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> 'a top" where
    "inf_top x y \<equiv> case x of Top \<Rightarrow> y | NotTop x \<Rightarrow> (case y of Top \<Rightarrow> NotTop x | NotTop y \<Rightarrow> NotTop (inf x y))"

  instance
  proof
    fix x y z :: "'a top"
    show "inf x y \<le> x"
      sorry
    show "inf x y \<le> y"
      sorry
    show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> inf y z"
      sorry
    show "x \<le> sup x y"
      sorry
    show "y \<le> sup x y"
      sorry
    show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> sup y z \<le> x"
      sorry
  qed
end

instantiation top :: (complete_lattice) complete_lattice
begin
  definition Inf_top :: "'a top set \<Rightarrow> 'a top" where "Inf_top \<equiv> undefined"

  definition Sup_top :: "'a top set \<Rightarrow> 'a top" where "Sup_top X \<equiv> if Top \<in> X then Top else NotTop (Sup {x. NotTop x \<in> X})"

  definition top_top :: "'a top" where "top_top = Top"

  definition bot_top :: "'a top" where "bot_top = NotTop bot"

  instance
  proof
    fix a :: "'a top"
    show "a \<le> top"
      by (cases a) (auto simp add: top_top_def less_eq_top_def)
    show "bot \<le> a"
      by (cases a) (auto simp add: bot_top_def less_eq_top_def)
  next
    fix x :: "'a top" and A :: "'a top set"
    assume xA: "x \<in> A"
    show "Inf A \<le> x"
      sorry
    show "x \<le> Sup A"
      by (insert xA, cases x, auto intro: Sup_upper simp add: Sup_top_def less_eq_top_def)
  next
    fix z :: "'a top" and A :: "'a top set"
    assume "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
    thus "z \<le> Inf A"
      sorry
  next
    fix z :: "'a top" and A :: "'a top set"
    assume "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
    thus "Sup A \<le> z"
      apply (cases z)
      apply (auto intro!: Sup_least simp add: Sup_top_def less_eq_top_def)
      apply (metis top.simps(4))
      by (metis (full_types) top.simps(5))
  qed
end

datatype 'a act = Act "'a set" "'a rel"

definition sync_free_list :: "'a act list \<Rightarrow> bool" where
  "sync_free_list = undefined"

fun eval_word :: "'a act list \<Rightarrow> 'a set \<Rightarrow> 'a set top" where
  "eval_word [] p = NotTop p"
| "eval_word (Act q x # xs) p = (if p \<subseteq> q then eval_word xs (x `` p) else top)"

lemma eval_word_empty [simp]: "eval_word xs {} = NotTop {}"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons x xs) thus ?case by (cases x) simp
qed

lemma eval_append_word: "eval_word (xs @ ys) h = eval_word ys \<hookleftarrow> eval_word xs h"
proof (induct xs arbitrary: h)
  case Nil show ?case by simp
next
  case (Cons x xs) thus ?case
    by (cases x) simp
qed

lemma eval_append_word_bind: "eval_word (xs @ ys) \<hookleftarrow> h = eval_word ys \<hookleftarrow> eval_word xs \<hookleftarrow> h"
  by (cases h) (simp_all add: eval_append_word)

lemma Image_continuous: "x `` (\<Union>X) = \<Union>Image x ` X"
  by auto

lemma NotTop_continuous: "NotTop (\<Union>X) = Sup (NotTop ` X)"
  by (auto simp add: Sup_top_def)

lemma top_in_Sup: "top \<in> X \<Longrightarrow> Sup X = top" sorry

lemma eval_word_continuous: "eval_word w (Sup X) = Sup (eval_word w ` X)"
proof (induct w arbitrary: X)
  case Nil show ?case by(simp add: NotTop_continuous)
next
  case (Cons x xs)
  show ?case
  proof (induct x)
    fix p x
    {
      assume "\<Union>X \<subseteq> p"
      hence "eval_word (Act p x # xs) (\<Union>X) = Sup (eval_word (Act p x # xs) ` X)"
        apply (simp add: image_def)
        apply (subst Image_continuous)
        apply (subst Cons.hyps)
        apply (rule arg_cong) back
        by auto
    }
    moreover
    {
      assume "\<not> (\<Union>X \<subseteq> p)"
      hence "eval_word (Act p x # xs) (\<Union>X) = Sup (eval_word (Act p x # xs) ` X)"
        apply (simp add: image_def)
        apply (rule sym)
        apply (rule top_in_Sup)
        by auto
    }
    ultimately show "eval_word (Act p x # xs) (\<Union>X) = Sup (eval_word (Act p x # xs) ` X)"
      by blast
  qed
qed

lemma eval_word_bind_continuous: "eval_word w \<hookleftarrow> (Sup X) = Sup {eval_word w \<hookleftarrow> x |x. x \<in> X}"
  apply (auto simp add: Sup_top_def eval_word_continuous image_def)
  apply (metis top.simps(5))
  apply (metis (full_types) top.exhaust top.simps(5))
  apply (metis top.simps(5))
  by (metis (full_types) top.exhaust top.simps(4) top.simps(5))

definition module :: "'a act lan \<Rightarrow> 'a set top \<Rightarrow> 'a set top" (infix "\<Colon>" 60) where
  "x \<Colon> h = Sup {eval_word w \<hookleftarrow> h|w. w \<in> x}"

lemma set_comp_f_eq: "(\<And>x. P x \<Longrightarrow> f x = g x) \<Longrightarrow> {f x |x. P x} = {g x |x. P x}"
  by auto metis

lemma (in complete_lattice) Sup_comp_mono [intro]: "(\<And>x. P x \<Longrightarrow> f x \<le> g x) \<Longrightarrow> Sup {f x |x. P x} \<le> Sup {g x |x. P x}"
  by (auto intro: Sup_mono)

lemma (in complete_lattice) Sup_comp_conj: "Sup {f x y |x y. P x \<and> Q y} = Sup {Sup {f x y |x. P x} |y. Q y}"
  apply (rule antisym)
  apply (simp_all add: Sup_le_iff)
  apply auto
  defer
  apply (rule Sup_mono)
  apply auto
  apply (subgoal_tac "f x y \<le> Sup {f x y |y. Q y}")
  apply (erule order_trans)
  defer
  apply (metis (lifting, full_types) Sup_upper mem_Collect_eq)
  apply (rule Sup_comp_mono)
  by (metis (lifting, full_types) Sup_upper mem_Collect_eq)

lemma mod_mult: "x\<cdot>y \<Colon> h = y \<Colon> (x \<Colon> h)"
proof -
  have "x\<cdot>y \<Colon> h = Sup {eval_word w \<hookleftarrow> h|w. w \<in> x\<cdot>y}"
    by (simp add: module_def)
  also have "... = Sup {eval_word (xw @ yw) \<hookleftarrow> h|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (rule arg_cong, auto simp: in_l_prod)
  also have "... = Sup {eval_word yw \<hookleftarrow> eval_word xw \<hookleftarrow> h|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (simp add: eval_append_word_bind)
  also have "... = Sup {Sup {eval_word yw \<hookleftarrow> eval_word xw \<hookleftarrow> h|xw. xw \<in> x}|yw. yw \<in> y}"
    by (simp add: Sup_comp_conj)
  also have "... = Sup {eval_word yw \<hookleftarrow> (Sup {eval_word xw \<hookleftarrow> h|xw. xw \<in> x})|yw. yw \<in> y}"
    by (auto intro!: arg_cong[where f = Sup] simp add: eval_word_bind_continuous)
  also have "... = Sup {eval_word yw \<hookleftarrow> (x \<Colon> h)|yw. yw \<in> y}"
    by (simp add: module_def)
  also have "... = y \<Colon> (x \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_one [simp]: "{[]} \<Colon> h = h"
  by (cases h) (simp_all add: module_def)

lemma mod_zero [simp]: "{} \<Colon> h = bot"
  by (simp add: module_def)

lemma mod_empty [simp]: "x \<Colon> bot = bot"
proof (cases "x = {}", simp)
  assume "x \<noteq> {}"
  have "x \<Colon> bot = Sup {eval_word w \<hookleftarrow> bot |w. w \<in> x}"
    by (simp add: module_def)
  also have "... = Sup {p. p = NotTop {} \<and> (\<exists>w. w \<in> x)}"
    by (simp add: bot_top_def)

lemma mod_distl: "(x \<union> y) \<Colon> h = (x \<Colon> h) \<union> (y \<Colon> h)"
proof -
  have "(x \<union> y) \<Colon> h = \<Union>{eval_word w h|w. w \<in> x \<union> y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h|w. w \<in> x \<or> w \<in> y}"
    by blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w h|w. w \<in> y}"
    by blast
  also have "... = (x \<Colon> h) \<union> (y \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_distr: "x \<Colon> (h \<union> g) = (x \<Colon> h) \<union> (x \<Colon> g)"
proof -
  have "x \<Colon> (h \<union> g) = \<Union>{eval_word w (h \<union> g)|w. w \<in> x}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h \<union> eval_word w g|w. w \<in> x}"
    by (simp add: eval_word_def) blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w g|w. w \<in> x}"
    by blast
  also have "... = (x \<Colon> h) \<union> (x \<Colon> g)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_isol: "x \<subseteq> y \<Longrightarrow> x \<Colon> p \<subseteq> y \<Colon> p"
  by (auto simp add: module_def)

lemma mod_isor: "p \<subseteq> q \<Longrightarrow> x \<Colon> p \<subseteq> x \<Colon> q"
  by (metis mod_distr subset_Un_eq)

lemma mod_continuous: "\<Union>X \<Colon> p = \<Union>{x \<Colon> p|x. x \<in> X}"
  by (simp add: module_def) blast

lemma mod_continuous_var: "\<Union>{f x|x. P x} \<Colon> p = \<Union>{f x \<Colon> p|x. P x}"
  by (simp add: mod_continuous) blast

definition mod_test :: "('a set) \<Rightarrow> 'a act lan" ("_?" [101] 100) where
  "p? \<equiv> {[Act (\<lambda>x. {x} \<inter> p)]}"

lemma mod_test: "p? \<Colon> q = p \<inter> q"
  by (auto simp add: module_def mod_test_def)

lemma test_true: "q \<subseteq> p \<Longrightarrow> p? \<Colon> q = q"
  by (metis Int_absorb1 mod_test)

lemma test_false: "q \<subseteq> -p \<Longrightarrow> p? \<Colon> q = {}"
  by (metis Int_commute disjoint_eq_subset_Compl mod_test)

lemma l_prod_distr: "(X \<union> Y) \<cdot> Z = X \<cdot> Z \<union> Y \<cdot> Z"
  by (insert l_prod_inf_distr[of "{X, Y}" Z]) auto

lemma l_prod_distl: "X \<cdot> (Y \<union> Z) = X \<cdot> Y \<union> X \<cdot> Z"
  by (insert l_prod_inf_distl[of "X" "{Y, Z}"]) auto

no_notation
  Transitive_Closure.trancl ("(_\<^sup>+)" [1000] 999)

definition l_plus :: "'a lan \<Rightarrow> 'a lan" ("_\<^sup>+" [101] 100) where
  "X\<^sup>+ = X\<cdot>X\<^sup>*"

lemma l_plus_unfold: "X\<^sup>+ = X \<union> X\<^sup>+"
  sorry

lemma "q \<subseteq> p \<Longrightarrow> (p?)\<^sup>+\<cdot>x \<Colon> q = (x \<Colon> q) \<union> ((p?)\<^sup>+\<cdot>x \<Colon> q)"
  by (smt l_plus_unfold l_prod_distr mod_distl mod_mult test_true)

lemma "(p?)\<^sup>+\<cdot>x \<Colon> q = (x \<Colon> q \<inter> p) \<union> ((p?)\<^sup>+\<cdot>x \<Colon> q)"
  by (metis inf.commute l_plus_unfold mod_distl mod_distr mod_mult mod_test)

lemma "q \<subseteq> p \<Longrightarrow> (p?)\<^sup>+\<cdot>x \<Colon> q = (x \<Colon> q)"
  nitpick

lemma "p?\<cdot>x \<Colon> q = x\<cdot>q"

lemma "q \<subseteq> -p \<Longrightarrow> p? \<Colon> q = {}"
  by (metis Int_commute disjoint_eq_subset_Compl mod_test)

lemma [simp]: "map \<langle>id,id\<rangle> ` (x \<union> y) = map \<langle>id,id\<rangle> ` x \<union> map \<langle>id,id\<rangle> ` y"
  by (auto simp add: image_def)

lemma image_InL [simp]: "map \<langle>id,id\<rangle> ` op # (InL x) ` X = op # x ` map \<langle>id,id\<rangle> ` X"
  by (auto simp add: image_def)

lemma image_InR [simp]: "map \<langle>id,id\<rangle> ` op # (InR x) ` X = op # x ` map \<langle>id,id\<rangle> ` X"
  by (auto simp add: image_def)

lemma image_singleton: "op # x ` X = {[x]} \<cdot> X"
  by (auto simp add: image_def l_prod_def complex_product_def)

lemma tshuffle_await_cons:
  "q \<subseteq> - p \<Longrightarrow> map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # ys) \<sha> (x # xs)) \<Colon> q = op # x ` (map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # ys) \<sha> xs)) \<Colon> q"
  apply (subst tshuffle_ind)
  apply (simp add: mod_distl)
  apply (simp add: image_singleton mod_mult)
  apply (subst module_def) back
  apply (subgoal_tac "q \<inter> p = {}")
  apply simp
  by blast

definition to_rel :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a rel" where
  "to_rel f = {(x, y)|x y. y \<in> f x}"

definition to_fun :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "to_fun R x = {y. (x, y) \<in> R}"

lemma rel_fun_inv [simp]: "to_rel (to_fun R) = R"
  by (auto simp add: to_fun_def to_rel_def)

lemma fun_rel_inv [simp]: "to_fun (to_rel f) = f"
  by (auto simp add: to_fun_def to_rel_def)

lemma [simp]: "to_fun {} = (\<lambda>x. {})"
  apply (rule ext)
  by (simp add: to_fun_def)

definition \<iota> :: "'a act lan \<Rightarrow> 'a rel" where
  "\<iota> X = \<Union>{to_rel (runAct x)|x. x \<in> symbols X}"

definition \<rho> :: "'a rel \<Rightarrow> 'a act lan" where
  "\<rho> R = pow_inv {Act (to_fun S)|S. S \<subseteq> R}"

lemma \<iota>_iso: "X \<subseteq> Y \<Longrightarrow> \<iota> X \<subseteq> \<iota> Y"
  apply (simp add: \<iota>_def symbols_def)
  by blast

lemma \<rho>_iso: "X \<subseteq> Y \<Longrightarrow> \<rho> X \<subseteq> \<rho> Y"
  apply (simp add: \<rho>_def)
  apply (rule pow_inv_iso)
  by blast

lemma [simp]: "symbols (pow_inv Z) = Z"
proof -
  {
    fix x
    assume "x \<in> Z"
    hence "[x] \<in> pow_inv Z"
      by (metis pow_inv.pinv_cons pow_inv.pinv_empty)
    hence "x \<in> symbols (pow_inv Z)"
      by (metis symbol_cons)
  }
  moreover
  have "symbols (pow_inv Z) \<subseteq> Z"
  proof (auto simp add: symbols_def)
    fix x xs
    assume "xs \<in> pow_inv Z" and "x \<in> set xs"
    thus "x \<in> Z"
      by (induct xs rule: pow_inv.induct) auto
  qed
  ultimately show ?thesis
    by auto
qed

lemma [simp]: "\<Union>{to_rel (runAct xa)|xa. \<exists>S. xa = Act (to_fun S) \<and> S \<subseteq> x} = \<Union>{S|S. S \<subseteq> x}"
  apply (rule arg_cong) back
  apply auto
  apply (rule_tac x = "Act (to_fun xa)" in exI)
  apply simp
  apply (rule_tac x = "xa" in exI)
  by auto

lemma \<iota>_\<rho>_eq: "\<iota> (\<rho> x) = x"
  by (simp add: \<iota>_def \<rho>_def, auto)

lemma \<rho>_\<iota>_eq: "x \<subseteq> \<rho> (\<iota> x)"
  apply (simp add: \<iota>_def \<rho>_def)
  apply (rule order_trans[of _ "pow_inv (symbols x)"])
  apply (metis inv_sym_extensive)
  apply (rule pow_inv_iso)
  apply auto
  apply (rule_tac x = "to_rel (runAct xa)" in exI)
  by auto

lemma galois_connection: "\<iota> x \<subseteq> y \<longleftrightarrow> x \<subseteq> \<rho> y"
  apply default
  apply (metis \<rho>_\<iota>_eq \<rho>_iso subset_trans)
  by (metis \<iota>_\<rho>_eq \<iota>_iso)

definition "preserves b \<equiv> {(\<sigma>,\<sigma>'). \<sigma> \<in> b \<longrightarrow> \<sigma>' \<in> b}"

lemma \<iota>_tl: "\<iota> {x # xs} \<subseteq> preserves p \<Longrightarrow> \<iota> {xs} \<subseteq> preserves p"
  by (auto simp add: preserves_def \<iota>_def symbols_def)

lemma \<iota>_hd: "\<iota> {x # xs} \<subseteq> preserves p \<Longrightarrow> \<iota> {[x]} \<subseteq> preserves p"
  by (auto simp add: preserves_def \<iota>_def symbols_def)

lemma \<iota>_member: "\<iota> x \<subseteq> preserves p \<Longrightarrow> xw \<in> x \<Longrightarrow> \<iota> {xw} \<subseteq> preserves p"
  by (auto simp add: preserves_def \<iota>_def symbols_def Sup_le_iff)

lemma \<iota>_singleton_preserves: "\<iota> {[x]} \<subseteq> preserves p \<longleftrightarrow> (\<forall>q. q \<subseteq> p \<longrightarrow> {[x]} \<Colon> q \<subseteq> p)"
  by (auto simp add: preserves_def module_def \<iota>_def symbols_def to_rel_def)

lemma tshuffle_await_append:
  "\<iota> {xs} \<subseteq> preserves (- p) \<Longrightarrow>
  q \<subseteq> -p \<Longrightarrow>
  map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> q = op @ xs ` (map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys)) \<Colon> q"
proof (induct xs arbitrary: q)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  assume ih: "\<And>q. \<iota> {xs} \<subseteq> preserves (- p) \<Longrightarrow>
                  q \<subseteq> - p \<Longrightarrow>
                  map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> q = op @ xs ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> q"
  and x_xs_preserves_not_p: "\<iota> {x # xs} \<subseteq> preserves (- p)"
  and not_p: "q \<subseteq> - p"

  hence not_p': "{[x]} \<Colon> q \<subseteq> -p"
    by (metis (hide_lams, no_types) \<iota>_hd \<iota>_singleton_preserves)

  have "map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ((x # xs) @ ys)) \<Colon> q = map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (x # xs @ ys)) \<Colon> q"
    by simp
  also have "... = op # x ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> q"
    by (simp only: tshuffle_await_cons[OF not_p])
  also have "... =  map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> ({[x]} \<Colon> q)"
    by (simp only: image_singleton mod_mult)
  also have "... = op @ xs ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> ({[x]} \<Colon> q)"
    by (simp only: ih[OF \<iota>_tl[OF x_xs_preserves_not_p] not_p'])
  also have "... = op # x ` op @ xs ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> q"
    by (simp only: mod_mult[symmetric] image_singleton[symmetric])
  also have "... = op @ (x # xs) ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> q"
    by (simp only: image_compose[symmetric] o_def append.simps)
  finally show ?case .
qed

lemma set_comp_3_eq: "(\<And>x y z. Q x y z \<Longrightarrow> P x y z = P' x y z) \<Longrightarrow> {P x y z|x y z. Q x y z} = {P' x y z|x y z. Q x y z}"
  by auto metis+

lemma helper: "\<Union>{{xw} \<cdot> P y z|y xw z. Q y z \<and> xw \<in> x \<and> Q y z} = \<Union>{x \<cdot> P y z|y z. Q y z}"
  by (auto simp add: l_prod_def complex_product_def)

lemma image_append: "op @ xs ` X = {xs} \<cdot> X"
  by (auto simp add: l_prod_def complex_product_def)

lemma await_par:
  assumes x_preserves_not_p: "\<iota> x \<subseteq> preserves (- p)"
  and not_p: "q \<subseteq> -p"
  shows "p?\<cdot>z \<parallel> x\<cdot>y \<Colon> q = x\<cdot>(p?\<cdot>z \<parallel> y) \<Colon> q"
proof -
  have "p?\<cdot>z \<parallel> x\<cdot>y \<Colon> q = \<Union>{map \<langle>id,id\<rangle> ` (pzw \<sha> xyw)|pzw xyw. pzw \<in> p? \<cdot> z \<and> xyw \<in> x \<cdot> y} \<Colon> q"
    by (simp add: shuffle_def)
  also have "... = \<Union>{map \<langle>id,id\<rangle> ` (pzw \<sha> xyw) \<Colon> q|pzw xyw. pzw \<in> p? \<cdot> z \<and> xyw \<in> x \<cdot> y}"
    by (subst mod_continuous) blast
  also have "... = \<Union>{map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> (xw @ yw)) \<Colon> q|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y}"
    by (simp add: l_prod_def complex_product_def mod_test_def, rule arg_cong, blast)
  also have "... = \<Union>{op @ xw ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw) \<Colon> q|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y}"
    apply (rule arg_cong) back
    apply (rule set_comp_3_eq)
    apply (subst tshuffle_await_append)
    apply (metis \<iota>_member x_preserves_not_p)
    apply (metis not_p)
    by simp
  also have "... = \<Union>{op @ xw ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y} \<Colon> q"
    by (subst mod_continuous) blast
  also have "... = \<Union>{{xw} \<cdot> map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y} \<Colon> q"
    by (simp only: image_append)
  also have "... = \<Union>{x \<cdot> map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw yw. zw \<in> z \<and> yw \<in> y} \<Colon> q"
    by (rule arg_cong, auto simp add: l_prod_def complex_product_def)
  also have "... = x \<cdot> \<Union>{map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw yw. zw \<in> z \<and> yw \<in> y} \<Colon> q"
    by (subst l_prod_inf_distl, rule arg_cong, blast)
  also have "... = x \<cdot> \<Union>{map \<langle>id,id\<rangle> ` (pzw \<sha> yw)|pzw yw. pzw \<in> p? \<cdot> z \<and> yw \<in> y} \<Colon> q"
    by (simp add: l_prod_def complex_product_def mod_test_def, rule arg_cong, blast)
  also have "... = x\<cdot>(p?\<cdot>z \<parallel> y) \<Colon> q"
    by (simp add: shuffle_def)
  finally show ?thesis .
qed

(*
primrec splittings_ind :: "'a list \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list) set" where
  "splittings_ind ys [] = {(ys, [])}"
| "splittings_ind ys (x#xs) = {(ys, x#xs)} \<union> (splittings_ind (ys @ [x]) xs)"

definition splittings where "splittings xs = {(ys,zs). ys @ zs = xs}"

definition add_first where "add_first xs X = (\<lambda>x. (xs @ fst x, snd x)) ` X"

lemma afs: "add_first ws (splittings xs) = {(ws @ ys,zs)|ys zs. ys @ zs = xs}"
  by (auto simp add: add_first_def splittings_def image_def)

lemma l1: "splittings_ind ys xs = add_first ys (splittings xs)"
  apply (simp add: afs)
  apply (induct xs arbitrary: ys)
  apply simp
  apply auto
  apply (metis Cons_eq_append_conv)
  by (metis (hide_lams, no_types) append_eq_Cons_conv)

lemma [simp]: "add_first [] (splittings xs) = splittings xs"
  by (simp add: splittings_def add_first_def)

lemma l2: "splittings_ind [] xs = splittings xs"
  by (insert l1[of "[]"], simp)
*)

type_synonym mem = "nat \<Rightarrow> nat option"

datatype atoms =
    Assign nat nat
  | Pred "mem set"

primrec atoms_interp :: "atoms \<Rightarrow> mem act" where
  "atoms_interp (Assign x v) = Act (\<lambda>mem. {\<lambda>y. if x = y then Some v else mem y})"
| "atoms_interp (Pred p) = Act (\<lambda>mem. if mem \<in> p then {mem} else {})"

definition domain :: "mem \<Rightarrow> nat set" where
  "domain f \<equiv> {x. f x \<noteq> None}"

definition disjoint :: "mem \<Rightarrow> mem \<Rightarrow> bool" where
  "disjoint f g \<equiv> domain f \<inter> domain g = {}"

definition merge :: "mem \<Rightarrow> mem \<Rightarrow> mem" where
  "merge \<sigma> \<sigma>' = (\<lambda>v. if \<sigma> v = None then \<sigma>' v else \<sigma> v)"

definition sep_conj :: "mem set \<Rightarrow> mem set \<Rightarrow> mem set" (infixr "**" 45) where
  "p ** q \<equiv> {\<sigma>''. \<exists>\<sigma> \<sigma>'. disjoint \<sigma> \<sigma>' \<and> \<sigma>'' = merge \<sigma> \<sigma>' \<and> \<sigma> \<in> p \<and> \<sigma>' \<in> q}"

definition quintuple :: "'b rel \<Rightarrow> 'b rel \<Rightarrow> ('a \<Rightarrow> 'b act) \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b set \<Rightarrow> bool"
  ("_, _ \<turnstile>\<^bsub>_\<^esub> \<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [20,20,0,20,20,20] 100) where
  "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> (\<rho> r \<parallel> semantics \<Gamma> c \<Colon> p \<subseteq> q) \<and> (\<iota> (semantics \<Gamma> c) \<subseteq> g)"

definition stable :: "'b rel \<Rightarrow> 'b set \<Rightarrow> bool" where
  "stable r p \<equiv> \<rho> r \<Colon> p \<subseteq> p"

lemma SKIP: "stable r p \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Skip \<lbrace>p\<rbrace>"
  by (simp add: quintuple_def \<iota>_def symbols_def stable_def)

lemma inv_exchange: "\<rho> r \<parallel> x \<cdot> y = (\<rho> r \<parallel> x) \<cdot> (\<rho> r \<parallel> y)"
  sorry

lemma inv_join: "\<iota>(x \<parallel> y) = \<iota> x \<union> \<iota> y"
  sorry

lemma SEQ:
  assumes "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C1 \<lbrace>q\<rbrace>" and "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>q\<rbrace> C2 \<lbrace>s\<rbrace>"
  shows "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C1; C2 \<lbrace>s\<rbrace>"
  using assms
  apply (simp add: quintuple_def inv_exchange mod_mult)
  apply (intro conjI)
  apply (metis mod_isor order_trans)
  by (metis Un_upper2 \<iota>_iso empty_subsetI inv_join shuffle_zerol subset_antisym)

lemma rely_dup: "\<rho> r = \<rho> r \<parallel> \<rho> r"
  by (metis (full_types) \<iota>_\<rho>_eq empty_subsetI galois_connection inv_join inv_shuffle inv_sym_extensive shuffle_zeror sup_top_left top_unique)

lemma shuffle_isor: "X \<subseteq> Y \<Longrightarrow> Z \<parallel> X \<subseteq> Z \<parallel> Y"
  by (metis shuffle_comm shuffle_iso)

lemma PAR:
  assumes "g1 \<subseteq> r2" and "r1, g1 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1\<rbrace> C1 \<lbrace>q1\<rbrace>"
  and "g2 \<subseteq> r1" and "r2, g2 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p2\<rbrace> C2 \<lbrace>q2\<rbrace>"
  shows "(r1 \<inter> r2), (g1 \<union> g2) \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> p2\<rbrace> Par C1 C2 \<lbrace>q1 \<inter> q2\<rbrace>"
proof (simp add: quintuple_def, intro conjI)
  let ?c1 = "semantics \<Gamma> C1"
  let ?c2 = "semantics \<Gamma> C2"

  have "\<rho> (r1 \<inter> r2) \<parallel> (?c1 \<parallel> ?c2) \<Colon> p1 \<inter> p2 = (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<Colon> p1 \<inter> p2"
    by (smt rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<Colon> p1"
    by (metis Int_lower1 mod_isor)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> (\<iota> ?c2)) \<Colon> p1"
    by (intro mod_isol shuffle_isor) (metis \<rho>_\<iota>_eq)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> g2) \<Colon> p1"
    by (intro mod_isol shuffle_isor) (metis \<rho>_iso assms(4) quintuple_def)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> \<rho> (r1 \<inter> r2) \<Colon> p1"
    by (intro mod_isol shuffle_isor) (metis empty_subsetI galois_connection inf_absorb2 inv_join le_inf_iff shuffle_zeror sup_ge1)
  also have "... \<subseteq> (\<rho> r1 \<parallel> ?c1) \<parallel> \<rho> r1 \<Colon> p1"
    by (metis \<iota>_\<rho>_eq galois_connection inf_le1 mod_isol rely_dup shuffle_assoc shuffle_comm shuffle_iso)
  also have "... = \<rho> r1 \<parallel> ?c1 \<Colon> p1"
    by (metis rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> q1"
    by (metis assms(2) quintuple_def)
  finally show "\<rho> (r1 \<inter> r2) \<parallel> (semantics \<Gamma> C1 \<parallel> semantics \<Gamma> C2) \<Colon> p1 \<inter> p2 \<subseteq> q1" .

  have "\<rho> (r1 \<inter> r2) \<parallel> (?c1 \<parallel> ?c2) \<Colon> p1 \<inter> p2 = \<rho> (r1 \<inter> r2) \<parallel> (?c2 \<parallel> ?c1) \<Colon> p1 \<inter> p2"
    by (metis shuffle_comm)
  also have "... = (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<Colon> p1 \<inter> p2"
    by (smt rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<Colon> p2"
    by (metis Int_lower2 mod_isor)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> (\<iota> ?c1)) \<Colon> p2"
    by (intro mod_isol shuffle_isor) (metis \<rho>_\<iota>_eq)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> g1) \<Colon> p2"
    by (intro mod_isol shuffle_isor) (metis \<rho>_iso assms(2) quintuple_def)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> \<rho> (r1 \<inter> r2) \<Colon> p2"
    by (intro mod_isol shuffle_isor) (metis empty_subsetI galois_connection inf_absorb2 inv_join shuffle_zeror sup_inf_absorb)
  also have "... \<subseteq> (\<rho> r2 \<parallel> ?c2) \<parallel> \<rho> r2 \<Colon> p2"
    by (metis \<rho>_iso inf_le2 mod_isol rely_dup shuffle_assoc shuffle_comm shuffle_iso)
  also have "... = \<rho> r2 \<parallel> ?c2 \<Colon> p2"
    by (metis rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> q2"
    by (metis assms(4) quintuple_def)
  finally show "\<rho> (r1 \<inter> r2) \<parallel> (semantics \<Gamma> C1 \<parallel> semantics \<Gamma> C2) \<Colon> p1 \<inter> p2 \<subseteq> q2" .

  show "\<iota> (?c1 \<parallel> ?c2) \<subseteq> g1 \<union> g2"
    by (metis assms(2) assms(4) inv_join quintuple_def sup_mono)
qed

lemma CHOICE:
  assumes "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C1 \<lbrace>q\<rbrace>" and "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C2 \<lbrace>q\<rbrace>"
  shows "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Choice C1 C2 \<lbrace>q\<rbrace>"
  using assms
  apply (simp add: quintuple_def)
  apply (intro conjI)
  apply (metis le_sup_iff mod_distl shuffle_distl)
  by (metis galois_connection le_sup_iff)

definition Await :: "mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> (atoms, mem) stmt" where
  "Await b C = Seq (Atom (Pred b)) C"

lemma helper2: "x \<subseteq> y \<Longrightarrow> y \<union> z \<subseteq> w \<Longrightarrow> x \<union> z \<subseteq> w"
  by (metis le_sup_iff order_trans)

lemma helper3: "x \<subseteq> y \<Longrightarrow> x \<union> y \<subseteq> y"
  by (metis le_sup_iff order_refl)

lemma test: "{(\<sigma>, \<sigma>'). \<sigma>' \<in> runAct a \<sigma>} \<subseteq> {(\<sigma>, \<sigma>'). \<sigma> \<in> p \<longrightarrow> \<sigma>' \<in> p} \<Longrightarrow> \<sigma> \<in> p \<longrightarrow> runAct a \<sigma> \<subseteq> p"
  by auto

lemma test_comm: "\<iota> {[x]} \<subseteq> preserves p \<Longrightarrow> {[Act (\<lambda>x. {x} \<inter> p)]} \<cdot> {[x]} \<Colon> q \<subseteq> {[x]} \<cdot> {[Act (\<lambda>x. {x} \<inter> p)]} \<Colon> q"
  by (auto simp add: l_prod_def complex_product_def module_def preserves_def \<iota>_def symbols_def to_rel_def)

lemma tshuffle_left_leq: "{[x]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> map \<langle>id,id\<rangle> ` ((x # xs) \<sha> ys)"
  apply (induct ys)
  apply (simp add: l_prod_def complex_product_def)
  apply (simp only: tshuffle_ind image_Un image_InL)
  apply (simp only: image_singleton)
  by (metis Un_upper1)

lemma tshuffle_right_leq: "{[y]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> map \<langle>id,id\<rangle> ` (xs \<sha> (y # ys))"
  by (metis (hide_lams, no_types) tshuffle_left_leq tshuffle_words_comm)

lemma mod_isol_var: "z \<subseteq> y \<Longrightarrow> x \<Colon> p \<subseteq> z \<Colon> p \<Longrightarrow> x \<Colon> p \<subseteq> y \<Colon> p"
  by (metis mod_isol subset_trans)

lemma preserve_test_tshuffle:
  "\<iota> {xs} \<subseteq> preserves p \<Longrightarrow> map \<langle>id,id\<rangle> ` (xs \<sha> (Act (\<lambda>x. {x} \<inter> p) # ys)) \<Colon> q = {[Act (\<lambda>x. {x} \<inter> p)]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<Colon> q"
  apply default
  defer
  apply (rule mod_isol)
  apply (rule tshuffle_right_leq)
proof (induct xs arbitrary: q)
  case Nil
  show ?case by (simp add: l_prod_def complex_product_def)
next
  case (Cons x xs)
  assume "\<And>q. \<iota> {xs} \<subseteq> preserves p \<Longrightarrow>
              map \<langle>id,id\<rangle> ` (xs \<sha> (Act (\<lambda>x. {x} \<inter> p) # ys)) \<Colon> q \<subseteq> {[Act (\<lambda>x. {x} \<inter> p)]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<Colon> q"
  and x_xs_preserves_p: "\<iota> {x # xs} \<subseteq> preserves p"
  note ih = this(1)[OF \<iota>_tl[OF this(2)]]

  show ?case
    apply (simp only: tshuffle_ind image_Un image_InL image_InR mod_distl)
    apply (simp only: image_singleton)
    apply (subst mod_mult)
    apply (rule helper2[OF ih])
    apply (subst mod_mult[symmetric])
    apply (rule helper3)
    apply (subst l_prod_assoc[symmetric])
    apply (rule mod_isol_var[OF l_prod_isor[OF tshuffle_left_leq]])
    apply (subst l_prod_assoc[symmetric])
    apply (subst mod_mult)
    apply (subst mod_mult) back
    apply (rule mod_isor)
    apply (subst mod_mult)
    apply (subst test_comm[OF q_satisfies_p \<iota>_hd[OF x_xs_preserves_p]])
    apply (subst mod_mult[symmetric])
    apply (subst l_prod_assoc)
    apply (rule mod_isol)
    apply (rule l_prod_isor)
    by (rule tshuffle_left_leq)
qed
*)

lemma preserve_test:
  assumes "r \<subseteq> preserves s" and "q \<subseteq> p"
  shows "(\<rho> r \<parallel> p? \<cdot> x) \<Colon> q = p? \<cdot> (\<rho> r \<parallel> x) \<Colon> q"
  sorry

lemma AWAIT1: "r \<subseteq> preserves s \<Longrightarrow> p \<subseteq> s \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>s\<rbrace> C \<lbrace>q\<rbrace> \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Await s C \<lbrace>q\<rbrace>" sorry

lemma AWAIT:
  assumes "g1 \<subseteq> r2" and "r1, g1 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> t\<rbrace> C1 \<lbrace>q1\<rbrace>"
  and "g2 \<subseteq> r1" and "r2, g2 \<inter> preserves t \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p2\<rbrace> C2 \<lbrace>t \<inter> q2\<rbrace>"
  shows "(r1 \<inter> r2), (g1 \<union> g2) \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> p2\<rbrace> Par (Await t C1) C2 \<lbrace>q1 \<inter> q2\<rbrace>"
  apply (rule PAR)
  sorry

lemma Sup_image_le_iff: "(\<Union>{f x|x. P x} \<subseteq> Y) \<longleftrightarrow> (\<forall>x. P x \<longrightarrow> f x \<subseteq> Y)"
  by blast

lemma mod_forall: "X \<Colon> p \<subseteq> q \<longleftrightarrow> (\<forall>x\<in>X. {x} \<Colon> p \<subseteq> q)"
  by (auto simp add: module_def)

lemma pow_inv_singleton: "x \<in> X \<Longrightarrow> [x] \<in> pow_inv X"
  by (metis pow_inv.pinv_cons pow_inv.pinv_empty)

lemma stable_forall: "stable r p \<longleftrightarrow> (\<forall>xs\<in>(pow_inv {Act (to_fun S) |S. S \<subseteq> r}). {xs} \<Colon> p \<subseteq> p)"
  apply (simp add: stable_def \<rho>_def)
  apply (subst mod_forall)
  by simp

lemma singleton_stable: "stable r p \<Longrightarrow> x \<in> {Act (to_fun S) |S. S \<subseteq> r} \<Longrightarrow> {[x]} \<Colon> p \<subseteq> p"
  apply (simp only: stable_forall \<rho>_def)
  apply (drule pow_inv_singleton)
  by auto

lemma mod_cons: "op # x ` X \<Colon> p = {[x]} \<cdot> X \<Colon> p"
  by (simp add: image_def complex_product_def l_prod_def, rule arg_cong, blast)

lemma [simp]: "map \<langle>id,id\<rangle> ` op # (InL x) ` X = op # x ` map \<langle>id,id\<rangle> ` X"
  by (auto simp add: image_def)

lemma mod_cons_var: "{x # xs} \<Colon> p = {[x]} \<cdot> {xs} \<Colon> p"
  by (auto simp add: l_prod_def complex_product_def)

lemma ATOM:
  assumes atom: "\<forall>\<sigma>\<in>p. runAct (\<Gamma> a) \<sigma> \<subseteq> q"
  and p_stable: "stable r p"
  and q_stable: "stable r q"
  shows "r, {(\<sigma>,\<sigma>'). \<sigma>' \<in> runAct (\<Gamma> a) \<sigma>}  \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Atom a \<lbrace>q\<rbrace>"
proof -
  from assms have atom': "({[\<Gamma> a]} \<Colon> p) \<subseteq> q"
    by (auto simp add: module_def)

  {
    fix xs
    assume "xs \<in> pow_inv {Act (to_fun S) |S. S \<subseteq> r}"
    hence "map \<langle>id,id\<rangle> ` (xs \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"
    proof (induct xs, simp add: atom')
      fix x and xs
      assume x_set: "x \<in> {Act (to_fun S) |S. S \<subseteq> r}"
      and xs_set: "xs \<in> pow_inv {Act (to_fun S) |S. S \<subseteq> r}"
      and ih: "map \<langle>id,id\<rangle> ` (xs \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"

      have "{[x]} \<Colon> p \<subseteq> p"
        by (rule singleton_stable[OF p_stable x_set])

      hence x_first: "op # x ` map \<langle>id,id\<rangle> ` (xs \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"
        by (simp add: mod_cons mod_mult) (metis (hide_lams, no_types) ih mod_isor subset_trans)

      have "x # xs \<in> pow_inv {Act (to_fun S) |S. S \<subseteq> r}"
        by (smt pow_inv.pinv_cons x_set xs_set)
      hence "{x#xs} \<Colon> q \<subseteq> q"
        by (metis \<rho>_def mod_forall q_stable stable_def)

      from x_first and this show "map \<langle>id,id\<rangle> ` ((x # xs) \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"
        apply (simp only: tshuffle_ind image_Un mod_distl, simp, subst mod_cons_var, subst mod_mult)
        by (metis atom' mod_isor subset_trans)
    qed
  }

  thus "r, {(\<sigma>,\<sigma>'). \<sigma>' \<in> runAct (\<Gamma> a) \<sigma>}  \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Atom a \<lbrace>q\<rbrace>"
    apply (simp add: quintuple_def)
    apply (intro conjI)
    apply (insert p_stable)
    defer
    apply (simp add: to_rel_def \<iota>_def symbols_def)
    apply (simp add: stable_def)
    apply (simp add: \<rho>_def shuffle_def)
    apply (subst mod_continuous_var)
    apply (subst Sup_image_le_iff)
    by auto
qed

lemma WEAKEN: "r' \<subseteq> r \<Longrightarrow> g \<subseteq> g' \<Longrightarrow> p' \<subseteq> p \<Longrightarrow> q \<subseteq> q' \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C \<lbrace>q\<rbrace> \<Longrightarrow> r', g' \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p'\<rbrace> C \<lbrace>q'\<rbrace>"
  apply (simp add: quintuple_def)
  by (metis \<rho>_iso mod_isol mod_isor order_trans shuffle_iso)

lemmas WEAKEN_RELY = WEAKEN[OF _ subset_refl subset_refl subset_refl]
  and STRENGTHEN_GUAR = WEAKEN[OF subset_refl _ subset_refl subset_refl]
  and WEAKEN_PRE = WEAKEN[OF subset_refl subset_refl _ subset_refl]
  and STRENGTHEN_POST = WEAKEN[OF subset_refl subset_refl subset_refl _]

lemma ATOM_VAR:
  assumes atom: "\<forall>\<sigma>\<in>p. runAct (\<Gamma> a) \<sigma> \<subseteq> q"
  and p_stable: "stable r p"
  and q_stable: "stable r q"
  and guar: "{(\<sigma>,\<sigma>'). \<sigma>' \<in> runAct (\<Gamma> a) \<sigma>} \<subseteq> g"
  shows "r, g  \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Atom a \<lbrace>q\<rbrace>"
  apply (rule STRENGTHEN_GUAR[OF guar])
  apply (rule ATOM)
  apply (metis atom)
  apply (metis p_stable)
  by (metis q_stable)

abbreviation quintuple' :: "mem rel \<Rightarrow> mem rel \<Rightarrow> mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> mem set \<Rightarrow> bool"
  ("_, _ \<turnstile>// \<lbrace>_\<rbrace>// _// \<lbrace>_\<rbrace>" [20,20,20,20,20] 100) where
  "r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> r, g \<turnstile>\<^bsub>atoms_interp\<^esub> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"

definition maps_to :: "nat \<Rightarrow> nat \<Rightarrow> mem set" (infix "\<mapsto>" 95) where
  "v \<mapsto> n \<equiv> {\<sigma>. \<sigma> v = Some n}"

definition maps_to_any :: "nat \<Rightarrow> mem set" ("_ \<mapsto> -" [96] 95) where
  "v \<mapsto> - = {\<sigma>. \<exists>n. \<sigma> v = Some n}"

abbreviation assignment :: "nat \<Rightarrow> nat \<Rightarrow> (atoms, mem) stmt" (infix ":=" 95) where
  "assignment v n \<equiv> Atom (Assign v n)"

abbreviation Test :: "mem set \<Rightarrow> (atoms, mem) stmt" where "Test t \<equiv> Atom (Pred t)"

lemma [simp]: "semantics atoms_interp (Test t) \<Colon> h = h \<inter> t"
  by (auto simp add: module_def)

definition Await :: "mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> (atoms, mem) stmt" where
  "Await b C = Seq (Test b) C"

definition "unchanged V \<equiv> {(\<sigma>,\<sigma>'). \<forall>v\<in>V. \<sigma> v = \<sigma>' v}"

definition "preserves b \<equiv> {(\<sigma>,\<sigma>'). \<sigma> \<in> b \<longrightarrow> \<sigma>' \<in> b}"

lemma AWAIT:
  assumes "\<exists>C11 C12 C13."
  shows "r, g \<turnstile> \<lbrace>p\<rbrace> Par C1 (Await b C2) \<lbrace>q1 \<inter> q2\<rbrace>"

lemma ASSIGN:
  shows "unchanged {v}, {(\<sigma>,\<sigma>'). \<sigma>' v = Some n \<and> (\<forall>v'. v' \<noteq> v \<longrightarrow> \<sigma> v' = \<sigma>' v')} \<turnstile> \<lbrace>v \<mapsto> -\<rbrace> v := n \<lbrace>v \<mapsto> n\<rbrace>"
  sorry

abbreviation K :: "bool \<Rightarrow> 'a set" where "K t \<equiv> {s. t}"

lemma disj1: "(x \<mapsto> - ** y \<mapsto> -) = (K (x \<noteq> y) \<inter> x \<mapsto> - ** K (x \<noteq> y) \<inter> y \<mapsto> -)"
  by (auto simp add: sep_conj_def maps_to_any_def disjoint_def domain_def)

lemma empty_mod: "x \<Colon> {} = {}"
  by (simp add: module_def eval_word_def)

lemma CONST: "(p' \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> C1 \<lbrace>q\<rbrace>) \<Longrightarrow> r, g \<turnstile> \<lbrace>K p' \<inter> p\<rbrace> C1 \<lbrace>q\<rbrace>"
  apply (simp add: quintuple_def empty_mod)
  by (metis Un_empty_left empty_subsetI galois_connection inv_join shuffle_zerol subset_empty)

lemma "x \<mapsto> n \<subseteq> x \<mapsto> -"
  by (auto simp add: maps_to_def maps_to_any_def)

lemma empty_rely1: "\<rho> {} \<Colon> p \<subseteq> p"
proof (auto simp add: \<rho>_def module_def eval_word_def)
  fix w x \<sigma>
  assume "w \<in> pow_inv {Act (\<lambda>x. {})}" and "x \<in> runAct (listsum w) \<sigma>"
  and "\<sigma> \<in> p"
  thus "x \<in> p"
    by (induct w rule: pow_inv.induct) (simp_all add: zero_act_def plus_act_def)
qed

lemma empty_rely2: "p \<subseteq> \<rho> {} \<Colon> p"
  apply (simp add: \<rho>_def module_def eval_word_def)
  apply auto
  apply (rule_tac x = p in exI)
  apply (intro conjI)
  apply auto
  apply (rule_tac x = "[]" in exI)
  by (auto simp add: zero_act_def)

lemma empty_rely [simp]: "\<rho> {} \<Colon> p = p"
  by (metis empty_rely1 empty_rely2 subset_antisym)

lemma "{}, UNIV \<turnstile> \<lbrace>x \<mapsto> n\<rbrace> Skip \<lbrace>x \<mapsto> -\<rbrace>"
  by (auto simp add: quintuple_def maps_to_any_def maps_to_def)

datatype ('a, 'b) rg_block =
    RGPar "('a, 'b) stmt" "('a, 'b) rg_block"
  | RGEnd "('a, 'b) stmt"

definition rg_block :: "'b rel \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b rel \<Rightarrow> ('a, 'b) rg_block \<Rightarrow> ('a, 'b) rg_block" ("//  RELY _//    DO _//  GUAR _; _" [31,31,31,30] 30) where
  "RELY r DO C GUAR g; prog \<equiv> RGPar C prog"

definition rg_block_end :: "'b rel \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b rel \<Rightarrow> ('a, 'b) rg_block" ("//  RELY _//    DO _//  GUAR _//COEND" [31,31,31] 30) where
  "RELY r DO C GUAR g COEND \<equiv> RGEnd C"

primrec cobegin :: "('a, 'b) rg_block \<Rightarrow> ('a, 'b) stmt" ("COBEGIN _" [30] 30) where
  "cobegin (RGPar c rg) = Par c (cobegin rg)"
| "cobegin (RGEnd c) = c"

abbreviation triple' :: "mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> mem set \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>// _// \<lbrace>_\<rbrace>" [20,20,20] 100) where
  "\<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> {}, UNIV \<turnstile>\<^bsub>atoms_interp\<^esub> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"

lemma COBEGIN:
  assumes "r1, g1 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1\<rbrace> C1 \<lbrace>q1\<rbrace>"
  and "r2, g2 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p2\<rbrace> C2 \<lbrace>q2\<rbrace>"
  and "g1 \<subseteq> r2" and "g2 \<subseteq> r1"
  and "r \<subseteq> r1 \<inter> r2" and "g1 \<union> g2 \<subseteq> g"
  shows "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> p2\<rbrace> COBEGIN RELY r1 DO C1 GUAR g1; RELY r2 DO C2 GUAR g2 COEND \<lbrace>q1 \<inter> q2\<rbrace>"
  apply (rule WEAKEN[OF assms(5) assms(6) subset_refl subset_refl])
  using assms
  by (auto simp add: rg_block_def rg_block_end_def intro: PAR)

definition PAR_ASSIGN :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (atoms, mem) stmt" ("_, _ := _, _" [96,96,96,96] 95) where
  "PAR_ASSIGN x y n m \<equiv>
    COBEGIN
      RELY unchanged {x}
      DO x := n
      GUAR unchanged (- {x});
      RELY unchanged {y}
      DO y := m
      GUAR unchanged (- {y})
    COEND"

lemma PAR_ASSIGN:
  "x \<noteq> y \<Longrightarrow> unchanged {x, y}, unchanged (- {x, y}) \<turnstile> \<lbrace>x \<mapsto> - \<inter> y \<mapsto> -\<rbrace> x, y :=  n, m \<lbrace>x \<mapsto> n \<inter> y \<mapsto> m\<rbrace>"
  apply (simp add: PAR_ASSIGN_def)
  apply (rule COBEGIN)
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  prefer 3
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  by (auto simp add: unchanged_def)

lemma PAR_ASSIGN: "x \<noteq> y \<Longrightarrow> {}, UNIV \<turnstile> \<lbrace>x \<mapsto> - \<inter> y \<mapsto> -\<rbrace> Par (x := n) (y := m) \<lbrace>x \<mapsto> n \<inter> y \<mapsto> m\<rbrace>"
  apply (rule STRENGTHEN_GUAR[of "unchanged (- {x}) \<union> unchanged (- {y})"])
  apply simp
  apply (rule WEAKEN_RELY[of _ "unchanged (- {y}) \<inter> unchanged (- {x})"])
  apply simp
  apply (rule PAR)
  apply simp
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  apply (force simp add: unchanged_def)+
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  by (force simp add: unchanged_def)+

end


theory Strings
  imports Core "strings/RegEx" "strings/Words"  "HOL-Library.Numeral_Type"  "HOL-Library.List_Lexorder"
begin

no_notation List.length ("\<bar>_\<bar>")
no_notation Groups.abs_class.abs  ("\<bar>_\<bar>")

section "Standard model for the SMT-LIB Theory of String"

subsection "Definition of Unicode characters"

text "The standard defines two sorts, String and RegLan.
In the standard model, the domain of these sorts are fixed as the set of all words over the
alphabet of unicode code points from 0 to 196606, and the powerset of this set, respectively.
We define the set of unicode code points as the ring of integers up to 196606.
Words as lists over this alphabet (type) and regular languages as regular expression over the
alphabet, equipped with a function that maps expression to actual languages."

type_synonym uc_char = "196607"
type_synonym uc_word = "uc_char word"
type_synonym uc_regex = "uc_char regex"

definition UC:: "uc_word set" where "UC = {w. True}"

subsection "Interpretation of the SMT-LIB theory of strings symbols"

text "In the following, we interprete all symbols of the SMT-LIB theory of strings.
The interprations are based on primitive functions implemented on lists and regular expressions.
Note that the symbols are not identicaly to the one state in the SMT-LIB theory due to syntactic
restrictions of Isabelle/HOL. However, there is a one to one mapping between the symbols used here
and the symbols used in SMT-LIB. This mapping is specified in 'spec.json'."

abbreviation str_char:: "uc_char \<Rightarrow> uc_word" where
  "str_char a \<equiv> a#\<epsilon>"

abbreviation str_concat:: "uc_word \<Rightarrow> uc_word  \<Rightarrow> uc_word" where
  "(str_concat) u v \<equiv> u\<cdot>v"

abbreviation str_len:: "uc_word \<Rightarrow> int" ("\<bar>_\<bar>") where
  "str_len w \<equiv> of_nat (length w)"

abbreviation str_at:: "uc_word \<Rightarrow> int \<Rightarrow> uc_word" where
  "str_at w i \<equiv> if i \<ge> 0 then w[(nat i); (nat i+1)] else \<epsilon>"

abbreviation str_substr:: "uc_word \<Rightarrow> int \<Rightarrow> int \<Rightarrow> uc_word" where
  "str_substr w m n \<equiv> if (n \<ge> 0 \<and> 0\<le>m \<and> ((nat m) \<le> (length w)-1)) then  w[(nat m);(nat (m+n))] else \<epsilon>"

abbreviation str_prefixof:: "uc_word \<Rightarrow> uc_word \<Rightarrow> bool" where
  "str_prefixof \<equiv> prefix"

abbreviation str_suffixof:: "uc_word \<Rightarrow> uc_word \<Rightarrow> bool" where
  "str_suffixof \<equiv> suffix"

abbreviation str_contains:: "uc_word \<Rightarrow> uc_word \<Rightarrow> bool" where
  "str_contains \<equiv> Words.contains"

(*fun str_indexof:: "uc_word \<Rightarrow> uc_word \<Rightarrow> int \<Rightarrow> int" where
  "str_indexof w v i = (if i \<ge> 0 \<and> (str_contains (str_substr w i \<bar>w\<bar>) v) \<and> i\<le>\<bar>w\<bar> then Int.int (str_indexof_nat w v (Int.nat i)) else -1)"*)

abbreviation str_indexof:: "uc_word \<Rightarrow> uc_word \<Rightarrow> int \<Rightarrow> int" where
  "str_indexof w v i \<equiv> (if i\<ge>0 \<and>  (str_contains (str_substr w i \<bar>w\<bar>) v) \<and> i\<le>\<bar>w\<bar> then Int.int (indexof_nat w v (Int.nat i)) else -1)"

abbreviation str_replace:: "uc_word \<Rightarrow> uc_word \<Rightarrow> uc_word \<Rightarrow> uc_word" where
  "str_replace \<equiv> replace"

abbreviation str_replace_all:: "uc_word \<Rightarrow> uc_word \<Rightarrow> uc_word \<Rightarrow> uc_word" where
  "str_replace_all \<equiv> undefined"

abbreviation str_replace_re:: "uc_word \<Rightarrow> uc_regex \<Rightarrow> uc_word \<Rightarrow> uc_word" where
  "str_replace_re \<equiv> undefined"

abbreviation str_replace_re_all:: "uc_word \<Rightarrow> uc_regex \<Rightarrow> uc_word \<Rightarrow> uc_word" where
  "str_replace_re_all \<equiv> undefined"

abbreviation str_in_re:: "uc_word \<Rightarrow> uc_regex \<Rightarrow> bool" where
  "str_in_re w r \<equiv> nullable (rderivw w r)"

abbreviation str_to_re:: "uc_word \<Rightarrow> uc_regex" where
  "str_to_re w \<equiv> regex.Const w"

abbreviation re_none:: "uc_regex" where
  "re_none \<equiv> regex.None"

abbreviation re_allchar:: "uc_regex" where
  "re_allchar \<equiv> regex.Any"

abbreviation re_all::"uc_regex" where
"re_all \<equiv> re_star re_allchar"

abbreviation re_concat:: "uc_regex \<Rightarrow> uc_regex \<Rightarrow> uc_regex" where
  "re_concat \<equiv> RegEx.re_concat"

abbreviation re_union:: "uc_regex \<Rightarrow> uc_regex \<Rightarrow> uc_regex" where
  "re_union  \<equiv> RegEx.re_union"

abbreviation re_inter:: "uc_regex \<Rightarrow> uc_regex \<Rightarrow> uc_regex" where
  "re_inter  \<equiv> RegEx.re_inter"

abbreviation re_star:: "uc_regex \<Rightarrow>uc_regex" where
  "re_star \<equiv> RegEx.re_star"

abbreviation re_plus:: "uc_regex \<Rightarrow> uc_regex" where
  "re_plus r \<equiv> RegEx.re_plus r"

fun re_range:: "uc_word \<Rightarrow> uc_word \<Rightarrow> uc_regex" where
  "re_range (l#\<epsilon>) (u#\<epsilon>) = RegEx.re_range l u"|
  "re_range _ _ = RegEx.None"

abbreviation re_opt::"uc_regex \<Rightarrow> uc_regex" where
  "re_opt r \<equiv> re_union (Const \<epsilon>) r"

abbreviation re_comp::"uc_regex \<Rightarrow> uc_regex" where
  "re_comp \<equiv> RegEx.re_comp"

abbreviation re_diff:: "uc_regex \<Rightarrow> uc_regex \<Rightarrow> uc_regex" where
  "re_diff \<equiv> RegEx.re_diff"

abbreviation re_pow::"nat \<Rightarrow> uc_regex \<Rightarrow> uc_regex" where
  "re_pow n r \<equiv> RegEx.re_pow r n"

abbreviation re_loop:: "nat \<Rightarrow> nat \<Rightarrow> uc_regex \<Rightarrow> uc_regex" where
  "re_loop a b r \<equiv> RegEx.re_loop r a b"

subsection "Model Proofs"

text "We shows that our interpretation of the functions satisfy all conditions stated by the SMT-LIB theory
of strings, which thus proofs it to be equivalent to the standard model of the theory."

abbreviation smallest_set where
  "smallest_set K P \<equiv> P K \<and> (\<forall>K'. P K' \<longrightarrow> K \<subseteq> K')"

abbreviation smallest_int where
  "smallest_int n P \<equiv> P n \<and> (\<forall>n'. P n' \<longrightarrow> n \<le> n')"

abbreviation shortest_word where
  "shortest_word w P \<equiv> P w \<and> (\<forall>w'. P w' \<longrightarrow> \<bar>w\<bar> \<le> \<bar>w'\<bar>)"

theorem "UNIV = UC"
  by (simp add: UC_def)

subsubsection "Lexicographic order"

theorem lexord_strict:"v < w \<longleftrightarrow> (v, w) \<in> lexord {(a, b). a<b}"
  by (simp add: list_less_def)

theorem lexord:"v \<le> w \<longleftrightarrow> (v, w) \<in> lexord {(a, b). a<b} \<or> v = w"
  by (simp add: list_le_def list_less_def)

subsubsection "Length"

text "Some lemmas about string length used later on"

lemma length_ge_0: "\<bar>w\<bar> \<ge> 0"
  by auto

lemma length_less_0: "\<not>\<bar>w\<bar> < 0"
  by auto

lemma length_int_nat: "\<bar>w\<bar> = int (length w)"
  by auto

lemma length_int_nat_le: "m \<ge> 0 \<Longrightarrow> m \<le> \<bar>w\<bar> \<longleftrightarrow> (nat m) \<le> (length w)"
  by auto

lemma length_int_nat_sub: "m \<ge> 0 \<Longrightarrow> m \<le> \<bar>w\<bar> \<Longrightarrow> int ((length w) - (nat m)) = (\<bar>w\<bar> - m)"
  by auto

lemma length_int_nat_min: "m \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> int (min (nat m) (nat n)) = min m n"
  by auto

lemma length_int_nat_sub_min:
  assumes "\<bar>w\<bar> \<ge> m"
    and "n \<ge> 0"
    and "m \<ge> 0"
  shows "int (min (nat n) ((length w)-nat m)) = (min n (\<bar>w\<bar>- m))"
  using assms by auto

lemma of_nat_nat_inv: "x \<ge> 0 \<Longrightarrow> of_nat (nat x) = x"
  by auto

subsubsection "Substrings (str.at, str.substr)"

theorem str_at:"str_at w n = str_substr w n 1"
  by (simp split: if_splits add: diff_nat_eq_if)

lemma substr_factor_equal:
  assumes "0 \<le> m"
    and "m < \<bar>w\<bar>"
    and "0 < n"
  shows "str_substr w m n = (w[nat m; nat m + nat n])"
  using assms diff_nat_eq_if by auto

theorem str_substr1:
  assumes "0 \<le> m" and "m < \<bar>w\<bar>" and "0 < n"
  shows "\<exists>!v. str_substr w m n = v \<and> (\<exists>x y. w =  x\<cdot>v\<cdot>y \<and> \<bar>x\<bar> = m \<and>  \<bar>v\<bar> = min n (\<bar>w\<bar> - m))"
  proof -
  from assms have "nat m < (length w) \<and> nat m \<le> nat m + nat n" by auto
  then have "\<exists>!v. (w[nat m; nat m + nat n]) = v \<and>
             (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> (length x) = nat m \<and>
               (length v) = min ((nat m + nat n)-nat m) ((length w)-nat m))"
    using factorization by metis
  then have "\<exists>!v. (w[nat m; nat m + nat n]) = v \<and>
             (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> \<bar>x\<bar> = m \<and> (length v) = min (nat n) ((length w)-nat m))"
    by (metis add_diff_cancel_left' assms(1) int_nat_eq)
  then have "\<exists>!v. str_substr w m n = v \<and>
             (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> \<bar>x\<bar> = m \<and> (length v) = min (nat n) ((length w)-nat m))"
    using assms substr_factor_equal by presburger
  then have "\<exists>!v. str_substr w m n = v \<and>
             (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> \<bar>x\<bar> = m \<and> \<bar>v\<bar> = int (min (nat n) ((length w)-nat m)))"
    by simp
  then have "\<exists>!v. str_substr w m n = v \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> \<bar>x\<bar> = m \<and> \<bar>v\<bar> = (min n (\<bar>w\<bar>- m)))"
    using length_int_nat_sub_min assms by auto
  then show ?thesis
    by blast
qed

theorem str_substr2:
  assumes "\<not>(0 \<le> m \<and> m <  \<bar>w\<bar> \<and> 0 < n)"
  shows "str_substr w m n = \<epsilon>"
proof -
  from assms have assm:"(0 > m \<or> m \<ge> \<bar>w\<bar> \<or> 0 \<ge> n)" (is "?A \<or> ?B \<or> ?C") by auto
  then show ?thesis  using assm by fastforce
qed

subsubsection "Factors (str.prefixof, str.suffixof, str.contains)"

theorem str_prefix: "str_prefixof v w \<longleftrightarrow> (\<exists>x. w = v\<cdot>x)"   by (simp add: prefix_def)

theorem str_suffix: "str_suffixof v w \<longleftrightarrow> (\<exists>x. w = x\<cdot>v)"   by (simp add: suffix_def)

theorem str_contains: "str_contains w v \<longleftrightarrow> (\<exists>x y. w = x\<cdot>v\<cdot>y)"
  by (auto simp add: contains_iff_factor sublist_def)

subsubsection "Searching and replacing (str.indexof, str.replace variants)"

text "The SMT-LIB standard states the following theorems

str_contains v w \<Longrightarrow> \<exists>n. str_indexof w v i = n \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. n' < n \<longrightarrow> (\<exists>x' y'. w = x'\<cdot>v\<cdot>y' \<and> i \<le> n' \<and> n = \<bar>x'\<bar>)) and
\<not>str_contains v w \<Longrightarrow> str_indexof w v i = -1 and

However, they are inconsistent. We find counterexamples.

- if i\<le>\<bar>w\<bar> no such n exists
  - Example: (indexof 'ab' \<epsilon> 3 = n) but no n wa and words x y satisfy 'ab' = x\<cdot>\<epsilon>\<cdot>y \<and> \<bar>x\<bar>=n \<and> n\<ge>3
- if (str_contains v w) but not str_contains (str_substr w i \<bar>w\<bar>) v, then no such n exists
  - Example: (indexof 'ab' 'a' 1 = n) but no n and words x y satisfy 'ab' = x\<cdot>'a'\<cdot>y \<and> \<bar>x\<bar> = n \<and> n\<ge>1

To be consistent, we need (str_contains (str_substr w i \<bar>w\<bar>) v)  instad of
(str_contains v w), and additionally need the premise i\<le>\<bar>w\<bar>.
If either of these premises is not met, or i<0, the the function must evaluate to -1.
"

theorem str_indexof1:
  assumes "i\<ge>0" and "i\<le>\<bar>w\<bar>" and "str_contains (str_substr w i \<bar>w\<bar>) v"
  shows "\<exists>n. str_indexof w v i = n \<and> smallest_int n (\<lambda>n. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n \<and> n = \<bar>x\<bar>))"
proof -
  have "nat i \<le> length w"
    using assms(2) nat_le_iff by blast
  moreover
  have "sublist v (drop (nat i) w)"
    by (smt (verit, best) assms(3) contains_iff_factor dual_order.refl factor.elims(1)
        factor_suffix nat_add_distrib nat_int sublist_Nil_left sublist_Nil_right trans_le_add2)
  ultimately
  have "smallest_int (indexof_nat w v (Int.nat i)) (\<lambda>n. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> (Int.nat i) \<le> n \<and> n = length x))"
    using str_indexof_nat1[of "Int.nat i" w v] by auto
  then show ?thesis
    by (metis assms nat_int nat_le_iff)
qed

theorem str_indexof2:
  assumes "i<0 \<or> i>\<bar>w\<bar> \<or> \<not> str_contains (str_substr w i \<bar>w\<bar>) v"
  shows "str_indexof w v i = -1"
proof -
  {
    assume "i<0"
    then have ?thesis
      by auto
  }
  moreover
  {
    assume "\<not> str_contains (str_substr w i \<bar>w\<bar>) v"
    then have ?thesis
      using assms indexof_if_not_contains''' by presburger
  }
  moreover
  {
    assume "i>\<bar>w\<bar>"
    then have ?thesis
      using assms by auto
  }
  ultimately show ?thesis
    using assms by metis
qed

theorem str_replace1:
  assumes "str_contains w v"
  shows "\<exists>x y. str_replace w v u = x\<cdot>u\<cdot>y \<and> w = x\<cdot>v\<cdot>y \<and> (\<forall> x'. (\<exists>y'. w=x'\<cdot>v\<cdot>y') \<longrightarrow> \<bar>x\<bar> \<le> \<bar>x'\<bar>)"
  using replace_first_factor
  by (metis assms of_nat_mono)

theorem str_replace2:
  assumes "\<not> str_contains w v"
  shows "str_replace w v u = w"
  sledgehammer
  using assms replace_id_if_not_contains by blast

(* TODO: Add replace_all, replace_re, replace_all_re! *)

subsubsection "Regular languages"

text "We represent regular languages using regular expression accompanied by a lang function that
maps expression to languages."

text "We first who that this lang operator maps into the powerset of all unicode strings"

theorem re_lang_unicode: "range (lang::(uc_char regex \<Rightarrow> uc_char word set)) \<subseteq> Pow UC"
  using UC_def by force

theorem str_to_re: "lang (str_to_re w) = {w}" by auto

theorem str_in_re: "str_in_re w R \<longleftrightarrow> w \<in> (lang R)"
  by (auto simp add: derivw_nullable_contains contains_derivw_nullable)

paragraph "Regular Operators"

theorem re_none: "lang re_none = {}" by auto

theorem re_allchar: "lang re_allchar = {w. \<bar>w\<bar> = 1}" by auto

theorem re_all: "lang re_all = UC"
  using UC_def star_any_is_univ by auto

theorem re_concat: "lang (re_concat r e) = {x\<cdot>y|x y. x \<in> lang r \<and> y \<in> lang e}"
  by (simp add: Regular.concat_def re_concat_correct)

theorem re_union: "lang (re_union r e) = {w|w. w \<in> lang r \<or> w \<in> lang e}"
  by (simp add: Un_def re_union_correct)

theorem re_inter: "lang (re_inter r1 r2) = {w|w. w\<in> lang r1 \<and> w \<in> lang r2}"
  by (auto simp add:  re_inter_correct)

lemma Star_smallest:
  assumes "w \<in> (pow (lang r) n)"
  assumes "\<epsilon> \<in> K'"
  assumes "{x \<cdot> y |x y. x \<in> lang r \<and> y \<in> K'} \<subseteq> K'"
  shows "w \<in> K'"
  using assms
proof (induction n arbitrary: w)
  case 0
  then show ?case
    by (simp add: star_all_pows star_of_empty)
next
  case (Suc n)
  from Suc(2) have "\<exists>u v. w = u \<cdot> v \<and> u \<in> (lang r) \<and> v \<in> pow (lang r) n"
    by (simp add: Regular.concat_def)
  then obtain u v where u_v_p: "w = u \<cdot> v" "u \<in> lang r" "v \<in> pow (lang r) n"
    by auto
  then have "v \<in> K'"
    using Suc(1)[of v] Suc(3) Suc(4) by auto
  then show ?case
    using u_v_p Suc by auto
qed

abbreviation smallest where
  "smallest K P \<equiv> P K \<and> (\<forall>K'. P K' \<longrightarrow> K \<subseteq> K')"

theorem re_star: "smallest (lang (Star r)) (\<lambda>K. \<epsilon> \<in> K \<and> {x\<cdot>y | x y. x \<in> lang r \<and> y \<in> K} \<subseteq> K)"
proof -
  have "\<epsilon> \<in> lang (r\<^sup>\<star>)"
    by simp
  moreover
  have "{x \<cdot> y |x y. x \<in> lang r \<and> y \<in> lang (r\<^sup>\<star>)} \<subseteq> lang (r\<^sup>\<star>)"
    by (auto simp add: concat_containment re_star_correct star_subsumes)
  moreover
  have "(\<forall>K'. \<epsilon> \<in> K' \<and> {x \<cdot> y |x y. x \<in> lang r \<and> y \<in> K'} \<subseteq> K' \<longrightarrow> lang (r\<^sup>\<star>) \<subseteq> K')"
    using Star_smallest by (auto simp add: star_def)
  ultimately
  show ?thesis
    by auto
qed

theorem re_plus: "lang (re_plus r) = lang (re_concat r (re_star r))"
  by auto

theorem re_range1: "\<bar>l\<bar> = 1 \<and> \<bar>u\<bar> = 1 \<Longrightarrow> lang (re_range l u) = {v| v. l \<le> v \<and>  v\<le>u \<and> \<bar>v\<bar> = 1}"
 apply(cases \<open>(l, u)\<close> rule: re_range.cases)
      apply (auto split: if_splits)
   apply (metis (no_types, lifting) Cons_less_Cons length_0_conv length_Suc_conv linorder_not_le)
  by (meson Cons_le_Cons dual_order.trans)

theorem re_range2: "\<bar>l\<bar> \<noteq> 1 \<or> \<bar>u\<bar> \<noteq> 1 \<Longrightarrow> lang (re_range l u) = {}"
  by (cases \<open>(l, u)\<close> rule:re_range.cases) (auto split: if_splits)

theorem re_comp: "lang (re_comp r) = UNIV - (lang r)"
  by (simp add: Compl_eq_Diff_UNIV re_comp_correct)

theorem re_diff: "lang (re_diff r1 r2) = lang r1 - lang r2"
  by (simp add: re_diff_correct)

theorem re_pow1: "lang (re_pow 0 r) = {\<epsilon>}"
  by auto

theorem re_pow2: "\<forall>n. re_pow (Suc n) r =  re_concat r (re_pow n r)"
  by simp

theorem re_loop1:
  assumes "a \<le> b"
  shows "lang (re_loop a b r) = (\<Union>x\<in>{a..b}. (lang (re_pow x r)))"
  using re_loop_iff1[of a b] using assms atLeastAtMost_iff by fastforce

theorem re_loop2: "a > b \<Longrightarrow> lang (re_loop a b r) = {}"
  by (simp add: re_loop_None_if)

end


(* Author: Tobias Nipkow *)

subsection \<open>Transfer of Tree Analysis to List Representation\<close>

theory Pairing_Heap_List1_Analysis2
imports
  Pairing_Heap_List1_Analysis
  Pairing_Heap_Tree_Analysis
begin

text\<open>This theory transfers the amortized analysis of the tree-based
pairing heaps to Okasaki's pairing heaps.\<close>

abbreviation "is_root' == Pairing_Heap_List1_Analysis.is_root"
abbreviation "del_min' == Pairing_Heap_List1.del_min"
abbreviation "insert' == Pairing_Heap_List1.insert"
abbreviation "merge' == Pairing_Heap_List1.merge"
abbreviation "pass\<^sub>1' == Pairing_Heap_List1.pass\<^sub>1"
abbreviation "pass\<^sub>2' == Pairing_Heap_List1.pass\<^sub>2"
abbreviation "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1' == Pairing_Heap_List1_Analysis.t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1"
abbreviation "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2' == Pairing_Heap_List1_Analysis.t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2"

fun homs :: "'a heap list \<Rightarrow> 'a tree" where
"homs [] = Leaf" |
"homs (Hp x lhs # rhs) = Node (homs lhs) x (homs rhs)"

fun hom :: "'a heap \<Rightarrow> 'a tree" where
"hom heap.Empty = Leaf" |
"hom (Hp x hs) = (Node (homs hs) x Leaf)"

lemma homs_pass1': "no_Emptys hs \<Longrightarrow> homs(pass\<^sub>1' hs) = pass\<^sub>1 (homs hs)"
apply(induction hs rule: Pairing_Heap_List1.pass\<^sub>1.induct)
  apply simp
 subgoal for h
 apply(case_tac h)
  apply (auto)
 done
subgoal for h1 h2
apply(case_tac h1)
 apply simp
apply(case_tac h2)
 apply (auto)
done
done

lemma hom_merge': "\<lbrakk> no_Emptys lhs; Pairing_Heap_List1_Analysis.is_root h\<rbrakk>
       \<Longrightarrow> hom (merge' (Hp x lhs) h) = link \<langle>homs lhs, x, hom h\<rangle>"
by(cases h) auto

lemma hom_pass2': "no_Emptys hs \<Longrightarrow> hom(pass\<^sub>2' hs) = pass\<^sub>2 (homs hs)"
by(induction hs rule: homs.induct) (auto simp: hom_merge' is_root_pass2)

lemma del_min': "is_root' h \<Longrightarrow> hom(del_min' h) = del_min (hom h)"
by(cases h)
  (auto simp: homs_pass1' hom_pass2' no_Emptys_pass1 is_root_pass2)

lemma insert': "is_root' h \<Longrightarrow> hom(insert' x h) = insert x (hom h)"
by(cases h)(auto)

lemma merge':
  "\<lbrakk> is_root' h1; is_root' h2 \<rbrakk> \<Longrightarrow> hom(merge' h1 h2) = merge (hom h1) (hom h2)"
apply(cases h1)
 apply(simp)
apply(cases h2)
 apply(auto)
done

lemma t_pass1': "no_Emptys hs \<Longrightarrow> t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1' hs = t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1(homs hs)"
apply(induction hs rule: Pairing_Heap_List1.pass\<^sub>1.induct)
  apply simp
 subgoal for h
 apply(case_tac h)
  apply (auto)
 done
subgoal for h1 h2
apply(case_tac h1)
 apply simp
apply(case_tac h2)
 apply (auto)
done
done

lemma t_pass2': "no_Emptys hs \<Longrightarrow> t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2' hs = t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2(homs hs)"
by(induction hs rule: homs.induct) (auto simp: hom_merge' is_root_pass2)

lemma size_hp: "is_root' h \<Longrightarrow> size_hp h = size (hom h)"
proof(induction h)
  case (Hp _ hs) thus ?case
    apply(induction hs rule: homs.induct)
      apply simp
     apply force
    apply simp
    done
qed simp

interpretation Amortized2
where arity = arity and exec = exec and inv = is_root
and cost = cost and \<Phi> = \<Phi> and U = U
and hom = hom
and exec' = Pairing_Heap_List1_Analysis.exec
and cost' = Pairing_Heap_List1_Analysis.cost and inv' = "is_root'"
and U' = Pairing_Heap_List1_Analysis.U
proof (standard, goal_cases)
  case (1 _ f) thus ?case
    by (cases f)(auto simp: merge' del_min' numeral_eq_Suc)
next
  case (2 ts f)
  show ?case
  proof(cases f)
    case [simp]: Del_min
    then obtain h where [simp]: "ts = [h]" using 2 by auto
    show ?thesis using 2
      by(cases h) (auto simp: is_root_pass2 no_Emptys_pass1)
  qed (insert 2,
      auto simp: Pairing_Heap_List1_Analysis.is_root_merge numeral_eq_Suc)
next
  case (3 t) thus ?case by (cases t) (auto)
next
  case (4 ts f) show ?case
  proof (cases f)
    case [simp]: Del_min
    then obtain h where [simp]: "ts = [h]" using 4 by auto
    show ?thesis using 4
      by (cases h)(auto simp: t_pass1' t_pass2' no_Emptys_pass1 homs_pass1')
  qed (insert 4, auto)
next
  case (5 _ f) thus ?case by(cases f) (auto simp: size_hp numeral_eq_Suc)
qed

end