section \<open>Core Lens Laws\<close>

theory Lens_Laws
imports
  Two Interp
begin

subsection \<open>Lens signature\<close>

record ('a, 'b) lens =
  lens_get :: "'b \<Rightarrow> 'a" ("get\<index>")
  lens_put :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("put\<index>")

type_notation
  lens (infixr "\<Longrightarrow>" 0)

text {*
  \begin{figure}
  \begin{center}
    \includegraphics[width=3.5cm]{figures/Lens}
  \end{center}
  \vspace{-5ex}
  \caption{Visualisation of a simple lens}
  \label{fig:Lens}
  \end{figure}

  A lens $X : \view \lto \src$, for source type $\src$ and view type $\view$, identifies
  $\view$ with a subregion of $\src$~\cite{Foster07,Foster09}, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes
  $X$ and the hatched area denotes the subregion $\view$ it characterises. Transformations on
  $\view$ can be performed without affecting the parts of $\src$ outside the hatched area. The lens
  signature consists of a pair of functions $\lget_X : \src \Rightarrow \view$ that extracts a view
  from a source, and $\lput_X : \src \Rightarrow \view \Rightarrow \src$ that updates a view within
  a given source. *}

named_theorems lens_defs

definition lens_create :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("create\<index>") where
[lens_defs]: "create\<^bsub>X\<^esub> v = put\<^bsub>X\<^esub> undefined v"

text {* Function $\lcreate_X~v$ creates an instance of the source type of $X$ by injecting $v$
  as the view, and leaving the remaining context arbitrary. *}

subsection \<open>Weak lenses\<close>

text {* Weak lenses are the least constrained class of lenses in our algebraic hierarchy. They
  simply require that the PutGet law~\cite{Foster09,Fischer2015} is satisfied, meaning that
  $\lget$ is the inverse of $\lput$. *}

locale weak_lens =
  fixes x :: "'a \<Longrightarrow> 'b" (structure)
  assumes put_get: "get (put \<sigma> v) = v"
begin

  lemma create_get: "get (create v) = v"
    by (simp add: lens_create_def put_get)

  lemma create_inj: "inj create"
    by (metis create_get injI)

  definition update :: "('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b)" where
  [lens_defs]: "update f \<sigma> = put \<sigma> (f (get \<sigma>))"

  lemma get_update: "get (update f \<sigma>) = f (get \<sigma>)"
    by (simp add: put_get update_def)

  lemma view_determination: "put \<sigma> u = put \<rho> v \<Longrightarrow> u = v"
    by (metis put_get)

  lemma put_inj: "inj (put \<sigma>)"
    by (simp add: injI view_determination)
end

declare weak_lens.put_get [simp]
declare weak_lens.create_get [simp]

subsection \<open>Well-behaved lenses\<close>

text {* Well-behaved lenses add to weak lenses that requirement that the GetPut law~\cite{Foster09,Fischer2015}
  is satisfied, meaning that $\lput$ is the inverse of $\lget$. *}

locale wb_lens = weak_lens +
  assumes get_put: "put \<sigma> (get \<sigma>) = \<sigma>"
begin

  lemma put_twice: "put (put \<sigma> v) v = put \<sigma> v"
    by (metis get_put put_get)

  lemma put_surjectivity: "\<exists> \<rho> v. put \<rho> v = \<sigma>"
    using get_put by blast

  lemma source_stability: "\<exists> v. put \<sigma> v = \<sigma>"
    using get_put by auto

end

declare wb_lens.get_put [simp]

lemma wb_lens_weak [simp]: "wb_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: wb_lens_def)

subsection {* Mainly well-behaved lenses *}

text {* Mainly well-behaved lenses extend weak lenses with the PutPut law that shows how one put
  override a previous one. *}

locale mwb_lens = weak_lens +
  assumes put_put: "put (put \<sigma> v) u = put \<sigma> u"
begin

end

declare mwb_lens.put_put [simp]

lemma mwb_lens_weak [simp]:
  "mwb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: mwb_lens_def)

subsection \<open>Very well-behaved lenses\<close>

text \<open>Very well-behaved lenses combine all three laws, as in the literature~\cite{Foster09,Fischer2015}.\<close>

locale vwb_lens = wb_lens + mwb_lens
begin

  lemma source_determination:"get \<sigma> = get \<rho> \<Longrightarrow> put \<sigma> v = put \<rho> v \<Longrightarrow> \<sigma> = \<rho>"
    by (metis get_put put_put)

 lemma put_eq:
   "\<lbrakk> get \<sigma> = k; put \<sigma> u = put \<rho> v \<rbrakk> \<Longrightarrow> put \<rho> k = \<sigma>"
   by (metis get_put put_put)

