section \<open>Deep representation of HyperCTL* -- syntax and semantics\<close>

(*<*)
theory Deep
imports Shallow "HOL-Library.Infinite_Set"
begin
(*>*)

subsection\<open>Path variables and environments\<close>

datatype pvar = Pvariable (natOf : nat)

text \<open>Deeply embedded (syntactic) formulas\<close>

datatype 'aprop dfmla =
  Atom 'aprop pvar |
  Fls | Neg "'aprop dfmla" | Dis "'aprop dfmla" "'aprop dfmla" |
  Next "'aprop dfmla" | Until "'aprop dfmla" "'aprop dfmla" |
  Exi pvar "'aprop dfmla"

text\<open>Derived operators\<close>

definition "Tr \<equiv> Neg Fls"
definition "Con \<phi> \<psi> \<equiv> Neg (Dis (Neg \<phi>) (Neg \<psi>))"
definition "Imp \<phi> \<psi> \<equiv> Dis (Neg \<phi>) \<psi>"
definition "Eq \<phi> \<psi> \<equiv> Con (Imp \<phi> \<psi>) (Imp \<psi> \<phi>) "
definition "Fall p \<phi> \<equiv> Neg (Exi p (Neg \<phi>))"
definition "Ev \<phi> \<equiv> Until Tr \<phi>"
definition "Alw \<phi> \<equiv> Neg (Ev (Neg \<phi>))"
definition "Wuntil \<phi> \<psi> \<equiv> Dis (Until \<phi> \<psi>) (Alw \<phi>)"
definition "Fall2 p p' \<phi> \<equiv> Fall p (Fall p' \<phi>)"

lemmas der_Op_defs =
Tr_def Con_def Imp_def Eq_def Ev_def Alw_def Wuntil_def Fall_def Fall2_def

text\<open>Well-formed formulas are those that do not have a temporal operator
outside the scope of any quantifier -- indeed, in HyperCTL* such a situation does not make sense,
since the temporal operators refer to previously introduced/quantified paths.\<close>

primrec wff :: "'aprop dfmla \<Rightarrow> bool" where
 "wff (Atom a p) = True"
|"wff Fls = True"
|"wff (Neg \<phi>) = wff \<phi>"
|"wff (Dis \<phi> \<psi>) = (wff \<phi> \<and> wff \<psi>)"
|"wff (Next \<phi>) = False"
|"wff (Until \<phi> \<psi>) = False"
|"wff (Exi p \<phi>) = True"

text \<open>The ability to pick a fresh variable\<close>

lemma finite_fresh_pvar:
assumes "finite (P :: pvar set)"
obtains p where "p \<notin> P"
proof-
  have "finite (natOf ` P)" by (metis assms finite_imageI)
  then obtain n where "n \<notin> natOf ` P" by (metis unbounded_k_infinite)
  hence "Pvariable n \<notin> P" by (metis imageI pvar.sel)
  thus ?thesis using that by auto
qed

definition getFresh :: "pvar set \<Rightarrow> pvar" where
"getFresh P \<equiv> SOME p. p \<notin> P"

lemma getFresh:
assumes "finite P" shows "getFresh P \<notin> P"
by (metis assms exE_some finite_fresh_pvar getFresh_def)

text \<open>The free-variables operator\<close>

primrec FV :: "'aprop dfmla \<Rightarrow> pvar set" where
 "FV (Atom a p) = {p}"
|"FV Fls = {}"
|"FV (Neg \<phi>) = FV \<phi>"
|"FV (Dis \<phi> \<psi>) = FV \<phi> \<union> FV \<psi>"
|"FV (Next \<phi>) = FV \<phi>"
|"FV (Until \<phi> \<psi>) = FV \<phi> \<union> FV \<psi>"
|"FV (Exi p \<phi>) = FV \<phi> - {p}"

text\<open>Environments\<close>

type_synonym env = "pvar \<Rightarrow> nat"

definition "eqOn P env env1 \<equiv> \<forall> p. p \<in> P \<longrightarrow> env p = env1 p"

lemma eqOn_Un[simp]:
"eqOn (P \<union> Q) env env1 \<longleftrightarrow> eqOn P env env1 \<and> eqOn Q env env1"
unfolding eqOn_def by auto

lemma eqOn_update[simp]:
"eqOn P (env(p := \<pi>)) (env1(p := \<pi>)) \<longleftrightarrow> eqOn (P - {p}) env env1"
unfolding eqOn_def by auto

lemma eqOn_singl[simp]:
"eqOn {p} env env1 \<longleftrightarrow> env p = env1 p"
unfolding eqOn_def by auto

context Shallow
begin

subsection \<open>The semantic operator\<close>

text\<open>The semantics will interpret deep (syntactic) formulas as shallow formulas.
Recall that the latter are predicates on lists of paths -- the interpretation will
be parameterized by an environment mapping each path variable to a number indicating
the index (in the list) for the path denoted by the variable.

The semantics will only
be meaningful if the indexes of a formula's free variables are smaller than the length
of the path list -- we call this property ``compatibility''.\<close>

primrec sem :: "'aprop dfmla \<Rightarrow> env \<Rightarrow> ('state,'aprop) sfmla" where
 "sem (Atom a p) env = atom a (env p)"
|"sem Fls env = fls"
|"sem (Neg \<phi>) env = neg (sem \<phi> env)"
|"sem (Dis \<phi> \<psi>) env = dis (sem \<phi> env) (sem \<psi> env)"
|"sem (Next \<phi>) env = next (sem \<phi> env)"
|"sem (Until \<phi> \<psi>) env = until (sem \<phi> env) (sem \<psi> env)"
|"sem (Exi p \<phi>) env = exi (\<lambda> \<pi> \<pi>l. sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]))"

lemma sem_Exi_explicit:
"sem (Exi p \<phi>) env \<pi>l \<longleftrightarrow>
 (\<exists> \<pi>. wfp AP' \<pi> \<and> stateOf \<pi> = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0) \<and>
       sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]))"
unfolding sem.simps
unfolding exi_def ..

lemma sem_derived[simp]:
 "sem Tr env = tr"
 "sem (Con \<phi> \<psi>) env = con (sem \<phi> env) (sem \<psi> env)"
 "sem (Imp \<phi> \<psi>) env = imp (sem \<phi> env) (sem \<psi> env)"
 "sem (Eq \<phi> \<psi>) env = eq (sem \<phi> env) (sem \<psi> env)"
 "sem (Fall p \<phi>) env = fall (\<lambda> \<pi> \<pi>l. sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]))"
 "sem (Ev \<phi>) env = ev (sem \<phi> env)"
 "sem (Alw \<phi>) env = alw (sem \<phi> env)"
 "sem (Wuntil \<phi> \<psi>) env = wuntil (sem \<phi> env) (sem \<psi> env)"
unfolding der_Op_defs der_op_defs by (auto simp: neg_def[abs_def])

lemma sem_Fall2[simp]:
"sem (Fall2 p p' \<phi>) env =
 fall2 (\<lambda> \<pi>' \<pi> \<pi>l. sem \<phi> (env (p := length \<pi>l, p' := Suc(length \<pi>l))) (\<pi>l @ [\<pi>,\<pi>']))"
unfolding Fall2_def fall2_def by (auto simp add: fall_def exi_def[abs_def] neg_def[abs_def])

text\<open>Compatibility of a pair (environment,path list) on a set of variables means
no out-or-range references:\<close>

definition "cpt P env \<pi>l \<equiv> \<forall> p \<in> P. env p < length \<pi>l"

lemma cpt_Un[simp]:
"cpt (P \<union> Q) env \<pi>l \<longleftrightarrow> cpt P env \<pi>l \<and> cpt Q env \<pi>l"
unfolding cpt_def by auto

lemma cpt_singl[simp]:
"cpt {p} env \<pi>l \<longleftrightarrow> env p < length \<pi>l"
unfolding cpt_def by auto

lemma cpt_map_stl[simp]:
"cpt P env \<pi>l \<Longrightarrow> cpt P env (map stl \<pi>l)"
unfolding cpt_def by auto

text \<open>Next we prove that the semantics of well-formed formulas only depends on the interpretation
of the free variables of a formula and on the current state of the last recorded path --
we call the latter the ``pointer'' of the path list.\<close>

fun pointerOf :: "('state,'aprop) path list \<Rightarrow> 'state" where
"pointerOf \<pi>l = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0)"

text\<open>Equality of two pairs (environment,path list) on a set of variables:\<close>

definition eqOn ::
"pvar set \<Rightarrow> env \<Rightarrow> ('state,'aprop) path list \<Rightarrow> env \<Rightarrow> ('state,'aprop) path list \<Rightarrow> bool"
where
"eqOn P env \<pi>l env1 \<pi>l1 \<equiv> \<forall> p. p \<in> P \<longrightarrow> \<pi>l!(env p) = \<pi>l1!(env1 p)"

lemma eqOn_Un[simp]:
"eqOn (P \<union> Q) env \<pi>l env1 \<pi>l1 \<longleftrightarrow> eqOn P env \<pi>l env1 \<pi>l1 \<and> eqOn Q env \<pi>l env1 \<pi>l1"
unfolding eqOn_def by auto

lemma eqOn_singl[simp]:
"eqOn {p} env \<pi>l env1 \<pi>l1 \<longleftrightarrow> \<pi>l!(env p) = \<pi>l1!(env1 p)"
unfolding eqOn_def by auto

lemma eqOn_map_stl[simp]:
"cpt P env \<pi>l \<Longrightarrow> cpt P env1 \<pi>l1 \<Longrightarrow>
 eqOn P env \<pi>l env1 \<pi>l1 \<Longrightarrow> eqOn P env (map stl \<pi>l) env1 (map stl \<pi>l1)"
unfolding eqOn_def cpt_def by auto

lemma cpt_map_sdrop[simp]:
"cpt P env \<pi>l \<Longrightarrow> cpt P env (map (sdrop i) \<pi>l)"
unfolding cpt_def by auto

lemma cpt_update[simp]:
assumes "cpt (P - {p}) env \<pi>l"
shows "cpt P (env(p := length \<pi>l)) (\<pi>l @ [\<pi>])"
using assms unfolding cpt_def by simp (metis Diff_iff less_SucI singleton_iff)

lemma eqOn_map_sdrop[simp]:
"cpt V env \<pi>l \<Longrightarrow> cpt V env1 \<pi>l1 \<Longrightarrow>
 eqOn V env \<pi>l env1 \<pi>l1 \<Longrightarrow> eqOn V env (map (sdrop i) \<pi>l) env1 (map (sdrop i) \<pi>l1)"
unfolding eqOn_def cpt_def by auto

lemma eqOn_update[simp]:
assumes "cpt (P - {p}) env \<pi>l" and "cpt (P - {p}) env1 \<pi>l1"
shows
"eqOn P (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>])
 \<longleftrightarrow>
 eqOn (P - {p}) env \<pi>l env1 \<pi>l1"
using assms unfolding eqOn_def cpt_def by simp (metis DiffI nth_append singleton_iff)

lemma eqOn_FV_sem_NE:
assumes "cpt (FV \<phi>) env \<pi>l" and "cpt (FV \<phi>) env1 \<pi>l1" and "eqOn (FV \<phi>) env \<pi>l env1 \<pi>l1"
and "\<pi>l \<noteq> []" and "\<pi>l1 \<noteq> []" and "last \<pi>l = last \<pi>l1"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l1"
using assms proof (induction \<phi> arbitrary: env \<pi>l env1 \<pi>l1)
  case (Until \<phi> \<psi> env \<pi>l env1 \<pi>l1)
  hence "\<And> i. sem \<phi> env (map (sdrop i) \<pi>l) = sem \<phi> env1 (map (sdrop i) \<pi>l1) \<and>
              sem \<psi> env (map (sdrop i) \<pi>l) = sem \<psi> env1 (map (sdrop i) \<pi>l1)"
  using Until by (auto simp: last_map)
  thus ?case by (auto simp: op_defs)
next
  case (Exi p \<phi> env \<pi>l env1 \<pi>l1)
  hence 1:
  "\<And> \<pi>. cpt (FV \<phi>) (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) \<and>
         cpt (FV \<phi>) (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>]) \<and>
         eqOn (FV \<phi>) (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>])"
  by simp_all
  thus ?case unfolding sem.simps exi_def using Exi
  by (intro iff_exI) (metis append_is_Nil_conv last_snoc)
qed(auto simp: last_map op_defs)

text\<open>The next theorem states that the semantics of a formula on an environment
and a list of paths only depends on the pointer of the list of paths.
\<close>

