(*  Title:      Traffic.thy
    Author:     Sven Linker

Defines a type for traffic snapshots. Consists of six elements:
pos: positions of cars
res: reservations of cars
clm: claims of cars
dyn: current dynamic behaviour of cars
physical_size: the real sizes of cars
braking_distance: braking distance each car needs in emergency

Definitions for transitions between traffic snapshots.
*)

section\<open>Traffic Snapshots\<close>
text\<open>
Traffic snapshots define the spatial and dynamical arrangement of cars
on the whole of the motorway at a single point in time. A traffic snapshot
consists of several functions assigning spatial properties and dynamical
behaviour to each car. The functions are named as follows.
\begin{itemize}
\item pos: positions of cars
\item res: reservations of cars
\item clm: claims of cars
\item dyn: current dynamic behaviour of cars
\item physical\_size: the real sizes of cars
\item braking\_distance: braking distance each car needs in emergency
\end{itemize}
\<close>

theory Traffic
imports NatInt RealInt Cars
begin
type_synonym lanes = nat_int
type_synonym extension = real_int

record snapshot =
  pos :: "cars \<Rightarrow> real"
  res :: "cars \<Rightarrow> lanes"
  clm :: "cars \<Rightarrow> lanes"
  dyn :: "cars \<Rightarrow> real \<Rightarrow> real"
  physical_size ::" cars \<Rightarrow> real"
  braking_distance :: "cars \<Rightarrow> real"

print_theorems

definition sane :: "snapshot \<Rightarrow> bool"
  where "sane ts ==  (\<forall>c.(res ts c \<sqinter> clm ts c) = \<emptyset>)
                   \<and> (\<forall>c. continuous (res ts c))
                   \<and> (\<forall>c. continuous (clm ts c))
                   \<and> (\<forall>c. |res ts c| \<ge> 1 )
                   \<and> (\<forall>c. |res ts c| \<le> 2)
                   \<and> (\<forall>c. |clm ts c| \<le> 1)
                   \<and> (\<forall>c. |res ts c| + |clm ts c| \<le> 2)
                   \<and> (\<forall>c. clm ts c \<noteq> \<emptyset> \<longrightarrow>( \<exists>n. n \<^bold>\<in> clm ts c \<squnion> res ts c \<and> (n+1) \<^bold>\<in> clm ts c \<squnion> res ts c )) \<comment>\<open>fix his!\<close>
                   \<and> (\<forall>c. physical_size ts c > 0)
                   \<and> (\<forall>c. braking_distance ts c > 0)  "

text \<open>Definition of the type of traffic snapshots.
The constraints on the different functions are the \emph{sanity conditions}
of traffic snapshots.\<close>
(*
typedef traffic =
  "{ts :: (cars\<Rightarrow>real)*(cars\<Rightarrow>lanes)*(cars\<Rightarrow>lanes)*(cars\<Rightarrow>real\<Rightarrow>real)*(cars\<Rightarrow>real)*(cars\<Rightarrow>real).
          (\<forall>c. ((fst (snd ts))) c \<sqinter> ((fst (snd (snd ts)))) c = \<emptyset> )  \<and>
          (\<forall>c. |(fst (snd ts)) c| \<ge> 1) \<and>
          (\<forall>c. |(fst (snd ts)) c| \<le> 2) \<and>
          (\<forall>c. |(fst (snd (snd ts)) c)| \<le> 1) \<and>
          (\<forall>c. |(fst (snd ts)) c| + |(fst (snd (snd ts))) c| \<le> 2) \<and>
          (\<forall>c. (fst(snd(snd (ts)))) c \<noteq> \<emptyset> \<longrightarrow>
                (\<exists> n. Rep_nat_int(fst (snd ts) c)\<union>Rep_nat_int(fst (snd (snd ts)) c)
                      = {n, n+1})) \<and>
          (\<forall>c . fst (snd (snd (snd (snd (ts))))) c > 0) \<and>
          (\<forall>c.  snd (snd (snd (snd (snd (ts))))) c > 0)
 } "
proof -
  let ?type =
    "{ts ::(cars\<Rightarrow>real)*(cars\<Rightarrow>lanes)*(cars\<Rightarrow>lanes)*(cars\<Rightarrow>real\<Rightarrow>real)*(cars\<Rightarrow>real)*(cars\<Rightarrow>real).
           (\<forall>c. ((fst (snd ts))) c \<sqinter> ((fst (snd (snd ts)))) c = \<emptyset> )  \<and>
           (\<forall>c. |(fst (snd ts)) c| \<ge> 1) \<and>
           (\<forall>c. |(fst (snd ts)) c| \<le> 2) \<and>
           (\<forall>c. |(fst (snd (snd ts)) c)| \<le> 1) \<and>
           (\<forall>c. |(fst (snd ts)) c| + |(fst (snd (snd ts))) c| \<le> 2) \<and>
           (\<forall>c. (fst(snd(snd (ts)))) c \<noteq> \<emptyset> \<longrightarrow>
                (\<exists> n. Rep_nat_int(fst (snd ts) c)\<union>Rep_nat_int(fst (snd (snd ts)) c)
                  = {n, n+1})) \<and>
           (\<forall>c . fst (snd (snd (snd (snd (ts))))) c > 0) \<and>
           (\<forall>c.  snd (snd (snd (snd (snd (ts))))) c > 0)
 }"
  obtain pos where sp_def:"\<forall>c::cars. pos c = (1::real)" by force
  obtain re where re_def:"\<forall>c::cars. re c = Abs_nat_int {1}" by force
  obtain cl where cl_def:"\<forall>c::cars. cl c = \<emptyset>" by force
  obtain dyn where dyn_def:"\<forall>c::cars. \<forall>x::real . (dyn c) x  = (0::real)"  by force
  obtain ps where ps_def :"\<forall>c::cars . ps c = (1::real)" by force
  obtain sd where sd_def:"\<forall>c::cars . sd c = (1::real)" by force
  obtain ts where ts_def:"ts =  (pos,re,cl, dyn, ps, sd)" by simp

  have disj:"\<forall>c .((re c) \<sqinter> (cl c) = \<emptyset>)"
    by (simp add: cl_def nat_int.inter_empty1)
  have re_geq_one:"\<forall>c. |re c| \<ge> 1"
    by (simp add: Abs_nat_int_inverse re_def)
  have re_leq_two:"\<forall>c. |re c| \<le> 2"
    using re_def nat_int.rep_single by auto
  have cl_leq_one:"\<forall>c. |cl c| \<le> 1"
    using nat_int.card_empty_zero cl_def by auto
  have add_leq_two:"\<forall>c . |re c| + |cl c| \<le> 2"
    using nat_int.card_empty_zero cl_def re_leq_two by (simp )
  have consec_re:" \<forall>c. |(re c)| =2 \<longrightarrow> (\<exists>n . Rep_nat_int (re c) = {n,n+1})"
    by (simp add: Abs_nat_int_inverse  re_def)
  have  clNextRe :
    "\<forall>c. ((cl c) \<noteq> \<emptyset> \<longrightarrow> (\<exists> n. Rep_nat_int (re c) \<union> Rep_nat_int (cl c) = {n, n+1}))"
    by (simp add: cl_def)
  from dyn_def have dyn_geq_zero:"\<forall>c. \<forall>x. dyn(c) x \<ge> 0"
    by auto
  from ps_def have ps_ge_zero:"\<forall>c. ps c > 0" by auto
  from sd_def have sd_ge_zero:"\<forall>c. sd c > 0" by auto

  have "ts\<in>?type"
    using sp_def re_def cl_def disj re_geq_one re_leq_two cl_leq_one add_leq_two
      consec_re ps_def sd_def ts_def by auto
  thus ?thesis by blast
qed
*)
typedef traffic = "{ts. sane ts}"
proof -
  obtain pos where sp_def:"\<forall>c::cars. pos c = (1::real)" by force
  obtain re where re_def:"\<forall>c::cars. re c = Abs_nat_int {1}" by force
  obtain cl where cl_def:"\<forall>c::cars. cl c = \<emptyset>" by force
  obtain dyn where dyn_def:"\<forall>c::cars. \<forall>x::real . (dyn c) x  = (0::real)"  by force
  obtain ps where ps_def :"\<forall>c::cars . ps c = (1::real)" by force
  obtain sd where sd_def:"\<forall>c::cars . sd c = (1::real)" by force
  obtain ts where ts_def:"ts =  \<lparr>pos = pos,res = re,clm =cl, dyn = dyn, physical_size = ps, braking_distance =sd \<rparr>" by simp
  have 0:"\<forall>c.  \<forall>l. l \<in> {1} \<longleftrightarrow> l \<^bold>\<in> (res ts c)" using re_def ts_def
    by (simp add: Abs_nat_int_inverse)
  then have 1:"\<forall>c. continuous (res ts c)" using nat_int.singleton_continuous
    by blast
  have 2: "\<forall>c. continuous (clm ts c)" using empty_continuous ts_def cl_def by auto
  have 3: "(\<forall>c. clm ts c \<noteq> \<emptyset> \<longrightarrow>( \<exists>n. n \<^bold>\<in> clm ts c \<squnion> res ts c \<and> (n+1) \<^bold>\<in> clm ts c \<squnion> res ts c ))" using cl_def ts_def by simp
  have "sane ts"
    using card_empty_zero cl_def nat_int.inter_empty1 ps_def re_def  sane_def sd_def ts_def 1 2 3
    by (simp add: Abs_nat_int_inverse)
  then have  "ts \<in> {ts. sane ts}" by simp
  then show ?thesis by blast
qed
setup_lifting type_definition_traffic

locale traffic
begin

notation nat_int.consec ("consec")

text\<open>For brevity, we define names for the different functions
within a traffic snapshot.\<close>

lift_definition pos :: "traffic \<Rightarrow> (cars \<Rightarrow> real)" is snapshot.pos .
lift_definition res :: "traffic \<Rightarrow> (cars \<Rightarrow> nat_int)" is snapshot.res .
lift_definition clm :: "traffic \<Rightarrow> (cars \<Rightarrow> nat_int)" is snapshot.clm .
lift_definition dyn :: "traffic \<Rightarrow> (cars \<Rightarrow> real \<Rightarrow> real)" is snapshot.dyn .
lift_definition physical_size :: "traffic \<Rightarrow> (cars \<Rightarrow> real)" is snapshot.physical_size .
lift_definition braking_distance :: "traffic \<Rightarrow> (cars \<Rightarrow> real)" is snapshot.braking_distance .

(*definition pos::"traffic \<Rightarrow> (cars \<Rightarrow> real)"
where "pos ts \<equiv> fst (Rep_traffic ts)"

definition res::"traffic \<Rightarrow> (cars \<Rightarrow> lanes)"
where "res ts \<equiv> fst (snd (Rep_traffic ts))"

definition clm ::"traffic \<Rightarrow> (cars \<Rightarrow> lanes)"
where "clm ts \<equiv> fst (snd (snd (Rep_traffic ts)))"

definition dyn::"traffic \<Rightarrow> (cars \<Rightarrow> (real\<Rightarrow> real))"
where "dyn ts \<equiv> fst (snd (snd (snd (Rep_traffic ts))))"

definition physical_size::"traffic \<Rightarrow> (cars \<Rightarrow> real)"
where "physical_size ts \<equiv> fst (snd (snd (snd (snd (Rep_traffic ts)))))"

definition braking_distance::"traffic \<Rightarrow> (cars \<Rightarrow> real)"
where "braking_distance ts \<equiv> snd (snd (snd (snd (snd (Rep_traffic ts)))))"
*)

text \<open>
It is helpful to be able to refer to the sanity conditions of a traffic
snapshot via lemmas, hence we prove that the sanity conditions hold
for each traffic snapshot.
\<close>

lemma disjoint: "(res ts c) \<sqinter> (clm ts c) = \<emptyset>"
  using Rep_traffic res.rep_eq clm.rep_eq sane_def by auto

lemma atLeastOneRes: "1 \<le> |res ts c|"
  using Rep_traffic res.rep_eq sane_def by auto

lemma atMostTwoRes:" |res ts c| \<le> 2"
  using Rep_traffic res.rep_eq sane_def by auto

lemma  atMostOneClm: "|clm ts c| \<le> 1"
  using Rep_traffic clm.rep_eq sane_def by auto

lemma atMostTwoLanes: "|res ts c| +|clm ts c| \<le> 2"
  using Rep_traffic res.rep_eq clm.rep_eq sane_def by auto

lemma  consecutiveRes:" |res ts  c| =2 \<longrightarrow> (\<exists>n . n \<^bold>\<in> (res ts c) \<and> (n+1) \<^bold>\<in> (res ts c))"
proof
  assume assm:"|res ts  c| =2"
  then have not_empty:"(res ts c) \<noteq> \<emptyset>"
    by (simp add: card_non_empty_geq_one)
  obtain m and n where "\<forall>l. l \<in> {m..n} \<longleftrightarrow> l\<^bold>\<in> (res ts c)"
    by (metis Rep_traffic continuous_nonE_atLeastAtMost mem_Collect_eq not_empty sane_def  traffic.res.rep_eq )
  then have "card {m..n} = 2" using assm atLeastAtMost_card by simp
  from this and assm have "n = m +1"
    by simp
  show "\<exists>n. n \<^bold>\<in> res ts c \<and> n + 1 \<^bold>\<in> res ts c"
    using \<open>\<forall>l. (l \<in> {m..n}) = (l \<^bold>\<in> local.res ts c)\<close> \<open>n = m + 1\<close> le_eq_less_or_eq by auto
qed