end

lemma vwb_lens_wb [simp]: "vwb_lens x \<Longrightarrow> wb_lens x"
  by (simp_all add: vwb_lens_def)

lemma vwb_lens_mwb [simp]: "vwb_lens x \<Longrightarrow> mwb_lens x"
  by (simp_all add: vwb_lens_def)

subsection {* Ineffectual lenses *}

text \<open>Ineffectual lenses can have no effect on the view type -- application of the $\lput$ function
  always yields the same source. They are trivially very well-behaved lenses.\<close>

locale ief_lens = weak_lens +
  assumes put_inef: "put \<sigma> v = \<sigma>"
begin

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: put_inef)
  show "put (put \<sigma> v) u = put \<sigma> u"
    by (simp add: put_inef)
qed

lemma ineffectual_const_get:
  "\<exists> v.  \<forall> \<sigma>. get \<sigma> = v"
  by (metis create_get lens_create_def put_inef)

end

abbreviation "eff_lens X \<equiv> (weak_lens X \<and> (\<not> ief_lens X))"

subsection {* Bijective lenses *}

text \<open>Bijective lenses characterise the situation where the source and view type are equivalent:
  in other words the view type full characterises the whole source type. This is specified using
  the strong GetPut law~\cite{Foster09,Fischer2015}.\<close>

locale bij_lens = weak_lens +
  assumes strong_get_put: "put \<sigma> (get \<rho>) = \<rho>"
begin

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: strong_get_put)
  show "put (put \<sigma> v) u = put \<sigma> u"
    by (metis put_get strong_get_put)
qed

  lemma put_surj: "surj (put \<sigma>)"
    by (metis strong_get_put surj_def)

  lemma put_bij: "bij (put \<sigma>)"
    by (simp add: bijI put_inj put_surj)

  lemma get_create: "create (get \<sigma>) = \<sigma>"
    by (metis put_get put_is_create source_stability)

end

declare bij_lens.strong_get_put [simp]
declare bij_lens.get_create [simp]

lemma bij_lens_weak [simp]:
  "bij_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: bij_lens_def)

lemma bij_lens_vwb [simp]: "bij_lens x \<Longrightarrow> vwb_lens x"
  by (unfold_locales, simp_all add: bij_lens.put_is_create)

subsection \<open>Lens independence\<close>

text {* Lens independence shows when two lenses $X$ and $Y$ characterise disjoint regions of the
  source type. We specify this by requiring that the $\lput$ functions of the two lenses commute,
  and that the $\lget$ function of each lens is unaffected by application of $\lput$ from the
  corresponding lens. *}

locale lens_indep =
  fixes X :: "'a \<Longrightarrow> 'c" and Y :: "'b \<Longrightarrow> 'c"
  assumes lens_put_comm: "lens_put X (lens_put Y \<sigma> v) u = lens_put Y (lens_put X \<sigma> u) v"
  and lens_put_irr1: "lens_get X (lens_put Y \<sigma> v) = lens_get X \<sigma>"
  and lens_put_irr2: "lens_get Y (lens_put X \<sigma> u) = lens_get Y \<sigma>"

notation lens_indep (infix "\<bowtie>" 50)

lemma lens_indepI:
  "\<lbrakk> \<And> u v \<sigma>. lens_put x (lens_put y \<sigma> v) u = lens_put y (lens_put x \<sigma> u) v;
     \<And> v \<sigma>. lens_get x (lens_put y \<sigma> v) = lens_get x \<sigma>;
     \<And> u \<sigma>. lens_get y (lens_put x \<sigma> u) = lens_get y \<sigma> \<rbrakk> \<Longrightarrow> x \<bowtie> y"
  by (simp add: lens_indep_def)

text \<open>Independence is symmetric.\<close>

lemma lens_indep_sym:  "x \<bowtie> y \<Longrightarrow> y \<bowtie> x"
  by (simp add: lens_indep_def)

lemma lens_indep_comm:
  "x \<bowtie> y \<Longrightarrow> lens_put x (lens_put y \<sigma> v) u = lens_put y (lens_put x \<sigma> u) v"
  by (simp add: lens_indep_def)

lemma lens_indep_get [simp]:
  assumes "x \<bowtie> y"
  shows "lens_get x (lens_put y \<sigma> v) = lens_get x \<sigma>"
  using assms lens_indep_def by fastforce
end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Formalizing the IPv4-address allocation in ZeroConf\<close>

theory Zeroconf_Analysis
  imports "../Discrete_Time_Markov_Chain"
begin

declare UNIV_bool[simp]

subsection \<open>Definition of a ZeroConf allocation run\<close>