theorem eqOn_FV_sem:
assumes "wff \<phi>" and "pointerOf \<pi>l = pointerOf \<pi>l1"
and "cpt (FV \<phi>) env \<pi>l" and "cpt (FV \<phi>) env1 \<pi>l1" and "eqOn (FV \<phi>) env \<pi>l env1 \<pi>l1"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l1"
using assms proof (induction \<phi> arbitrary: env \<pi>l env1 \<pi>l1)
  case (Until \<phi> \<psi> env \<pi>l env1 \<pi>l1)
  hence "\<And> i. sem \<phi> env (map (sdrop i) \<pi>l) = sem \<phi> env1 (map (sdrop i) \<pi>l1) \<and>
              sem \<psi> env (map (sdrop i) \<pi>l) = sem \<psi> env1 (map (sdrop i) \<pi>l1)"
  using Until by (auto simp: last_map)
  thus ?case by (auto simp: op_defs)
next
  case (Exi p \<phi> env \<pi>l env1 \<pi>l1)
  have "\<And> \<pi>. sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) =
             sem \<phi> (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>])"
  apply(rule eqOn_FV_sem_NE) using Exi by auto
  thus ?case unfolding sem.simps exi_def using Exi by (intro iff_exI conj_cong) simp_all
qed(auto simp: last_map op_defs)

corollary FV_sem:
assumes "wff \<phi>" and "\<forall> p \<in> FV \<phi>. env p = env1 p"
and "cpt (FV \<phi>) env \<pi>l" and "cpt (FV \<phi>) env1 \<pi>l"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l"
apply(rule eqOn_FV_sem)
using assms unfolding eqOn_def by auto

text\<open>As a consequence, the interpretation of a closed formula (i.e., a formula
with no free variables) will not depend on the environment and, from the
list of paths, will only depend on its pointer:\<close>

corollary interp_closed:
assumes "wff \<phi>" and "FV \<phi> = {}" and "pointerOf \<pi>l = pointerOf \<pi>l1"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l1"
apply(rule eqOn_FV_sem)
using assms unfolding eqOn_def cpt_def by auto

text\<open>Therefore, it makes sense to define the interpretation of a closed formula
by choosing any environment and any list of paths such that its pointer is the initial state
(e.g., the empty list) -- knowing that the choices are irrelevant.\<close>

definition "semClosed \<phi> \<equiv> sem \<phi> (any::env) (SOME \<pi>l. pointerOf \<pi>l = s0)"

lemma semClosed:
assumes \<phi>: "wff \<phi>" "FV \<phi> = {}" and p: "pointerOf \<pi>l = s0"
shows "semClosed \<phi> = sem \<phi> env \<pi>l"
proof-
  have "pointerOf (SOME \<pi>l. pointerOf \<pi>l = s0) = s0"
  by (rule someI[of _ "[]"]) simp
  thus ?thesis unfolding semClosed_def using interp_closed[OF \<phi>] p by auto
qed

lemma semClosed_Nil:
assumes \<phi>: "wff \<phi>" "FV \<phi> = {}"
shows "semClosed \<phi> = sem \<phi> env []"
using assms semClosed by auto

subsection\<open>The conjunction of a finite set of formulas\<close>

text\<open>This is defined by making the set into a list (by choosing any ordering of the
elements) and iterating binary conjunction.\<close>

definition Scon :: "'aprop dfmla set \<Rightarrow> 'aprop dfmla" where
"Scon \<phi>s \<equiv> foldr Con (asList \<phi>s) Tr"

lemma sem_Scon[simp]:
assumes "finite \<phi>s"
shows "sem (Scon \<phi>s) env = scon ((\<lambda> \<phi>. sem \<phi> env) ` \<phi>s)"
proof-
  define \<phi>l where "\<phi>l = asList \<phi>s"
  have "sem (foldr Con \<phi>l Tr) env = scon ((\<lambda> \<phi>. sem \<phi> env) ` (set \<phi>l))"
  by (induct \<phi>l) (auto simp: scon_def)
  thus ?thesis unfolding \<phi>l_def Scon_def by (metis assms set_asList)
qed

lemma FV_Scon[simp]:
assumes "finite \<phi>s"
shows "FV (Scon \<phi>s) = \<Union> (FV ` \<phi>s)"
proof-
  define \<phi>l where "\<phi>l = asList \<phi>s"
  have "FV (foldr Con \<phi>l Tr) = \<Union> (set (map FV \<phi>l))"
  by (induct \<phi>l) (auto simp: der_Op_defs)
  thus ?thesis unfolding \<phi>l_def Scon_def by (metis assms set_map set_asList)
qed

(*<*)
end (* context Shallow  *)
(*>*)

text\<open>end-of-context Shallow\<close>

(*<*)
end
(*>*)


(*  Author:     Tobias Nipkow, 2007  *)

header "DLO"

theory DLO
imports QE Complex_Main
begin

subsection "Basics"

class dlo = linorder +
assumes dense: "x < z \<Longrightarrow> \<exists>y. x < y \<and> y < z"
and no_ub: "\<exists>u. x < u" and no_lb: "\<exists>l. l < x"

instance real :: dlo
proof
  fix r s :: real
  let ?v = "(r + s) / 2"
  assume "r < s"
  hence "r < ?v \<and> ?v < s" by simp
  thus "\<exists>v. r < v \<and> v < s" ..
next
  fix r :: real
  have "r < r + 1" by arith
  thus "\<exists>s. r < s" ..
next
  fix r :: real
  have "r - 1 < r" by arith
  thus "\<exists>s. s < r" ..
qed

datatype atom = Less nat nat | Eq nat nat

fun is_Less :: "atom \<Rightarrow> bool" where
"is_Less (Less i j) = True" |
"is_Less f = False"

abbreviation "is_Eq \<equiv> Not o is_Less"

lemma is_Less_iff: "is_Less a = (\<exists>i j. a = Less i j)"
by(cases a) auto
lemma is_Eq_iff: "(\<forall>i j. a \<noteq> Less i j) = (\<exists>i j. a = Eq i j)"
by(cases a) auto
lemma not_is_Eq_iff: "(\<forall>i j. a \<noteq> Eq i j) = (\<exists>i j. a = Less i j)"
by(cases a) auto

fun neg\<^sub>d\<^sub>l\<^sub>o :: "atom \<Rightarrow> atom fm" where
"neg\<^sub>d\<^sub>l\<^sub>o (Less i j) = Or (Atom(Less j i)) (Atom(Eq i j))" |
"neg\<^sub>d\<^sub>l\<^sub>o (Eq i j) = Or (Atom(Less i j)) (Atom(Less j i))"

fun I\<^sub>d\<^sub>l\<^sub>o :: "atom \<Rightarrow> 'a\<Colon>dlo list \<Rightarrow> bool" where
"I\<^sub>d\<^sub>l\<^sub>o (Eq i j) xs = (xs!i = xs!j)" |
"I\<^sub>d\<^sub>l\<^sub>o (Less i j) xs = (xs!i < xs!j)"

fun depends\<^sub>d\<^sub>l\<^sub>o :: "atom \<Rightarrow> bool" where
"depends\<^sub>d\<^sub>l\<^sub>o(Eq i j) = (i=0 | j=0)" |
"depends\<^sub>d\<^sub>l\<^sub>o(Less i j) = (i=0 | j=0)"

fun decr\<^sub>d\<^sub>l\<^sub>o :: "atom \<Rightarrow> atom" where
"decr\<^sub>d\<^sub>l\<^sub>o (Less i j) = Less (i - 1) (j - 1)" |
"decr\<^sub>d\<^sub>l\<^sub>o (Eq i j) = Eq (i - 1) (j - 1)"

(* needed for code generation *)
definition [code del]: "nnf = ATOM.nnf neg\<^sub>d\<^sub>l\<^sub>o"
definition [code del]: "qelim = ATOM.qelim depends\<^sub>d\<^sub>l\<^sub>o decr\<^sub>d\<^sub>l\<^sub>o"
definition [code del]: "lift_dnf_qe = ATOM.lift_dnf_qe neg\<^sub>d\<^sub>l\<^sub>o depends\<^sub>d\<^sub>l\<^sub>o decr\<^sub>d\<^sub>l\<^sub>o"
definition [code del]: "lift_nnf_qe = ATOM.lift_nnf_qe neg\<^sub>d\<^sub>l\<^sub>o"

hide_const nnf qelim lift_dnf_qe lift_nnf_qe

lemmas DLO_code_lemmas = nnf_def qelim_def lift_dnf_qe_def lift_nnf_qe_def

interpretation DLO!:
  ATOM neg\<^sub>d\<^sub>l\<^sub>o "(\<lambda>a. True)" I\<^sub>d\<^sub>l\<^sub>o depends\<^sub>d\<^sub>l\<^sub>o decr\<^sub>d\<^sub>l\<^sub>o
apply(unfold_locales)
apply(case_tac a)
apply simp_all
apply(case_tac a)
apply (simp_all add:linorder_class.not_less_iff_gr_or_eq
                    linorder_not_less linorder_neq_iff)
apply(case_tac a)
apply(simp_all add:nth_Cons')
done

lemmas [folded DLO_code_lemmas, code] =
  DLO.nnf.simps DLO.qelim_def DLO.lift_dnf_qe.simps DLO.lift_dnf_qe.simps

setup {* Sign.revert_abbrev "" @{const_abbrev DLO.I} *}

definition lbounds where "lbounds as = [i. Less (Suc i) 0 \<leftarrow> as]"
definition ubounds where "ubounds as = [i. Less 0 (Suc i) \<leftarrow> as]"
definition ebounds where
 "ebounds as = [i. Eq (Suc i) 0 \<leftarrow> as] @ [i. Eq 0 (Suc i) \<leftarrow> as]"

lemma set_lbounds: "set(lbounds as) = {i. Less (Suc i) 0 : set as}"
by(auto simp: lbounds_def split:nat.splits atom.splits)
lemma set_ubounds: "set(ubounds as) = {i. Less 0 (Suc i) : set as}"
by(auto simp: ubounds_def split:nat.splits atom.splits)
lemma set_ebounds:
  "set(ebounds as) = {k. Eq (Suc k) 0 : set as \<or> Eq 0 (Suc k) : set as}"
by(auto simp: ebounds_def split: atom.splits nat.splits)

abbreviation "LB f xs \<equiv> {xs!i|i. Less (Suc i) 0 : set(DLO.atoms\<^sub>0 f)}"
abbreviation "UB f xs \<equiv> {xs!i|i. Less 0 (Suc i) : set(DLO.atoms\<^sub>0 f)}"
definition "EQ f xs = {xs!k|k.
  Eq (Suc k) 0 : set(DLO.atoms\<^sub>0 f) \<or> Eq 0 (Suc k) : set(DLO.atoms\<^sub>0 f)}"

lemma EQ_And[simp]: "EQ (And f g) xs = (EQ f xs Un EQ g xs)"
by(auto simp:EQ_def)

lemma EQ_Or[simp]: "EQ (Or f g) xs = (EQ f xs Un EQ g xs)"
by(auto simp:EQ_def)

lemma EQ_conv_set_ebounds:
  "x \<in> EQ f xs = (\<exists>e\<in>set(ebounds(DLO.atoms\<^sub>0 f)). x = xs!e)"
by(auto simp: EQ_def set_ebounds)

fun isubst where "isubst k 0 = k" | "isubst k (Suc i) = i"

fun asubst :: "nat \<Rightarrow> atom \<Rightarrow> atom" where
"asubst k (Less i j) = Less (isubst k i) (isubst k j)"|
"asubst k (Eq i j) = Eq (isubst k i) (isubst k j)"

abbreviation "subst \<phi> k \<equiv> map\<^bsub>fm\<^esub> (asubst k) \<phi>"

lemma I_subst:
 "qfree f \<Longrightarrow> DLO.I (subst f k) xs = DLO.I f (xs!k # xs)"
apply(induct f)
apply(simp_all)
apply(rename_tac a)
apply(case_tac a)
apply(simp_all add:nth.simps split:nat.splits)
done

fun amin_inf :: "atom \<Rightarrow> atom fm" where
"amin_inf (Less _ 0) = FalseF" |
"amin_inf (Less 0 _) = TrueF" |
"amin_inf (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"amin_inf (Eq 0 0) = TrueF" |
"amin_inf (Eq 0 _) = FalseF" |
"amin_inf (Eq _ 0) = FalseF" |
"amin_inf (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation min_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>-") where
"inf\<^sub>- \<equiv> amap\<^bsub>fm\<^esub> amin_inf"

fun aplus_inf :: "atom \<Rightarrow> atom fm" where
"aplus_inf (Less 0 _) = FalseF" |
"aplus_inf (Less _ 0) = TrueF" |
"aplus_inf (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"aplus_inf (Eq 0 0) = TrueF" |
"aplus_inf (Eq 0 _) = FalseF" |
"aplus_inf (Eq _ 0) = FalseF" |
"aplus_inf (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation plus_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>+") where
"inf\<^sub>+ \<equiv> amap\<^bsub>fm\<^esub> aplus_inf"