(*
  have "Rep_nat_int (res ts  c) = {} \<or> (\<exists>n . Rep_nat_int (res ts c) = {n,n+1})"
    by (metis add_diff_cancel_left' atLeastAtMost_singleton insert_is_Un nat_int.un_consec_seq
        one_add_one order_refl)

  with assump show "(\<exists>n . Rep_nat_int (res ts c) = {n,n+1})"
    using Rep_nat_int_inject bot_nat_int.rep_eq card_non_empty_geq_one
    by (metis not_empty)
qed
*)
lemma clmNextRes :
  "(clm ts c) \<noteq> \<emptyset> \<longrightarrow> (\<exists> n. n \<^bold>\<in> res ts c \<squnion> clm ts c \<and> (n+1) \<^bold>\<in> res ts c \<squnion> clm ts c )"
  using res_def clm_def sane_def
  by (metis Rep_traffic mem_Collect_eq sup_commute traffic.clm.rep_eq traffic.res.rep_eq)

lemma psGeZero:"\<forall>c. (physical_size ts c > 0)"
  using sane_def Rep_traffic traffic.physical_size.rep_eq by auto

lemma sdGeZero:"\<forall>c. (braking_distance ts c > 0)"
  using sane_def Rep_traffic braking_distance.rep_eq by auto

lemma res_non_empty: "res ts c \<noteq> \<emptyset>"
 using sane_def  Rep_traffic res.rep_eq
  by (simp add: card_non_empty_geq_one)

text \<open>
While not a sanity condition directly, the following lemma helps to establish
general properties of HMLSL later on. It is a consequence of clmNextRes.
\<close>

lemma clm_two_lanes: "clm ts c \<noteq> \<emptyset> \<longrightarrow> |clm ts c \<squnion> res ts c| = 2"
proof
  assume assm:"clm ts c \<noteq> \<emptyset>"
  have 1:"|res ts c| \<ge> 1"
    using card_non_empty_geq_one traffic.res_non_empty by auto
  have 2:"|clm ts c| \<ge> 1"
    using \<open>local.clm ts c \<noteq> bot\<close> card_non_empty_geq_one by blast
  have "clm ts c \<sqinter> res ts c = \<emptyset>" using sane_def
    by (metis Rep_traffic clm.rep_eq inf_aci(1) mem_Collect_eq res.rep_eq)
  then have 3:"|clm ts c| + |res ts c| = |clm ts c \<squnion> res ts c|"
    using card_un_add by auto
  then have "|clm ts c \<squnion> res ts c| \<ge> 2" using sane_def 1 2
    by linarith
  have "|clm ts c \<squnion> res ts c| \<le> 2" using assm sane_def 3
    by (metis "2" Rep_traffic add_numeral_left clm.rep_eq le_antisym mem_Collect_eq not_less_eq_eq numeral_One numeral_plus_numeral one_add_one plus_1_eq_Suc res.rep_eq)
  then show "|clm ts c \<squnion> res ts c| = 2"
    using \<open>2 \<le> |local.clm ts c \<squnion> local.res ts c|\<close> le_antisym by blast
qed

lemma clm_consec_res:
" (clm ts c) \<noteq> \<emptyset> \<longrightarrow> consec (clm ts c) (res ts c) \<or> consec (res ts c) (clm ts c)"
proof
  assume "(clm ts c) \<noteq> \<emptyset>"
  then obtain n where 0:" n \<^bold>\<in> clm ts c \<squnion> res ts c \<and> (n+1) \<^bold>\<in> clm ts c \<squnion> res ts c" using sane_def
    by (metis sup_commute traffic.clmNextRes)
  have "|clm ts c \<squnion> res ts c| = 2"
    using \<open>local.clm ts c \<noteq> bot\<close> traffic.clm_two_lanes by blast
  have 1:"clm ts c \<sqinter> res ts c = \<emptyset>" using sane_def
    by (metis Rep_traffic clm.rep_eq inf_aci(1) mem_Collect_eq res.rep_eq)
  have 2:"|clm ts c| = 1" using sane_def
    by (metis "1" \<open>local.clm ts c \<noteq> bot\<close> \<open>|local.clm ts c \<squnion> local.res ts c| = 2\<close> add_le_same_cancel1 card_non_empty_geq_one card_un_add le_antisym not_less_eq_eq one_add_one plus_1_eq_Suc traffic.res_non_empty)
  have 3:"|res ts c| = 1" using sane_def
    using "1" "2" \<open>local.clm ts c \<noteq> bot\<close> \<open>|local.clm ts c \<squnion> local.res ts c| = 2\<close> card_non_empty_geq_one card_un_add by auto
  show "consec (clm ts c) (res ts c) \<or> consec (res ts c) (clm ts c)"
  proof (cases "n \<^bold>\<in> clm ts c")
    case True
    then have 4:" n \<^bold>\<notin> res ts c" using 1 excl_el1 by blast
    have "(n+1) \<^bold>\<in> clm ts c \<squnion> res ts c" using 0 by blast
    have "(n+1) \<^bold>\<notin> clm ts c" using 2 True singleton
      by (metis add_eq_self_zero in_not_in_iff2 one_neq_zero singletonD)
    then have "(n+1) \<^bold>\<in> res ts c" using 1 2 3 4 singleton un_excl_el1
      using \<open>n + 1 \<^bold>\<in> local.clm ts c \<squnion> local.res ts c\<close> by blast
    then show ?thesis
      by (metis "2" "3" True \<open>local.clm ts c \<noteq> bot\<close> consec_def maximum_in minimum_in singleton singletonD traffic.res_non_empty)
  next
    case False
    then have "n \<^bold>\<notin> clm ts c" by auto
    then have 4:"(n+1) \<^bold>\<in> clm ts c"
      by (metis "0" "1" "3" add_eq_self_zero in_not_in_iff1 one_neq_zero singleton singletonD un_excl_el1)
    have "n \<^bold>\<in> res ts c"
      using "0" "1" \<open>n \<^bold>\<notin> local.clm ts c\<close> un_excl_el1 by blast
    then show ?thesis using 4
        by (metis "2" "3"  \<open>local.clm ts c \<noteq> bot\<close> consec_def maximum_in minimum_in singleton singletonD traffic.res_non_empty)
  qed
qed

(*proof (rule impI)+
  assume assm:"clm (ts::traffic) c \<noteq>\<emptyset>"
  hence adj:"(\<exists> n. res ts c \<squnion> clm ts c = Abs_nat_int{n, n+1})"
    using clmNextRes by blast
  obtain n where n_def:"res ts c \<squnion> clm ts c = Abs_nat_int{n, n+1}"
    using adj by blast
  have disj:"res ts c \<sqinter> clm ts c = \<emptyset>"
    using Rep_traffic clm.rep_eq res.rep_eq sane_def by auto
  from n_def and disj
    have "(n \<^bold>\<in> res ts c \<and> n \<^bold>\<notin> clm ts c) \<or> (n \<^bold>\<in> clm ts c \<and> n \<^bold>\<notin> res ts c)"
      by (metis UnE bot_nat_int.rep_eq disjoint_insert(1) el.rep_eq inf_nat_int.rep_e q
          insertI1 insert_absorb not_in.rep_eq)
  thus "consec (clm ts c) (res ts c) \<or> consec (res ts c) (clm ts c)"
  proof
    assume n_in_res: "n \<^bold>\<in> res ts c \<and>  n \<^bold>\<notin> clm ts c"
    hence suc_n_in_clm:"n+1 \<^bold>\<in> clm ts c"
      by (metis UnCI assm el.rep_eq in_not_in_iff1 insert_iff n_def non_empty_elem_ in
          singletonD)
    have "Rep_nat_int (res ts c) \<noteq> {n, n + 1}"
      by (metis assm disj n_def inf_absorb1 inf_commute less_eq_nat_int.rep_eq
          sup.cobounded2)
    then have suc_n_not_in_res:"n+1 \<^bold>\<notin> res ts c"
      using n_def n_in_res nat_int.el.rep_eq nat_int.not_in.rep_eq
        by auto
    from n_in_res have n_not_in_clm:"n \<^bold>\<notin> clm ts c" by blast
    have max:"nat_int.maximum (res ts c) = n"
      using n_in_res suc_n_not_in_res nat_int.el.rep_eq nat_int.not_in.rep_eq n_def
        nat_int.maximum_in nat_int.non_empty_elem_in inf_sup_aci(4)
      by fastforce
    have min:"nat_int.minimum (clm ts c) = n+1"
      using suc_n_in_clm n_not_in_clm nat_int.el.rep_eq nat_int.not_in.rep_eq
        n_def nat_int.minimum_in nat_int.non_empty_elem_in  using inf_sup_aci(4)
        not_in.rep_eq by fastforce
    show ?thesis
      using assm max min n_in_res nat_int.consec_def nat_int.non_empty_elem_in
      by auto
  next
    assume n_in_clm: "n \<^bold>\<in> clm ts c \<and> n \<^bold>\<notin> res ts c "
    have suc_n_in_res:"n+1 \<^bold>\<in> res ts c"
    proof (rule ccontr)
      assume "\<not>n+1 \<^bold>\<in> res ts c"
      then have "n \<^bold>\<in> res ts c "
        by (metis Int_insert_right_if0 One_nat_def Suc_leI add.right_neutral add_Suc_right
            atMostTwoRes el.rep_eq inf_bot_right inf_sup_absorb insert_not_empty le_antisym
            n_def one_add_one order.not_eq_order_implies_strict singleton traffic.atLeastOneRes
            traffic.consecutiveRes)
      then show False using n_in_clm
        using nat_int.el.rep_eq nat_int.not_in.rep_eq by auto
    qed
    have max:"nat_int.maximum (clm ts c) = n"
      by (metis Rep_nat_int_inverse assm n_in_clm card_non_empty_geq_one
          le_antisym nat_int.in_singleton nat_int.maximum_in singleton traffic.atMostOneClm)
    have min:"nat_int.minimum (res ts c) = n+1"
      by (metis Int_insert_right_if0 Int_insert_right_if1 Rep_nat_int_inverse
          bot_nat_int.rep_eq el.rep_eq in_not_in_iff1 in_singleton inf_nat_int.rep_eq
          inf_sup_absorb insert_not_empty inter_empty1 minimum_in n_def
          n_in_clm suc_n_in_res)
    then show ?thesis
      using assm max min nat_int.consec_def nat_int.non_empty_elem_in
        suc_n_in_res by auto
  qed
qed
*)

text \<open>We define several possible transitions between traffic snapshots.
Cars may create or withdraw claims and reservations, as long as the sanity conditions
of the traffic snapshots are fullfilled.

In particular, a car can only create
a claim, if it possesses only a reservation on a single lane, and does not
already possess a claim. Withdrawing a claim can be done in any situation.
It only has an effect, if the car possesses a claim. Similarly, the
transition for a car to create a reservation is always possible, but only
changes the spatial situation on the road, if the car already has a claim.
Finally, a car may withdraw its reservation to a single lane, if its
current reservation consists of two lanes.

All of these transitions concern the spatial properties of a single car at a time, i.e.,
for several cars to change their properties, several transitions have to be taken.
\<close>

definition create_claim ::
  "traffic\<Rightarrow>cars\<Rightarrow>nat\<Rightarrow>traffic\<Rightarrow>bool" ("_ \<^bold>\<midarrow>c'( _, _ ') \<^bold>\<rightarrow> _" 27)