datatype zc_state = start
                  | probe nat
                  | ok
                  | error

lemma inj_probe: "inj_on probe X"
  by (auto simp: inj_on_def)

text \<open>Countability of @{typ zc_state} simplifies measurability of functions on @{typ zc_state}.\<close>

instance zc_state :: countable
proof
  have "countable ({start, ok, error} \<union> probe`UNIV)"
    by auto
  also have "{start, ok, error} \<union> probe`UNIV = UNIV"
    using zc_state.nchotomy by auto
  finally show "\<exists>f::zc_state \<Rightarrow> nat. inj f"
    using inj_on_to_nat_on[of "UNIV :: zc_state set"] by auto
qed

locale Zeroconf_Analysis =
  fixes N :: nat and p q r e :: real
  assumes p: "0 < p" "p < 1" and q: "0 < q" "q < 1"
  assumes r[simp]: "0 \<le> r" and e[simp]: "0 \<le> e"
begin

lemma p_bounds[simp]: "0 \<le> p" "p \<le> 1"
  using p by auto

lemma q_bounds[simp]: "0 \<le> q" "q \<le> 1"
  using q by auto

abbreviation states where
  "states \<equiv> probe ` {.. N} \<union> {start, ok, error}"

primrec \<tau> :: "zc_state \<Rightarrow> zc_state pmf" where
  "\<tau> start     = map_pmf (\<lambda>True \<Rightarrow> probe 0 | False \<Rightarrow> ok) (bernoulli_pmf q)"
| "\<tau> (probe n) = map_pmf (\<lambda>True \<Rightarrow> (if n < N then probe (Suc n) else error) | False \<Rightarrow> start) (bernoulli_pmf p)"
| "\<tau> ok        = return_pmf ok"
| "\<tau> error     = return_pmf error"

primrec \<rho> :: "zc_state \<Rightarrow> zc_state \<Rightarrow> real" where
  "\<rho> start     = (\<lambda>_. 0) (probe 0 := r, ok := r * (N + 1))"
| "\<rho> (probe n) = (if n < N then (\<lambda>_. 0) (probe (Suc n) := r) else (\<lambda>_. 0) (error := e))"
| "\<rho> ok        = (\<lambda>_. 0) (ok := 0)"
| "\<rho> error     = (\<lambda>_. 0) (error := 0)"

lemma \<rho>_nonneg'[simp]: "0 \<le> \<rho> s t"
  using r e by (cases s) auto

sublocale MC_with_rewards \<tau> \<rho> "\<lambda>s. 0"
  proof qed (simp_all add: pair_measure_countable)

subsection \<open>The allocation run is a rewarded DTMC\<close>

abbreviation "E s \<equiv> set_pmf (\<tau> s)"

lemma enabled_ok: "enabled ok \<omega> \<longleftrightarrow> \<omega> = sconst ok"
  by (simp add: enabled_iff_sconst)

lemma finite_E[intro, simp]: "finite (E s)"
  by (cases s) auto

lemma enabled_error: "enabled error \<omega> \<longleftrightarrow> \<omega> = sconst error"
  by (simp add: enabled_iff_sconst)

lemma pos_neg_q_pn: "0 < 1 - q * (1 - p^Suc N)"
proof -
  have "p ^ Suc N \<le> 1 ^ Suc N"
    using p by (intro power_mono) auto
  with p q have "q * (1 - p^Suc N) < 1 * 1"
    by (intro mult_strict_mono) (auto simp: field_simps simp del: power_Suc)
  then show ?thesis by simp
qed

lemma to_error: assumes "n \<le> N" shows "(probe n, error) \<in> acc"
  using \<open>n \<le> N\<close>