lemma min_inf:
  "nqfree f \<Longrightarrow> \<exists>x. \<forall>y\<le>x. DLO.I (inf\<^sub>- f) xs = DLO.I f (y # xs)"
  (is "_ \<Longrightarrow> \<exists>x. ?P f x")
proof(induct f)
  case (Atom a)
  show ?case
  proof (cases a rule: amin_inf.cases)
    case 1 thus ?thesis by(auto simp add:nth_Cons' linorder_not_less)
  next
    case 2 thus ?thesis
      by (simp) (metis no_lb linorder_not_less order_less_le_trans)
  next
    case 5 thus ?thesis
      by(simp add:nth_Cons') (metis no_lb linorder_not_less)
  next
    case 6 thus ?thesis by simp (metis no_lb linorder_not_less)
  qed simp_all
next
  case (And f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (min x1 x2)" by(force simp:and_def)
  thus ?case ..
next
  case (Or f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (min x1 x2)" by(force simp:or_def)
  thus ?case ..
qed simp_all

lemma plus_inf:
  "nqfree f \<Longrightarrow> \<exists>x.\<forall>y\<ge>x. DLO.I (inf\<^sub>+ f) xs = DLO.I f (y # xs)"
  (is "_ \<Longrightarrow> \<exists>x. ?P f x")
proof (induct f)
  have dlo_bound: "\<And>z::'a. \<exists>x. \<forall>y\<ge>x. y > z"
  proof -
    fix z
    from no_ub obtain w :: 'a where "w > z" ..
    then have "\<forall>y\<ge>w. y > z" by auto
    then show "?thesis z" ..
  qed
  case (Atom a)
  show ?case
  proof (cases a rule: aplus_inf.cases)
    case 1 thus ?thesis
      by (simp add: nth_Cons') (metis linorder_not_less)
  next
    case 2 thus ?thesis by (auto intro: dlo_bound)
  next
    case 5 thus ?thesis
      by simp (metis dlo_bound less_imp_neq)
  next
    case 6 thus ?thesis
      by simp (metis dlo_bound less_imp_neq)
  qed simp_all
next
  case (And f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (max x1 x2)" by(force simp:and_def)
  thus ?case ..
next
  case (Or f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (max x1 x2)" by(force simp:or_def)
  thus ?case ..
qed simp_all

declare[[simp_depth_limit=2]]
lemma LBex:
 "\<lbrakk> nqfree f; DLO.I f (x#xs); \<not>DLO.I (inf\<^sub>- f) xs; x \<notin> EQ f xs \<rbrakk>
  \<Longrightarrow> \<exists>l\<in> LB f xs. l < x"
proof(induct f)
  case (Atom a) thus ?case
    by (cases a rule: amin_inf.cases)
       (simp_all add: nth.simps EQ_def split: nat.splits)
qed auto

lemma UBex:
 "\<lbrakk> nqfree f; DLO.I f (x#xs); \<not>DLO.I (inf\<^sub>+ f) xs; x \<notin> EQ f xs \<rbrakk>
  \<Longrightarrow> \<exists>u \<in> UB f xs. x < u"
proof(induct f)
  case (Atom a) thus ?case
    by (cases a rule: aplus_inf.cases)
       (simp_all add: nth.simps EQ_def split: nat.splits)
qed auto
declare[[simp_depth_limit=50]]

lemma finite_LB: "finite(LB f xs)"
proof -
  have "LB f xs = (\<lambda>k. xs!k) ` set(lbounds(DLO.atoms\<^sub>0 f))"
    by (auto simp:set_lbounds image_def)
  thus ?thesis by simp
qed

lemma finite_UB: "finite(UB f xs)"
proof -
  have "UB f xs = (\<lambda>k.  xs!k) ` set(ubounds(DLO.atoms\<^sub>0 f))"
    by (auto simp:set_ubounds image_def)
  thus ?thesis by simp
qed

lemma qfree_amin_inf: "qfree (amin_inf a)"
by(cases a rule:amin_inf.cases) simp_all

lemma qfree_min_inf: "nqfree \<phi> \<Longrightarrow> qfree(inf\<^sub>- \<phi>)"
by(induct \<phi>)(simp_all add:qfree_amin_inf)

lemma qfree_aplus_inf: "qfree (aplus_inf a)"
by(cases a rule:aplus_inf.cases) simp_all

lemma qfree_plus_inf: "nqfree \<phi> \<Longrightarrow> qfree(inf\<^sub>+ \<phi>)"
by(induct \<phi>)(simp_all add:qfree_aplus_inf)

end


(* Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Examples of applicative lifting\<close>

subsection \<open>Algebraic operations for the environment functor\<close>

theory Applicative_Environment_Algebra imports
  Applicative_Environment
  "HOL-Library.Function_Division"
begin

text \<open> Link between applicative instance of the environment functor with the pointwise operations
  for the algebraic type classes \<close>

context includes applicative_syntax
begin

lemma plus_fun_af [applicative_unfold]: "f + g = pure (+) \<diamondop> f \<diamondop> g"
unfolding plus_fun_def const_def apf_def ..

lemma zero_fun_af [applicative_unfold]: "0 = pure 0"
unfolding zero_fun_def const_def ..

lemma times_fun_af [applicative_unfold]: "f * g = pure (*) \<diamondop> f \<diamondop> g"
unfolding times_fun_def const_def apf_def ..

lemma one_fun_af [applicative_unfold]: "1 = pure 1"
unfolding one_fun_def const_def ..

lemma of_nat_fun_af [applicative_unfold]: "of_nat n = pure (of_nat n)"
unfolding of_nat_fun const_def ..

lemma inverse_fun_af [applicative_unfold]: "inverse f = pure inverse \<diamondop> f"
unfolding inverse_fun_def o_def const_def apf_def ..

lemma divide_fun_af [applicative_unfold]: "divide f g = pure divide \<diamondop> f \<diamondop> g"
unfolding divide_fun_def const_def apf_def ..

end

end


(*  Title:      Containers/DList_Set.thy
    Author:     Andreas Lochbihler, KIT *)

theory DList_Set imports
  Collection_Eq
  Equal
begin

section \<open>Sets implemented by distinct lists\<close>

subsection \<open>Operations on the raw type with parametrised equality\<close>

context equal_base begin

primrec list_member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
  "list_member []       y \<longleftrightarrow> False"
| "list_member (x # xs) y \<longleftrightarrow> equal x y \<or> list_member xs y"

primrec list_distinct :: "'a list \<Rightarrow> bool"
where
  "list_distinct []       \<longleftrightarrow> True"
| "list_distinct (x # xs) \<longleftrightarrow> \<not> list_member xs x \<and> list_distinct xs"

definition list_insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_insert x xs = (if list_member xs x then xs else x # xs)"

primrec list_remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_remove1 x [] = []"
| "list_remove1 x (y # xs) = (if equal x y then xs else y # list_remove1 x xs)"

primrec list_remdups :: "'a list \<Rightarrow> 'a list" where
  "list_remdups [] = []"
| "list_remdups (x # xs) = (if list_member xs x then list_remdups xs else x # list_remdups xs)"

lemma list_member_filterD: "list_member (filter P xs) x \<Longrightarrow> list_member xs x"
by(induct xs)(auto split: if_split_asm)

lemma list_distinct_filter [simp]: "list_distinct xs \<Longrightarrow> list_distinct (filter P xs)"
by(induct xs)(auto dest: list_member_filterD)

lemma list_distinct_tl [simp]: "list_distinct xs \<Longrightarrow> list_distinct (tl xs)"
by(cases xs) simp_all

end

lemmas [code] =
  equal_base.list_member.simps
  equal_base.list_distinct.simps
  equal_base.list_insert_def
  equal_base.list_remove1.simps
  equal_base.list_remdups.simps

lemmas [simp] =
  equal_base.list_member.simps
  equal_base.list_distinct.simps
  equal_base.list_remove1.simps
  equal_base.list_remdups.simps

lemma list_member_conv_member [simp]:
  "equal_base.list_member (=) = List.member"
proof(intro ext)
  fix xs and x :: 'a
  show "equal_base.list_member (=) xs x = List.member xs x"
    by(induct xs)(auto simp add: List.member_def)
qed

lemma list_distinct_conv_distinct [simp]:
  "equal_base.list_distinct (=) = List.distinct"
proof
  fix xs :: "'a list"
  show "equal_base.list_distinct (=) xs = distinct xs"
    by(induct xs)(auto simp add: List.member_def)
qed

lemma list_insert_conv_insert [simp]:
  "equal_base.list_insert (=) = List.insert"
unfolding equal_base.list_insert_def[abs_def] List.insert_def[abs_def]
by(simp add: List.member_def)

lemma list_remove1_conv_remove1 [simp]:
  "equal_base.list_remove1 (=) = List.remove1"
unfolding equal_base.list_remove1_def List.remove1_def ..

lemma list_remdups_conv_remdups [simp]:
  "equal_base.list_remdups (=) = List.remdups"
unfolding equal_base.list_remdups_def List.remdups_def list_member_conv_member List.member_def ..

context equal begin

lemma member_insert [simp]: "list_member (list_insert x xs) y \<longleftrightarrow> equal x y \<or> list_member xs y"
by(auto simp add: equal_eq List.member_def)

lemma member_remove1 [simp]:
  "\<not> equal x y \<Longrightarrow> list_member (list_remove1 x xs) y = list_member xs y"
by(simp add: equal_eq List.member_def)

lemma distinct_remove1:
  "list_distinct xs \<Longrightarrow> list_distinct (list_remove1 x xs)"
by(simp add: equal_eq)

lemma distinct_member_remove1 [simp]:
  "list_distinct xs \<Longrightarrow> list_member (list_remove1 x xs) = (list_member xs)(x := False)"
by(auto simp add: equal_eq List.member_def[abs_def] fun_eq_iff)

end

lemma ID_ceq: (* FIXME: Adapt Set_Impl to directly use above equal class! *)
  "ID CEQ('a :: ceq) = Some eq \<Longrightarrow> equal eq"
by(unfold_locales)(clarsimp simp add: ID_ceq)

subsection \<open>The type of distinct lists\<close>

typedef (overloaded) 'a :: ceq set_dlist =
  "{xs::'a list. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None}"
  morphisms list_of_dlist Abs_dlist'
proof
  show "[] \<in> ?set_dlist" by(simp)
qed

definition Abs_dlist :: "'a :: ceq list \<Rightarrow> 'a set_dlist"
where
  "Abs_dlist xs = Abs_dlist'
  (if equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None then xs
   else equal_base.list_remdups ceq' xs)"

lemma Abs_dlist_inverse:
  fixes y :: "'a :: ceq list"
  assumes "y \<in> {xs. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None}"
  shows "list_of_dlist (Abs_dlist y) = y"
using assms by(auto simp add: Abs_dlist_def Abs_dlist'_inverse)

lemma list_of_dlist_inverse: "Abs_dlist (list_of_dlist dxs) = dxs"
by(cases dxs)(simp add: Abs_dlist'_inverse Abs_dlist_def)

lemma type_definition_set_dlist':
  "type_definition list_of_dlist Abs_dlist
  {xs :: 'a :: ceq list. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None}"
by(unfold_locales)(rule set_dlist.list_of_dlist Abs_dlist_inverse list_of_dlist_inverse)+

lemmas Abs_dlist_cases[cases type: set_dlist] =
  type_definition.Abs_cases[OF type_definition_set_dlist']
  and Abs_dlist_induct[induct type: set_dlist] =
  type_definition.Abs_induct[OF type_definition_set_dlist'] and
  Abs_dlist_inject = type_definition.Abs_inject[OF type_definition_set_dlist']

setup_lifting type_definition_set_dlist'

subsection \<open>Operations\<close>

lift_definition empty :: "'a :: ceq set_dlist" is "[]"
by simp

lift_definition insert :: "'a :: ceq \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" is
  "equal_base.list_insert ceq'"
by(simp add: equal_base.list_insert_def)

lift_definition remove :: "'a :: ceq \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" is
  "equal_base.list_remove1 ceq'"
by(auto simp: equal.distinct_remove1 ID_ceq)

lift_definition filter :: "('a :: ceq \<Rightarrow> bool) \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" is List.filter
by(auto simp add: equal_base.list_distinct_filter)

text \<open>Derived operations:\<close>

lift_definition null :: "'a :: ceq set_dlist \<Rightarrow> bool" is List.null .

lift_definition member :: "'a :: ceq set_dlist \<Rightarrow> 'a \<Rightarrow> bool" is "equal_base.list_member ceq'" .

lift_definition length :: "'a :: ceq set_dlist \<Rightarrow> nat" is List.length .

lift_definition fold :: "('a :: ceq \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set_dlist \<Rightarrow> 'b \<Rightarrow> 'b" is List.fold .

lift_definition foldr :: "('a :: ceq \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set_dlist \<Rightarrow> 'b \<Rightarrow> 'b" is List.foldr .

lift_definition hd :: "'a :: ceq set_dlist \<Rightarrow> 'a" is "List.hd" .

lift_definition tl :: "'a :: ceq set_dlist \<Rightarrow> 'a set_dlist" is "List.tl"
by(auto simp add: equal_base.list_distinct_tl)

lift_definition dlist_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a :: ceq set_dlist \<Rightarrow> bool" is "list_all" .

lift_definition dlist_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a :: ceq set_dlist \<Rightarrow> bool" is "list_ex" .

definition union :: "'a :: ceq set_dlist \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" where
  "union = fold insert"

lift_definition product :: "'a :: ceq set_dlist \<Rightarrow> 'b :: ceq set_dlist \<Rightarrow> ('a \<times> 'b) set_dlist"
  is "\<lambda>xs ys. rev (concat (map (\<lambda>x. map (Pair x) ys) xs))"
proof -
  fix xs :: "'a list" and ys :: "'b list"
  assume *: "equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None"
    "equal_base.list_distinct ceq' ys \<or> ID CEQ('b) = None"
  let ?product = "concat (map (\<lambda>x. map (Pair x) ys) xs)"
  { assume neq: "ID CEQ('a) \<noteq> None" "ID CEQ('b) \<noteq> None"
    hence ceq': "ceq' = ((=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool)" "ceq' = ((=) :: 'b \<Rightarrow> 'b \<Rightarrow> bool)"
      by(auto intro: equal.equal_eq[OF ID_ceq])
    with * neq have dist: "distinct xs" "distinct ys" by simp_all
    hence "distinct ?product"
      by(cases "ys = []")(auto simp add: distinct_map map_replicate_const intro!: inj_onI distinct_concat)
    hence "distinct (rev ?product)" by simp
    moreover have "ceq' = ((=) :: ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool)"
      using neq ceq' by (auto simp add: ceq_prod_def ID_Some fun_eq_iff list_all_eq_def)
    ultimately have "equal_base.list_distinct ceq' (rev ?product)" by simp }
  with *
  show "equal_base.list_distinct ceq' (rev ?product) \<or> ID CEQ('a \<times> 'b) = None"
    by(fastforce simp add: ceq_prod_def ID_def split: option.split_asm)
qed

lift_definition Id_on :: "'a :: ceq set_dlist \<Rightarrow> ('a \<times> 'a) set_dlist"
 is "map (\<lambda>x. (x, x))"
proof -
  fix xs :: "'a list"
  assume ceq: "equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None"
  {
    assume ceq: "ID CEQ('a \<times> 'a) \<noteq> None"
      and xs: "equal_base.list_distinct ceq' xs"
    from ceq have "ID CEQ('a) \<noteq> None"
      and "ceq' = ((=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
      and "ceq' = ((=) :: ('a \<times> 'a) \<Rightarrow> ('a \<times> 'a) \<Rightarrow> bool)"
      by(auto simp add: equal.equal_eq[OF ID_ceq] ceq_prod_def ID_None ID_Some split: option.split_asm)
    hence "?thesis xs" using xs by(auto simp add: distinct_map intro: inj_onI) }
  thus "?thesis xs" using ceq by(auto dest: equal.equal_eq[OF ID_ceq] simp add: ceq_prod_def ID_None)
qed

subsection \<open>Properties\<close>

lemma member_empty [simp]: "member empty = (\<lambda>_. False)"
by transfer (simp add: fun_eq_iff)

lemma null_iff [simp]: "null xs \<longleftrightarrow> xs = empty"
by transfer(simp add: List.null_def)

lemma list_of_dlist_empty [simp]: "list_of_dlist DList_Set.empty = []"
by(rule empty.rep_eq)

lemma list_of_dlist_insert [simp]: "\<not> member dxs x \<Longrightarrow> list_of_dlist (insert x dxs) = x # list_of_dlist dxs"
by(cases dxs)(auto simp add: DList_Set.insert_def DList_Set.member_def Abs_dlist_inverse Abs_dlist_inject equal_base.list_insert_def List.member_def intro: Abs_dlist_inverse)

lemma list_of_dlist_eq_Nil_iff [simp]: "list_of_dlist dxs = [] \<longleftrightarrow> dxs = empty"
by(cases dxs)(auto simp add: Abs_dlist_inverse Abs_dlist_inject DList_Set.empty_def)

lemma fold_empty [simp]: "DList_Set.fold f empty b = b"
by(transfer) simp

lemma fold_insert [simp]: "\<not> member dxs x \<Longrightarrow> DList_Set.fold f (insert x dxs) b = DList_Set.fold f dxs (f x b)"
by(transfer)(simp add: equal_base.list_insert_def)

lemma no_memb_fold_insert:
  "\<not> member dxs x \<Longrightarrow> fold f (insert x dxs) b = fold f dxs (f x b)"
by(transfer)(simp add: equal_base.list_insert_def)

lemma set_fold_insert: "set (List.fold List.insert xs1 xs2) = set xs1 \<union> set xs2"
by(induct xs1 arbitrary: xs2) simp_all

lemma list_of_dlist_eq_singleton_conv:
  "list_of_dlist dxs = [x] \<longleftrightarrow> dxs = DList_Set.insert x DList_Set.empty"
by transfer(case_tac dxs, auto simp add: equal_base.list_insert_def)

lemma product_code [code abstract]:
  "list_of_dlist (product dxs1 dxs2) = fold (\<lambda>a. fold (\<lambda>c rest. (a, c) # rest) dxs2) dxs1 []"
proof -
  { fix xs ys and zs :: "('a \<times> 'b) list"
    have "rev (concat (map (\<lambda>x. map (Pair x) ys) xs)) @ zs =
          List.fold (\<lambda>a. List.fold (\<lambda>c rest. (a, c) # rest) ys) xs zs"
    proof(induction xs arbitrary: zs)
      case Nil thus ?case by simp
    next
      case (Cons x xs)
      have "List.fold (\<lambda>c rest. (x, c) # rest) ys zs = rev (map (Pair x) ys) @ zs"
        by(induct ys arbitrary: zs) simp_all
      with Cons.IH[of "rev (map (Pair x) ys) @ zs"]
      show ?case by simp
    qed }
  from this[of "list_of_dlist dxs2" "list_of_dlist dxs1" "[]"]
  show ?thesis by(simp add: product.rep_eq fold.rep_eq)
qed

lemma set_list_of_dlist_Abs_dlist:
  "set (list_of_dlist (Abs_dlist xs)) = set xs"
by(clarsimp simp add: Abs_dlist_def Abs_dlist'_inverse)(subst Abs_dlist'_inverse, auto dest: equal.equal_eq[OF ID_ceq])

context assumes ID_ceq_neq_None: "ID CEQ('a :: ceq) \<noteq> None"
begin

lemma equal_ceq: "equal (ceq' :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
using ID_ceq_neq_None by(clarsimp)(rule ID_ceq)

(* workaround for the next theorem *)
declare Domainp_forall_transfer[where A = "pcr_set_dlist (=)", simplified set_dlist.domain_eq, transfer_rule]

lemma set_dlist_induct [case_names Nil insert, induct type: set_dlist]:
  fixes dxs :: "'a :: ceq set_dlist"
  assumes Nil: "P empty" and Cons: "\<And>a dxs. \<lbrakk> \<not> member dxs a; P dxs \<rbrakk> \<Longrightarrow> P (insert a dxs)"
  shows "P dxs"
using assms
proof transfer
  fix P :: "'a list \<Rightarrow> bool" and xs :: "'a list"
  assume NIL: "P []"
    and Insert: "\<And>xs. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None
                 \<Longrightarrow> (\<And>x. \<lbrakk> \<not> equal_base.list_member ceq' xs x; P xs \<rbrakk> \<Longrightarrow> P (equal_base.list_insert ceq' x xs))"
    and Eq: "equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None"
  from Eq show "P xs"
  proof(induction xs)
    case Nil show ?case by(rule NIL)
  next
    case (Cons x xs) thus ?case using Insert[of xs x] equal.equal_eq[OF equal_ceq] ID_ceq_neq_None
      by(auto simp add: List.member_def simp del: not_None_eq)
  qed
qed

context includes lifting_syntax
begin

lemma fold_transfer2 [transfer_rule]:
  assumes "is_equality A"
  shows "((A ===> pcr_set_dlist (=) ===> pcr_set_dlist (=)) ===>
    (pcr_set_dlist (=) :: 'a list \<Rightarrow> 'a set_dlist \<Rightarrow> bool) ===> pcr_set_dlist (=) ===> pcr_set_dlist (=))
     List.fold DList_Set.fold"
unfolding Transfer.Rel_def set_dlist.pcr_cr_eq
proof(rule rel_funI)+
  fix f :: "'a \<Rightarrow> 'b list \<Rightarrow> 'b list" and g and xs :: "'a list" and ys and b :: "'b list" and c
  assume fg: "(A ===> cr_set_dlist ===> cr_set_dlist) f g"
  assume "cr_set_dlist xs ys" "cr_set_dlist b c"
  thus "cr_set_dlist (List.fold f xs b) (DList_Set.fold g ys c)"
  proof(induct ys arbitrary: xs b c rule: set_dlist_induct)
    case Nil thus ?case by(simp add: cr_set_dlist_def)
  next
    case (insert y dxs)
    have "A y y" and "cr_set_dlist (list_of_dlist c) c"
      using assms by(simp_all add: cr_set_dlist_def is_equality_def)
    with fg have "cr_set_dlist (f y (list_of_dlist c)) (g y c)"
      by -(drule (1) rel_funD)+
    thus ?case using insert by(simp add: cr_set_dlist_def)
  qed
qed

end

lemma distinct_list_of_dlist:
  "distinct (list_of_dlist (dxs :: 'a set_dlist))"
using list_of_dlist[of dxs] equal.equal_eq[OF equal_ceq]
by(simp add: ID_ceq_neq_None)

lemma member_empty_empty: "(\<forall>x :: 'a. \<not> member dxs x) \<longleftrightarrow> dxs = empty"
by(transfer)(simp add: equal.equal_eq[OF equal_ceq] List.member_def)

lemma Collect_member: "Collect (member (dxs :: 'a set_dlist)) = set (list_of_dlist dxs)"
by(simp add: member_def equal.equal_eq[OF equal_ceq] List.member_def[abs_def])

lemma member_insert: "member (insert (x :: 'a) xs) = (member xs)(x := True)"
by(transfer)(simp add: fun_eq_iff List.member_def ID_ceq_neq_None equal.equal_eq[OF equal_ceq])

lemma member_remove:
  "member (remove (x :: 'a) xs) = (member xs)(x := False)"
by transfer (auto simp add: fun_eq_iff ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def)

lemma member_union: "member (union (xs1 :: 'a set_dlist) xs2) x \<longleftrightarrow> member xs1 x \<or> member xs2 x"
unfolding union_def
by(transfer)(simp add: equal.equal_eq[OF equal_ceq] List.member_def set_fold_insert)

lemma member_fold_insert: "member (List.fold insert xs dxs) (x :: 'a) \<longleftrightarrow> member dxs x \<or> x \<in> set xs"
by transfer(auto simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def set_fold_insert)

lemma card_eq_length [simp]:
  "card (Collect (member (dxs :: 'a set_dlist))) = length dxs"
by transfer(simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def[abs_def] distinct_card)

lemma finite_member [simp]:
  "finite (Collect (member (dxs :: 'a set_dlist)))"
by transfer(simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def[abs_def])

lemma member_filter [simp]: "member (filter P xs) = (\<lambda>x :: 'a. member xs x \<and> P x)"
by transfer(simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def[abs_def])

lemma dlist_all_conv_member: "dlist_all P dxs \<longleftrightarrow> (\<forall>x :: 'a. member dxs x \<longrightarrow> P x)"
by transfer(auto simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] list_all_iff List.member_def)

lemma member_Id_on: "member (Id_on dxs) = (\<lambda>(x :: 'a, y). x = y \<and> member dxs x)"
proof -
  have "ID CEQ('a \<times> 'a) = Some (=)"
    using equal.equal_eq[where ?'a='a, OF equal_ceq]
    by(auto simp add: ceq_prod_def list_all_eq_def ID_ceq_neq_None ID_Some fun_eq_iff split: option.split)
  thus ?thesis
    using equal.equal_eq[where ?'a='a, OF equal_ceq]
    by transfer(auto simp add: ID_ceq_neq_None List.member_def[abs_def] ID_Some intro!: ext split: option.split_asm)
qed

end

lemma product_member:
  assumes "ID CEQ('a :: ceq) \<noteq> None" "ID CEQ('b :: ceq) \<noteq> None"
  shows "member (product dxs1 dxs2) = (\<lambda>(a :: 'a, b :: 'b). member dxs1 a \<and> member dxs2 b)"
proof -
  from assms have "ceq' = ((=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool)" "ceq' = ((=) :: 'b \<Rightarrow> 'b \<Rightarrow> bool)"
    by(auto intro: equal.equal_eq[OF ID_ceq])
  moreover with assms have "ceq' = ((=) :: ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool)"
    by(auto simp add: ceq_prod_def list_all_eq_def ID_Some fun_eq_iff)
  ultimately show ?thesis by(transfer)(auto simp add: List.member_def[abs_def])
qed

hide_const (open) empty insert remove null member length fold foldr union filter hd tl dlist_all product Id_on

end


(*  Title:      ZF/pair.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section\<open>Ordered Pairs\<close>

theory Ordered_Pair imports Unordered_Pair
begin

ML_file "simpdata.ML"

setup \<open>
  map_theory_simpset
    (Simplifier.set_mksimps (fn ctxt => map mk_eq o ZF_atomize o Variable.gen_all ctxt)
      #> Simplifier.add_cong @{thm if_weak_cong})
\<close>

ML \<open>val ZF_ss = simpset_of @{context}\<close>

simproc_setup defined_Bex ("\<exists>x\<in>A. P(x) & Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_bex
    (fn ctxt =>
      unfold_tac ctxt @{thms Bex_def} THEN
      Quantifier1.prove_one_point_ex_tac ctxt)
\<close>

simproc_setup defined_Ball ("\<forall>x\<in>A. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_ball
    (fn ctxt =>
      unfold_tac ctxt @{thms Ball_def} THEN
      Quantifier1.prove_one_point_all_tac ctxt)
\<close>

(** Lemmas for showing that <a,b> uniquely determines a and b **)

lemma singleton_eq_iff [iff]: "{a} = {b} \<longleftrightarrow> a=b"
by (rule extension [THEN iff_trans], blast)

lemma doubleton_eq_iff: "{a,b} = {c,d} \<longleftrightarrow> (a=c & b=d) | (a=d & b=c)"
by (rule extension [THEN iff_trans], blast)

lemma Pair_iff [simp]: "<a,b> = <c,d> \<longleftrightarrow> a=c & b=d"
by (simp add: Pair_def doubleton_eq_iff, blast)

lemmas Pair_inject = Pair_iff [THEN iffD1, THEN conjE, elim!]

lemmas Pair_inject1 = Pair_iff [THEN iffD1, THEN conjunct1]
lemmas Pair_inject2 = Pair_iff [THEN iffD1, THEN conjunct2]

lemma Pair_not_0: "<a,b> \<noteq> 0"
apply (unfold Pair_def)
apply (blast elim: equalityE)
done

lemmas Pair_neq_0 = Pair_not_0 [THEN notE, elim!]

declare sym [THEN Pair_neq_0, elim!]

lemma Pair_neq_fst: "<a,b>=a ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = a"
  have  "{a, a} \<in> {{a, a}, {a, b}}" by (rule consI1)
  hence "{a, a} \<in> a" by (simp add: eq)
  moreover have "a \<in> {a, a}" by (rule consI1)
  ultimately show "P" by (rule mem_asym)
qed

lemma Pair_neq_snd: "<a,b>=b ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = b"
  have  "{a, b} \<in> {{a, a}, {a, b}}" by blast
  hence "{a, b} \<in> b" by (simp add: eq)
  moreover have "b \<in> {a, b}" by blast
  ultimately show "P" by (rule mem_asym)
qed

subsection\<open>Sigma: Disjoint Union of a Family of Sets\<close>

text\<open>Generalizes Cartesian product\<close>

lemma Sigma_iff [simp]: "<a,b>: Sigma A B \<longleftrightarrow> a \<in> A & b \<in> B(a)"
by (simp add: Sigma_def)

lemma SigmaI [TC,intro!]: "[| a \<in> A;  b \<in> B(a) |] ==> <a,b> \<in> Sigma A B"
by simp

lemmas SigmaD1 = Sigma_iff [THEN iffD1, THEN conjunct1]
lemmas SigmaD2 = Sigma_iff [THEN iffD1, THEN conjunct2]

(*The general elimination rule*)
lemma SigmaE [elim!]:
    "[| c \<in> Sigma A B;
        !!x y.[| x \<in> A;  y \<in> B(x);  c=<x,y> |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma SigmaE2 [elim!]:
    "[| <a,b> \<in> Sigma A B;
        [| a \<in> A;  b \<in> B(a) |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma Sigma_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==>
     Sigma A B = Sigma A' B'"
by (simp add: Sigma_def)

(*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
  flex-flex pairs and the "Check your prover" error.  Most
  Sigmas and Pis are abbreviated as * or -> *)

lemma Sigma_empty1 [simp]: "Sigma 0 B = 0"
by blast

lemma Sigma_empty2 [simp]: "A*0 = 0"
by blast

lemma Sigma_empty_iff: "A*B=0 \<longleftrightarrow> A=0 | B=0"
by blast

subsection\<open>Projections @{term fst} and @{term snd}\<close>

lemma fst_conv [simp]: "fst(<a,b>) = a"
by (simp add: fst_def)

lemma snd_conv [simp]: "snd(<a,b>) = b"
by (simp add: snd_def)

lemma fst_type [TC]: "p \<in> Sigma A B ==> fst(p) \<in> A"
by auto

lemma snd_type [TC]: "p \<in> Sigma A B ==> snd(p) \<in> B(fst(p))"
by auto

lemma Pair_fst_snd_eq: "a \<in> Sigma A B ==> <fst(a),snd(a)> = a"
by auto

subsection\<open>The Eliminator, @{term split}\<close>

(*A META-equality, so that it applies to higher types as well...*)
lemma split [simp]: "split (%x y. c x y) <a,b> == c a b"
by (simp add: split_def)

lemma split_type [TC]:
    "[|  p \<in> Sigma A B;
         !!x y.[| x \<in> A; y \<in> B(x) |] ==> c x y : C <x,y>
     |] ==> split (%x y. c x y) p \<in> C p"
by (erule SigmaE, auto)

lemma expand_split:
  "u \<in> A*B ==>
        R (split c u) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = <x,y> \<longrightarrow> R (c x y))"
by (auto simp add: split_def)

subsection\<open>A version of @{term split} for Formulae: Result Type @{typ o}\<close>

lemma splitI: "R a b ==> split R <a,b>"
by (simp add: split_def)

lemma splitE:
    "[| split R z;  z \<in> Sigma A B;
        !!x y. [| z = <x,y>;  R x y |] ==> P
     |] ==> P"
by (auto simp add: split_def)

lemma splitD: "split R <a,b> ==> R a b"
by (simp add: split_def)

text \<open>
  \bigskip Complex rules for Sigma.
\<close>

lemma split_paired_Bex_Sigma [simp]:
     "(\<exists>z \<in> Sigma A B. P(z)) \<longleftrightarrow> (\<exists>x \<in> A. \<exists>y \<in> B(x). P(<x,y>))"
by blast

lemma split_paired_Ball_Sigma [simp]:
     "(\<forall>z \<in> Sigma A B. P(z)) \<longleftrightarrow> (\<forall>x \<in> A. \<forall>y \<in> B(x). P(<x,y>))"
by blast

end


theory s184235_4 imports SeCaV begin

\<comment> \<open>Please keep each line shorter than 100 characters and do not modify the above "imports" at all\<close>

section \<open>Problem 1\<close>

proposition \<open>(\<forall>x. p x) \<longrightarrow> p a\<close> by metis

lemma  \<open>\<tturnstile>
  [
    Imp (Uni (Pre 0[Var 0]))  (Pre 0 [Fun 0 []])
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
       Neg (Uni (Pre 0[Var 0])),
       Pre 0 [Fun 0 []]
    ]
    \<close>
      using that by simp
  with GammaUni[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
       Neg (Pre 0[Fun 0 []]),
       Pre 0 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
       Pre 0 [Fun 0 []],
       Neg (Pre 0[Fun 0 []])

    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Problem 2\<close>

proposition \<open>p a a \<longrightarrow> (\<exists>x y. p x y)\<close> by metis

lemma  \<open>\<tturnstile>
  [
    Imp (Pre 0 [Fun 0 [],Fun 0[]]) (Exi(Exi (Pre 0[Var 1, Var 0])))
  ]
  \<close>
proof -
     from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
       Neg (Pre 0 [Fun 0 [],Fun 0[]]),
       Exi(Exi (Pre 0[Var 1, Var 0]))
    ]
    \<close>
       using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Exi(Exi (Pre 0[Var 1, Var 0])),
      Neg (Pre 0 [Fun 0 [],Fun 0[]])
    ]
    \<close>
    using that by simp
  with GammaExi[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
      Pre 0[Fun 0 [], Fun 0[]],
      Neg (Pre 0 [Fun 0 [],Fun 0[]])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Problem 3\<close>

proposition \<open>(\<forall>x. p x) \<and> (\<forall>x. q x) \<longrightarrow> (\<forall>x. p x \<and> q x)\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp
      (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
      (Uni (Con (Pre 0 [Var 0]) (Pre 1 [Var 0])))
  ]
  \<close>
proof -
    from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0]))),
      Uni (Con (Pre 0 [Var 0]) (Pre 1 [Var 0]))
    ]
    \<close>
      using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
     Uni (Con (Pre 0 [Var 0]) (Pre 1 [Var 0])),
     Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close>
    using that by simp
  with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
     Con (Pre 0 [Fun 0 [] ]) (Pre 1 [Fun 0[]]),
     Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close>
    using that by simp
  with BetaCon have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 [] ],
      Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close> and \<open>\<tturnstile>
    [
      Pre 1 [Fun 0[]],
      Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0]))),
      Pre 0 [Fun 0 []]
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg (Con (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0]))),
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])) ,
      Neg (Uni (Pre 1 [Var 0])),
      Pre 0 [Fun 0 []]
    ]\<close> and \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])),
      Neg (Uni (Pre 1 [Var 0])),
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
 with Ext have ?thesis if \<open>\<tturnstile>
  [
      Neg (Uni (Pre 0 [Var 0])) ,
      Neg (Uni (Pre 1 [Var 0])),
      Pre 0 [Fun 0 []]
    ]\<close> and \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])),
      Neg (Uni (Pre 1 [Var 0])),
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with GammaUni[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
  [
      Neg (Pre 0 [Fun 0 [] ]) ,
      Neg (Uni (Pre 1 [Var 0])),
      Pre 0 [Fun 0 []]
    ]\<close> and \<open>\<tturnstile>
    [
      Neg  (Pre 0 [Fun 0 []]),
      Neg (Uni (Pre 1 [Var 0])),
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
 with Ext have ?thesis if \<open>\<tturnstile>
  [
      Neg (Uni (Pre 1 [Var 0])),
      Neg (Pre 0 [Fun 0 [] ]) ,
      Pre 0 [Fun 0 []]
    ]\<close> and \<open>\<tturnstile>
    [
      Neg (Uni (Pre 1 [Var 0])),
      Neg  (Pre 0 [Fun 0[]]),
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with GammaUni[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
 [
      Neg  (Pre 1  [Fun 0 []] ),
      Neg (Pre 0 [Fun 0 [] ]) ,
      Pre 0 [Fun 0 []]
    ]\<close> and \<open>\<tturnstile>
    [
      Neg  (Pre 1  [Fun 0 []] ),
      Neg  (Pre 0 [Fun 0[]]),
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
 [
      Pre 0 [Fun 0 []],
      Neg (Pre 0 [Fun 0 [] ])
    ]\<close> and \<open>\<tturnstile>
    [
      Pre 1 [Fun 0 []],
      Neg (Pre 1  [Fun 0 []] )
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp

qed

\<comment> \<open>Please keep the "end" command and ensure that Isabelle2020 does not indicate any errors at all\<close>

end


theory System_device
  imports System_coon
begin

definition device_camera :: "scheduler proc" where
  "device_camera =
Rep (Cm (''outputs_camera_image''[!](\<lambda>_. -1)); Wait (\<lambda>_ . 0.2))"

fun device_camera_block :: "nat \<Rightarrow> scheduler tassn" where
  "device_camera_block 0 = emp\<^sub>t"
| "device_camera_block (Suc n) =
    Out\<^sub>t (EState (sch [],\<lambda>_ . 0)) ''outputs_camera_image'' (-1) @\<^sub>t
    Wait\<^sub>t 0.2 (\<lambda>_. EState (sch [],\<lambda>_ . 0)) ({}, {}) @\<^sub>t
   device_camera_block n"

lemma device_camera_block_snoc:
"device_camera_block (Suc n) = device_camera_block n @\<^sub>t
Out\<^sub>t (EState (sch [],\<lambda>_ . 0)) ''outputs_camera_image'' (-1) @\<^sub>t
    Wait\<^sub>t 0.2 (\<lambda>_. EState (sch [],\<lambda>_ . 0)) ({}, {})"
proof (induction n)
  case 0
  then show ?case by auto
next
  case Con:(Suc n)
  then show ?case
    apply (subst device_camera_block.simps(2)[of "n"])
    apply (subst device_camera_block.simps(2)[of "Suc n"])
    apply (subst Con)
    by (smt (z3) join_assoc)
qed

lemma device_camera_prop:
"\<Turnstile>{\<lambda>(a,s) t. (a,s) = (sch [],\<lambda>_ . 0) \<and> emp\<^sub>t t}
device_camera
{\<lambda>(a,s) t. \<exists> n. (a,s) = (sch [],\<lambda>_ . 0) \<and> device_camera_block n t}"
  unfolding device_camera_def
  apply(rule Valid_weaken_pre)
   prefer 2
   apply (rule Valid_rep)
   apply(rule Valid_ex_pre')
  subgoal for n
    apply(rule Valid_seq)
     apply(rule Valid_send_sp_st)
    apply (rule Valid_strengthen_post)
     prefer 2
     apply (rule Valid_wait_sp_st)
    apply (auto simp add: entails_def)
    apply(rule exI[where x="Suc n"])
      apply(subst device_camera_block_snoc)
      by(auto simp add: join_assoc)
  apply(auto simp add: entails_def)
  apply(rule exI[where x="0"])
    by auto

definition device_radar :: "scheduler proc" where
  "device_radar =
    t ::= (\<lambda>_ .0);
    data ::= (\<lambda>_ . 0);
    Rep (
      IF (\<lambda>(a,s). s t < 10) THEN
        data ::= (\<lambda>_ . 0)
      ELSE (IF (\<lambda>(a,s). s t < 20) THEN
        data ::= (\<lambda>(a,s). 2 * s t + 15)
      ELSE
        data ::= (\<lambda>_ . 0)
      FI) FI;
      Cm (''outputs_radar_obsposradar''[!](\<lambda>(a,s). s data));
      Wait (\<lambda>_ . 0.01);
      t ::= (\<lambda>(a,s). s t + 0.01)
    )"

fun device_radar_func :: "real \<Rightarrow> real" where
  "device_radar_func tt = (if tt < 10 then 0 else (if tt < 20 then 2 * tt + 15 else 0))"

fun device_radar_block :: "nat \<Rightarrow> nat \<Rightarrow> scheduler tassn" where
  "device_radar_block start 0 = emp\<^sub>t"
| "device_radar_block start (Suc n) =
   device_radar_block start n @\<^sub>t
   Out\<^sub>t (EState (sch [], (\<lambda>_ . 0)(data := device_radar_func (0.01 * (n + start)),
                                  t := 0.01 * (n + start))))
        ''outputs_radar_obsposradar''
        (device_radar_func (0.01 * (n + start))) @\<^sub>t
   Wait\<^sub>t 0.01 (\<lambda>_. EState (sch [],(\<lambda>_ . 0)(data := device_radar_func (0.01 * (n + start)),
                                           t := 0.01 * (n + start))))
         ({}, {})"

lemma device_radar_block_cons:
  "device_radar_block start (Suc n) =
   Out\<^sub>t (EState (sch [], (\<lambda>_ . 0)(data := device_radar_func (0.01 * (start)),
                                  t := 0.01 * (start))))
        ''outputs_radar_obsposradar''
        (device_radar_func (0.01 * (start))) @\<^sub>t
   Wait\<^sub>t 0.01 (\<lambda>_. EState (sch [],(\<lambda>_ . 0)(data := device_radar_func (0.01 * (start)),
                                           t := 0.01 * (start))))
         ({}, {}) @\<^sub>t
   device_radar_block (Suc start) n"
proof(induction start arbitrary: n)
  case 0
  then show ?case
  proof(induction n)
    case 0
    then show ?case
      apply(subst device_radar_block.simps(1))
      apply(subst device_radar_block.simps(2))
      apply(subst device_radar_block.simps(1))
      by(auto simp add:join_assoc)
  next
    case Conn:(Suc n)
    have a: "real n + real (Suc 0) = real (Suc n) + real 0"
      by auto
    then show ?case
      apply(subst device_radar_block.simps(2)[of 0 "Suc n"])
      apply(subst device_radar_block.simps(2)[of "Suc 0" "n"])
      apply(subst Conn)
      unfolding a
      by(auto simp add: join_assoc)
  qed
next
  case Cons:(Suc start)
  then show ?case
  proof(induction n)
    case 0
    then show ?case
      apply(subst device_radar_block.simps(2)[of "Suc start" 0])
      apply(subst device_radar_block.simps(1))+
      by(auto simp add:join_assoc)
  next
    case Conn:(Suc n)
    then show ?case
    proof-
      have a:"device_radar_block (Suc start) (Suc n) =
  Out\<^sub>t
   (EState
     (System_coon.scheduler.sch [], (\<lambda>_. 0)
      (data := device_radar_func (1 / 10\<^sup>2 * real (Suc start)),
       t := 1 / 10\<^sup>2 * real (Suc start))))
   ''outputs_radar_obsposradar'' (device_radar_func (1 / 10\<^sup>2 * real (Suc start))) @\<^sub>t
  Wait\<^sub>t (1 / 10\<^sup>2)
   (\<lambda>_. EState
         (System_coon.scheduler.sch [], (\<lambda>_. 0)
          (data := device_radar_func (1 / 10\<^sup>2 * real (Suc start)),
           t := 1 / 10\<^sup>2 * real (Suc start))))
   ({}, {}) @\<^sub>t
  device_radar_block (Suc (Suc start)) n"
        using Conn by blast
      have b:"real n + real (Suc (Suc start)) = real (Suc n) + real (Suc start)"
        by auto
      show ?thesis
        apply(subst device_radar_block.simps(2))
        apply(subst a)
        apply(subst device_radar_block.simps(2))
        apply(subst b)+
        by(auto simp add:join_assoc)
    qed
qed
qed

lemma device_radar_prop:
"\<Turnstile>{\<lambda>(a,s) tr. (a,s) = (sch [],\<lambda>_ . 0) \<and> emp\<^sub>t tr}
device_radar
{\<lambda>(a,s) tr. \<exists> n. (a,s) = (sch [],(\<lambda>_ . 0)(data := device_radar_func (0.01 * (n-1)),t := 0.01 * n)) \<and> device_radar_block 0 n tr}"
  unfolding device_radar_def
  apply(rule Valid_seq)
   prefer 2
   apply(rule Valid_seq)
  prefer 2
    apply(rule Valid_rep)
  subgoal
    apply(rule Valid_ex_pre')
    apply(rule Valid_ex_post')
    subgoal for n
      apply(rule exI[where x= "Suc n"])
    apply(rule Valid_cond_split')
    subgoal
     apply(rule Valid_seq)
       apply(rule Valid_assign_sp_bst')
      apply(rule Valid_seq)
       apply(rule Valid_send_sp_bst)
      apply(rule Valid_seq)
       apply(rule Valid_wait_sp_bst)
      apply(rule Valid_strengthen_post)
      prefer 2
       apply(rule Valid_assign_sp_bst)
      apply(auto simp add: entails_def fun_upd_def join_assoc)
      apply(subgoal_tac"(\<lambda>x. if x = data then 0
                   else if x = t then real n / 100 else if x = data then 0 else 0) = (\<lambda>x. if x = t then real n / 100 else if x = data then 0 else 0)")
     by auto
   apply(rule Valid_cond_split')
    subgoal
      apply(rule Valid_seq)
      apply(rule Valid_weaken_pre[where P'="\<lambda>s ta. ((case s of (a, s) \<Rightarrow> s t < 20) \<and>
               \<not> (case s of (a, s) \<Rightarrow> s t < 10))\<and>
               s =
               (System_coon.scheduler.sch [], (\<lambda>_. 0)
                (data := device_radar_func (1 / 10\<^sup>2 * (real n - 1)),
                 t := 1 / 10\<^sup>2 * real n)) \<and>
               device_radar_block 0 n ta"])
      subgoal
        by(auto simp add: entails_def)
        apply(rule Valid_assign_sp_bst')
      apply(rule Valid_seq)
       apply(rule Valid_send_sp_bst)
      apply(rule Valid_seq)
       apply(rule Valid_wait_sp_bst)
      apply(rule Valid_strengthen_post)
      prefer 2
       apply(rule Valid_assign_sp_bst)
      apply(auto simp add: entails_def fun_upd_def)
      subgoal premises pre for tr
      proof -
        have a1: "n = 1000"
          using pre by auto
        have a2: "(\<lambda>x. if x = t then real 1000 / 100
                 else if x = data then 2 * (real 1000 / 100) + 15 else 0) =
                  (\<lambda>x. if x = data then real 1000 / 50 + 15
            else if x = t then real 1000 / 100 else if x = data then 0 else 0)"
          by auto
        show ?thesis
          using pre(3)
          unfolding a1 a2  by(auto simp add:join_assoc)
      qed
      subgoal premises pre for tr
      proof -
        have a: "(\<lambda>x. if x = t then real n / 100
                 else if x = data then 2 * (real n / 100) + 15 else 0)
                  =(\<lambda>x. if x = data then real n / 50 + 15
                 else if x = t then real n / 100
                      else if x = data then 2 * ((real n - 1) / 100) + 15 else 0)"
          by auto
        show ?thesis using pre(3)
          unfolding a by(auto simp add:join_assoc)
      qed
      done
    apply(rule Valid_seq)
      apply(rule Valid_weaken_pre[where P'="(\<lambda>s ta.
       ( \<not> (case s of (a, s) \<Rightarrow> s t < 20) \<and>
        \<not> (case s of (a, s) \<Rightarrow> s t < 10)) \<and>
        s =
               (System_coon.scheduler.sch [], (\<lambda>_. 0)
                (data := device_radar_func (1 / 10\<^sup>2 * (real n - 1)),
                 t := 1 / 10\<^sup>2 * real n)) \<and>
        device_radar_block 0 n ta)"])
      subgoal by(auto simp add: entails_def)
      apply(rule Valid_assign_sp_bst')
      apply(rule Valid_seq)
       apply(rule Valid_send_sp_bst)
      apply(rule Valid_seq)
       apply(rule Valid_wait_sp_bst)
      apply(rule Valid_strengthen_post)
      prefer 2
       apply(rule Valid_assign_sp_bst)
      apply(auto simp add: entails_def)
      subgoal premises pre for tr
      proof-
        have a:"(\<lambda>_. 0)(data := 0, t := real n / 100) = (\<lambda>_. 0)(t := real n / 100, data := 0)"
          by auto
        show ?thesis using pre unfolding a
          by(auto simp add: join_assoc)
      qed
      done
    done
  prefer 2
  apply(rule Valid_assign_sp_st')
  apply(rule Valid_ex_post')
  apply(rule exI[where x=0])
  apply(rule Valid_strengthen_post)
  prefer 2
  apply(rule Valid_assign_sp_st')
  by(auto simp add:entails_def)

definition device_actuator :: "scheduler proc" where
" device_actuator =
Rep (Cm (''inputs_actuator_cmd''[?] cmd); Cm (''outputs_PHYvehicleimp_veha''[!] (\<lambda>(a,s). s cmd)); Wait (\<lambda>_. 0.002))"

fun device_actuator_block :: "real \<Rightarrow> real list \<Rightarrow> scheduler tassn" where
  "device_actuator_block init [] = emp\<^sub>t"
| "device_actuator_block init (r#res) =
  In\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(cmd := init)))) ''inputs_actuator_cmd'' r  @\<^sub>t
  Out\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(cmd := r)))) ''outputs_PHYvehicleimp_veha'' r @\<^sub>t
  Wait\<^sub>t 0.002 (\<lambda>_ . (EState (sch [], ((\<lambda>_ . 0)(cmd := r))))) ({},{}) @\<^sub>t
  device_actuator_block r res"

lemma device_actuator_block_snoc:
"device_actuator_block init (fcs@[r]) =
    device_actuator_block init fcs @\<^sub>t
  In\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(cmd := last(init#fcs))))) ''inputs_actuator_cmd'' r  @\<^sub>t
  Out\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(cmd := r)))) ''outputs_PHYvehicleimp_veha'' r @\<^sub>t
  Wait\<^sub>t 0.002 (\<lambda>_ . (EState (sch [], ((\<lambda>_ . 0)(cmd := r))))) ({},{})"
proof(induction fcs arbitrary: init r)
  case Nil
  then show ?case
    apply(subst device_actuator_block.simps(1))
    by auto
next
  case Con:(Cons a fcs)
  have a:"(a # fcs) @ [r] = a # (fcs @ [r])"
    by auto
  have b:"last (a # fcs) = last (init # a # fcs)"
    by auto
  show ?case
    apply(subst a)
    apply(subst device_actuator_block.simps(2)[of init a "fcs @ [r]"])
    apply(subst Con)
    apply(subst device_actuator_block.simps(2)[of init a "fcs"])
    unfolding b
    by(auto simp add:join_assoc)
qed

lemma device_actuator_prop:
"\<Turnstile>{\<lambda>(a,s) tr. (a,s) = (sch [],\<lambda>_ . 0) \<and> emp\<^sub>t tr}
device_actuator
{\<lambda>(a,s) tr. \<exists> list. (a,s) = (sch [],(\<lambda>_ . 0)(cmd := last (0#list))) \<and> device_actuator_block 0 list tr}"
  unfolding device_actuator_def
  apply(rule Valid_weaken_pre)
   prefer 2
   apply(rule Valid_rep)
   apply(rule Valid_ex_pre')
  apply(rule Valid_seq)
  apply(rule Valid_receive_sp_st)
   apply(rule Valid_ex_pre)
  subgoal for list v
    apply(rule Valid_ex_post')
    apply(rule exI[where x="list@[v]"])
   apply(rule Valid_seq)
    apply(rule Valid_send_sp_st)
   apply(rule Valid_strengthen_post)
  prefer 2
     apply(rule Valid_wait_sp_st)
    unfolding device_actuator_block_snoc[of 0 list v]
    apply(auto simp add:entails_def fun_upd_def)
     apply (metis join_assoc)
    apply(subgoal_tac "(\<lambda>x. if x = cmd then v else 0) = (\<lambda>x. if x = cmd then v else if x = cmd then last list else 0)")
    by(auto simp add:join_assoc)
  apply(simp add:entails_def)
  apply clarify
  subgoal premises pre for tr
    apply(rule exI[where x="[]"])
    by auto
  done

definition device_gps :: "scheduler proc" where
" device_gps =
Rep (Cm (''inputs_PHYvehicleimp_vehs''[?] data); Cm (''outputs_gps_vehpos''[!] (\<lambda>(a,s). s data)); Wait (\<lambda>_. 0.006))"

fun device_gps_block :: "real \<Rightarrow> real list \<Rightarrow> scheduler tassn" where
  "device_gps_block init [] = emp\<^sub>t"
| "device_gps_block init (r#res) =
  In\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(data := init)))) ''inputs_PHYvehicleimp_vehs'' r  @\<^sub>t
  Out\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(data := r)))) ''outputs_gps_vehpos'' r @\<^sub>t
  Wait\<^sub>t 0.006 (\<lambda>_ . (EState (sch [], ((\<lambda>_ . 0)(data := r))))) ({},{}) @\<^sub>t
  device_gps_block r res"

lemma device_gps_block_snoc:
"device_gps_block init (fcs@[r]) =
    device_gps_block init fcs @\<^sub>t
  In\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(data := last(init#fcs))))) ''inputs_PHYvehicleimp_vehs'' r  @\<^sub>t
  Out\<^sub>t (EState (sch [], ((\<lambda>_ . 0)(data := r)))) ''outputs_gps_vehpos'' r @\<^sub>t
  Wait\<^sub>t 0.006 (\<lambda>_ . (EState (sch [], ((\<lambda>_ . 0)(data := r))))) ({},{})"
proof(induction fcs arbitrary: init r)
  case Nil
  then show ?case
    apply(subst device_gps_block.simps(1))
    by auto
next
  case Con:(Cons a fcs)
  have a:"(a # fcs) @ [r] = a # (fcs @ [r])"
    by auto
  have b:"last (a # fcs) = last (init # a # fcs)"
    by auto
  show ?case
    apply(subst a)
    apply(subst device_gps_block.simps(2)[of init a "fcs @ [r]"])
    apply(subst Con)
    apply(subst device_gps_block.simps(2)[of init a "fcs"])
    unfolding b
    by(auto simp add:join_assoc)
qed

lemma device_gps_prop:
"\<Turnstile>{\<lambda>(a,s) tr. (a,s) = (sch [],\<lambda>_ . 0) \<and> emp\<^sub>t tr}
device_gps
{\<lambda>(a,s) tr. \<exists> list. (a,s) = (sch [],(\<lambda>_ . 0)(data := last (0#list))) \<and> device_gps_block 0 list tr}"
  unfolding device_gps_def
  apply(rule Valid_weaken_pre)
   prefer 2
   apply(rule Valid_rep)
   apply(rule Valid_ex_pre')
  apply(rule Valid_seq)
  apply(rule Valid_receive_sp_st)
   apply(rule Valid_ex_pre)
  subgoal for list v
    apply(rule Valid_ex_post')
    apply(rule exI[where x="list@[v]"])
   apply(rule Valid_seq)
    apply(rule Valid_send_sp_st)
   apply(rule Valid_strengthen_post)
  prefer 2
     apply(rule Valid_wait_sp_st)
    unfolding device_gps_block_snoc[of 0 list v]
    apply(auto simp add:entails_def fun_upd_def)
     apply (metis join_assoc)
    apply(subgoal_tac "(\<lambda>x. if x = data then v else 0) = (\<lambda>x. if x = data then v else if x = data then last list else 0)")
    by(auto simp add:join_assoc)
  apply(simp add:entails_def)
  apply clarify
  subgoal premises pre for tr
    apply(rule exI[where x="[]"])
    by auto
  done

definition device_laser :: "scheduler proc" where
" device_laser =
Rep (Cm (''inputs_PHYvehicleimp_vehv1''[?] data); t::= (\<lambda>_ .0);
Interrupt (ODE ((\<lambda> _ _.0)(t := (\<lambda> _ . 1)))) (\<lambda> s. s t < 0.01) [(''outputs_laser_laservalid''[!](\<lambda> _. 1), Cm (''outputs_laser_laserv''[!] (\<lambda>(a,s). s data)))];
Cont (ODE ((\<lambda> _ _.0)(t := (\<lambda> _ . 1)))) (\<lambda> s. s t < 0.01))"

inductive device_laser_block :: "nat \<Rightarrow> scheduler tassn" where
  "device_laser_block 0 []"
| "
device_laser_block (Suc n) []"


theory SM_Finite_Reachable
imports Type_System
begin

(* TODO: Move to Misc, near lists_of_len_fin1 - lemma *)
lemma lists_le_len_fin: "finite P \<Longrightarrow> finite (lists P \<inter> { l. length l \<le> n })"
proof (induct n)
  case 0 thus ?case by auto
next
  case (Suc n)
  have "lists P \<inter> { l. length l \<le> Suc n }
        = (lists P \<inter> {l. length l \<le> n})
        \<union> (\<lambda>(a,l). a#l) ` (P \<times> (lists P \<inter> {l. length l \<le> n}))"
    apply auto
    apply (case_tac x)
    apply auto
    done
  moreover from Suc have "finite \<dots>" by auto
  ultimately show ?case by simp
qed

lemma obtain_list_of_multiset:
  obtains l where "mset l = m"
proof -
  have "\<exists>l. mset l = m"
    apply (induction m)
    apply auto
    apply (rule_tac x="x#l" in exI)
    apply auto
    done
  thus ?thesis using that by blast
qed

lemma finitely_many_lists_for_multiset[simp, intro!]:
  "finite {l . mset l = m}"
proof -
  have "{l . mset l = m} \<subseteq> {l. set l \<subseteq> set_mset m \<and> length l = size m}"
    by auto
  also note finite_lists_length_eq
  finally (finite_subset) show ?thesis by auto
qed

lemma finite_size_bounded_msets:
  assumes "finite S"
  shows "finite { m . size m \<le> len \<and> set_mset m \<subseteq> S }"
proof -
  have "{ m . size m \<le> len \<and> set_mset m \<subseteq> S }
    \<subseteq> mset`(lists S \<inter> {l. length l \<le> len})"
    apply clarsimp
    apply (rule_tac m=x in obtain_list_of_multiset)
    apply (auto intro!: imageI)
    done
  also have "finite (mset`(lists S \<inter> {l. length l \<le> len}))"
    apply (rule finite_imageI)
    apply (rule lists_le_len_fin)
    by (rule assms)
  finally (finite_subset) show ?thesis .
qed

lemma finite_maps_to_finite_type:
  assumes "finite (D::'a set)" "finite (UNIV::'v set)"
  shows "finite ((dom::(_ \<rightharpoonup> 'v) \<Rightarrow> _) -` Pow D)"
proof -
  {fix DD::"'a set"
    have "{x. dom x \<subseteq> DD} = \<Union>{ {x. dom x = D } | D.  D\<subseteq>DD }"
    by auto
  } note aux2=this

  from assms show ?thesis
    apply (simp add: vimage_def)
    apply (subst aux2)
    apply (rule finite_Union)
    using [[simproc add: finite_Collect]]
    apply simp
    apply clarsimp
    apply (rule finite_set_of_finite_maps[where B="UNIV::'v set", simplified])
    apply (erule finite_subset)
    apply simp
    by simp
qed

text \<open>In the following, we prove that the set of reachable states is finite.\<close>

text \<open>Approximation of reachable CFG-states\<close>
definition "cfg_approx prog
  \<equiv> \<Union>{approx_reachable ((proc_decl.body p)) | p. p\<in>set (program.processes prog)}"

definition "local_var_approx prog \<equiv> \<Union>{
  set (proc_decl.local_vars p) | p. p\<in>set (program.processes prog) }"
definition "global_var_approx prog \<equiv> set (program.global_vars prog)"

definition "lc_approx prog \<equiv> {
  \<lparr>
    local_config.command = c,
    local_config.state = \<lparr> local_state.variables = v\<rparr> \<rparr>
  | c v. c \<in> cfg_approx prog \<and> dom v \<subseteq> local_var_approx prog }"

definition "gc_approx prog \<equiv> {
  \<lparr> global_config.processes = lcs,
    global_config.state = \<lparr> global_state.variables = v \<rparr>
  \<rparr> | lcs v.
    size lcs \<le> length (program.processes prog)
  \<and> set_mset lcs \<subseteq> lc_approx prog
  \<and> dom v \<subseteq> global_var_approx prog
}"

definition "gco_approx prog \<equiv> insert None (Some`gc_approx prog)"

lemma ginit_approx: "init_gc prog\<in>gc_approx prog"
  unfolding init_gc_def gc_approx_def
  apply auto
  apply (auto simp:
    init_pc_def lc_approx_def cfg_approx_def local_var_approx_def
    global_var_approx_def )
  done

lemma init_approx: "gc \<in> li.init prog \<Longrightarrow> gc \<in> gco_approx prog"
  apply (cases gc)
  apply (auto simp: gco_approx_def ginit_approx li.init_conv)
  done

lemma cfg_approx:
  assumes "c\<in>cfg_approx prog"
  assumes "cfg c a c'"
  shows "c'\<in>cfg_approx prog"
  using assms
  unfolding cfg_approx_def
  by (auto dest: approx_reachable_closed)

lemma step_approx:
  assumes "gc\<in>gco_approx prog"
  assumes "(gc, gc') \<in> li.step"
  shows "gc'\<in>gco_approx prog"
  using assms
  unfolding li.step_def
  apply (cases gc, simp_all add: gco_approx_def)
  apply (auto simp: li.gstep_eq_conv elim!: stutter_extend_edgesE) []
  apply (cases gc', simp_all)
  apply (rule imageI)
  apply (auto simp: li.gstep_eq_conv elim!: stutter_extend_edgesE) []

  unfolding li.gstep_succ_def
  apply clarsimp
  apply (clarsimp split: sum.splits option.splits bool.splits Option.bind_splits)
  apply (clarsimp simp: gco_approx_def gc_approx_def)
  apply (case_tac bb, clarsimp_all)
  apply (frule la_ex_pres_gs_vars, clarsimp)
  apply (clarsimp simp: lc_approx_def)
  apply (case_tac ac, clarsimp_all)
  apply (frule la_ex_pres_ls_vars, clarsimp)

  apply (auto simp: cfg_approx) []
  done

lemma finite_local_var_approx[simp, intro!]: "finite (local_var_approx prog)"
  using [[simproc add: finite_Collect]]
  unfolding local_var_approx_def
  apply (rule finite_Union)
  apply simp
  apply clarsimp
  done

lemma finite_global_var_approx[simp, intro!]: "finite (global_var_approx prog)"
  using [[simproc add: finite_Collect]]
  unfolding global_var_approx_def
  by simp

lemma gco_approx_finite[simp, intro!]: "finite (gco_approx prog)"
proof -
  have aux1: "({lcs.
        size lcs
        \<le> length (program.processes prog)} \<inter>
       set_mset -` Pow (lc_approx prog))
    = {lcs. size lcs \<le> length (program.processes prog) \<and> set_mset lcs \<subseteq> lc_approx prog }"
    by auto

  {fix DD::"ident set"
    have "{x. dom x \<subseteq> DD} = \<Union>{ {x. dom x = D } | D.  D\<subseteq>DD }"
    by auto
  } note aux2=this

  show ?thesis
    unfolding gco_approx_def
    apply simp
    apply (rule finite_imageI)
    unfolding gc_approx_def
    using [[simproc add: finite_Collect]]
    apply simp
    apply (rule finite_imageI)
    apply (subst aux1)
    apply (rule finite_cartesian_product)
    apply (rule finite_size_bounded_msets)
    unfolding lc_approx_def
    apply simp
    apply (rule finite_imageI)
    apply (rule finite_cartesian_product)
    unfolding cfg_approx_def
    apply (rule finite_Union)
    apply simp
    apply auto []
    apply (simp add: finite_maps_to_finite_type)
    apply (simp add: finite_maps_to_finite_type)
    done
qed

lemma sys_finite_reachable: "finite ((g_E (li.system_automaton prog))\<^sup>* ``
  g_V0 (li.system_automaton prog))"
proof -
  have "(g_E (li.system_automaton prog))\<^sup>* `` g_V0 (li.system_automaton prog) \<subseteq> gco_approx prog"
    apply safe
    apply (erule rtrancl_induct)
    apply (auto intro: step_approx init_approx)
    done
  also note gco_approx_finite
  finally (finite_subset) show ?thesis .
qed

lemma "finite ((g_E (li.system_automaton (dloc prog)))\<^sup>* ``
  g_V0 (li.system_automaton (dloc prog)))"
  by (rule sys_finite_reachable)

context well_typed_prog begin
  lemma li'_finite_reachable: "finite ((g_E li'.s2.system_automaton)\<^sup>* `` g_V0 li'.s2.system_automaton)"
  proof -
    show ?thesis
      apply (rule li'.bisim.s1.reachable_finite_sim)
      apply (rule sys_finite_reachable)
      apply (clarsimp simp: build_rel_def)
      apply (case_tac b)
      apply simp
      apply simp
      done
  qed
end

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Basic Order Properties\<close>
theory Transport_Natural_Functors_Order_Base
  imports
    Transport_Natural_Functors_Base
begin

lemma reflexive_on_in_field_FrelI:
  assumes "reflexive_on (in_field R1) R1"
  and "reflexive_on (in_field R2) R2"
  and "reflexive_on (in_field R3) R3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "reflexive_on (in_field R) R"
  apply (subst reflexive_on_iff_eq_restrict_left_le)
  apply (subst Frel_eq[symmetric])
  apply (unfold R_def)
  apply (subst in_field_Frel_eq_Fpred_in_in_field)
  apply (subst restrict_left_sup_eq)
  apply (subst Frel_restrict_left_Fpred_eq_Frel_restrict_left)+
  apply (rule le_supI;
    rule Frel_mono;
    subst reflexive_on_iff_eq_restrict_left_le[symmetric],
    rule reflexive_on_if_le_pred_if_reflexive_on,
    rule assms,
    rule le_predI[OF in_field_if_in_dom]
      le_predI[OF in_field_if_in_codom],
    assumption)
  done

lemma transitive_FrelI:
  assumes "transitive R1"
  and "transitive R2"
  and "transitive R3"
  shows "transitive (Frel R1 R2 R3)"
  apply (subst transitive_iff_rel_comp_le_self)
  apply (subst Frel_comp_eq_Frel_rel_comp)
  apply (rule Frel_mono;
    subst transitive_iff_rel_comp_le_self[symmetric],
    rule assms)
  done

lemma preorder_on_in_field_FrelI:
  assumes "preorder_on (in_field R1) R1"
  and "preorder_on (in_field R2) R2"
  and "preorder_on (in_field R3) R3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "preorder_on (in_field R) R"
  apply (unfold R_def)
  apply (insert assms)
  apply (elim preorder_on_in_fieldE)
  apply (rule preorder_onI)
  apply (rule reflexive_on_in_field_FrelI; assumption)
  apply (subst transitive_on_in_field_iff_transitive)
  apply (rule transitive_FrelI; assumption)
  done

lemma symmetric_FrelI:
  assumes "symmetric R1"
  and "symmetric R2"
  and "symmetric R3"
  shows "symmetric (Frel R1 R2 R3)"
  apply (subst symmetric_iff_rel_inv_eq_self)
  apply (subst Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (subst rel_inv_eq_self_if_symmetric, fact)+
  apply (rule refl)
  done

lemma partial_equivalence_rel_FrelI:
  assumes "partial_equivalence_rel R1"
  and "partial_equivalence_rel R2"
  and "partial_equivalence_rel R3"
  shows "partial_equivalence_rel (Frel R1 R2 R3)"
  apply (insert assms)
  apply (elim partial_equivalence_relE preorder_on_in_fieldE)
  apply (rule partial_equivalence_relI;
    rule transitive_FrelI symmetric_FrelI;
    assumption)
  done

context transport_natural_functor
begin

lemmas reflexive_on_in_field_leftI = reflexive_on_in_field_FrelI
  [of L1 L2 L3, folded transport_defs]

lemmas transitive_leftI = transitive_FrelI[of L1 L2 L3, folded transport_defs]

lemmas preorder_on_in_field_leftI = preorder_on_in_field_FrelI
  [of L1 L2 L3, folded transport_defs]

lemmas symmetricI = symmetric_FrelI[of L1 L2 L3, folded transport_defs]

lemmas partial_equivalence_rel_leftI = partial_equivalence_rel_FrelI
  [of L1 L2 L3, folded transport_defs]

end

end


(* Author: Fabian Hellauer, 2018 *)
subsection \<open>Example Instantiations\<close>
theory Examples
  imports Field_Extension
begin

abbreviation standard_ring
  where "standard_ring carr \<equiv> \<lparr>carrier = carr, monoid.mult = (*), one = 1, zero = 0, add = (+)\<rparr>"

definition "Ints_ring = standard_ring \<int>"
definition "Rats_field = standard_ring \<rat>"
definition "Reals_field = standard_ring \<real>"
txt \<open>There seems to be no \<open>of_complex\<close> available. However, restricting the type is no problem here
  since it is the largest example anyway.\<close>
definition complex_field :: "complex ring" where "complex_field = standard_ring UNIV"

lemma examples:
  shows cring_Ints_ring: "cring Ints_ring" \<comment> \<open>not always a domain\<close>
    and field_rat_field: "field Rats_field"
    and field_real_field: "field Reals_field"
    and field_complex_field: "field complex_field"
  unfolding Ints_ring_def Rats_field_def Reals_field_def complex_field_def
     apply unfold_locales
                      apply (auto intro: add.right_inverse right_inverse simp: Units_def algebra_simps)
     apply (metis (full_types) Ints_cases mult_of_int_commute)
    apply (metis (full_types) Reals_cases linordered_field_class.sign_simps(24) of_real_mult)
   apply (metis (full_types) Reals_cases mult_eq_0_iff of_real_eq_0_iff of_real_mult)
  by (metis (no_types, hide_lams) Reals_cases Reals_of_real left_inverse mult.left_neutral
      mult.right_neutral mult_scaleR_left mult_scaleR_right of_real_0 of_real_1 of_real_def
      of_real_mult scaleR_conv_of_real)

text \<open>\<open>\<int>\<close> is a subdomain of \<open>\<rat>\<close>:\<close>

lemma subdomain_example: "subdomain \<int> Rats_field"
proof -
  interpret field Rats_field by (fact examples(2))
  show ?thesis
    apply (rule subdomainI)
    apply (rule subcringI')
    apply (rule ring.ring_incl_imp_subring)
      apply (simp add: ring_axioms)
    unfolding Rats_field_def apply (simp add: Ints_subset_Rats)
    using examples(1)[unfolded Ints_ring_def] unfolding cring_def by auto
qed

text \<open>\<open>\<real>\<close> is a field extension of \<open>\<rat>\<close>:\<close>

lemma of_real_of_rat_eq[simp]: "of_real (real_of_rat q) = of_rat q"
proof (cases q)
  case (Fract a b)
  obtain rr :: "real \<Rightarrow> rat" where
    f3: "\<forall>r. r \<notin> \<rat> \<or> r = real_of_rat (rr r)"
    by (metis (no_types) Rats_cases)
  have f4: "\<forall>i. (of_rat (rat_of_int i)::'a) = of_real (real_of_int i)"
    by simp
  have f5: "rat_of_int 1 = 1"
      by blast
  have f6: "\<forall>i. rat_of_int i = rr (real_of_int i)"
    using f3 by (metis of_rat_of_int_eq Rats_of_rat of_rat_eq_iff)
  then have f7: "inverse (rr (real_of_int b)) * rr (real_of_int a) = q"
    by (simp add: Fract(1) Fract_of_int_quotient inverse_eq_divide)
  have f8: "\<forall>r. real_of_rat (inverse r) = inverse (real_of_rat r)"
    by (metis (no_types) divide_inverse mult.left_neutral of_rat_1 of_rat_divide)
  have f9: "\<forall>r. of_real r * of_real (inverse r) = (1::'a) \<or> r = 0"
    using f5 f4 by (metis of_rat_of_int_eq Real_Vector_Spaces.of_real_mult of_rat_1 right_inverse)
  have f10: "of_real (inverse (real_of_int b)) * (of_real (real_of_int a)::'a) = of_real (real_of_rat q)"
    using f8 f7 f3 by (metis of_rat_of_int_eq Rats_of_rat Real_Vector_Spaces.of_real_mult of_rat_eq_iff of_rat_mult)
  have "inverse (of_real (real_of_int b)) * of_real (real_of_int a) = (of_rat q::'a)"
    using f7 f6 f4 by (metis (no_types) divide_inverse mult.left_neutral of_rat_1 of_rat_divide of_rat_mult)
  then show ?thesis
    using f10 f9 Fract(2) by (metis (no_types) divide_inverse mult.right_neutral mult_zero_left nonzero_mult_div_cancel_left of_int_0_eq_iff one_neq_zero order_less_irrefl)
qed

lemma Reals_of_rat[simp]: "of_rat z \<in> \<real>"
  by (subst of_real_of_rat_eq [symmetric]) (rule Reals_of_real)

lemma Rats_subset_Reals: "\<rat> \<subseteq> \<real>"
  using Rats_cases by force

lemma "field_extension Reals_field \<rat>"
proof (auto simp add: field_extension_def)
  show "subfield \<rat> Reals_field"
    apply (rule ring.subfield_iff(1))
      apply (simp add: cring.axioms(1) examples(3) fieldE(1))
     apply (metis examples(2) partial_object.update_convs(1) Rats_field_def Reals_field_def)
    by (simp add: Rats_subset_Reals Reals_field_def)
qed (fact examples(3))

text \<open>\<open>\<complex>\<close> is a finitely generated field extension of \<open>\<real>\<close>:\<close>

lemma subfield_Reals_complex_field: "subfield \<real> complex_field"
  apply (rule ring.subfield_iff(1))
  apply (simp add: cring.axioms(1) examples(4) fieldE(1))
  unfolding complex_field_def by (auto simp: examples(3)[unfolded Reals_field_def])

lemma generate_field_\<i>_UNIV: "generate_field complex_field (insert \<i> \<real>) = UNIV"
proof -
  define P where "P = UP (standard_ring \<real> :: complex ring)"
  interpret UP_field_extension complex_field \<real> P \<i>
    unfolding UP_field_extension_def UP_field_extension_axioms_def
    by (simp add: examples(4) field_extension_def subfield_Reals_complex_field)
      (simp_all add: complex_field_def P_def)
  show ?thesis unfolding genfield_singleton_explicit apply auto
  proof (rule exI, rule exI)
    fix x :: complex
    let ?f = "monom P (Im x) 1 \<oplus>\<^bsub>P\<^esub> monom P (Re x) 0"
    let ?g = "\<one>\<^bsub>P\<^esub>"
    have [simp]: "inv\<^bsub>complex_field\<^esub> 1 = 1"
      unfolding complex_field_def m_inv_def by simp
    have "x = Eval (monom P (complex_of_real (Im x)) 1) \<oplus>\<^bsub>complex_field\<^esub> complex_of_real (Re x)"
      unfolding complex_field_def apply (simp del: One_nat_def)
      using add.commute complex_eq mult.commute
      by (metis Eval_cx Reals_of_real complex_field_def monoid.simps(1))
    then show "x = Eval ?f \<otimes>\<^bsub>complex_field\<^esub> inv\<^bsub>complex_field\<^esub> Eval ?g \<and> ?f \<in> carrier P \<and> ?g \<in> carrier
 P \<and> Eval ?g \<noteq> \<zero>\<^bsub>complex_field\<^esub>"
      by (auto, simp add: complex_field_def)
  qed
qed

corollary finitely_generated_field_extension_complex_over_real:
  "finitely_generated_field_extension complex_field \<real>"
  unfolding finitely_generated_field_extension_def using generate_field_\<i>_UNIV
  by (metis complex_field_def examples(4) field_extension_def finite.emptyI finite.insertI
      insert_is_Un partial_object.select_convs(1) subfield_Reals_complex_field)

end