where "  (ts \<^bold>\<midarrow>c(c,n)\<^bold>\<rightarrow> ts')  == (pos ts') = (pos ts)
                                \<and> (res ts') = (res ts)
                                \<and> (dyn ts') = (dyn ts)
                                \<and> (physical_size ts') = (physical_size ts)
                                \<and> (braking_distance ts') = (braking_distance ts)
                                \<and> |clm ts c| = 0
                                \<and> |res ts c| = 1
                                \<and> ((n+1) \<^bold>\<in> res ts c \<or> (n-1 \<^bold>\<in> res ts c))
                                \<and> (clm ts') = (clm ts)(c:=Abs_nat_int {n})"

definition withdraw_claim ::
  "traffic\<Rightarrow>cars \<Rightarrow>traffic\<Rightarrow>bool" ("_ \<^bold>\<midarrow>wdc'( _ ') \<^bold>\<rightarrow> _" 27)
where "  (ts \<^bold>\<midarrow>wdc(c)\<^bold>\<rightarrow> ts')  == (pos ts') = (pos ts)
                                \<and> (res ts') = (res ts)
                                \<and> (dyn ts') = (dyn ts)
                                \<and> (physical_size ts') = (physical_size ts)
                                \<and> (braking_distance ts') = (braking_distance ts)
                                \<and> (clm ts') = (clm ts)(c:=\<emptyset>)"

definition create_reservation ::
  "traffic\<Rightarrow>cars\<Rightarrow>traffic\<Rightarrow>bool" ("_ \<^bold>\<midarrow>r'( _ ') \<^bold>\<rightarrow> _" 27)
where "  (ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts')  == (pos ts') = (pos ts)
                                \<and> (res ts') = (res ts)(c:=( (res ts c)\<squnion> (clm ts c) ))
                                \<and> (dyn ts') = (dyn ts)
                                \<and> (clm ts') = (clm ts)(c:=\<emptyset>)
                                \<and> (physical_size ts') = (physical_size ts)
                                \<and> (braking_distance ts') = (braking_distance ts)"

definition withdraw_reservation ::
  "traffic\<Rightarrow>cars\<Rightarrow>nat\<Rightarrow>traffic\<Rightarrow> bool" ("_ \<^bold>\<midarrow>wdr'( _, _ ') \<^bold>\<rightarrow> _" 27)
where "  (ts \<^bold>\<midarrow>wdr(c,n)\<^bold>\<rightarrow> ts')  == (pos ts') = (pos ts)
                                \<and> (res ts') = (res ts)(c:= Abs_nat_int{n} )
                                \<and> (dyn ts') = (dyn ts)
                                \<and> (clm ts') = (clm ts)
                                \<and> (physical_size ts') = (physical_size ts)
                                \<and> (braking_distance ts') = (braking_distance ts)
                                \<and> n \<^bold>\<in> (res ts c)
                                \<and> |res ts c| = 2"

text \<open>
The following two transitions concern the dynamical behaviour of the cars.
Similar to the spatial properties, a car may change its dynamics, by setting
it to a new function \(f\) from real to real. Observe that this function is indeed
arbitrary and does not constrain the possible behaviour in any way. However,
this transition allows a car to change the function determining their braking
distance (in fact, all cars are allowed to change this function, if a car changes
sets a new dynamical function). That is, our model describes an over-approximation
of a concrete situation, where the braking distance is determined by the dynamics.

The final transition describes the passing of \(x\) time units. That is, all cars
update their position according to their current dynamical behaviour. Observe that
this transition requires that the dynamics of each car is at least \(0\), for each time
point between \(0\) and \(x\). Hence, this condition denotes that all cars drive
into the same direction. If the current dynamics of a car violated this constraint,
it would have to reset its dynamics, until time may pass again.
\<close>

definition change_dyn::
  "traffic\<Rightarrow>cars\<Rightarrow>(real\<Rightarrow>real)\<Rightarrow>traffic\<Rightarrow> bool" (" _ \<^bold>\<midarrow> dyn'(_,_') \<^bold>\<rightarrow> _" 27)
where "(ts \<^bold>\<midarrow>dyn(c, f)\<^bold>\<rightarrow> ts') == (pos ts' = pos ts)
                              \<and> (res ts' = res ts)
                              \<and> (clm ts' = clm ts)
                              \<and> (dyn ts' = (dyn ts)(c:= f))
                              \<and> (physical_size ts') = (physical_size ts)"

definition drive::
  "traffic\<Rightarrow>real\<Rightarrow>traffic\<Rightarrow>bool" (" _ \<^bold>\<midarrow> _ \<^bold>\<rightarrow> _" 27)
where "(ts \<^bold>\<midarrow> x \<^bold>\<rightarrow> ts') == (\<forall>c. (pos ts' c = (pos ts c) + (dyn ts c x)))
                              \<and> (\<forall> c y. 0 \<le> y \<and> y \<le> x \<longrightarrow> dyn ts c y \<ge> 0)
                              \<and> (res ts' = res ts)
                              \<and> (clm ts' = clm ts)
                              \<and> (dyn ts' = dyn ts)
                              \<and> (physical_size ts') = (physical_size ts)
                              \<and> (braking_distance ts') = (braking_distance ts)
                             "

text\<open>
We bundle the dynamical transitions into \emph{evolutions}, since
we will only reason about combinations of the dynamical behaviour.
This fits to the level of abstraction by hiding the dynamics completely
inside of the model.
\<close>

inductive evolve::"traffic \<Rightarrow> traffic \<Rightarrow> bool" ("_ \<^bold>\<leadsto> _")
where refl : "ts \<^bold>\<leadsto> ts" |
 change: "\<exists>c. \<exists>f. (ts \<^bold>\<midarrow>dyn(c,f)\<^bold>\<rightarrow>ts') \<Longrightarrow> ts' \<^bold>\<leadsto> ts'' \<Longrightarrow> ts \<^bold>\<leadsto> ts''" |
 drive:  "\<exists>x. x \<ge> 0 \<and>  ( ts \<^bold>\<midarrow>x\<^bold>\<rightarrow> ts') \<Longrightarrow> ts' \<^bold>\<leadsto> ts''    \<Longrightarrow> ts \<^bold>\<leadsto> ts''"

lemma evolve_trans:"(ts0 \<^bold>\<leadsto> ts1) \<Longrightarrow> (ts1 \<^bold>\<leadsto> ts2) \<Longrightarrow> (ts0 \<^bold>\<leadsto> ts2)"
proof (induction rule:evolve.induct)
  case (refl ts)
  then show ?case by simp
next
  case (drive ts ts' ts'')
  then show ?case by (metis evolve.drive)
next
  case (change ts ts' ts'')
  then show ?case by (metis evolve.change)
qed

text \<open>
For general transition sequences, we introduce \emph{abstract transitions}.
A traffic snapshot \(ts^\prime\) is reachable from \(ts\) via an abstract transition,
if there is an arbitrary sequence of transitions from \(ts\) to \(ts^\prime\).
\<close>

inductive abstract::"traffic \<Rightarrow> traffic \<Rightarrow> bool"  ("_ \<^bold>\<Rightarrow> _") for ts
where refl: "(ts \<^bold>\<Rightarrow> ts)" |
  evolve:"  ts \<^bold>\<Rightarrow> ts' \<Longrightarrow> ts' \<^bold>\<leadsto> ts''   \<Longrightarrow> ts \<^bold>\<Rightarrow> ts''" |
  cr_clm:" ts \<^bold>\<Rightarrow> ts' \<Longrightarrow>\<exists>c. \<exists> n.  (ts' \<^bold>\<midarrow>c(c,n)\<^bold>\<rightarrow> ts'')     \<Longrightarrow> ts \<^bold>\<Rightarrow> ts''" |
  wd_clm:"ts \<^bold>\<Rightarrow> ts'  \<Longrightarrow> \<exists>c.  (ts' \<^bold>\<midarrow>wdc(c)\<^bold>\<rightarrow> ts'') \<Longrightarrow>  ts \<^bold>\<Rightarrow> ts''" |
  cr_res:"ts \<^bold>\<Rightarrow> ts' \<Longrightarrow> \<exists>c.  (ts' \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts'') \<Longrightarrow>  ts \<^bold>\<Rightarrow> ts''" |
  wd_res:"ts \<^bold>\<Rightarrow> ts' \<Longrightarrow> \<exists>c. \<exists> n.  (ts' \<^bold>\<midarrow>wdr(c,n)\<^bold>\<rightarrow> ts'') \<Longrightarrow>  ts \<^bold>\<Rightarrow> ts''"

lemma abs_trans:" (ts1 \<^bold>\<Rightarrow> ts2) \<Longrightarrow>(ts0 \<^bold>\<Rightarrow> ts1) \<Longrightarrow> (ts0 \<^bold>\<Rightarrow> ts2)"
proof (induction  rule:abstract.induct    )
  case refl
  then show ?case by simp
next
  case (evolve ts' ts'')
  then show ?case
    using traffic.evolve by blast
next
  case (cr_clm ts' ts'')
  then show ?case
    using traffic.cr_clm by blast
next
  case (wd_clm ts' ts'')
  then show ?case
    using traffic.wd_clm by blast
next
  case (cr_res ts' ts'')
  then show ?case
    using traffic.cr_res by blast
next
  case (wd_res ts' ts'')
  then show ?case
    using traffic.wd_res by blast
qed

text \<open>
Most properties of the transitions are straightforward. However, to show
that the transition to create a reservation is always possible,
we need to explicitly construct the resulting traffic snapshot. Due
to the size of such a snapshot, the proof is lengthy.
\<close>

lemma create_res_subseteq1:"(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts') \<longrightarrow> res ts c \<sqsubseteq> res ts' c "
proof
  assume assm:"(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts')"
  hence "res ts' c = res ts c \<squnion> clm ts c" using create_reservation_def
    using fun_upd_apply by auto
  thus "res ts c \<sqsubseteq> res ts' c" by simp
qed

lemma create_res_subseteq2:"(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts') \<longrightarrow> clm ts c \<sqsubseteq> res ts' c "
proof
  assume assm:"(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts')"
  hence "res ts' c = res ts c \<squnion> clm ts c" using create_reservation_def
    using fun_upd_apply by auto
  thus "clm ts c \<sqsubseteq> res ts' c"
    by simp
qed

lemma create_res_subseteq1_neq:"(ts \<^bold>\<midarrow>r(d)\<^bold>\<rightarrow> ts') \<and> d \<noteq>c \<longrightarrow> res ts c = res ts' c "
proof
  assume assm:"(ts \<^bold>\<midarrow>r(d)\<^bold>\<rightarrow> ts') \<and> d \<noteq>c"
  thus "res ts c = res ts' c" using create_reservation_def
  using fun_upd_apply by auto
qed

lemma create_res_subseteq2_neq:"(ts \<^bold>\<midarrow>r(d)\<^bold>\<rightarrow> ts') \<and> d \<noteq>c \<longrightarrow> clm ts c= clm ts' c "
proof
  assume assm:"(ts \<^bold>\<midarrow>r(d)\<^bold>\<rightarrow> ts') \<and> d \<noteq>c"
  thus "clm ts c =  clm ts' c" using create_reservation_def
    using fun_upd_apply by auto
qed

lemma create_res_continuous: "(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts') \<longrightarrow> continuous (res ts' c)"
proof
  assume "ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts'"
  show "continuous (res ts' c)"
  proof (cases "clm ts c = \<emptyset>")
    case True
    then have "res ts c = res ts' c"
      using \<open>ts \<^bold>\<midarrow>r( c ) \<^bold>\<rightarrow> ts'\<close> traffic.create_reservation_def by auto
    then have "\<forall>c. continuous (res ts' c)" using sane_def Rep_traffic Abs_traffic_inverse
      by (simp add: traffic.res.rep_eq)
    then show ?thesis using sane_def
      by blast
  next
      case False
      then have "res ts' c = (res ts c \<squnion> clm ts c)"
        using \<open>ts \<^bold>\<midarrow>r( c ) \<^bold>\<rightarrow> ts'\<close> traffic.create_reservation_def by auto
    then have "\<forall>c. continuous (res ts' c)" using sane_def Rep_traffic Abs_traffic_inverse
      by (simp add: traffic.res.rep_eq)
    then show ?thesis using sane_def
      by blast
  qed
qed

declare [[show_types]]

lemma always_create_res:"\<exists>ts'. (ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts')"
proof -
  fix ts
  show " \<exists>ts'. (ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts')"
  proof (cases "clm ts c = \<emptyset>")
    case True
    obtain ts' where ts'_def:"ts' = ts" by simp
    then have "ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts'"
      using create_reservation_def True fun_upd_triv
      by auto
    thus ?thesis ..
  next
    case False
    obtain ts1 :: snapshot where ts1_def:"ts1 = Rep_traffic ts" by blast
    then have 1:"sane ts1"
      using Rep_traffic by blast
    obtain ts' where ts'_def : "ts' = \<lparr> snapshot.pos = snapshot.pos ts1,
                        snapshot.res = (snapshot.res ts1)(c:=((snapshot.res ts1 c)\<squnion>(snapshot.clm ts1 c) )),
                        snapshot.clm = (snapshot.clm ts1)(c:=\<emptyset>),
                                snapshot.dyn = (snapshot.dyn ts1),
                                snapshot.physical_size =(snapshot.physical_size ts1),
                                snapshot.braking_distance =(snapshot.braking_distance ts1)
                         \<rparr>" by blast
    have "snapshot.clm ts' c = \<emptyset>" using ts'_def  by simp
    have disj:"\<forall>c. snapshot.res ts' c \<sqinter> snapshot.clm ts' c = \<emptyset>" using 1
      by (simp add: inter_empty1 sane_def ts'_def)
    have ps_ge_zero: "(\<forall>c . snapshot.physical_size ts' c > 0)"
      using ts'_def sane_def 1 by simp
    have sd_ge_zero: "(\<forall>c . snapshot.braking_distance ts' c > 0)"
      using ts'_def sane_def 1 by simp
    have re_geq_one:"\<forall>d. |snapshot.res ts' d| \<ge> 1"
    proof
      fix d
      show " |snapshot.res ts' d| \<ge> 1"
      proof (cases "c = d")
        case True
        then have "snapshot.res ts' d = res ts d \<squnion> clm ts c"
          by (simp add: ts1_def traffic.clm.rep_eq traffic.res.rep_eq ts'_def)
        then have "res ts d \<sqsubseteq> snapshot.res ts' d" by simp
        then show ?thesis using sane_def
          by (metis bot.extremum_unique card_non_empty_geq_one traffic.res_non_empty)
      next
        case False
        then show ?thesis
          using "1" sane_def ts'_def by auto
      qed
    qed
    have re_leq_two:"\<forall>c. |(snapshot.res ts') c| \<le> 2" using ts'_def sane_def 1 clmNextRes ts1_def
      using card_un_add by auto
    have cl_leq_one:"\<forall>c. |(snapshot.clm ts') c| \<le> 1"
      using sane_def 1 nat_int.card_empty_zero ts'_def by auto
    have add_leq_two:"\<forall>c . |snapshot.res ts' c| + |snapshot.clm ts' c| \<le> 2"
      by (metis "1" add.right_neutral card_empty_zero fun_upd_apply re_leq_two sane_def select_convs(2) simps(3) ts'_def)

    have clNextRe :
      "\<forall>c. (snapshot.clm ts' c) \<noteq> \<emptyset> \<longrightarrow>
        (\<exists> n.  n \<^bold>\<in> (snapshot.res ts' c) \<squnion> (snapshot.clm ts' c) \<and> (n+1) \<^bold>\<in> (snapshot.res ts' c) \<squnion> (snapshot.clm ts' c))"
      using sane_def 1 ts'_def
      using traffic.clm.rep_eq traffic.clmNextRes traffic.res.rep_eq ts1_def by auto
    have cont1: "\<forall>c. continuous (snapshot.res ts' c)"
    proof
      fix d
      show "continuous (snapshot.res ts' d)"
      proof (cases "c = d")
        case False
        then show ?thesis using sane_def ts'_def
          using "1" by auto
      next
        case True
        then have "continuous (res ts c \<squnion> clm ts c)"
          by (metis "1"    nchop_cont nchop_def sane_def sup_bot.left_neutral sup_commute traffic.clm.rep_eq traffic.clm_consec_res  traffic.res.rep_eq  ts1_def)
        then show ?thesis using sane_def ts'_def
          by (simp add: True traffic.clm.rep_eq traffic.res.rep_eq ts1_def)
      qed
    qed
    have cont2: "\<forall>c. continuous (snapshot.clm ts' c)"
      using "1" empty_continuous sane_def ts'_def by auto
    then have "sane ts'" using 1
      using add_leq_two cl_leq_one disj re_geq_one re_leq_two sane_def ts'_def cont1 cont2
      by (simp add: re_leq_two)
    then have "ts' \<in> {ts. sane ts}" by blast
    then have "ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> Abs_traffic ts'"
    proof -
      obtain tt :: "snapshot \<Rightarrow> traffic" where
    f1: "\<lparr>snapshot.pos = snapshot.pos ts1, res = (snapshot.res ts1) (c := snapshot.res ts1 c \<squnion> snapshot.clm ts1 c), clm = (snapshot.clm ts1)(c := bot), dyn = snapshot.dyn ts1, physical_size = snapshot.physical_size ts1, braking_distance = snapshot.braking_distance ts1\<rparr> = Rep_traffic (tt \<lparr>snapshot.pos = snapshot.pos ts1, res = (snapshot.res ts1) (c := snapshot.res ts1 c \<squnion> snapshot.clm ts1 c), clm = (snapshot.clm ts1)(c := bot), dyn = snapshot.dyn ts1, physical_size = snapshot.physical_size ts1, braking_distance = snapshot.braking_distance ts1\<rparr>)"
    by (metis (full_types) Rep_traffic_cases \<open>(ts'::snapshot) \<in> {ts::snapshot. sane ts}\<close> ts'_def)
  then have "Abs_traffic ts' = tt \<lparr>snapshot.pos = snapshot.pos ts1, res = (snapshot.res ts1) (c := snapshot.res ts1 c \<squnion> snapshot.clm ts1 c), clm = (snapshot.clm ts1)(c := bot), dyn = snapshot.dyn ts1, physical_size = snapshot.physical_size ts1, braking_distance = snapshot.braking_distance ts1\<rparr>"
    by (metis (no_types) Rep_traffic_inverse ts'_def)
  then show ?thesis
    using f1 by (simp add: ts1_def traffic.braking_distance.rep_eq traffic.clm.rep_eq traffic.create_reservation_def traffic.dyn.rep_eq traffic.physical_size.rep_eq traffic.pos.rep_eq traffic.res.rep_eq)
  qed
    then show ?thesis by blast
  qed
qed

lemma create_clm_eq_res:"(ts \<^bold>\<midarrow>c(d,n)\<^bold>\<rightarrow> ts')  \<longrightarrow> res ts c = res ts' c "
  using create_claim_def by auto

lemma withdraw_clm_eq_res:"(ts \<^bold>\<midarrow>wdc(d)\<^bold>\<rightarrow> ts') \<longrightarrow> res ts c= res ts' c "
  using withdraw_claim_def by auto

lemma withdraw_res_subseteq:"(ts \<^bold>\<midarrow>wdr(d,n)\<^bold>\<rightarrow> ts') \<longrightarrow> res ts' c \<sqsubseteq> res ts c "
  using withdraw_reservation_def order_refl less_eq_nat_int.rep_eq nat_int.el.rep_eq
       fun_upd_apply subset_eq  Abs_nat_int_inverse by auto

end
end


theory Residual
imports
  Nominal2.Nominal2
begin

section \<open>Residuals\<close>

subsection \<open>Binding names\<close>

text \<open>To define $\alpha$-equivalence, we require actions to be equipped with an equivariant
function~@{term bn} that gives their binding names. Actions may only bind finitely many names. This
is necessary to ensure that we can use a finite permutation to rename the binding names in an
action.\<close>

class bn = fs +
  fixes bn :: "'a \<Rightarrow> atom set"
  assumes bn_eqvt: "p \<bullet> (bn \<alpha>) = bn (p \<bullet> \<alpha>)"
  and bn_finite: "finite (bn \<alpha>)"

lemma bn_subset_supp: "bn \<alpha> \<subseteq> supp \<alpha>"
by (metis (erased, opaque_lifting) bn_eqvt bn_finite eqvt_at_def finite_supp supp_eqvt_at supp_finite_atom_set)

subsection \<open>Raw residuals and \texorpdfstring{$\alpha$}{alpha}-equivalence\<close>

text \<open>Raw residuals are simply pairs of actions and states. Binding names in the action bind into
(the action and) the state.\<close>

fun alpha_residual :: "('act::bn \<times> 'state::pt) \<Rightarrow> ('act \<times> 'state) \<Rightarrow> bool" where
  "alpha_residual (\<alpha>1,P1) (\<alpha>2,P2) \<longleftrightarrow> [bn \<alpha>1]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"

text \<open>$\alpha$-equivalence is equivariant.\<close>

lemma alpha_residual_eqvt [eqvt]:
  assumes "alpha_residual r1 r2"
  shows "alpha_residual (p \<bullet> r1) (p \<bullet> r2)"
using assms by (cases r1, cases r2) (simp, metis Pair_eqvt bn_eqvt permute_Abs_set)

text \<open>$\alpha$-equivalence is an equivalence relation.\<close>

lemma alpha_residual_reflp: "reflp alpha_residual"
by (metis alpha_residual.simps prod.exhaust reflpI)

lemma alpha_residual_symp: "symp alpha_residual"
by (metis alpha_residual.simps prod.exhaust sympI)

lemma alpha_residual_transp: "transp alpha_residual"
by (rule transpI) (metis alpha_residual.simps prod.exhaust)

lemma alpha_residual_equivp: "equivp alpha_residual"
by (metis alpha_residual_reflp alpha_residual_symp alpha_residual_transp equivpI)

subsection \<open>Residuals\<close>

text \<open>Residuals are raw residuals quotiented by $\alpha$-equivalence.\<close>

quotient_type
  ('act,'state) residual = "'act::bn \<times> 'state::pt" / "alpha_residual"
  by (fact alpha_residual_equivp)

lemma residual_abs_rep [simp]: "abs_residual (rep_residual res) = res"
by (metis Quotient_residual Quotient_abs_rep)

lemma residual_rep_abs [simp]: "alpha_residual (rep_residual (abs_residual r)) r"
by (metis residual.abs_eq_iff residual_abs_rep)

text \<open>The permutation operation is lifted from raw residuals.\<close>

instantiation residual :: (bn,pt) pt
begin

  lift_definition permute_residual :: "perm \<Rightarrow> ('a,'b) residual \<Rightarrow> ('a,'b) residual"
    is permute
  by (fact alpha_residual_eqvt)

  instance
  proof
    fix res :: "(_,_) residual"
    show "0 \<bullet> res = res"
      by transfer (metis alpha_residual_equivp equivp_reflp permute_zero)
  next
    fix p q :: perm and res :: "(_,_) residual"
    show "(p + q) \<bullet> res = p \<bullet> q \<bullet> res"
      by transfer (metis alpha_residual_equivp equivp_reflp permute_plus)
  qed

end

text \<open>The abstraction function from raw residuals to residuals is equivariant. The representation
function is equivariant modulo $\alpha$-equivalence.\<close>

lemmas permute_residual.abs_eq [eqvt, simp]

lemma alpha_residual_permute_rep_commute [simp]: "alpha_residual (p \<bullet> rep_residual res) (rep_residual (p \<bullet> res))"
by (metis residual.abs_eq_iff residual_abs_rep permute_residual.abs_eq)

subsection \<open>Notation for pairs as residuals\<close>

abbreviation abs_residual_pair :: "'act::bn \<Rightarrow> 'state::pt \<Rightarrow> ('act,'state) residual" ("\<langle>_,_\<rangle>" [0,0] 1000)
where
  "\<langle>\<alpha>,P\<rangle> == abs_residual (\<alpha>,P)"

lemma abs_residual_pair_eqvt [simp]: "p \<bullet> \<langle>\<alpha>,P\<rangle> = \<langle>p \<bullet> \<alpha>, p \<bullet> P\<rangle>"
by (metis Pair_eqvt permute_residual.abs_eq)

subsection \<open>Support of residuals\<close>

text \<open>We only consider finitely supported states now.\<close>

lemma supp_abs_residual_pair: "supp \<langle>\<alpha>, P::'state::fs\<rangle> = supp (\<alpha>,P) - bn \<alpha>"
proof -
  have "supp \<langle>\<alpha>,P\<rangle> = supp ([bn \<alpha>]set. (\<alpha>, P))"
    by (simp add: supp_def residual.abs_eq_iff bn_eqvt)
  then show ?thesis by (simp add: supp_Abs)
qed

lemma bn_abs_residual_fresh [simp]: "bn \<alpha> \<sharp>* \<langle>\<alpha>,P::'state::fs\<rangle>"
by (simp add: fresh_star_def fresh_def supp_abs_residual_pair)

lemma finite_supp_abs_residual_pair [simp]: "finite (supp \<langle>\<alpha>, P::'state::fs\<rangle>)"
by (metis finite_Diff finite_supp supp_abs_residual_pair)

subsection \<open>Equality between residuals\<close>

lemma residual_eq_iff_perm: "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle> \<longleftrightarrow>
  (\<exists>p. supp (\<alpha>1, P1) - bn \<alpha>1 = supp (\<alpha>2, P2) - bn \<alpha>2 \<and> (supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> (\<alpha>1, P1) = (\<alpha>2, P2) \<and> p \<bullet> bn \<alpha>1 = bn \<alpha>2)"
  (is "?l \<longleftrightarrow> ?r")
proof
  assume *: "?l"
  then have "[bn \<alpha>1]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"
    by (simp add: residual.abs_eq_iff)
  then obtain p where "(bn \<alpha>1, (\<alpha>1,P1)) \<approx>set ((=)) supp p (bn \<alpha>2, (\<alpha>2,P2))"
    using Abs_eq_iff(1) by blast
  then show "?r"
    by (metis (mono_tags, lifting) alpha_set.simps)
next
  assume *: "?r"
  then obtain p where "(bn \<alpha>1, (\<alpha>1,P1)) \<approx>set ((=)) supp p (bn \<alpha>2, (\<alpha>2,P2))"
    using alpha_set.simps by blast
  then have "[bn \<alpha>1]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"
    using Abs_eq_iff(1) by blast
  then show "?l"
    by (simp add: residual.abs_eq_iff)
qed

lemma residual_eq_iff_perm_renaming: "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle> \<longleftrightarrow>
  (\<exists>p. supp (\<alpha>1, P1) - bn \<alpha>1 = supp (\<alpha>2, P2) - bn \<alpha>2 \<and> (supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> (\<alpha>1, P1) = (\<alpha>2, P2) \<and> p \<bullet> bn \<alpha>1 = bn \<alpha>2 \<and> supp p \<subseteq> bn \<alpha>1 \<union> p \<bullet> bn \<alpha>1)"
  (is "?l \<longleftrightarrow> ?r")
proof
  assume "?l"
  then obtain p where p: "supp (\<alpha>1, P1) - bn \<alpha>1 = supp (\<alpha>2, P2) - bn \<alpha>2 \<and> (supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> (\<alpha>1, P1) = (\<alpha>2, P2) \<and> p \<bullet> bn \<alpha>1 = bn \<alpha>2"
    by (metis residual_eq_iff_perm)
  moreover obtain q where q_p: "\<forall>b\<in>bn \<alpha>1. q \<bullet> b = p \<bullet> b" and supp_q: "supp q \<subseteq> bn \<alpha>1 \<union> p \<bullet> bn \<alpha>1"
    by (metis set_renaming_perm2)
  have "supp q \<subseteq> supp p"
  proof
    fix a assume *: "a \<in> supp q" then show "a \<in> supp p"
    proof (cases "a \<in> bn \<alpha>1")
      case True then show ?thesis
        using "*" q_p by (metis mem_Collect_eq supp_perm)
    next
      case False then have "a \<in> p \<bullet> bn \<alpha>1"
        using "*" supp_q using UnE subsetCE by blast
      with False have "p \<bullet> a \<noteq> a"
        by (metis mem_permute_iff)
      then show ?thesis
        using fresh_def fresh_perm by blast
    qed
  qed
  with p have "(supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* q"
    by (meson fresh_def fresh_star_def subset_iff)
  moreover with p and q_p have "\<And>a. a \<in> supp \<alpha>1 \<Longrightarrow> q \<bullet> a = p \<bullet> a" and "\<And>a. a \<in> supp P1 \<Longrightarrow> q \<bullet> a = p \<bullet> a"
    by (metis Diff_iff fresh_perm fresh_star_def UnCI supp_Pair)+
  then have "q \<bullet> \<alpha>1 = p \<bullet> \<alpha>1" and "q \<bullet> P1 = p \<bullet> P1"
    by (metis supp_perm_perm_eq)+
  ultimately show "?r"
    using supp_q by (metis Pair_eqvt bn_eqvt)
next
  assume "?r" then show "?l"
    by (meson residual_eq_iff_perm)
qed

subsection \<open>Strong induction\<close>

lemma residual_strong_induct:
  assumes "\<And>(act::'act::bn) (state::'state::fs) (c::'a::fs). bn act \<sharp>* c \<Longrightarrow> P c \<langle>act,state\<rangle>"
  shows "P c residual"
proof (rule residual.abs_induct, clarify)
  fix act :: 'act and state :: 'state
  obtain p where 1: "(p \<bullet> bn act) \<sharp>* c" and 2: "supp \<langle>act,state\<rangle> \<sharp>* p"
    proof (rule at_set_avoiding2[of "bn act" c "\<langle>act,state\<rangle>", THEN exE])
      show "finite (bn act)" by (fact bn_finite)
    next
      show "finite (supp c)" by (fact finite_supp)
    next
      show "finite (supp \<langle>act,state\<rangle>)" by (fact finite_supp_abs_residual_pair)
    next
      show "bn act \<sharp>* \<langle>act,state\<rangle>" by (fact bn_abs_residual_fresh)
    qed metis
  from 2 have "\<langle>p \<bullet> act, p \<bullet> state\<rangle> = \<langle>act,state\<rangle>"
    using supp_perm_eq by fastforce
  then show "P c \<langle>act,state\<rangle>"
    using assms 1 by (metis bn_eqvt)
qed

subsection \<open>Other lemmas\<close>

lemma residual_empty_bn_eq_iff:
  assumes "bn \<alpha>1 = {}"
  shows "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle> \<longleftrightarrow> \<alpha>1 = \<alpha>2 \<and> P1 = P2"
proof
  assume "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle>"
  with assms have "[{}]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"
    by (simp add: residual.abs_eq_iff)
  then obtain p where "({}, (\<alpha>1, P1)) \<approx>set ((=)) supp p (bn \<alpha>2, (\<alpha>2, P2))"
    using Abs_eq_iff(1) by blast
  then show "\<alpha>1 = \<alpha>2 \<and> P1 = P2"
    unfolding alpha_set using supp_perm_eq by fastforce
next
  assume "\<alpha>1 = \<alpha>2 \<and> P1 = P2" then show "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle>"
    by simp
qed

\<comment> \<open>The following lemma is not about residuals, but we have no better place for it.\<close>
lemma set_bounded_supp:
  assumes "finite S" and "\<And>x. x\<in>X \<Longrightarrow> supp x \<subseteq> S"
  shows "supp X \<subseteq> S"
proof -
  have "S supports X"
    unfolding supports_def proof (clarify)
    fix a b
    assume a: "a \<notin> S" and b: "b \<notin> S"
    {
      fix x
      assume "x \<in> X"
      then have "(a \<rightleftharpoons> b) \<bullet> x = x"
        using a b \<open>\<And>x. x\<in>X \<Longrightarrow> supp x \<subseteq> S\<close> by (meson fresh_def subsetCE swap_fresh_fresh)
    }
    then show "(a \<rightleftharpoons> b) \<bullet> X = X"
      by auto (metis (full_types) eqvt_bound mem_permute_iff, metis mem_permute_iff)
  qed
  then show "supp X \<subseteq> S"
    using assms(1) by (fact supp_is_subset)
qed

end


section {*control\_theory\_on\_languages\_\_alternative\_characterization\_of\_controllable\_language*}
theory
  control_theory_on_languages__alternative_characterization_of_controllable_language

imports
  control_theory_on_languages

begin

definition star_controllable_language :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> bool" where
  "star_controllable_language A \<Sigma>UC L \<equiv>
  (append_language A (kleene_star \<Sigma>UC)) \<inter> L \<subseteq> A"

definition equal_star_controllable_language :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> bool" where
  "equal_star_controllable_language A \<Sigma>UC L \<equiv>
  (append_language A (kleene_star \<Sigma>UC)) \<inter> L = A"

definition right_quotient :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set" where
  "right_quotient L1 L2 \<equiv>
  {w . \<exists>v \<in> L2. w @ v \<in> L1}"

lemma example1_right_quotient: "
  right_quotient { [ (2::nat), 1, 0 ] , [ 1, 2 ] , [ 0, 2, 0 ] } { [ 0 ] , [ 1, 0 ] } = { [ 2, 1 ] , [ 0, 2 ] , [ 2 ] }"
  apply(simp add: right_quotient_def)
  apply(rule antisym)
   apply(clarsimp)
  apply(clarsimp)
  done

lemma example2_right_quotient : "
  right_quotient (append_language { [] } { [ 1 ] , [ 0, 1 ] }) { [ 1 ] , [ 0, 1 ] } = { [] , [ 0 ] }"
  apply(simp add: right_quotient_def append_language_def)
  apply(rule antisym)
   apply(clarsimp)
  apply(clarsimp)
  done

lemma example3_right_quotient: "
  right_quotient A (kleene_star B) \<supseteq> A"
  apply(simp add: right_quotient_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      x="[]"
      in exI)
  apply(clarsimp)
  done

lemma example4_right_quotient: "
  A = prefix_closure A
  \<Longrightarrow> B \<subseteq> A
  \<Longrightarrow> right_quotient B (kleene_star C) \<subseteq> A"
  apply(simp add: prefix_closure_def right_quotient_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac x v)(*strict*)
  apply(rule_tac
      A="{w. \<exists>v. v \<in> A \<and> w \<sqsubseteq> v}"
      in set_mp)
   apply(rename_tac x v)(*strict*)
   apply(force)
  apply(rename_tac x v)(*strict*)
  apply(simp (no_asm))
  apply(rule_tac
      x="x@v"
      in exI)
  apply(simp add: prefix_def)
  apply(force)
  done

definition left_quotient :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set" where
  "left_quotient L1 L2 \<equiv>
  {w. \<exists>v \<in> L1. v @ w \<in> L2}"

definition right_quotient_controllable_language :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> bool" where
  "right_quotient_controllable_language L1 \<Sigma>UC L2 \<Sigma> \<equiv>
  right_quotient ((kleene_star \<Sigma> - L1) \<inter> L2) (kleene_star \<Sigma>UC)
    \<subseteq> (kleene_star \<Sigma> - L1 ) \<inter> L2"

definition equal_right_quotient_controllable_language :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> bool" where
  "equal_right_quotient_controllable_language L1 \<Sigma>UC L2 \<Sigma> \<equiv>
  right_quotient ((kleene_star \<Sigma> - L1) \<inter> L2) (kleene_star \<Sigma>UC)
    = (kleene_star \<Sigma> - L1 ) \<inter> L2"

lemma rev_inj: "
  rev a = rev b
  \<Longrightarrow> a = b"
  apply(induct a arbitrary: b)
   apply(rename_tac b)(*strict*)
   apply(force)
  apply(rename_tac a1 a2 b)(*strict*)
  apply(clarsimp)
  apply(case_tac b)
   apply(rename_tac a1 a2 b)(*strict*)
   apply(clarsimp)
  apply(rename_tac a1 a2 b a list)(*strict*)
  apply(clarsimp)
  done

lemma left_quotient_to_right_quotient: "
  left_quotient A B = rev ` (right_quotient (rev ` B) (rev ` A))"
  apply(simp add: left_quotient_def right_quotient_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac x v)(*strict*)
   apply(rule inMap)
   apply(rule_tac
      x="rev x"
      in bexI)
    apply(rename_tac x v)(*strict*)
    apply(clarsimp)
   apply(rename_tac x v)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      x="v"
      in bexI)
    apply(rename_tac x v)(*strict*)
    apply(rule inMap)
    apply(rule_tac
      x="v@x"
      in bexI)
     apply(rename_tac x v)(*strict*)
     apply(force)
    apply(rename_tac x v)(*strict*)
    apply(force)
   apply(rename_tac x v)(*strict*)
   apply(force)
  apply(clarsimp)
  apply(rename_tac xa v xb)(*strict*)
  apply(rule_tac
      x="v"
      in bexI)
   apply(rename_tac xa v xb)(*strict*)
   apply(rule_tac
      t="v@rev xa"
      and s="xb"
      in ssubst)
    apply(rename_tac xa v xb)(*strict*)
    apply(rule rev_inj)
    apply(clarsimp)
   apply(rename_tac xa v xb)(*strict*)
   apply(force)
  apply(rename_tac xa v xb)(*strict*)
  apply(clarsimp)
  done

lemma right_quotient_to_left_quotient: "
  right_quotient A B = rev ` (left_quotient (rev ` B) (rev ` A))"
  apply(simp add: left_quotient_def right_quotient_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac x v)(*strict*)
   apply(rule inMap)
   apply(rule_tac
      x="rev x"
      in bexI)
    apply(rename_tac x v)(*strict*)
    apply(clarsimp)
   apply(rename_tac x v)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      x="v"
      in bexI)
    apply(rename_tac x v)(*strict*)
    apply(rule inMap)
    apply(rule_tac
      x="x@v"
      in bexI)
     apply(rename_tac x v)(*strict*)
     apply(force)
    apply(rename_tac x v)(*strict*)
    apply(force)
   apply(rename_tac x v)(*strict*)
   apply(force)
  apply(clarsimp)
  apply(rename_tac xa v xb)(*strict*)
  apply(rule_tac
      x="v"
      in bexI)
   apply(rename_tac xa v xb)(*strict*)
   apply(rule_tac
      t="rev xa@v"
      and s="xb"
      in ssubst)
    apply(rename_tac xa v xb)(*strict*)
    apply(rule rev_inj)
    apply(clarsimp)
   apply(rename_tac xa v xb)(*strict*)
   apply(force)
  apply(rename_tac xa v xb)(*strict*)
  apply(clarsimp)
  done

lemma apply_controllability: "
  append_alphabet A \<Sigma>UC \<inter> L \<subseteq> A
  \<Longrightarrow> w \<in> A
  \<Longrightarrow> u \<in> \<Sigma>UC
  \<Longrightarrow> w @ [u] \<in> L
  \<Longrightarrow> w @ [u] \<in> A"
  apply(simp add: append_alphabet_def append_language_def alphabet_to_language_def)
  apply(force)
  done

lemma star_controllable_language_vs_controllable_language_hlp2: "
  L = prefix_closure L
  \<Longrightarrow> (append_alphabet A \<Sigma>UC) \<inter> L \<subseteq> A
  \<Longrightarrow> a @ b \<in> L
  \<Longrightarrow> a \<in> A
  \<Longrightarrow> b \<in> (kleene_star \<Sigma>UC)
  \<Longrightarrow> a @ b \<in> L \<and> set b \<subseteq> \<Sigma>UC \<longrightarrow> a @ b \<in> A"
  apply(rule_tac
      P="\<lambda>v. a @ v \<in> L \<and> set v \<subseteq> \<Sigma>UC \<longrightarrow> a @ v \<in> A"
      in rev_induct)
   apply(simp)
  apply(rename_tac x xs)(*strict*)
  apply(rule impI)
  apply(erule conjE)
  apply(erule impE)
   apply(rename_tac x xs)(*strict*)
   apply(rule conjI)
    apply(rename_tac x xs)(*strict*)
    apply(rule_tac
      L="L"
      and w="a @ xs"
      and v="[x]"
      in prefixExists)
     apply(rename_tac x xs)(*strict*)
     apply(simp)
    apply(rename_tac x xs)(*strict*)
    apply(simp)
   apply(rename_tac x xs)(*strict*)
   apply(simp)
  apply(rename_tac x xs)(*strict*)
  apply(simp)
  apply(drule_tac
      A="A"
      and \<Sigma>UC="\<Sigma>UC"
      and L="L"
      and w="a @ xs"
      and u="x"
      in apply_controllability)
     apply(rename_tac x xs)(*strict*)
     apply(force)
    apply(rename_tac x xs)(*strict*)
    apply(force)
   apply(rename_tac x xs)(*strict*)
   apply(force)
  apply(rename_tac x xs)(*strict*)
  apply(force)
  done

lemma star_controllable_language_vs_controllable_language_hlp1: "
  L = prefix_closure L
  \<Longrightarrow> (append_alphabet A \<Sigma>UC) \<inter> L \<subseteq> A
  \<Longrightarrow> x \<in> append_language A (kleene_star \<Sigma>UC)
  \<Longrightarrow> x \<in> L
  \<Longrightarrow> x \<in> A"
  apply(simp add: append_alphabet_def append_language_def)
  apply(clarsimp)
  apply(rename_tac a b)(*strict*)
  apply(subgoal_tac "X" for X)
   apply(rename_tac a b)(*strict*)
   prefer 2
   apply(rule_tac
      L="L"
      and A="A"
      in star_controllable_language_vs_controllable_language_hlp2)
       apply(rename_tac a b)(*strict*)
       apply(force)
      apply(rename_tac a b)(*strict*)
      apply(simp add: append_alphabet_def append_language_def)
     apply(rename_tac a b)(*strict*)
     apply(force)
    apply(rename_tac a b)(*strict*)
    apply(force)
   apply(rename_tac a b)(*strict*)
   apply(force)
  apply(rename_tac a b)(*strict*)
  apply(erule impE)
   apply(rename_tac a b)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac a b)(*strict*)
  apply(clarsimp)
  apply(rename_tac a b x)(*strict*)
  apply(simp add: kleene_star_def)
  apply(force)
  done

corollary star_controllable_language_implies_controllable_language: "
  star_controllable_language A \<Sigma>UC L
  \<Longrightarrow> controllable_language A \<Sigma>UC L"
  apply(simp add: star_controllable_language_def controllable_language_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac v s)(*strict*)
  apply(force)
  done

corollary controllable_language_implies_star_controllable_language: "
  L = prefix_closure L
  \<Longrightarrow> controllable_language A \<Sigma>UC L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L"
  apply(simp add: star_controllable_language_def controllable_language_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(rule star_controllable_language_vs_controllable_language_hlp1)
     apply(rename_tac x)(*strict*)
     apply(force)
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

corollary star_controllable_language_vs_controllable_language: "
  L = prefix_closure L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L \<longleftrightarrow> controllable_language A \<Sigma>UC L"
  apply(rule antisym)
   apply(clarsimp)
   apply(rule star_controllable_language_implies_controllable_language)
   apply(force)
  apply(clarsimp)
  apply(rule controllable_language_implies_star_controllable_language)
   apply(force)
  apply(force)
  done

corollary star_controllable_language_implies_equal_star_controllable_language: "
  A \<subseteq> L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L
  \<Longrightarrow> equal_star_controllable_language A \<Sigma>UC L"
  apply(simp add: star_controllable_language_def equal_star_controllable_language_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
  apply(rule conjI)
   apply(rename_tac x)(*strict*)
   apply(rule_tac
      x="x"
      in bexI)
    apply(rename_tac x)(*strict*)
    apply(rule_tac
      x="[]"
      in exI)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

corollary equal_star_controllable_language_implies_star_controllable_language: "
  equal_star_controllable_language A \<Sigma>UC L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L"
  apply(simp add: star_controllable_language_def equal_star_controllable_language_def)
  done

corollary star_controllable_language_vs_equal_star_controllable_language: "
  A \<subseteq> L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L = equal_star_controllable_language A \<Sigma>UC L"
  apply(rule antisym)
   apply(clarsimp)
   apply(rule star_controllable_language_implies_equal_star_controllable_language)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rule equal_star_controllable_language_implies_star_controllable_language)
  apply(force)
  done

corollary right_quotient_controllable_language_implies_star_controllable_language: "
  L \<subseteq> kleene_star \<Sigma>
  \<Longrightarrow> right_quotient_controllable_language A \<Sigma>UC L \<Sigma>
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L"
  apply(simp add: star_controllable_language_def right_quotient_controllable_language_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp only: append_alphabet_def append_language_def alphabet_to_language_def)
  apply(simp)
  apply(erule bexE)
  apply(rename_tac x a)(*strict*)
  apply(erule bexE)
  apply(rename_tac x a b)(*strict*)
  apply(simp)
  apply(rule_tac
      A="kleene_star \<Sigma>"
      and x="a@b"
      and B="A"
      in complementA)
   apply(rename_tac x a b)(*strict*)
   apply(rule_tac
      A="L"
      and B="kleene_star \<Sigma>"
      in set_rev_mp)
    apply(rename_tac x a b)(*strict*)
    apply(simp)
   apply(rename_tac x a b)(*strict*)
   apply(force)
  apply(rename_tac x a b)(*strict*)
  apply(simp add: right_quotient_def append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac a b)(*strict*)
  apply(blast)
  done

corollary star_controllable_language_implies_equal_right_quotient_controllable_language: "
  L = prefix_closure L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L
  \<Longrightarrow> equal_right_quotient_controllable_language A \<Sigma>UC L \<Sigma>"
  apply(simp only: star_controllable_language_def equal_right_quotient_controllable_language_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(simp add: right_quotient_def append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
   apply(rule conjI)
    apply(clarsimp)
    apply(rename_tac x v)(*strict*)
    apply(force)
   apply(clarsimp)
   apply(rename_tac x v)(*strict*)
   apply(simp add: prefix_closure_def prefix_def)
   apply(force)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: right_quotient_def append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
  apply(simp add: prefix_closure_def prefix_def)
  apply(rule_tac
      x="[]"
      in exI)
  apply(clarsimp)
  done

corollary equal_right_quotient_controllable_language_implies_right_quotient_controllable_language: "
  equal_right_quotient_controllable_language A \<Sigma>UC L \<Sigma>
  \<Longrightarrow> right_quotient_controllable_language A \<Sigma>UC L \<Sigma>"
  apply(simp add: equal_right_quotient_controllable_language_def right_quotient_controllable_language_def)
  done

end


(*
  File:     Error_Function.thy
  Author:   Manuel Eberl, TU München

  The complex and real error function (most results are on the real error function though)
*)
section \<open>The complex and real error function\<close>
theory Error_Function
  imports "HOL-Complex_Analysis.Complex_Analysis" "HOL-Library.Landau_Symbols"
begin

subsection \<open>Auxiliary Facts\<close>

lemma tendsto_sandwich_mono:
  assumes "(\<lambda>n. f (real n)) \<longlonglongrightarrow> (c::real)"
  assumes "eventually (\<lambda>x. \<forall>y z. x \<le> y \<and> y \<le> z \<longrightarrow> f y \<le> f z) at_top"
  shows   "(f \<longlongrightarrow> c) at_top"
proof (rule tendsto_sandwich)
  from assms(2) obtain C where C: "\<And>x y. C \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
    by (auto simp: eventually_at_top_linorder)
  show "eventually (\<lambda>x. f (real (nat \<lfloor>x\<rfloor>)) \<le> f x) at_top"
    using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
    by eventually_elim (rule C, linarith+)
  show "eventually (\<lambda>x. f (real (Suc (nat \<lfloor>x\<rfloor>))) \<ge> f x) at_top"
    using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
    by eventually_elim (rule C, linarith+)
qed (auto intro!: filterlim_compose[OF assms(1)]
                  filterlim_compose[OF filterlim_nat_sequentially]
                  filterlim_compose[OF filterlim_Suc] filterlim_floor_sequentially
          simp del: of_nat_Suc)

lemma tendsto_sandwich_antimono:
  assumes "(\<lambda>n. f (real n)) \<longlonglongrightarrow> (c::real)"
  assumes "eventually (\<lambda>x. \<forall>y z. x \<le> y \<and> y \<le> z \<longrightarrow> f y \<ge> f z) at_top"
  shows   "(f \<longlongrightarrow> c) at_top"
proof (rule tendsto_sandwich)
  from assms(2) obtain C where C: "\<And>x y. C \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
    by (auto simp: eventually_at_top_linorder)
  show "eventually (\<lambda>x. f (real (nat \<lfloor>x\<rfloor>)) \<ge> f x) at_top"
    using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
    by eventually_elim (rule C, linarith+)
  show "eventually (\<lambda>x. f (real (Suc (nat \<lfloor>x\<rfloor>))) \<le> f x) at_top"
    using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
    by eventually_elim (rule C, linarith+)
qed (auto intro!: filterlim_compose[OF assms(1)]
                  filterlim_compose[OF filterlim_nat_sequentially]
                  filterlim_compose[OF filterlim_Suc] filterlim_floor_sequentially
          simp del: of_nat_Suc)

lemma has_bochner_integral_completion [intro]:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  shows "has_bochner_integral M f I \<Longrightarrow> has_bochner_integral (completion M) f I"
  by (auto simp: has_bochner_integral_iff integrable_completion integral_completion
                 borel_measurable_integrable)

lemma has_bochner_integral_imp_has_integral:
  "has_bochner_integral lebesgue (\<lambda>x. indicator S x *\<^sub>R f x) I \<Longrightarrow>
     (f has_integral (I :: 'b :: euclidean_space)) S"
  using has_integral_set_lebesgue[of S f]
  by (simp add: has_bochner_integral_iff set_integrable_def set_lebesgue_integral_def)

lemma has_bochner_integral_imp_has_integral':
  "has_bochner_integral lborel (\<lambda>x. indicator S x *\<^sub>R f x) I \<Longrightarrow>
     (f has_integral (I :: 'b :: euclidean_space)) S"
  by (intro has_bochner_integral_imp_has_integral has_bochner_integral_completion)

lemma has_bochner_integral_erf_aux:
  "has_bochner_integral lborel (\<lambda>x. indicator {0..} x *\<^sub>R exp (- x\<^sup>2)) (sqrt pi / 2)"
proof -
  let ?pI = "\<lambda>f. (\<integral>\<^sup>+s. f (s::real) * indicator {0..} s \<partial>lborel)"
  let ?gauss = "\<lambda>x. exp (- x\<^sup>2)"
  let ?I = "indicator {0<..} :: real \<Rightarrow> real"
  let ?ff= "\<lambda>x s. x * exp (- x\<^sup>2 * (1 + s\<^sup>2)) :: real"
  have *: "?pI ?gauss = (\<integral>\<^sup>+x. ?gauss x * ?I x \<partial>lborel)"
    by (intro nn_integral_cong_AE AE_I[where N="{0}"]) (auto split: split_indicator)

  have "?pI ?gauss * ?pI ?gauss = (\<integral>\<^sup>+x. \<integral>\<^sup>+s. ?gauss x * ?gauss s * ?I s * ?I x \<partial>lborel \<partial>lborel)"
    by (auto simp: nn_integral_cmult[symmetric] nn_integral_multc[symmetric] *
                   ennreal_mult[symmetric] intro!: nn_integral_cong split: split_indicator)
  also have "\<dots> = (\<integral>\<^sup>+x. \<integral>\<^sup>+s. ?ff x s * ?I s * ?I x \<partial>lborel \<partial>lborel)"
  proof (rule nn_integral_cong, cases)
    fix x :: real assume "x \<noteq> 0"
    then show "(\<integral>\<^sup>+s. ?gauss x * ?gauss s * ?I s * ?I x \<partial>lborel) =
                 (\<integral>\<^sup>+s. ?ff x s * ?I s * ?I x \<partial>lborel)"
      by (subst nn_integral_real_affine[where t="0" and c="x"])
         (auto simp: mult_exp_exp nn_integral_cmult[symmetric] field_simps zero_less_mult_iff ennreal_mult[symmetric]
               intro!: nn_integral_cong split: split_indicator)
  qed simp
  also have "... = \<integral>\<^sup>+s. \<integral>\<^sup>+x. ?ff x s * ?I s * ?I x \<partial>lborel \<partial>lborel"
    by (rule lborel_pair.Fubini'[symmetric]) auto
  also have "... = ?pI (\<lambda>s. ?pI (\<lambda>x. ?ff x s))"
    by (rule nn_integral_cong_AE)
       (auto intro!: nn_integral_cong_AE AE_I[where N="{0}"] split: split_indicator_asm)
  also have "\<dots> = ?pI (\<lambda>s. ennreal (1 / (2 * (1 + s\<^sup>2))))"
  proof (intro nn_integral_cong ennreal_mult_right_cong)
    fix s :: real show "?pI (\<lambda>x. ?ff x s) = ennreal (1 / (2 * (1 + s\<^sup>2)))"
    proof (subst nn_integral_FTC_atLeast)
      have "((\<lambda>a. - (exp (- ((1 + s\<^sup>2) * a\<^sup>2)) / (2 + 2 * s\<^sup>2))) \<longlongrightarrow> (- (0 / (2 + 2 * s\<^sup>2)))) at_top"
        by (intro tendsto_intros filterlim_compose[OF exp_at_bot]
                  filterlim_compose[OF filterlim_uminus_at_bot_at_top]
                  filterlim_tendsto_pos_mult_at_top)
           (auto intro!: filterlim_at_top_mult_at_top[OF filterlim_ident filterlim_ident]
                 simp: add_pos_nonneg  power2_eq_square add_nonneg_eq_0_iff)
      then show "((\<lambda>a. - (exp (- a\<^sup>2 - s\<^sup>2 * a\<^sup>2) / (2 + 2 * s\<^sup>2))) \<longlongrightarrow> 0) at_top"
        by (simp add: field_simps)
    qed (auto intro!: derivative_eq_intros simp: field_simps add_nonneg_eq_0_iff)
  qed
  also have "... = ennreal (pi / 4)"
  proof (subst nn_integral_FTC_atLeast)
    show "((\<lambda>a. arctan a / 2) \<longlongrightarrow> (pi / 2) / 2 ) at_top"
      by (intro tendsto_intros) (simp_all add: tendsto_arctan_at_top)
  qed (auto intro!: derivative_eq_intros simp: add_nonneg_eq_0_iff field_simps power2_eq_square)
  finally have "?pI ?gauss^2 = pi / 4"
    by (simp add: power2_eq_square)
  then have "?pI ?gauss = sqrt (pi / 4)"
    using power_eq_iff_eq_base[of 2 "enn2real (?pI ?gauss)" "sqrt (pi / 4)"]
    by (cases "?pI ?gauss") (auto simp: power2_eq_square ennreal_mult[symmetric] ennreal_top_mult)
  also have "?pI ?gauss = (\<integral>\<^sup>+x. indicator {0..} x *\<^sub>R exp (- x\<^sup>2) \<partial>lborel)"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also have "sqrt (pi / 4) = sqrt pi / 2"
    by (simp add: real_sqrt_divide)
  finally show ?thesis
    by (rule has_bochner_integral_nn_integral[rotated 3])
       auto
qed

lemma contour_integrable_on_linepath_neg_exp_squared [simp, intro]:
  "(\<lambda>t. exp (-(t^2))) contour_integrable_on linepath 0 z"
  by (auto intro!: contour_integrable_continuous_linepath continuous_intros)

lemma holomorphic_on_chain:
  "g holomorphic_on t \<Longrightarrow> f holomorphic_on s \<Longrightarrow> f ` s \<subseteq> t \<Longrightarrow>
    (\<lambda>x. g (f x)) holomorphic_on s"
  using holomorphic_on_compose_gen[of f s g t] by (simp add: o_def)

lemma holomorphic_on_chain_UNIV:
  "g holomorphic_on UNIV \<Longrightarrow> f holomorphic_on s\<Longrightarrow>
    (\<lambda>x. g (f x)) holomorphic_on s"
  using holomorphic_on_compose_gen[of f s g UNIV] by (simp add: o_def)

lemmas holomorphic_on_exp' [holomorphic_intros] =
  holomorphic_on_exp [THEN holomorphic_on_chain_UNIV]

lemma leibniz_rule_field_derivative_real:
  fixes f::"'a::{real_normed_field, banach} \<Rightarrow> real \<Rightarrow> 'a"
  assumes fx: "\<And>x t. x \<in> U \<Longrightarrow> t \<in> {a..b} \<Longrightarrow> ((\<lambda>x. f x t) has_field_derivative fx x t) (at x within U)"
  assumes integrable_f2: "\<And>x. x \<in> U \<Longrightarrow> (f x) integrable_on {a..b}"
  assumes cont_fx: "continuous_on (U \<times> {a..b}) (\<lambda>(x, t). fx x t)"
  assumes U: "x0 \<in> U" "convex U"
  shows "((\<lambda>x. integral {a..b} (f x)) has_field_derivative integral {a..b} (fx x0)) (at x0 within U)"
  using leibniz_rule_field_derivative[of U a b f fx x0] assms by simp

lemma has_vector_derivative_linepath_within [derivative_intros]:
  assumes [derivative_intros]:
    "(f has_vector_derivative f') (at x within S)" "(g has_vector_derivative g') (at x within S)"
    "(h has_real_derivative h') (at x within S)"
  shows "((\<lambda>x. linepath (f x) (g x) (h x)) has_vector_derivative
           (1 - h x) *\<^sub>R f' + h x *\<^sub>R g' - h' *\<^sub>R (f x - g x)) (at x within S)"
  unfolding linepath_def [abs_def]
  by (auto intro!: derivative_eq_intros simp: field_simps scaleR_diff_right)

lemma has_field_derivative_linepath_within [derivative_intros]:
  assumes [derivative_intros]:
    "(f has_field_derivative f') (at x within S)" "(g has_field_derivative g') (at x within S)"
    "(h has_real_derivative h') (at x within S)"
  shows "((\<lambda>x. linepath (f x) (g x) (h x)) has_field_derivative
           (1 - h x) *\<^sub>R f' + h x *\<^sub>R g' - h' *\<^sub>R (f x - g x)) (at x within S)"
  unfolding linepath_def [abs_def]
  by (auto intro!: derivative_eq_intros simp: field_simps scaleR_diff_right)

lemma continuous_on_linepath' [continuous_intros]:
  assumes [continuous_intros]: "continuous_on A f" "continuous_on A g" "continuous_on A h"
  shows   "continuous_on A (\<lambda>x. linepath (f x) (g x) (h x))"
  using assms unfolding linepath_def by (auto intro!: continuous_intros)

subsection \<open>Definition of the error function\<close>

definition erf_coeffs :: "nat \<Rightarrow> real" where
  "erf_coeffs n =
     (if odd n then 2 / sqrt pi * (-1) ^ (n div 2) / (of_nat n * fact (n div 2))
      else 0)"

lemma summable_erf:
  fixes z :: "'a :: {real_normed_div_algebra, banach}"
  shows "summable (\<lambda>n. of_real (erf_coeffs n) * z ^ n)"
proof -
  define b where "b = (\<lambda>n. 2 / sqrt pi * (if odd n then inverse (fact (n div 2)) else 0))"
  show ?thesis
  proof (rule summable_comparison_test[OF exI[of _ 1]], clarify)
    fix n :: nat assume n: "n \<ge> 1"
    hence "norm (of_real (erf_coeffs n) * z ^ n) \<le> b n * norm z ^ n"
      unfolding norm_mult norm_power erf_coeffs_def b_def
      by (intro mult_right_mono) (auto simp: field_simps norm_divide abs_mult)
    thus "norm (of_real (erf_coeffs n) * z ^ n) \<le> b n * norm z ^ n"
      by (simp add: mult_ac)
  next
    have "summable (\<lambda>n. (norm z * 2 / sqrt pi) * (inverse (fact n) * norm z ^ (2*n)))"
      (is "summable ?c") unfolding power_mult by (intro summable_mult summable_exp)
    also have "?c = (\<lambda>n. b (2*n+1) * norm z ^ (2*n+1))"
      unfolding b_def by (auto simp: fun_eq_iff b_def)
    also have "summable \<dots> \<longleftrightarrow> summable (\<lambda>n. b n * norm z ^ n)"
      using summable_mono_reindex [of "\<lambda>n. 2*n+1"]
      by (intro summable_mono_reindex [of "\<lambda>n. 2*n+1"])
         (auto elim!: oddE simp: strict_mono_def b_def)
    finally show \<dots> .
  qed
qed

definition erf :: "('a :: {real_normed_field, banach}) \<Rightarrow> 'a" where
  "erf z = (\<Sum>n. of_real (erf_coeffs n) * z ^ n)"

lemma erf_converges: "(\<lambda>n. of_real (erf_coeffs n) * z ^ n) sums erf z"
  using summable_erf by (simp add: sums_iff erf_def)

lemma erf_0 [simp]: "erf 0 = 0"
  unfolding erf_def powser_zero by (simp add: erf_coeffs_def)

lemma erf_minus [simp]: "erf (-z) = - erf z"
  unfolding erf_def
  by (subst suminf_minus [OF summable_erf, symmetric], rule suminf_cong)
     (simp_all add: erf_coeffs_def)

lemma erf_of_real [simp]: "erf (of_real x) = of_real (erf x)"
  unfolding erf_def using summable_erf[of x]
  by (subst suminf_of_real) (simp_all add: summable_erf)

lemma of_real_erf_numeral [simp]: "of_real (erf (numeral n)) = erf (numeral n)"
  by (simp only: erf_of_real [symmetric] of_real_numeral)

lemma of_real_erf_1 [simp]: "of_real (erf 1) = erf 1"
  by (simp only: erf_of_real [symmetric] of_real_1)

lemma erf_has_field_derivative:
  "(erf has_field_derivative of_real (2 / sqrt pi) * exp (-(z^2))) (at z within A)"
proof -
    define a' where "a' = (\<lambda>n. 2 / sqrt pi *
     (if even n then (- 1) ^ (n div 2) / fact (n div 2) else 0))"

  have "(erf has_field_derivative
           (\<Sum>n. diffs (\<lambda>n. of_real (erf_coeffs n)) n * z ^ n)) (at z)"
    using summable_erf unfolding erf_def by (rule termdiffs_strong_converges_everywhere)
  also have "diffs (\<lambda>n. of_real (erf_coeffs n)) = (\<lambda>n. of_real (a' n) :: 'a)"
    by (simp add: erf_coeffs_def a'_def diffs_def fun_eq_iff del: of_nat_Suc)
  hence "(\<Sum>n. diffs (\<lambda>n. of_real (erf_coeffs n)) n * z ^ n) =
           (\<Sum>n. of_real (a' n) * z ^ n)" by simp
  also have "\<dots> = (\<Sum>n. of_real (a' (2*n)) * z ^ (2*n))"
    by (intro suminf_mono_reindex [symmetric]) (auto simp: strict_mono_def a'_def elim!: evenE)
  also have "(\<lambda>n. of_real (a' (2*n)) * z ^ (2*n)) =
               (\<lambda>n. of_real (2 / sqrt pi) * (inverse (fact n) * (-(z^2))^n))"
    by (simp add: fun_eq_iff power_mult [symmetric] a'_def field_simps power_minus')
  also have "suminf \<dots> = of_real (2 / sqrt pi) * exp (-(z^2))"
    by (subst suminf_mult, intro summable_exp)
       (auto simp: field_simps scaleR_conv_of_real exp_def)
  finally show ?thesis by (rule DERIV_subset) simp_all
qed

lemmas erf_has_field_derivative' [derivative_intros] =
  erf_has_field_derivative [THEN DERIV_chain2]

lemma erf_continuous_on: "continuous_on A erf"
  by (rule DERIV_continuous_on erf_has_field_derivative)+

lemma continuous_on_compose2_UNIV:
  "continuous_on UNIV g \<Longrightarrow> continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. g (f x))"
  by (rule continuous_on_compose2[of UNIV g s f]) simp_all

lemmas erf_continuous_on' [continuous_intros] =
  erf_continuous_on [THEN continuous_on_compose2_UNIV]

lemma erf_continuous [continuous_intros]: "continuous (at x within A) erf"
  by (rule continuous_within_subset[OF _ subset_UNIV])
     (insert erf_continuous_on[of UNIV], auto simp: continuous_on_eq_continuous_at)

lemmas erf_continuous' [continuous_intros] =
  continuous_within_compose2[OF _ erf_continuous]

lemmas tendsto_erf [tendsto_intros] = isCont_tendsto_compose[OF erf_continuous]

lemma erf_cnj [simp]: "erf (cnj z) = cnj (erf z)"
proof -
  interpret bounded_linear cnj by (rule bounded_linear_cnj)
  from suminf[OF summable_erf] show ?thesis by (simp add: erf_def erf_coeffs_def)
qed

lemma integral_exp_minus_squared_real:
  assumes "a \<le> b"
  shows   "((\<lambda>t. exp (-(t^2))) has_integral (sqrt pi / 2 * (erf b - erf a))) {a..b}"
proof -
  have "((\<lambda>t. exp (-(t^2))) has_integral (sqrt pi / 2 * erf b - sqrt pi / 2 * erf a)) {a..b}"
    using assms
    by (intro fundamental_theorem_of_calculus)
       (auto intro!: derivative_eq_intros
             simp: has_field_derivative_iff_has_vector_derivative [symmetric])
  thus ?thesis by (simp add: field_simps)
qed

lemma erf_real_altdef_nonneg:
  "x \<ge> 0 \<Longrightarrow> erf (x::real) = 2 / sqrt pi * integral {0..x} (\<lambda>t. exp (-(t^2)))"
  using integral_exp_minus_squared_real[of 0 x]
  by (simp add: has_integral_iff field_simps)

lemma erf_real_altdef_nonpos:
  "x \<le> 0 \<Longrightarrow> erf (x::real) = -2 / sqrt pi * integral {0..-x} (\<lambda>t. exp (-(t^2)))"
  using erf_real_altdef_nonneg[of "-x"] by simp

lemma less_imp_erf_real_less:
  assumes "a < (b::real)"
  shows   "erf a < erf b"
proof -
  from assms have "\<exists>z. z > a \<and> z < b \<and> erf b - erf a = (b - a) * (2 / sqrt pi * exp (- z\<^sup>2))"
    by (intro MVT2) (auto intro!: derivative_eq_intros simp: field_simps)
  then guess z by (elim exE conjE) note z = this
  note z(3)
  also from assms have "(b - a) * (2 / sqrt pi * exp (- z\<^sup>2)) > 0"
    by (intro mult_pos_pos divide_pos_pos) simp_all
  finally show ?thesis by simp
qed

lemma le_imp_erf_real_le: "a \<le> (b::real) \<Longrightarrow> erf a \<le> erf b"
  by (cases "a < b") (auto dest: less_imp_erf_real_less)

lemma erf_real_less_cancel [simp]: "(erf (a :: real) < erf b) \<longleftrightarrow> a < b"
  using less_imp_erf_real_less[of a b] less_imp_erf_real_less[of b a]
  by (cases a b rule: linorder_cases) simp_all

lemma erf_real_eq_iff [simp]: "erf (a::real) = erf b \<longleftrightarrow> a = b"
  by (cases a b rule: linorder_cases) (auto dest: less_imp_erf_real_less)

lemma erf_real_le_cancel [simp]: "(erf (a :: real) \<le> erf b) \<longleftrightarrow> a \<le> b"
  by (cases a b rule: linorder_cases) (auto simp: less_eq_real_def)

lemma inj_on_erf_real [intro]: "inj_on (erf :: real \<Rightarrow> real) A"
  by (auto simp: inj_on_def)

lemma strict_mono_erf_real [intro]: "strict_mono (erf :: real \<Rightarrow> real)"
  by (auto simp: strict_mono_def)

lemma mono_erf_real [intro]: "mono (erf :: real \<Rightarrow> real)"
  by (auto simp: mono_def)

lemma erf_real_ge_0_iff [simp]: "erf (x::real) \<ge> 0 \<longleftrightarrow> x \<ge> 0"
  using erf_real_le_cancel[of 0 x] unfolding erf_0 .

lemma erf_real_le_0_iff [simp]: "erf (x::real) \<le> 0 \<longleftrightarrow> x \<le> 0"
  using erf_real_le_cancel[of x 0] unfolding erf_0 .

lemma erf_real_gt_0_iff [simp]: "erf (x::real) > 0 \<longleftrightarrow> x > 0"
  using erf_real_less_cancel[of 0 x] unfolding erf_0 .

lemma erf_real_less_0_iff [simp]: "erf (x::real) < 0 \<longleftrightarrow> x < 0"
  using erf_real_less_cancel[of x 0] unfolding erf_0 .

lemma erf_at_top [tendsto_intros]: "((erf :: real \<Rightarrow> real) \<longlongrightarrow> 1) at_top"
proof -
  have *: "(\<Union>n. {0..real n}) = {0..}" by (auto intro!: real_nat_ceiling_ge)
  let ?f = "\<lambda>t::real. exp (-t\<^sup>2)"
  have "(\<lambda>n. set_lebesgue_integral lborel {0..real n} ?f)
          \<longlonglongrightarrow> set_lebesgue_integral lborel (\<Union>n. {0..real n}) ?f"
    using has_bochner_integral_erf_aux
    by (intro set_integral_cont_up )
       (insert *, auto simp: incseq_def has_bochner_integral_iff set_integrable_def)
  also note *
  also have "(\<lambda>n. set_lebesgue_integral lborel {0..real n} ?f) = (\<lambda>n. integral {0..real n} ?f)"
  proof -
    have "\<And>n. set_integrable lborel {0..real n} (\<lambda>x. exp (- x\<^sup>2))"
      unfolding set_integrable_def
      by (intro borel_integrable_compact) (auto intro!: continuous_intros)
    then show ?thesis
      by (intro set_borel_integral_eq_integral ext)
  qed
  also have "\<dots> = (\<lambda>n. sqrt pi / 2 * erf (real n))" by (simp add: erf_real_altdef_nonneg)
  also have "set_lebesgue_integral lborel {0..} ?f = sqrt pi / 2"
    using has_bochner_integral_erf_aux by (simp add: has_bochner_integral_iff set_lebesgue_integral_def)
  finally have "(\<lambda>n. 2 / sqrt pi * (sqrt pi / 2 * erf (real n))) \<longlonglongrightarrow>
                  (2 / sqrt pi) * (sqrt pi / 2)" by (intro tendsto_intros)
  hence "(\<lambda>n. erf (real n)) \<longlonglongrightarrow> 1" by simp
  thus ?thesis by (rule tendsto_sandwich_mono) auto
qed

lemma erf_at_bot [tendsto_intros]: "((erf :: real \<Rightarrow> real) \<longlongrightarrow> -1) at_bot"
  by (simp add: filterlim_at_bot_mirror tendsto_minus_cancel_left erf_at_top)

lemmas tendsto_erf_at_top [tendsto_intros] = filterlim_compose[OF erf_at_top]
lemmas tendsto_erf_at_bot [tendsto_intros] = filterlim_compose[OF erf_at_bot]

subsection \<open>The complimentary error function\<close>

definition erfc where "erfc z = 1 - erf z"

lemma erf_conv_erfc: "erf z = 1 - erfc z" by (simp add: erfc_def)

lemma erfc_0 [simp]: "erfc 0 = 1"
  by (simp add: erfc_def)

lemma erfc_minus: "erfc (-z) = 2 - erfc z"
  by (simp add: erfc_def)

lemma erfc_of_real [simp]: "erfc (of_real x) = of_real (erfc x)"
  by (simp add: erfc_def)

lemma of_real_erfc_numeral [simp]: "of_real (erfc (numeral n)) = erfc (numeral n)"
  by (simp add: erfc_def)

lemma of_real_erfc_1 [simp]: "of_real (erfc 1) = erfc 1"
  by (simp add: erfc_def)

lemma less_imp_erfc_real_less: "a < (b::real) \<Longrightarrow> erfc a > erfc b"
  by (simp add: erfc_def)

lemma le_imp_erfc_real_le: "a \<le> (b::real) \<Longrightarrow> erfc a \<ge> erfc b"
  by (simp add: erfc_def)

lemma erfc_real_less_cancel [simp]: "(erfc (a :: real) < erfc b) \<longleftrightarrow> a > b"
  by (simp add: erfc_def)

lemma erfc_real_eq_iff [simp]: "erfc (a::real) = erfc b \<longleftrightarrow> a = b"
  by (simp add: erfc_def)

lemma erfc_real_le_cancel [simp]: "(erfc (a :: real) \<le> erfc b) \<longleftrightarrow> a \<ge> b"
  by (simp add: erfc_def)

lemma inj_on_erfc_real [intro]: "inj_on (erfc :: real \<Rightarrow> real) A"
  by (auto simp: inj_on_def)

lemma antimono_erfc_real [intro]: "antimono (erfc :: real \<Rightarrow> real)"
  by (auto simp: antimono_def)

lemma erfc_real_ge_0_iff [simp]: "erfc (x::real) \<ge> 1 \<longleftrightarrow> x \<le> 0"
  by (simp add: erfc_def)

lemma erfc_real_le_0_iff [simp]: "erfc (x::real) \<le> 1 \<longleftrightarrow> x \<ge> 0"
  by (simp add: erfc_def)

lemma erfc_real_gt_0_iff [simp]: "erfc (x::real) > 1 \<longleftrightarrow> x < 0"
  by (simp add: erfc_def)

lemma erfc_real_less_0_iff [simp]: "erfc (x::real) < 1 \<longleftrightarrow> x > 0"
  by (simp add: erfc_def)

lemma erfc_has_field_derivative:
  "(erfc has_field_derivative -of_real (2 / sqrt pi) * exp (-(z^2))) (at z within A)"
  unfolding erfc_def [abs_def] by (auto intro!: derivative_eq_intros)

lemmas erfc_has_field_derivative' [derivative_intros] =
  erfc_has_field_derivative [THEN DERIV_chain2]

lemma erfc_continuous_on: "continuous_on A erfc"
  by (rule DERIV_continuous_on erfc_has_field_derivative)+

lemmas erfc_continuous_on' [continuous_intros] =
  erfc_continuous_on [THEN continuous_on_compose2_UNIV]

lemma erfc_continuous [continuous_intros]: "continuous (at x within A) erfc"
  by (rule continuous_within_subset[OF _ subset_UNIV])
     (insert erfc_continuous_on[of UNIV], auto simp: continuous_on_eq_continuous_at)

lemmas erfc_continuous' [continuous_intros] =
  continuous_within_compose2[OF _ erfc_continuous]

lemmas tendsto_erfc [tendsto_intros] = isCont_tendsto_compose[OF erfc_continuous]

lemma erfc_at_top [tendsto_intros]: "((erfc :: real \<Rightarrow> real) \<longlongrightarrow> 0) at_top"
  unfolding erfc_def [abs_def] by (auto intro!: tendsto_eq_intros)

lemma erfc_at_bot [tendsto_intros]: "((erfc :: real \<Rightarrow> real) \<longlongrightarrow> 2) at_bot"
  unfolding erfc_def [abs_def] by (auto intro!: tendsto_eq_intros)

lemmas tendsto_erfc_at_top [tendsto_intros] = filterlim_compose[OF erfc_at_top]
lemmas tendsto_erfc_at_bot [tendsto_intros] = filterlim_compose[OF erfc_at_bot]

lemma integrable_exp_minus_squared:
  assumes "A \<subseteq> {0..}" "A \<in> sets lborel"
  shows   "set_integrable lborel A (\<lambda>t::real. exp (-t\<^sup>2))" (is ?thesis1)
    and   "(\<lambda>t::real. exp (-t\<^sup>2)) integrable_on A" (is ?thesis2)
proof -
  show ?thesis1
    by (rule set_integrable_subset[of _ "{0..}"])
       (insert assms has_bochner_integral_erf_aux, auto simp: has_bochner_integral_iff set_integrable_def)
  thus ?thesis2 by (rule set_borel_integral_eq_integral)
qed

lemma
  assumes "x \<ge> 0"
  shows   erfc_real_altdef_nonneg: "erfc x = 2 / sqrt pi * integral {x..} (\<lambda>t. exp (-t\<^sup>2))"
    and   has_integral_erfc:       "((\<lambda>t. exp (-t\<^sup>2)) has_integral (sqrt pi / 2 * erfc x)) {x..}"
proof -
  let ?f = "\<lambda>t::real. exp (-t\<^sup>2)"
  have int: "set_integrable lborel {0..} ?f"
    using has_bochner_integral_erf_aux by (simp add: has_bochner_integral_iff set_integrable_def)
  from assms have *: "{(0::real)..} = {0..x} \<union> {x..}" by auto
  have "set_lebesgue_integral lborel ({0..x} \<union> {x..}) ?f =
               set_lebesgue_integral lborel {0..x} ?f + set_lebesgue_integral lborel {x..} ?f"
    by (subst set_integral_Un_AE; (rule set_integrable_subset[OF int])?)
       (insert assms AE_lborel_singleton[of x], auto elim!: eventually_mono)
  also note * [symmetric]
  also have "set_lebesgue_integral lborel {0..} ?f = sqrt pi / 2"
    using has_bochner_integral_erf_aux by (simp add: has_bochner_integral_iff set_lebesgue_integral_def)
  also have "set_lebesgue_integral lborel {0..x} ?f = sqrt pi / 2 * erf x"
    by (subst set_borel_integral_eq_integral(2)[OF set_integrable_subset[OF int]])
       (insert assms, auto simp: erf_real_altdef_nonneg)
  also have "set_lebesgue_integral lborel {x..} ?f = integral {x..} ?f"
    by (subst set_borel_integral_eq_integral(2)[OF set_integrable_subset[OF int]])
       (insert assms, auto)
  finally show "erfc x = 2 / sqrt pi * integral {x..} ?f" by (simp add: field_simps erfc_def)
  with integrable_exp_minus_squared(2)[of "{x..}"] assms
  show "(?f has_integral (sqrt pi / 2 * erfc x)) {x..}"
    by (simp add: has_integral_iff)
qed

lemma erfc_real_gt_0 [simp, intro]: "erfc (x::real) > 0"
proof (cases "x \<ge> 0")
  case True
  have "0 < integral {x..x+1} (\<lambda>t. exp (-(x+1)\<^sup>2))" by simp
  also from True have "\<dots> \<le> integral {x..x+1} (\<lambda>t. exp (-t\<^sup>2))"
    by (intro integral_le)
       (auto intro!: integrable_continuous_real continuous_intros power_mono)
  also have "\<dots> \<le> sqrt pi / 2 * erfc x"
    by (rule has_integral_subset_le[OF _ integrable_integral has_integral_erfc])
       (auto intro!: integrable_continuous_real continuous_intros True)
  finally have "sqrt pi / 2 * erfc x > 0" .
  hence "\<dots> * (2 / sqrt pi) > 0" by (rule mult_pos_pos) simp_all
  thus "erfc x > 0" by simp
next
  case False
  have "0 \<le> (1::real)" by simp
  also from False have "\<dots> < erfc x" by simp
  finally show ?thesis .
qed

lemma erfc_real_less_2 [intro]: "erfc (x::real) < 2"
  using erfc_real_gt_0[of "-x"] unfolding erfc_minus by simp

lemma erf_real_gt_neg1 [intro]: "erf (x::real) > -1"
  using erfc_real_less_2[of x] unfolding erfc_def by simp

lemma erf_real_less_1 [intro]: "erf (x::real) < 1"
  using erfc_real_gt_0[of x] unfolding erfc_def by simp

lemma erfc_cnj [simp]: "erfc (cnj z) = cnj (erfc z)"
  by (simp add: erfc_def)

subsection \<open>Specific facts about the complex case\<close>

lemma erf_complex_altdef:
  "erf z = of_real (2 / sqrt pi) * contour_integral (linepath 0 z) (\<lambda>t. exp (-(t^2)))"
proof -
  define A where "A = (\<lambda>z. contour_integral (linepath 0 z) (\<lambda>t. exp (-(t^2))))"
  have [derivative_intros]: "(A has_field_derivative exp (-(z^2))) (at z)" for z :: complex
    unfolding A_def
    by (rule contour_integral_has_field_derivative[where A = UNIV])
       (auto intro!: holomorphic_intros)
  have "erf z - 2 / sqrt pi * A z = erf 0 - 2 / sqrt pi * A 0"
    by (rule has_derivative_zero_unique [where f = "\<lambda>z. erf z - 2 / sqrt pi * A z" and s = UNIV])
       (auto intro!: has_field_derivative_imp_has_derivative derivative_eq_intros)
  also have "A 0 = 0" by (simp only: A_def contour_integral_trivial)
  finally show ?thesis unfolding A_def by (simp add: algebra_simps)
qed

lemma erf_holomorphic_on: "erf holomorphic_on A"
  by (auto simp: holomorphic_on_def field_differentiable_def intro!: erf_has_field_derivative)

lemmas erf_holomorphic_on' [holomorphic_intros] =
  erf_holomorphic_on [THEN holomorphic_on_chain_UNIV]

lemma erf_analytic_on: "erf analytic_on A"
  by (auto simp: analytic_on_def) (auto intro!: exI[of _ 1] holomorphic_intros)

lemma erf_analytic_on'  [analytic_intros]:
  assumes "f analytic_on A"
  shows   "(\<lambda>x. erf (f x)) analytic_on A"
proof -
  from assms and erf_analytic_on have "erf \<circ> f analytic_on A"
    by (rule analytic_on_compose_gen) auto
  thus ?thesis by (simp add: o_def)
qed

lemma erfc_holomorphic_on: "erfc holomorphic_on A"
  by (auto simp: holomorphic_on_def field_differentiable_def intro!: erfc_has_field_derivative)

lemmas erfc_holomorphic_on' [holomorphic_intros] =
  erfc_holomorphic_on [THEN holomorphic_on_chain_UNIV]

lemma erfc_analytic_on: "erfc analytic_on A"
  by (auto simp: analytic_on_def) (auto intro!: exI[of _ 1] holomorphic_intros)

lemma erfc_analytic_on' [analytic_intros]:
  assumes "f analytic_on A"
  shows   "(\<lambda>x. erfc (f x)) analytic_on A"
proof -
  from assms and erfc_analytic_on have "erfc \<circ> f analytic_on A"
    by (rule analytic_on_compose_gen) auto
  thus ?thesis by (simp add: o_def)
qed

end


theory Worklist_Algorithms_Misc
  imports "HOL-Library.Multiset"
begin

lemma mset_eq_empty_iff:
  "M = {#} \<longleftrightarrow> set_mset M = {}"
  by auto

lemma filter_mset_eq_empty_iff:
  "{#x \<in># A. P x#} = {#} \<longleftrightarrow> (\<forall>x \<in> set_mset A. \<not> P x)"
  by (auto simp: mset_eq_empty_iff)

end