proof (induction rule: inc_induct)
  case (step n') with p show ?case
    by (intro rtrancl_trans[OF r_into_rtrancl step.IH]) auto
qed (insert p, auto)

subsection \<open>Probability of a erroneous allocation\<close>

definition "P_err s = \<P>(\<omega> in T s. ev (HLD {error}) (s ## \<omega>))"

lemma P_err:
  defines "p_start == (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
  defines "p_probe == (\<lambda>n. p ^ Suc (N - n) + (1 - p^Suc (N - n)) * p_start)"
  assumes s: "s \<in> states - {ok, error}"
  shows "P_err s = (case s of ok \<Rightarrow> 0 | error \<Rightarrow> 1 | probe n \<Rightarrow> p_probe n | start \<Rightarrow> p_start)"
    (is "\<dots> = ?E s")
  using s
proof (rule unique_les)
  have [arith]: "0 \<le> p * (q * p ^ N)"
    using p q by simp
  have p_eq: "p_start = p_probe 0 * q"
    "\<And>n. n < N \<Longrightarrow> p_probe n = p_probe (Suc n) * p + p_start * (1 - p)"
    "p_probe N = p + p_start * (1 - p)"
    using p q
    by (auto simp: p_probe_def p_start_def power_Suc[symmetric] Suc_diff_Suc divide_simps
             simp del: power_Suc)
       (auto simp: field_simps)
  fix s assume s: "s \<in> states - {ok, error}"
  then show "?E s = (\<integral>t. ?E t \<partial>\<tau> s) + 0"
    using p q by (auto intro: p_eq)
  show "\<exists>t\<in>{ok, error}. (s, t) \<in> acc"
    using s q to_error by auto
  from s show "P_err s = integral\<^sup>L (measure_pmf (\<tau> s)) P_err + 0"
    unfolding P_err_def[abs_def] by (subst prob_T) (auto simp: ev_Stream simp del: UNIV_bool)
next
  fix s assume "s \<in> {ok, error}" then show "P_err s = ?E s"
    by (auto intro!: T.prob_eq_0_AE T.prob_Collect_eq_1[THEN iffD2]
             simp: P_err_def AE_sconst ev_sconst HLD_iff ev_Stream T.prob_space
             simp del: space_T sets_T )
qed (insert p q, auto intro!: integrable_measure_pmf_finite split: if_split_asm)

lemma P_err_start: "P_err start = (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
  by (simp add: P_err)

subsection \<open>An allocation run terminates almost surely\<close>

lemma states_closed:
  assumes "s \<in> states"
  assumes "(s, t) \<in> acc_on (- {error, ok})"
  shows "t \<in> states"
  using assms(2,1) p q by induction (auto split: if_split_asm)

lemma finite_reached:
  assumes s: "s \<in> states" shows "finite (acc_on (- {error, ok}) `` {s})"
  using states_closed[OF s]
  by (rule_tac finite_subset[of _ states]) auto

lemma AE_reaches_error_or_ok:
  assumes s: "s \<in> states"
  shows "AE \<omega> in T s. ev (HLD {error, ok}) \<omega>"
proof (rule AE_T_ev_HLD)
  { fix t assume t: "(s, t) \<in> acc_on (- {error, ok})"
    with states_closed[OF s t] to_error p q show "\<exists>t'\<in>{error, ok}. (t, t') \<in> acc"
      by auto }
qed (rule finite_reached[OF s])

subsection \<open>Expected runtime of an allocation run\<close>

definition "R s = (\<integral>\<^sup>+ \<omega>. reward_until {error, ok} s \<omega> \<partial>T s)"

definition "R' s = enn2real (R s)"

lemma R_iter: "s \<noteq> error \<Longrightarrow> s \<noteq> ok \<Longrightarrow> R s = (\<integral>\<^sup>+t. ennreal (\<rho> s t) + R t \<partial>\<tau> s)"
  unfolding R_def using T.emeasure_space_1
  by (subst nn_integral_T)
     (auto simp del: \<tau>.simps \<rho>.simps simp add: AE_measure_pmf_iff nn_integral_add
           intro!: nn_integral_cong_AE)

lemma R_finite:
  assumes s: "s \<in> states"
  shows "R s \<noteq> \<infinity>"
  unfolding R_def
proof (rule nn_integral_reward_until_finite)
  { fix t assume "(s, t) \<in> acc" from this s p q have "t \<in> states"
      by induction (auto split: if_split_asm) }
  then have "acc `` {s} \<subseteq> states"
    by auto
  then show "finite (acc `` {s})"
    by (auto dest: finite_subset)
qed (auto simp: AE_reaches_error_or_ok[OF s])

lemma R_less_top: "s \<in> states \<Longrightarrow> R s < top"
  using R_finite[of s] by (subst less_top[symmetric]) simp

lemma R'_iter: assumes s: "s \<in> states" "s \<noteq> error" "s \<noteq> ok" shows "R' s = (\<integral>t. \<rho> s t + R' t \<partial>\<tau> s)"
  unfolding R'_def R_iter[OF s(2,3)]
proof (rule enn2real_nn_integral_eq_integral)
  have "t \<in> E s \<Longrightarrow> R t < top" for t
    using \<open>s\<in>states\<close> E_closed[of s] by (intro R_less_top) auto
  then show "AE t in \<tau> s. ennreal (\<rho> s t) + R t = ennreal (\<rho> s t + enn2real (R t))"
    by (auto simp: AE_measure_pmf_iff intro!: ennreal_enn2real[symmetric])
  show "(\<integral>\<^sup>+ t. ennreal (\<rho> s t) + R t \<partial>\<tau> s) < \<top>"
    unfolding R_iter[symmetric, OF s(2,3)] by (rule R_less_top) fact
qed auto

lemma cost_from_start:
  "R' start =
    (q * (r + p^Suc N * e + r * p * (1 - p^N) / (1 - p)) + (1 - q) * (r * Suc N)) /
    (1 - q + q * p^Suc N)"
proof -
  have ok_error: "R' ok = 0 \<and> R' error = 0"
    unfolding R'_def R_def by (subst (1 2) reward_until_unfold[abs_def]) simp

  then have R_start: "R' start = q * (r + R' (probe 0)) + (1 - q) * (r * (N + 1))"
    using q r by (subst R'_iter) (simp_all add: field_simps)

  have R_probe: "\<And>n. n < N \<Longrightarrow> R' (probe n) = p * R' (probe (Suc n)) + p * r + (1 - p) * R' start"
    using p r by (subst R'_iter) (simp_all add: field_simps distrib_right)

  have R_N: "R' (probe N) = p * e + (1 - p) * R' start"
    using p e ok_error by (subst R'_iter) (auto simp: mult.commute )

  { fix n
    assume "n \<le> N"
    then have "R' (probe (N - n)) =
      p ^ Suc n * e + (1 - p^n) * r * p / (1 - p) + (1 - p^Suc n) * R' start"
    proof (induct n)
      case 0 with R_N show ?case by simp
    next
      case (Suc n)
      moreover then have "Suc (N - Suc n) = N - n" by simp
      ultimately show ?case
        using R_probe[of "N - Suc n"] p by (simp_all add: field_simps Suc)
    qed }
  from this[of N]
  have [simp]: "R' (probe 0) = p ^ Suc N * e + (1 - p^N) * r * p / (1 - p) + (1 - p^Suc N) * R' start"
    by simp
  have "R' start - q * (1 - p^Suc N) * R' start =
    q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * (N + 1))"
    by (subst R_start) (simp_all add: field_simps)
  then have "R' start = (q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * Suc N)) /
    (1 - q * (1 - p^Suc N))"
    using pos_neg_q_pn by (simp_all add: field_simps)
  then show ?thesis
    by (simp add: field_simps)
qed

end

interpretation ZC: Zeroconf_Analysis 2 "16 / 65024 :: real" "0.01" "0.002" "3600"
  by standard auto

lemma "ZC.P_err start \<le> 1 / 10^12"
  unfolding ZC.P_err_start by (simp add: power_divide power_one_over[symmetric])

lemma "ZC.R' start \<le> 0.007"
  unfolding ZC.cost_from_start by (simp add: power_divide power_one_over[symmetric])

end


section {* UTP variables *}

theory utp_urel_setup
  imports utp_lift utp_tactics utp_recursion
begin
(*tactics are in utp_tactics*)

text {* An alphabetised relation is simply a predicate whose state-space is a product type. In this
  theory we construct the core operators of the relational calculus, and prove a libary of
  associated theorems, based on Chapters 2 and 5 of the UTP book~\cite{Hoare&98}. *}

subsection {* Relational Alphabets *}

text {* We set up convenient syntax to refer to the input and output parts of the alphabet, as is
  common in UTP. Since we are in a product space, these are simply the lenses @{term "fst\<^sub>L"} and
  @{term "snd\<^sub>L"}. *}

definition in\<alpha> :: "('\<alpha> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in\<alpha> = fst\<^sub>L"

definition out\<alpha> :: "('\<beta> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out\<alpha> = snd\<^sub>L"

lemma in\<alpha>_uvar [simp]: "vwb_lens in\<alpha>"
  by (unfold_locales, auto simp add: in\<alpha>_def)

lemma out\<alpha>_uvar [simp]: "vwb_lens out\<alpha>"
  by (unfold_locales, auto simp add: out\<alpha>_def)

lemma var_in_alpha [simp]: "x ;\<^sub>L in\<alpha> = ivar x"
  by (simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma var_out_alpha [simp]: "x ;\<^sub>L out\<alpha> = ovar x"
  by (simp add: out\<alpha>_def out_var_def snd_lens_def)

lemma drop_pre_inv [simp]: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> \<lceil>\<lfloor>p\<rfloor>\<^sub><\<rceil>\<^sub>< = p"
  by (pred_simp)

lemma usubst_lookup_ivar_unrest [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (ivar x) = $x"
  by (rel_simp, metis fstI)

lemma usubst_lookup_ovar_unrest [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (ovar x) = $x\<acute>"
  by (rel_simp, metis sndI)

lemma out_alpha_in_indep [simp]:
  "out\<alpha> \<bowtie> in_var x" "in_var x \<bowtie> out\<alpha>"
  by (simp_all add: in_var_def out\<alpha>_def lens_indep_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_alpha_out_indep [simp]:
  "in\<alpha> \<bowtie> out_var x" "out_var x \<bowtie> in\<alpha>"
  by (simp_all add: in_var_def in\<alpha>_def lens_indep_def fst_lens_def lens_comp_def)

text {* The following two functions lift a predicate substitution to a relational one. *}

abbreviation usubst_rel_lift :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<times> '\<beta>) usubst" ("\<lceil>_\<rceil>\<^sub>s") where
"\<lceil>\<sigma>\<rceil>\<^sub>s \<equiv> \<sigma> \<oplus>\<^sub>s in\<alpha>"

abbreviation usubst_rel_drop :: "('\<alpha> \<times> '\<alpha>) usubst \<Rightarrow> '\<alpha> usubst" ("\<lfloor>_\<rfloor>\<^sub>s") where
"\<lfloor>\<sigma>\<rfloor>\<^sub>s \<equiv> \<sigma> \<restriction>\<^sub>s in\<alpha>"

text {* The alphabet of a relation then consists wholly of the input and output portions. *}

lemma alpha_in_out:
  "\<Sigma> \<approx>\<^sub>L in\<alpha> +\<^sub>L out\<alpha>"
  by (simp add: fst_snd_id_lens in\<alpha>_def lens_equiv_refl out\<alpha>_def)

end


(*  Title:      statecharts/DataSpace/Contrib.thy
    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

header {* Contributions to the Standard Library of HOL *}

theory Contrib
imports Main
begin

subsection {* Basic definitions and lemmas *}

subsubsection {* Lambda expressions *}

definition restrict :: "['a => 'b, 'a set] => ('a => 'b)" where
 "restrict f A = (%x. if x : A then f x else (@ y. True))"

syntax
  "_lambda_in" :: "[pttrn, 'a set, 'a => 'b] => ('a => 'b)"  ("(3%_:_./ _)" [0, 0, 3] 3)

syntax (xsymbols)
  "_lambda_in" :: "[pttrn, 'a set, 'a => 'b] => ('a => 'b)"  ("(3\<lambda>_\<in>_./ _)" [0, 0, 3] 3)

translations
  "\<lambda>x\<in>A. f"  == "CONST restrict (%x. f) A"
  "%x:A. f"  == "CONST restrict (%x. f) A"

subsubsection {* Maps *}

definition chg_map :: "('b => 'b) => 'a => ('a ~=> 'b) => ('a ~=> 'b)" where
 "chg_map f a m = (case m a of None => m | Some b => m(a|->f b))"

lemma map_some_list [simp]:
   "map the (map Some L) = L"
apply (induct_tac L)
apply auto
done

lemma dom_ran_the:
  "\<lbrakk> ran G = {y}; x \<in> (dom G) \<rbrakk> \<Longrightarrow> (the (G x)) = y"
apply (unfold ran_def dom_def)
apply auto
done

lemma dom_None:
  "(S \<notin> dom F) \<Longrightarrow> (F S = None)"
by (unfold dom_def, auto)

lemma ran_dom_the:
  "\<lbrakk> y \<notin> Union (ran G); x \<in> dom G \<rbrakk> \<Longrightarrow> y \<notin> the (G x)"
by (unfold ran_def dom_def, auto)

lemma dom_map_upd: "dom(m(a|->b)) = insert a (dom m)"
apply auto
done

subsubsection {* @{text "rtrancl"} *}

lemma rtrancl_mem_Sigma:
 "\<lbrakk> a \<noteq> b; (a, b) \<in> (A \<times> A)^* \<rbrakk> \<Longrightarrow> b \<in> A"
apply (frule rtranclD)
apply (cut_tac r="A \<times> A" and A=A in trancl_subset_Sigma)
apply auto
done

lemma help_rtrancl_Range:
 "\<lbrakk> a \<noteq> b; (a,b) \<in> R ^* \<rbrakk> \<Longrightarrow> b \<in> Range R"
apply (erule rtranclE)
apply auto
done

lemma rtrancl_Int_help:
  "(a,b) \<in> (A \<inter> B) ^*  ==> (a,b) \<in> A^* \<and> (a,b) \<in> B^*"
apply (unfold Int_def)
apply auto
apply (rule_tac b=b in rtrancl_induct)
apply auto
apply (rule_tac b=b in rtrancl_induct)
apply auto
done

lemmas rtrancl_Int1 = rtrancl_Int_help [THEN conjunct1]
lemmas rtrancl_Int2 = rtrancl_Int_help [THEN conjunct2]

lemma tranclD3 [rule_format]:
  "(S,T) \<in> R^+ \<Longrightarrow> (S,T) \<notin> R \<longrightarrow> (\<exists> U. (S,U) \<in> R \<and> (U,T) \<in> R^+)"
apply (rule_tac a="S" and b="T" and r=R in trancl_induct)
apply auto
done

lemma tranclD4 [rule_format]:
  "(S,T) \<in> R^+ \<Longrightarrow> (S,T) \<notin> R \<longrightarrow> (\<exists> U. (S,U) \<in> R^+ \<and> (U,T) \<in> R)"
apply (rule_tac a="S" and b="T" and r=R in trancl_induct)
apply auto
done

lemma trancl_collect [rule_format]:
  "\<lbrakk> (x,y) \<in> R^*; S \<notin> Domain R \<rbrakk> \<Longrightarrow> y \<noteq> S \<longrightarrow> (x,y) \<in> {p. fst p \<noteq> S \<and> snd p \<noteq> S \<and> p \<in> R}^*"
apply (rule_tac b=y in rtrancl_induct)
apply auto
apply (rule rtrancl_into_rtrancl)
apply fast
apply auto
done

lemma trancl_subseteq:
  "\<lbrakk> R \<subseteq> Q; S \<in> R^* \<rbrakk> \<Longrightarrow> S \<in> Q^*"
apply (frule rtrancl_mono)
apply fast
done

lemma trancl_Int_subset:
   "(R \<inter> (A \<times> A))\<^sup>+ \<subseteq> R\<^sup>+ \<inter> (A \<times> A)"
apply (rule subsetI)
apply (rename_tac S)
apply (case_tac "S")
apply (rename_tac T V)
apply auto
apply (rule_tac a=T and b=V and r="(R  \<inter> A \<times> A)" in converse_trancl_induct, auto)+
done

lemma trancl_Int_mem:
   "(S,T) \<in> (R \<inter> (A \<times> A))\<^sup>+ \<Longrightarrow> (S,T)  \<in> R\<^sup>+ \<inter> A \<times> A"
by (rule trancl_Int_subset [THEN subsetD], assumption)

lemma Int_expand:
  "{(S,S'). P S S' \<and>  Q S S'} = ({(S,S'). P S S'} \<inter> {(S,S'). Q S S'})"
by auto

subsubsection {* @{text "finite"} *}

lemma finite_conj:
 "finite ({(S,S'). P S S'}::(('a*'b)set)) \<longrightarrow>
     finite {(S,S'). P (S::'a) (S'::'b) \<and> Q (S::'a) (S'::'b)}"
apply (rule impI)
apply (subst Int_expand)
apply (rule finite_Int)
apply auto
done

lemma finite_conj2:
  "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> finite ({(S,S'). S: A \<and> S' : B})"
by auto

subsubsection {* @{text "override"} *}

lemma dom_override_the:
  "(x \<in> (dom G2)) \<longrightarrow> ((G1 ++ G2) x) = (G2 x)"
by (auto)

lemma dom_override_the2 [simp]:
  "\<lbrakk> dom G1 \<inter> dom G2 = {}; x \<in> (dom G1) \<rbrakk> \<Longrightarrow> ((G1 ++ G2) x) = (G1 x)"
apply (unfold dom_def map_add_def)
apply auto
apply (drule sym)
apply (erule equalityE)
apply (unfold Int_def)
apply auto
apply (erule_tac x=x in allE)
apply auto
done

lemma dom_override_the3 [simp]:
  "\<lbrakk> x \<notin> dom G2; x \<in> dom G1 \<rbrakk> \<Longrightarrow> ((G1 ++ G2) x) = (G1 x)"
apply (unfold dom_def map_add_def)
apply auto
done

lemma Union_ran_override [simp]:
  "S \<in> dom G \<Longrightarrow> \<Union> (ran (G ++ empty(S \<mapsto> insert SA (the(G S))))) =
   (insert SA (Union (ran G)))"
apply (unfold dom_def ran_def)
apply auto
apply (rename_tac T)
apply (case_tac "T = S")
apply auto
done

lemma Union_ran_override2 [simp]:
  "S \<in> dom G \<Longrightarrow> \<Union> (ran (G(S \<mapsto> insert SA (the(G S))))) = (insert SA (Union (ran G)))"
apply (unfold dom_def ran_def)
apply auto
apply (rename_tac T)
apply (case_tac "T = S")
apply auto
done

lemma chg_map_upd [simp]:
  "m a = Some b \<Longrightarrow> chg_map f a m = m(a|->f b)";
by (unfold chg_map_def, auto)

lemma ran_override_chg_map:
  "A \<in> dom G \<Longrightarrow> ran (G ++ empty(A|->B)) = (ran (chg_map (\<lambda> x. B) A G))"
apply (unfold dom_def ran_def)
apply (subst map_add_Some_iff [THEN ext])
apply auto
apply (rename_tac T)
apply (case_tac "T = A")
apply auto
done

subsubsection {* @{text "Part"} *}

definition  Part :: "['a set, 'b => 'a] => 'a set" where
            "Part A h = A \<inter> {x. \<exists> z. x = h(z)}"

lemma Part_UNIV_Inl_comp:
 "((Part UNIV (Inl o f)) = (Part UNIV (Inl o g))) = ((Part UNIV f) = (Part UNIV g))"
apply (unfold Part_def)
apply auto
apply (erule equalityE)
apply (erule subsetCE)
apply auto
apply (erule equalityE)
apply (erule subsetCE)
apply auto
done

lemma Part_eqI [intro]: "\<lbrakk> a \<in> A; a=h(b) \<rbrakk> \<Longrightarrow> a \<in> Part A h"
by (auto simp add: Part_def)

lemmas PartI = Part_eqI [OF _ refl]

lemma PartE [elim!]: "\<lbrakk> a \<in> Part A h;  !!z. \<lbrakk> a \<in> A;  a=h(z) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (auto simp add: Part_def)

lemma Part_subset: "Part A h \<subseteq> A"
by (auto simp add: Part_def)

lemma Part_mono: "A \<subseteq> B \<Longrightarrow> Part A h \<subseteq> Part B h"
by blast

lemmas basic_monos = basic_monos Part_mono

lemma PartD1: "a \<in> Part A h \<Longrightarrow> a \<in> A"
by (simp add: Part_def)

lemma Part_id: "Part A (\<lambda> x. x) = A"
by blast

lemma Part_Int: "Part (A \<inter> B) h = (Part A h) \<inter> (Part B h)"
by blast

lemma Part_Collect: "Part (A \<inter> {x. P x}) h = (Part A h) \<inter> {x. P x}"
by blast

subsubsection {* Set operators *}

lemma subset_lemma:
  "\<lbrakk> A \<inter> B = {}; A \<subseteq> B \<rbrakk> \<Longrightarrow> A = {}"
by auto

lemma subset_lemma2:
 "\<lbrakk> B \<inter> A = {}; C \<subseteq> A \<rbrakk> \<Longrightarrow> C \<inter> B = {}"
by auto

lemma insert_inter:
  "\<lbrakk> a \<notin> A; (A \<inter> B) = {} \<rbrakk> \<Longrightarrow> (A \<inter> (insert a B)) = {}"
by auto

lemma insert_notmem:
  "\<lbrakk> a \<noteq> b; a \<notin> B \<rbrakk> \<Longrightarrow> a \<notin> (insert b B)"
by auto

lemma insert_union:
 "A \<union> (insert a B) = insert a A \<union> B"
by auto

lemma insert_or:
     "{s. s = t1 \<or>  (P s)} = insert t1 {s. P s }"
by auto

lemma Collect_subset:
  "{x . x \<subseteq> A \<and> P x} = {x \<in> Pow A. P x}"
by auto

lemma OneElement_Card [simp]:
  "\<lbrakk> finite M; card M <= Suc 0; t \<in> M \<rbrakk> \<Longrightarrow> M = {t}"
apply auto
apply (rename_tac s)
apply (rule_tac P="finite M" in mp)
apply (rule_tac P="card M <= Suc 0" in mp)
apply (rule_tac P="t \<in> M" in mp)
apply (rule_tac F="M" in finite_induct)
apply auto
apply (rule_tac P="finite M" in mp)
apply (rule_tac P="card M <= Suc 0" in mp)
apply (rule_tac P="s \<in> M" in mp)
apply (rule_tac P="t \<in> M" in mp)
apply (rule_tac F="M" in finite_induct)
apply auto
done

subsubsection {* One point rule *}

lemma Ex1_one_point [simp]:
  "(\<exists>! x. P x \<and> x = a) = P a"
by auto

lemma Ex1_one_point2 [simp]:
  "(\<exists>! x. P x \<and> Q x \<and> x = a) = (P a \<and> Q a)"
by auto

lemma Some_one_point [simp]:
 "P a \<Longrightarrow> (SOME x. P x \<and> x = a) = a"
by auto

lemma Some_one_point2 [simp]:
 "\<lbrakk> Q a; P a \<rbrakk> \<Longrightarrow> (SOME x. P x \<and> Q x \<and> x = a) = a"
by auto

end