theory Predictive imports Main begin
  section{*Languages as predicates on lists*}

  text{*In this formalization we use lists of some type variable "'a" to model
    words over "'a"*}

  text{*Syntax for the lattice operations:*}

  notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70) and
    sup (infixl "\<squnion>" 65)

  text{*We introduce the prefix relation on lists as an instantiation of
    a partial order relation. The fact that $x$ is a prefix of a list $y$
    is denoted by $x \le y$. We prove that the prefix relation is a partial
    order, and we also prove some additional properties*}

  instantiation "list" :: (type) order begin
    primrec less_eq_list where
      "([] \<le> x) = True" |
      "((a # x) \<le> y) = (case y of [] \<Rightarrow> False | b # z \<Rightarrow> a = b \<and> (x \<le> z))"

    definition less_list_def: "((x::'a list) < y) = (x \<le> y \<and> \<not> y \<le> x)"

    lemma prefix_antisym: "\<And>y . (x::'a list) \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
      apply (induction x)
        apply (case_tac y, simp_all)
        by (case_tac y, simp_all)

    lemma prefix_trans: "\<And>y z . (x::'a list) \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
      apply (induction x, simp_all)
        apply (case_tac y, simp_all)
        by (case_tac z, simp_all, auto)

    lemma [simp]: "(y \<le> []) = (y = [])"
      by (unfold less_eq_list_def, case_tac y, auto)

    lemma [simp]: "[] \<le> ax"
      by (simp add: less_eq_list_def)

    lemma prefix_concat: "\<And> x . x \<le> y = (\<exists> z . y = x @ z)"
      by (induction y, simp_all, case_tac x, auto)

    lemma [simp]: "(butlast x) \<le> x"
      by (induction x, simp_all)

    lemma prefix_butlast: "\<And> y . (x \<le> y) = (x = y \<or> x \<le> (butlast y))"
      proof (induction x)
        case Nil show ?case by simp
        case (Cons x xs)
          assume A: "\<And> y . (xs \<le> y) = (xs = y \<or> xs \<le> (butlast y))"
          show ?case
            apply simp
            apply (case_tac y, simp_all)
            apply safe
            apply simp_all
            apply (subst (asm) A, simp)
            by (subst A, simp)
      qed

    lemma [simp]: "(x @ y \<le> x) = (y = [])"
      by (induction x, simp_all)

    instance proof
      qed (simp_all add: less_list_def prefix_antisym, rule prefix_trans)
  end

  section{*Finite deterministic automata*}

  text{*A finite deterministic automaton is modeled as a record of a transition
    function $\delta:'s \to 'a \to 's$ and a set $Final : 's set$ of final states,
    and an initial state $s_0:'s$. The states of the automaton are from the type
    variable $'s$, and the letters of the alphabet from $'a$.*}

  record ('s, 'a) automaton =
       \<delta> :: "'s \<Rightarrow> 'a \<Rightarrow> 's"
       Final :: "'s set"
       s\<^sub>0 :: 's

  text{*The language of an automaton $A$ is a predicate on lists of letters, and
   it is defined by primitive recursion:*}

  primrec lang:: "('s, 'a, 'c) automaton_ext \<Rightarrow> 'a list \<Rightarrow> bool" where
    "lang A [] = ((s\<^sub>0 A) \<in> (Final A))" |
    "lang A (a # x) = lang (A\<lparr>s\<^sub>0 := \<delta> A (s\<^sub>0 A) a\<rparr>) x"

  text{*We extend the transition function $\delta$ from letters to lists of letters,
    also by primitive induction*}

  primrec \<delta>e:: "('s, 'a, 'b) automaton_ext \<Rightarrow> 'a list \<Rightarrow> 's" where
    "\<delta>e A [] = s\<^sub>0 A" |
    "\<delta>e A (a # x) = \<delta>e (A\<lparr>s\<^sub>0:=\<delta> A (s\<^sub>0 A) a\<rparr>) x"

  text{*Next two lemma connect the language definition to the extended transition function.*}

  lemma lang_deltae: "\<And> A . lang A x = ((\<delta>e A x) \<in> Final A)"
    by (induction x, simp_all)

  lemma lang_deltaeb: "\<And> y A . lang A (x @ y) = lang (A\<lparr>s\<^sub>0:= (\<delta>e A x)\<rparr>) y"
    by (induction x, simp_all)

  lemma delta_but_last_aux: "\<And> a s . \<delta>e (A\<lparr>s\<^sub>0:=s\<rparr>) (x @ [a]) = \<delta> A (\<delta>e (A\<lparr>s\<^sub>0:=s\<rparr>) x) a"
    apply (induction x)
    by simp_all

  lemma delta_but_last: "\<delta>e A (x @ [a]) = \<delta> A (\<delta>e A x) a"
    apply (cut_tac A = A and s = "s\<^sub>0 A" and x = x and a = a in delta_but_last_aux)
    by simp

  text{*We introduce the standard product construction of two automata. Here we construct the
    product corresponding the intersection of the languages of the two automata.*}

  definition product :: "('s, 'a, 'c) automaton_ext \<Rightarrow> ('t, 'a, 'c) automaton_ext
        \<Rightarrow> ('s \<times> 't, 'a, 'c) automaton_ext" (infix "**" 60) where
    "A ** B = \<lparr>
        \<delta> = (\<lambda> (s, t) a . (\<delta> A s a, \<delta> B t a)),
        Final = Final A \<times> Final B,
        s\<^sub>0 = (s\<^sub>0 A,  s\<^sub>0 B),
        \<dots> = automaton.more A\<rparr>"

  text{*Next five lemmas are straightforward properties of the product of two automata.*}

  lemma [simp]: "s\<^sub>0 (A ** B) = (s\<^sub>0 A, s\<^sub>0 B)"
    by (simp add: product_def)

  lemma [simp]: "Final (A ** B) = (Final A \<times> Final B)"
    by (simp add: product_def)

  lemma [simp]: "(A ** B)\<lparr>s\<^sub>0 := (s, t) \<rparr> = (A\<lparr>s\<^sub>0 := s\<rparr>) ** (B\<lparr>s\<^sub>0 := t\<rparr> )"
    by (simp add: product_def)

  lemma [simp]: "\<delta> (A ** B) (s, t) a = (\<delta> A s a, \<delta> B t a)"
    by (simp add: product_def)

  lemma [simp]: "\<And> A B . \<delta>e (A ** B) x = (\<delta>e A x, \<delta>e B x)"
    by (induction x, simp_all)

  text{*Next two lemmas show that the language of the product is the intersection of the
    languages of the automata. Second lemma is the point-free version of the first lemma.*}

  lemma intersection_aux: "\<And> A B . lang (A ** B) x =  (lang A x \<and> lang B x)"
    apply (induction x)
    by (auto simp add:  lang_deltae)

  lemma intersection: "lang (A ** B) =  (lang A \<sqinter> lang B)"
    by (simp add: fun_eq_iff intersection_aux)

  text{*Next declaration introduces the complement of an automaton as a instantiation
   of the Isabelle uminus class. We take this approach because we what to use the
   unary symbol $-$ for the complement. Otherwise this is just a simple definition
   similar to the product.*}

  instantiation automaton_ext :: (type, type, type) uminus begin
    definition complement_def: "- A = A\<lparr>Final := -Final A\<rparr>"
    instance proof qed
  end

  text{*Next five lemmas give some properties of the complement.*}
  lemma [simp]: "\<delta> (-A) = \<delta> A"
    by (simp add: complement_def)

  lemma [simp]: "s\<^sub>0 (-A) = s\<^sub>0 A"
    by (simp add: complement_def)

  lemma complement_init[simp]: "(-A)\<lparr> s\<^sub>0 := s \<rparr> = -(A\<lparr> s\<^sub>0 := s \<rparr>)"
    by (simp add: complement_def)

  lemma [simp]: "\<And> A . \<delta>e (-A) x = \<delta>e A x"
    by (induction x, simp_all)

  lemma [simp]: "Final (-A) = - Final A"
    by (simp add: complement_def)

  text{*The language of the complement of $A$ is the complement of the
    language of $A$. Next two lemmas express this property in point-wise
    and point-free manner.*}

  lemma complement_aux: "\<And>A . lang (- A) x = (\<not> (lang A x))"
    by (simp add: lang_deltae)

  lemma complement: "lang (-A) = (- (lang A))"
    by (simp add: fun_eq_iff complement_aux)

  text{*Next definition introduces an automaton $Extension\ A$ based on automaton $A$.
    A list $x$ is in the language of $Extension\ A$ if and only if there is a prefix
    of $x$ in the language of $A$. In the paper this automaton is denoted by
    $B_\varphi$, where $\varphi = lang\ A$.*}

  definition "Extension A = \<lparr>
    \<delta> = (\<lambda> s a . if s \<in> Final A then s else \<delta> A s a),
    Final = Final A,
    s\<^sub>0 = s\<^sub>0 A,
    \<dots> = more A\<rparr>"

  lemma [simp]: "s\<^sub>0 (Extension A) = s\<^sub>0 A"
    by (simp add: Extension_def)

  text{*We introduce some properties of $Extension\ A$ in the next six lemmas.*}

  lemma Extension_initial[simp]: "Extension A\<lparr>s\<^sub>0 := s\<rparr> = Extension (A\<lparr>s\<^sub>0 := s\<rparr>)"
    by (auto simp add: Extension_def fun_eq_iff)

  lemma prefix_final[simp]: "s \<in> Final A \<Longrightarrow> lang ((Extension A)\<lparr>s\<^sub>0 := s\<rparr>) x"
    by (induction x, simp_all add: Extension_def)

  lemma [simp]: "s\<^sub>0 A \<in> Final A \<Longrightarrow> lang (Extension A) x"
    by (drule prefix_final, simp)

  lemma [simp]: "s \<in> Final A \<Longrightarrow> \<delta> (Extension A) s a = s"
    by (simp add: Extension_def)

  lemma [simp]: "s \<notin> Final A \<Longrightarrow> \<delta> (Extension A) s a = \<delta> A s a"
    by (simp add: Extension_def)

  lemma "lang ((Extension A)\<lparr>s\<^sub>0 := s\<rparr>) = \<top> \<Longrightarrow> s \<in> Final A"
    apply (simp add: fun_eq_iff Extension_def image_def)
    by (drule_tac x = "[]" in spec, simp)

  text{*The language of $Extension\ A$ in terms of the language of $A$ is given by
    the next lemma.*}

  lemma Extension_lang: "\<And> (A::('s, 'a, 'c) automaton_ext) . lang (Extension A) x = (\<exists> y . lang A y \<and> y \<le> x)"
    proof (induction x)
    case (Nil) show ?case
      by (simp add: Extension_def image_def)
    next
    case (Cons a x)
      assume A: "\<And> (A::('s, 'a, 'c) automaton_ext) .  lang (Extension A) x = (\<exists>y. lang A y \<and> y \<le> x)"
      from A have B: "\<And> (A::('s, 'a, 'c) automaton_ext) y . lang A y \<Longrightarrow> y \<le> x \<Longrightarrow> lang (Extension A) x"
        by blast
      show ?case
        apply simp
        apply safe
          apply (case_tac "s\<^sub>0 A \<in>  Final A", simp_all)
          apply (rule_tac x = "[]" in exI, simp)
          apply (simp add: A, safe)
          apply (rule_tac x = "a # y" in exI)

          apply simp
          apply (case_tac y, simp_all, safe)
          apply (case_tac "s\<^sub>0 A \<in>  Final A", simp_all)
          by (drule B, simp_all)
    qed

  section{*Constraints of the Predictive Enforcement*}

  text{*Next definition introduces $k_{\psi,\varphi}$ function from the paper
    \cite{predictive}. The automata $A_\psi$ and $A_\varphi$ correspond to the properties
    $\psi$ and $\varphi$, respectively.*}

  definition "kfunc A\<^sub>\<psi> A\<^sub>\<phi> x = (\<forall> y . lang A\<^sub>\<psi> (x @ y) \<longrightarrow> (\<exists> z .(lang A\<^sub>\<phi> (x @ z)) \<and> z \<le> y))"

  text{*The Urgency constraint is introduced in the next definition, and it has as hypothesis
    the $kfunc$ function. For simplicity we introduce first $kfunc$ and then Urgency. In the
    paper Urgency precedes the definition of $kfunc$.*}

  definition "Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf = (\<forall> x . kfunc A\<^sub>\<psi> A\<^sub>\<phi> x \<longrightarrow> Enf x = x)"

  definition "Soundness A\<^sub>\<psi> A\<^sub>\<phi> Enf = (\<forall> x . lang A\<^sub>\<psi> x \<and> Enf x \<noteq> [] \<longrightarrow> lang A\<^sub>\<phi> (Enf x))"

  definition "Transparency1 Enf = (\<forall> x . Enf x \<le> x)"

  definition "Transparency2 A\<^sub>\<phi> Enf = (\<forall> x . lang A\<^sub>\<phi> x \<longrightarrow> Enf x = x)"

  definition [simp]: "Monotonicity Enf = mono Enf"

  text{*Next lemma shows that Transparency2 is a consequence of Urgency*}

  lemma "Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<Longrightarrow> Transparency2 A\<^sub>\<phi> Enf"
    by (metis Transparency2_def Urgency_def append_Nil2 kfunc_def less_eq_list.simps(1))

  section{*Independence of Urgency, Transparency1, Monotonicity and Soundness*}

  lemma Urgency_true [simp]: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang  A\<^sub>\<phi> = \<bottom> \<Longrightarrow> Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf"
    by (simp add: Urgency_def kfunc_def)

  lemma Urgency_phi[simp]: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang A\<^sub>\<phi> = B \<Longrightarrow> Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf = (\<forall> x . B x \<longrightarrow> Enf x = x)"
    apply (simp add: kfunc_def Urgency_def, auto)
    apply (drule_tac x = x in spec, safe)
    apply (rule_tac x = "[]" in exI, simp)
    apply (drule_tac x = x in spec)
    by (drule_tac x = "[]" in spec, simp)

  lemma Urgency_id [simp]: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang  A\<^sub>\<phi> = \<top> \<Longrightarrow> (Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf) = (Enf = id)"
    by (simp add: Urgency_def kfunc_def fun_eq_iff, auto)

  lemma Indep1: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang A\<^sub>\<phi> = \<bottom> \<Longrightarrow> (\<forall> x . Enf x = x) \<Longrightarrow>
     Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<and> Monotonicity Enf \<and> Transparency1 Enf \<and> \<not> Soundness  A\<^sub>\<psi> A\<^sub>\<phi> Enf"
     by (simp add: Soundness_def mono_def Transparency1_def, auto)

  lemma Indep1a: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang A\<^sub>\<phi> = (\<lambda> x . x = [()]) \<Longrightarrow> (\<forall> x . Enf x = x) \<Longrightarrow>
     Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<and> Monotonicity Enf \<and> Transparency1 Enf \<and> \<not> Soundness  A\<^sub>\<psi> A\<^sub>\<phi> Enf"
     by (simp add: Soundness_def mono_def Transparency1_def, auto)

  lemma Indep2: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang  A\<^sub>\<phi> = (\<lambda> x . x = [()]) \<Longrightarrow> (\<forall> x . Enf x = [()]) \<Longrightarrow>
     Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<and> Monotonicity Enf \<and> \<not> Transparency1 Enf \<and> Soundness  A\<^sub>\<psi> A\<^sub>\<phi> Enf"
     apply (simp add: Soundness_def mono_def Transparency1_def)
     by (rule_tac x = "[]" in exI, simp)

  lemma Indep3: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang  A\<^sub>\<phi> = (\<lambda> x . x = [()]) \<Longrightarrow> (\<forall> x . Enf x = (if x = [()] then [()] else [])) \<Longrightarrow>
     Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<and> \<not> Monotonicity Enf \<and> Transparency1 Enf \<and> Soundness  A\<^sub>\<psi> A\<^sub>\<phi> Enf"
     apply (simp add: Soundness_def mono_def Transparency1_def)
     by (rule_tac x = "[(),()]" in exI, simp)

  lemma Indep4: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> lang  A\<^sub>\<phi> = \<top> \<Longrightarrow> (\<forall> x . Enf x = []) \<Longrightarrow>
     \<not> Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<and> Monotonicity Enf \<and> Transparency1 Enf \<and> Soundness  A\<^sub>\<psi> A\<^sub>\<phi> Enf"
     apply (simp add: Soundness_def mono_def Transparency1_def)
     by (rule_tac x = "[Eps \<top>]" in exI, simp)

  section{*Alternative Urgency*}

  text{*A weaker version of Urgency is introduced by:*}
  definition "Urgency' A\<^sub>\<psi> A\<^sub>\<phi> Enf = (\<forall> x . (\<forall> y . lang A\<^sub>\<psi> (x @ y) \<longrightarrow> lang A\<^sub>\<phi> x) \<longrightarrow> Enf x = x)"

  lemma Urgency_Urgency'_aux: "(\<forall> y . lang A\<^sub>\<psi> (x @ y) \<longrightarrow> lang A\<^sub>\<phi> x) \<Longrightarrow> kfunc A\<^sub>\<psi> A\<^sub>\<phi> x"
    by (metis kfunc_def append_Nil2 less_eq_list.simps(1))

  text{*Urgency is stronger than Urgency'*}

  lemma Urgency_Urgency': "Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf \<Longrightarrow> Urgency'  A\<^sub>\<psi> A\<^sub>\<phi> Enf"
    by (metis Urgency'_def Urgency_def kfunc_def append_Nil2 less_eq_list.simps(1))

  section{*Implementation of $kfunc$ as the inclusion of two regular languages*}

  text{*Next definition is a more abstract variant of $kfunc$ as an inclusion of regular
    languages. Here we do not have the existential quantifier.*}
  definition "kfunc_lang A\<^sub>\<psi> A\<^sub>\<phi> x = (lang (A\<^sub>\<psi>\<lparr>s\<^sub>0 := (\<delta>e A\<^sub>\<psi> x)\<rparr>) \<le> lang ((Extension A\<^sub>\<phi>)\<lparr> s\<^sub>0 := \<delta>e A\<^sub>\<phi> x \<rparr>))"

  lemma kfunc_kfunc_lang: "kfunc A\<^sub>\<psi> A\<^sub>\<phi> x = kfunc_lang A\<^sub>\<psi> A\<^sub>\<phi> x"
    by (simp add: kfunc_def kfunc_lang_def lang_deltaeb Predictive.Extension_lang le_fun_def)

  lemma kfunc_lang_empty: " kfunc_lang A\<^sub>\<psi> A\<^sub>\<phi> x = (lang ((A\<^sub>\<psi> ** - (Extension A\<^sub>\<phi>))\<lparr>s\<^sub>0 := (\<delta>e A\<^sub>\<psi> x, \<delta>e A\<^sub>\<phi> x)\<rparr>) = \<bottom>)"
    by (simp add: intersection Predictive.complement kfunc_lang_def fun_eq_iff le_fun_def)

  text{*Next theorem shows the implementation of $kfunc$ as a test of emptiness of a regular language
    (Theorem 2 in \cite{predictive}).*}

  theorem kfunc_empty: "kfunc A\<^sub>\<psi> A\<^sub>\<phi> x = (lang ((A\<^sub>\<psi> ** - (Extension A\<^sub>\<phi>))\<lparr>s\<^sub>0 := (\<delta>e A\<^sub>\<psi> x, \<delta>e A\<^sub>\<phi> x)\<rparr>) = \<bottom>)"
    by (unfold kfunc_kfunc_lang kfunc_lang_empty, simp)

  section{*Enforcement Function*}

  text{*Next definition introduces the enforcement function. In this formalization we chose
    to define $enforce$ directly while in \cite{predictive} we define it using another function
    called $store$ that returns two sequences. The $enforce$ function is the first component
    of $store$.*}

  fun enforce :: "('s, 'a, 'c) automaton_ext \<Rightarrow> ('t, 'a, 'c) automaton_ext \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "enforce A\<^sub>\<psi> A\<^sub>\<phi> x =
      (if x = [] then
        []
      else
        (if kfunc A\<^sub>\<psi> A\<^sub>\<phi> x then
          x
        else
          enforce A\<^sub>\<psi> A\<^sub>\<phi> (butlast x)))"

(*
  definition  enforce_nat :: "(nat, nat, nat) automaton_ext \<Rightarrow> (nat, nat, nat) automaton_ext \<Rightarrow> nat list \<Rightarrow> nat list" where
    "enforce_nat = enforce"

  export_code enforce_nat in SML
    module_name Example file "example.ML"

  export_code enforce_nat in Scala
    module_name Example file "example.scala"

  export_code enforce_nat in OCaml
    module_name Example file "example.ocaml"
*)

  text{*When the property $\psi$ is true for all sequences, then the Urgency property
    is simplified to the non-predictive case.*}

  lemma no_prediction: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> Urgency A\<^sub>\<psi> A\<^sub>\<phi> Enf = (\<forall>x. lang A\<^sub>\<phi> x \<longrightarrow> Enf x = x)"
    apply (auto simp add: Urgency_def kfunc_def)
    apply (metis append_Nil2 less_eq_list.simps(1))
    by (metis list.simps(4) neq_Nil_conv less_eq_list.simps(2) self_append_conv)

  text{*When the property $\psi$ is included in $\varphi$, then output of the
    enforcer is always equal to the input.*}

  lemma subset_enforce: "lang A\<^sub>\<psi> \<le> lang A\<^sub>\<phi> \<Longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> x = x"
    by (metis enforce.simps kfunc_def order_refl predicate1D)

  text{*When the property $\psi$ is true for all sequences, then the kfun
    is simplified to:*}

  lemma no_prediction_kfunc: "lang A\<^sub>\<psi> = \<top> \<Longrightarrow> kfunc A\<^sub>\<psi> A\<^sub>\<phi> x = lang A\<^sub>\<phi> x"
    apply (auto simp add: kfunc_def)
    using less_eq_list.simps(1) prefix_antisym apply fastforce
    by (metis append_Nil2 less_eq_list.simps(1))

  text{*Next three lemmas are used in the proofs of soundness,  transparency, and urgency.*}

  lemma kfunc_enforce: "enforce A\<^sub>\<psi> A\<^sub>\<phi> x \<noteq> [] \<Longrightarrow> kfunc A\<^sub>\<psi> A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x)"
    proof (induction x rule: length_induct)
      fix xs::"'a list"
      assume "\<forall>ys. length ys < length xs \<longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> ys \<noteq> [] \<longrightarrow> kfunc A\<^sub>\<psi> A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> ys)"
      from this have A: "\<And> ys . length ys < length xs \<Longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> ys \<noteq> [] \<Longrightarrow> kfunc A\<^sub>\<psi> A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> ys)"
        by simp
      assume C: "enforce A\<^sub>\<psi> A\<^sub>\<phi> xs \<noteq> []"
      from this have B: "xs \<noteq> []"
        by (case_tac xs, simp_all)
      from B and C have  D: "\<not> kfunc A\<^sub>\<psi> A\<^sub>\<phi> xs \<Longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> (butlast xs) \<noteq> []"
        apply (subst enforce.simps)
        apply (subst (asm) enforce.simps)
        apply (subst (asm) enforce.simps)
        by (simp del: enforce.simps)
      from B and D show "kfunc A\<^sub>\<psi> A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> xs)"
        apply (subst enforce.simps)
        apply (simp del: enforce.simps, safe)
        by (cut_tac ys = "butlast xs" in A, simp_all del: enforce.simps)
    qed

  lemma kfunc_prefix_enforce: "kfunc A\<^sub>\<psi> A\<^sub>\<phi> y \<Longrightarrow> y \<le> x \<Longrightarrow> y \<le> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x)"
    apply (induction x rule: length_induct)
    apply (subst enforce.simps)
    apply (case_tac "xs = []")
    apply simp
    apply (simp del: enforce.simps, safe)
    apply (drule_tac x = "butlast xs" in spec, safe)
    apply (simp_all del: enforce.simps)
    by (subst (asm) prefix_butlast, simp)

  lemma lang_enf_kfunc: "lang A\<^sub>\<phi> x \<Longrightarrow> kfunc A\<^sub>\<psi> A\<^sub>\<phi> x"
    apply (simp add: kfunc_def, safe)
    by (rule_tac x= "[]" in exI, simp)

  text{*Finally we prove the enforcement function satisfies
    soundness,  transparency, monotonicity, and urgency properties.*}

  theorem Transparency1: "enforce A\<^sub>\<psi> A\<^sub>\<phi> x \<le> x"
    apply (induction x rule: length_induct)
    apply (subst enforce.simps)
    apply (case_tac "xs = []")
    apply (unfold if_P)
    apply simp
    apply (unfold if_not_P)
    apply (case_tac "kfunc A\<^sub>\<psi> A\<^sub>\<phi> xs")
    apply simp
    apply (unfold if_not_P)
    apply (drule_tac x = "butlast xs" in spec)
    apply safe
    apply simp
    by (rule_tac y = "butlast xs" in prefix_trans, simp_all)

  lemma Monotonicity_aux: "\<And> x y . x \<le> y \<Longrightarrow> n = length y \<Longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> x \<le> enforce A\<^sub>\<psi> A\<^sub>\<phi> y"
    apply (induction n)
    apply simp
    apply (subst enforce.simps)
    apply (subst (2) enforce.simps)
    apply (simp del: enforce.simps, safe)
    apply (case_tac x, simp_all del: enforce.simps)
    apply (metis kfunc_prefix_enforce prefix_butlast)
    apply (metis Transparency1 enforce.simps prefix_trans)
    by (metis Suc_eq_plus1 add.commute add_diff_cancel_left' enforce.simps length_butlast prefix_butlast)

  theorem Monotonicity: "Monotonicity (enforce A\<^sub>\<psi> A\<^sub>\<phi>)"
    apply (simp)
    apply (unfold mono_def)
    apply safe
    by (rule Monotonicity_aux, simp_all)

  theorem Urgency: "kfunc A\<^sub>\<psi> A\<^sub>\<phi> x \<Longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> x = x"
    by simp

  theorem Soundness: "lang A\<^sub>\<psi> x \<Longrightarrow> enforce A\<^sub>\<psi> A\<^sub>\<phi> x \<noteq> [] \<Longrightarrow> lang A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x)"
    proof -
      assume A: "lang A\<^sub>\<psi> x"
      assume B: "enforce A\<^sub>\<psi> A\<^sub>\<phi> x \<noteq> []"
      have "enforce A\<^sub>\<psi> A\<^sub>\<phi> x \<le> x" by (rule Transparency1)
      from this obtain z where D: "x = enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ z" by (simp add: prefix_concat del: enforce.simps, safe, simp)
      from A and this have [simp]: "lang A\<^sub>\<psi> ( enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ z)" by simp
      from B have "kfunc A\<^sub>\<psi> A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x)" by (rule kfunc_enforce)
      from this have C: "\<And> y . lang A\<^sub>\<psi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ y) \<Longrightarrow> (\<exists>t . lang A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ t) \<and> t \<le> y)" by (simp add: kfunc_def)
      have "(\<exists>t . lang  A\<^sub>\<phi>  (enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ t) \<and> (t \<le> z))" by (rule C, simp del: enforce.simps)
      then obtain za where F: "lang A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ za)" and E: "za \<le> z" by blast
      from this have "kfunc A\<^sub>\<psi> A\<^sub>\<phi> (enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ za)" by (simp add: lang_enf_kfunc del: enforce.simps)
      from this have "enforce A\<^sub>\<psi> A\<^sub>\<phi> x @ za \<le> enforce A\<^sub>\<psi> A\<^sub>\<phi> x"
        apply (rule kfunc_prefix_enforce)
        by (cut_tac D E, simp add: prefix_concat del: enforce.simps, blast)
      from this have [simp]: "za = []" by simp
      from F show ?thesis by (simp del: enforce.simps)
    qed

  section{*Enforcement Algorithm*}

  text{*Because the enforcement algorithm has a non-terminating loop we cannot represent it as function
  in Isabelle. We introduce here the invariant of the algorithm, and we prove the initialization
  establishes the invariant, and that each step of the algorithm preserves the invariant. The
  invariant expresses the desired properties of the algorithm*}

  text{*$x$ is the input received so far, $y$ is the concatenation of all released words, and
  $z$ ($\sigma_c$ in the paper) is the pending word.*}

  definition "Invariant A\<^sub>\<psi> A\<^sub>\<phi> C p q x y z = (
    C = A\<^sub>\<psi> ** - (Extension A\<^sub>\<phi>)
    \<and> p = \<delta>e A\<^sub>\<psi> x
    \<and> q =  \<delta>e A\<^sub>\<phi> x \<and> x = y @ z
    \<and> enforce A\<^sub>\<psi> A\<^sub>\<phi> x = y)"

  definition "Init A\<^sub>\<psi> A\<^sub>\<phi> = (let (z, p, q, C) = ([], s\<^sub>0 A\<^sub>\<psi>, s\<^sub>0 A\<^sub>\<phi>, A\<^sub>\<psi> ** - (Extension A\<^sub>\<phi>)) in (z, p, q, C))"

  definition "Step A\<^sub>\<psi> A\<^sub>\<phi> C p q z a = (let (p',q') = (\<delta> A\<^sub>\<psi> p a, \<delta> A\<^sub>\<phi> q a) in (p', q', if lang (C\<lparr>s\<^sub>0 := (p',q')\<rparr>) = \<bottom> then (z @ [a], []) else ([], z @ [a])))"

  text{*The initialization establishes the invariant*}

  lemma Init: "(z, p, q, C) = Init A\<^sub>\<psi> A\<^sub>\<phi> \<Longrightarrow> Invariant A\<^sub>\<psi> A\<^sub>\<phi> C p q [] [] z"
    by (simp add: Init_def Invariant_def)

  text{*The step preserves the invariant*}

  lemma Step: "(p', q', yr, zo) = Step A\<^sub>\<psi> A\<^sub>\<phi> C p q z a \<Longrightarrow> Invariant A\<^sub>\<psi> A\<^sub>\<phi> C p q x y z \<Longrightarrow> Invariant A\<^sub>\<psi> A\<^sub>\<phi> C p' q' (x @ [a]) (y @ yr) zo"
    apply (simp add: Step_def)
    apply (unfold Invariant_def)
    apply (simp del: enforce.simps)
    apply (cut_tac A\<^sub>\<psi>1 = A\<^sub>\<psi> and A\<^sub>\<phi>1 = A\<^sub>\<phi> and x1 = "x @ [a]" in  kfunc_lang_empty [THEN sym])
    apply (simp del: enforce.simps add:  delta_but_last)
    apply (unfold append_assoc [THEN sym])
    apply (simp del: enforce.simps append_assoc add:  delta_but_last)
    apply (unfold kfunc_kfunc_lang [THEN sym])
    apply (case_tac  "kfunc A\<^sub>\<psi> A\<^sub>\<phi> ((y @ z) @ [a])")
    apply (simp_all del: enforce.simps)
    apply (rule Urgency, simp)
    by (metis (no_types, lifting) append_assoc enforce.simps snoc_eq_iff_butlast)

  section{*Example*}

  datatype Sa = "l0" | "l1" | "l2"
  datatype Sig = "a" | "b" | "c"
  datatype Sb = "k0" | "k1" | "k2" | "k3"

  fun
    \<delta>a :: "Sa \<Rightarrow> Sig \<Rightarrow> Sa"
  where
    "\<delta>a l0 a = l0" |
    "\<delta>a l0 b = l1" |
    "\<delta>a l1 c = l0" |
    "\<delta>a _  a = l2" |
    "\<delta>a _  b = l2" |
    "\<delta>a _  c = l2"

  definition "Fa = {l0}"

  fun
    \<delta>b :: "Sb \<Rightarrow> Sig \<Rightarrow> Sb"
  where
    "\<delta>b k0 a = k0" |
    "\<delta>b k0 b = k1" |
    "\<delta>b k1 a = k0" |
    "\<delta>b k1 c = k2" |
    "\<delta>b k2 a = k0" |
    "\<delta>b _  a = k3" |
    "\<delta>b _  b = k3" |
    "\<delta>b _  c = k3"

  definition "Fb = {k0, k1, k2}"

  lemma "kfunc_lang \<lparr>\<delta> = \<delta>b, Final = Fb, s\<^sub>0 = k0\<rparr> \<lparr>\<delta> = \<delta>a, Final = Fa, s\<^sub>0 = l0\<rparr> [a,b] = False"
    apply (simp add: kfunc_lang_def le_fun_def)
    apply (rule_tac x = "[]" in exI)
    by (simp add: Fb_def Extension_def Fa_def )

  lemma "kfunc \<lparr>\<delta> = \<delta>b, Final = Fb, s\<^sub>0 = k0\<rparr> \<lparr>\<delta> = \<delta>a, Final = Fa, s\<^sub>0 = l0\<rparr> [a]"
    apply (simp add: kfunc_def Fb_def Fa_def, auto)
    by (rule_tac x = "[]" in exI, simp)
end


(*  Title:      HOL/Map.thy
    Author:     Tobias Nipkow, based on a theory by David von Oheimb
    Copyright   1997-2003 TU Muenchen

The datatype of "maps"; strongly resembles maps in VDM.
*)

section \<open>Maps\<close>

theory Map
  imports List
  abbrevs "(=" = "\<subseteq>\<^sub>m"
begin

type_synonym ('a, 'b) "map" = "'a \<Rightarrow> 'b option" (infixr "\<rightharpoonup>" 0)

abbreviation
  empty :: "'a \<rightharpoonup> 'b" where
  "empty \<equiv> \<lambda>x. None"

definition
  map_comp :: "('b \<rightharpoonup> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c)"  (infixl "\<circ>\<^sub>m" 55) where
  "f \<circ>\<^sub>m g = (\<lambda>k. case g k of None \<Rightarrow> None | Some v \<Rightarrow> f v)"

definition
  map_add :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "++" 100) where
  "m1 ++ m2 = (\<lambda>x. case m2 x of None \<Rightarrow> m1 x | Some y \<Rightarrow> Some y)"

definition
  restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "|`"  110) where
  "m|`A = (\<lambda>x. if x \<in> A then m x else None)"

notation (latex output)
  restrict_map  ("_\<restriction>\<^bsub>_\<^esub>" [111,110] 110)

definition
  dom :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" where
  "dom m = {a. m a \<noteq> None}"

definition
  ran :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set" where
  "ran m = {b. \<exists>a. m a = Some b}"

definition
  graph :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) set" where
  "graph m = {(a, b) | a b. m a = Some b}"

definition
  map_le :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool"  (infix "\<subseteq>\<^sub>m" 50) where
  "(m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2) \<longleftrightarrow> (\<forall>a \<in> dom m\<^sub>1. m\<^sub>1 a = m\<^sub>2 a)"

nonterminal maplets and maplet

syntax
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /\<mapsto>/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[\<mapsto>]/ _")
  ""         :: "maplet \<Rightarrow> maplets"             ("_")
  "_Maplets" :: "[maplet, maplets] \<Rightarrow> maplets" ("_,/ _")
  "_MapUpd"  :: "['a \<rightharpoonup> 'b, maplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
  "_Map"     :: "maplets \<Rightarrow> 'a \<rightharpoonup> 'b"            ("(1[_])")

syntax (ASCII)
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /|->/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[|->]/ _")

translations
  "_MapUpd m (_Maplets xy ms)"  \<rightleftharpoons> "_MapUpd (_MapUpd m xy) ms"
  "_MapUpd m (_maplet  x y)"    \<rightleftharpoons> "m(x := CONST Some y)"
  "_Map ms"                     \<rightleftharpoons> "_MapUpd (CONST empty) ms"
  "_Map (_Maplets ms1 ms2)"     \<leftharpoondown> "_MapUpd (_Map ms1) ms2"
  "_Maplets ms1 (_Maplets ms2 ms3)" \<leftharpoondown> "_Maplets (_Maplets ms1 ms2) ms3"

primrec map_of :: "('a \<times> 'b) list \<Rightarrow> 'a \<rightharpoonup> 'b"
where
  "map_of [] = empty"
| "map_of (p # ps) = (map_of ps)(fst p \<mapsto> snd p)"

definition map_upds :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a \<rightharpoonup> 'b"
  where "map_upds m xs ys = m ++ map_of (rev (zip xs ys))"
translations
  "_MapUpd m (_maplets x y)" \<rightleftharpoons> "CONST map_upds m x y"

lemma map_of_Cons_code [code]:
  "map_of [] k = None"
  "map_of ((l, v) # ps) k = (if l = k then Some v else map_of ps k)"
  by simp_all

subsection \<open>@{term [source] empty}\<close>

lemma empty_upd_none [simp]: "empty(x := None) = empty"
  by (rule ext) simp

subsection \<open>@{term [source] map_upd}\<close>

lemma map_upd_triv: "t k = Some x \<Longrightarrow> t(k\<mapsto>x) = t"
  by (rule ext) simp

lemma map_upd_nonempty [simp]: "t(k\<mapsto>x) \<noteq> empty"
proof
  assume "t(k \<mapsto> x) = empty"
  then have "(t(k \<mapsto> x)) k = None" by simp
  then show False by simp
qed

lemma map_upd_eqD1:
  assumes "m(a\<mapsto>x) = n(a\<mapsto>y)"
  shows "x = y"
proof -
  from assms have "(m(a\<mapsto>x)) a = (n(a\<mapsto>y)) a" by simp
  then show ?thesis by simp
qed

lemma map_upd_Some_unfold:
  "((m(a\<mapsto>b)) x = Some y) = (x = a \<and> b = y \<or> x \<noteq> a \<and> m x = Some y)"
  by auto

lemma image_map_upd [simp]: "x \<notin> A \<Longrightarrow> m(x \<mapsto> y) ` A = m ` A"
  by auto

lemma finite_range_updI:
  assumes "finite (range f)" shows "finite (range (f(a\<mapsto>b)))"
proof -
  have "range (f(a\<mapsto>b)) \<subseteq> insert (Some b) (range f)"
    by auto
  then show ?thesis
    by (rule finite_subset) (use assms in auto)
qed

subsection \<open>@{term [source] map_of}\<close>

lemma map_of_eq_empty_iff [simp]:
  "map_of xys = empty \<longleftrightarrow> xys = []"
proof
  show "map_of xys = empty \<Longrightarrow> xys = []"
    by (induction xys) simp_all
qed simp

lemma empty_eq_map_of_iff [simp]:
  "empty = map_of xys \<longleftrightarrow> xys = []"
by(subst eq_commute) simp

lemma map_of_eq_None_iff:
  "(map_of xys x = None) = (x \<notin> fst ` (set xys))"
by (induct xys) simp_all

lemma map_of_eq_Some_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (map_of xys x = Some y) = ((x,y) \<in> set xys)"
proof (induct xys)
  case (Cons xy xys)
  then show ?case
    by (cases xy) (auto simp flip: map_of_eq_None_iff)
qed auto

lemma Some_eq_map_of_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (Some y = map_of xys x) = ((x,y) \<in> set xys)"
by (auto simp del: map_of_eq_Some_iff simp: map_of_eq_Some_iff [symmetric])

lemma map_of_is_SomeI [simp]:
  "\<lbrakk>distinct(map fst xys); (x,y) \<in> set xys\<rbrakk> \<Longrightarrow> map_of xys x = Some y"
  by simp

lemma map_of_zip_is_None [simp]:
  "length xs = length ys \<Longrightarrow> (map_of (zip xs ys) x = None) = (x \<notin> set xs)"
by (induct rule: list_induct2) simp_all

lemma map_of_zip_is_Some:
  assumes "length xs = length ys"
  shows "x \<in> set xs \<longleftrightarrow> (\<exists>y. map_of (zip xs ys) x = Some y)"
using assms by (induct rule: list_induct2) simp_all

lemma map_of_zip_upd:
  fixes x :: 'a and xs :: "'a list" and ys zs :: "'b list"
  assumes "length ys = length xs"
    and "length zs = length xs"
    and "x \<notin> set xs"
    and "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)"
  shows "map_of (zip xs ys) = map_of (zip xs zs)"
proof
  fix x' :: 'a
  show "map_of (zip xs ys) x' = map_of (zip xs zs) x'"
  proof (cases "x = x'")
    case True
    from assms True map_of_zip_is_None [of xs ys x']
      have "map_of (zip xs ys) x' = None" by simp
    moreover from assms True map_of_zip_is_None [of xs zs x']
      have "map_of (zip xs zs) x' = None" by simp
    ultimately show ?thesis by simp
  next
    case False from assms
      have "(map_of (zip xs ys)(x \<mapsto> y)) x' = (map_of (zip xs zs)(x \<mapsto> z)) x'" by auto
    with False show ?thesis by simp
  qed
qed

lemma map_of_zip_inject:
  assumes "length ys = length xs"
    and "length zs = length xs"
    and dist: "distinct xs"
    and map_of: "map_of (zip xs ys) = map_of (zip xs zs)"
  shows "ys = zs"
  using assms(1) assms(2)[symmetric]
  using dist map_of
proof (induct ys xs zs rule: list_induct3)
  case Nil show ?case by simp
next
  case (Cons y ys x xs z zs)
  from \<open>map_of (zip (x#xs) (y#ys)) = map_of (zip (x#xs) (z#zs))\<close>
    have map_of: "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)" by simp
  from Cons have "length ys = length xs" and "length zs = length xs"
    and "x \<notin> set xs" by simp_all
  then have "map_of (zip xs ys) = map_of (zip xs zs)" using map_of by (rule map_of_zip_upd)
  with Cons.hyps \<open>distinct (x # xs)\<close> have "ys = zs" by simp
  moreover from map_of have "y = z" by (rule map_upd_eqD1)
  ultimately show ?case by simp
qed

lemma map_of_zip_nth:
  assumes "length xs = length ys"
  assumes "distinct xs"
  assumes "i < length ys"
  shows "map_of (zip xs ys) (xs ! i) = Some (ys ! i)"
using assms proof (induct arbitrary: i rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons x xs y ys)
  then show ?case
    using less_Suc_eq_0_disj by auto
qed

lemma map_of_zip_map:
  "map_of (zip xs (map f xs)) = (\<lambda>x. if x \<in> set xs then Some (f x) else None)"
  by (induct xs) (simp_all add: fun_eq_iff)

lemma finite_range_map_of: "finite (range (map_of xys))"
proof (induct xys)
  case (Cons a xys)
  then show ?case
    using finite_range_updI by fastforce
qed auto

lemma map_of_SomeD: "map_of xs k = Some y \<Longrightarrow> (k, y) \<in> set xs"
  by (induct xs) (auto split: if_splits)

lemma map_of_mapk_SomeI:
  "inj f \<Longrightarrow> map_of t k = Some x \<Longrightarrow>
   map_of (map (case_prod (\<lambda>k. Pair (f k))) t) (f k) = Some x"
by (induct t) (auto simp: inj_eq)

lemma weak_map_of_SomeI: "(k, x) \<in> set l \<Longrightarrow> \<exists>x. map_of l k = Some x"
by (induct l) auto

lemma map_of_filter_in:
  "map_of xs k = Some z \<Longrightarrow> P k z \<Longrightarrow> map_of (filter (case_prod P) xs) k = Some z"
by (induct xs) auto

lemma map_of_map:
  "map_of (map (\<lambda>(k, v). (k, f v)) xs) = map_option f \<circ> map_of xs"
  by (induct xs) (auto simp: fun_eq_iff)

lemma dom_map_option:
  "dom (\<lambda>k. map_option (f k) (m k)) = dom m"
  by (simp add: dom_def)

lemma dom_map_option_comp [simp]:
  "dom (map_option g \<circ> m) = dom m"
  using dom_map_option [of "\<lambda>_. g" m] by (simp add: comp_def)

subsection \<open>\<^const>\<open>map_option\<close> related\<close>

lemma map_option_o_empty [simp]: "map_option f \<circ> empty = empty"
by (rule ext) simp

lemma map_option_o_map_upd [simp]:
  "map_option f \<circ> m(a\<mapsto>b) = (map_option f \<circ> m)(a\<mapsto>f b)"
by (rule ext) simp

subsection \<open>@{term [source] map_comp} related\<close>

lemma map_comp_empty [simp]:
  "m \<circ>\<^sub>m empty = empty"
  "empty \<circ>\<^sub>m m = empty"
by (auto simp: map_comp_def split: option.splits)

lemma map_comp_simps [simp]:
  "m2 k = None \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = None"
  "m2 k = Some k' \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = m1 k'"
by (auto simp: map_comp_def)

lemma map_comp_Some_iff:
  "((m1 \<circ>\<^sub>m m2) k = Some v) = (\<exists>k'. m2 k = Some k' \<and> m1 k' = Some v)"
by (auto simp: map_comp_def split: option.splits)

lemma map_comp_None_iff:
  "((m1 \<circ>\<^sub>m m2) k = None) = (m2 k = None \<or> (\<exists>k'. m2 k = Some k' \<and> m1 k' = None)) "
by (auto simp: map_comp_def split: option.splits)

subsection \<open>\<open>++\<close>\<close>

lemma map_add_empty[simp]: "m ++ empty = m"
by(simp add: map_add_def)

lemma empty_map_add[simp]: "empty ++ m = m"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_assoc[simp]: "m1 ++ (m2 ++ m3) = (m1 ++ m2) ++ m3"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_Some_iff:
  "((m ++ n) k = Some x) = (n k = Some x \<or> n k = None \<and> m k = Some x)"
by (simp add: map_add_def split: option.split)

lemma map_add_SomeD [dest!]:
  "(m ++ n) k = Some x \<Longrightarrow> n k = Some x \<or> n k = None \<and> m k = Some x"
by (rule map_add_Some_iff [THEN iffD1])

lemma map_add_find_right [simp]: "n k = Some xx \<Longrightarrow> (m ++ n) k = Some xx"
by (subst map_add_Some_iff) fast

lemma map_add_None [iff]: "((m ++ n) k = None) = (n k = None \<and> m k = None)"
by (simp add: map_add_def split: option.split)

lemma map_add_upd[simp]: "f ++ g(x\<mapsto>y) = (f ++ g)(x\<mapsto>y)"
by (rule ext) (simp add: map_add_def)

lemma map_add_upds[simp]: "m1 ++ (m2(xs[\<mapsto>]ys)) = (m1++m2)(xs[\<mapsto>]ys)"
by (simp add: map_upds_def)

lemma map_add_upd_left: "m\<notin>dom e2 \<Longrightarrow> e1(m \<mapsto> u1) ++ e2 = (e1 ++ e2)(m \<mapsto> u1)"
by (rule ext) (auto simp: map_add_def dom_def split: option.split)

lemma map_of_append[simp]: "map_of (xs @ ys) = map_of ys ++ map_of xs"
  unfolding map_add_def
proof (induct xs)
  case (Cons a xs)
  then show ?case
    by (force split: option.split)
qed auto

lemma finite_range_map_of_map_add:
  "finite (range f) \<Longrightarrow> finite (range (f ++ map_of l))"
proof (induct l)
case (Cons a l)
  then show ?case
    by (metis finite_range_updI map_add_upd map_of.simps(2))
qed auto

lemma inj_on_map_add_dom [iff]:
  "inj_on (m ++ m') (dom m') = inj_on m' (dom m')"
  by (fastforce simp: map_add_def dom_def inj_on_def split: option.splits)

lemma map_upds_fold_map_upd:
  "m(ks[\<mapsto>]vs) = foldl (\<lambda>m (k, v). m(k \<mapsto> v)) m (zip ks vs)"
unfolding map_upds_def proof (rule sym, rule zip_obtain_same_length)
  fix ks :: "'a list" and vs :: "'b list"
  assume "length ks = length vs"
  then show "foldl (\<lambda>m (k, v). m(k\<mapsto>v)) m (zip ks vs) = m ++ map_of (rev (zip ks vs))"
    by(induct arbitrary: m rule: list_induct2) simp_all
qed

lemma map_add_map_of_foldr:
  "m ++ map_of ps = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) ps m"
  by (induct ps) (auto simp: fun_eq_iff map_add_def)

subsection \<open>@{term [source] restrict_map}\<close>

lemma restrict_map_to_empty [simp]: "m|`{} = empty"
  by (simp add: restrict_map_def)

lemma restrict_map_insert: "f |` (insert a A) = (f |` A)(a := f a)"
  by (auto simp: restrict_map_def)

lemma restrict_map_empty [simp]: "empty|`D = empty"
  by (simp add: restrict_map_def)

lemma restrict_in [simp]: "x \<in> A \<Longrightarrow> (m|`A) x = m x"
  by (simp add: restrict_map_def)

lemma restrict_out [simp]: "x \<notin> A \<Longrightarrow> (m|`A) x = None"
  by (simp add: restrict_map_def)

lemma ran_restrictD: "y \<in> ran (m|`A) \<Longrightarrow> \<exists>x\<in>A. m x = Some y"
  by (auto simp: restrict_map_def ran_def split: if_split_asm)

lemma dom_restrict [simp]: "dom (m|`A) = dom m \<inter> A"
  by (auto simp: restrict_map_def dom_def split: if_split_asm)

lemma restrict_upd_same [simp]: "m(x\<mapsto>y)|`(-{x}) = m|`(-{x})"
  by (rule ext) (auto simp: restrict_map_def)

lemma restrict_restrict [simp]: "m|`A|`B = m|`(A\<inter>B)"
  by (rule ext) (auto simp: restrict_map_def)

lemma restrict_fun_upd [simp]:
  "m(x := y)|`D = (if x \<in> D then (m|`(D-{x}))(x := y) else m|`D)"
  by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_None_restrict [simp]:
  "(m|`D)(x := None) = (if x \<in> D then m|`(D - {x}) else m|`D)"
  by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict: "(m|`D)(x := y) = (m|`(D-{x}))(x := y)"
  by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict_conv [simp]:
  "x \<in> D \<Longrightarrow> (m|`D)(x := y) = (m|`(D-{x}))(x := y)"
  by (rule fun_upd_restrict)

lemma map_of_map_restrict:
  "map_of (map (\<lambda>k. (k, f k)) ks) = (Some \<circ> f) |` set ks"
  by (induct ks) (simp_all add: fun_eq_iff restrict_map_insert)

lemma restrict_complement_singleton_eq:
  "f |` (- {x}) = f(x := None)"
  by auto

subsection \<open>@{term [source] map_upds}\<close>

lemma map_upds_Nil1 [simp]: "m([] [\<mapsto>] bs) = m"
  by (simp add: map_upds_def)

lemma map_upds_Nil2 [simp]: "m(as [\<mapsto>] []) = m"
  by (simp add:map_upds_def)

lemma map_upds_Cons [simp]: "m(a#as [\<mapsto>] b#bs) = (m(a\<mapsto>b))(as[\<mapsto>]bs)"
  by (simp add:map_upds_def)

lemma map_upds_append1 [simp]:
  "size xs < size ys \<Longrightarrow> m(xs@[x] [\<mapsto>] ys) = m(xs [\<mapsto>] ys)(x \<mapsto> ys!size xs)"
proof (induct xs arbitrary: ys m)
  case Nil
  then show ?case
    by (auto simp: neq_Nil_conv)
next
  case (Cons a xs)
  then show ?case
    by (cases ys) auto
qed

lemma map_upds_list_update2_drop [simp]:
  "size xs \<le> i \<Longrightarrow> m(xs[\<mapsto>]ys[i:=y]) = m(xs[\<mapsto>]ys)"
proof (induct xs arbitrary: m ys i)
  case Nil
  then show ?case
    by auto
next
  case (Cons a xs)
  then show ?case
    by (cases ys) (use Cons in \<open>auto split: nat.split\<close>)
qed

text \<open>Something weirdly sensitive about this proof, which needs only four lines in apply style\<close>
lemma map_upd_upds_conv_if:
  "(f(x\<mapsto>y))(xs [\<mapsto>] ys) =
   (if x \<in> set(take (length ys) xs) then f(xs [\<mapsto>] ys)
                                    else (f(xs [\<mapsto>] ys))(x\<mapsto>y))"
proof (induct xs arbitrary: x y ys f)
  case (Cons a xs)
  show ?case
  proof (cases ys)
    case (Cons z zs)
    then show ?thesis
      using Cons.hyps
      apply (auto split: if_split simp: fun_upd_twist)
      using Cons.hyps apply fastforce+
      done
  qed auto
qed auto

lemma map_upds_twist [simp]:
  "a \<notin> set as \<Longrightarrow> m(a\<mapsto>b)(as[\<mapsto>]bs) = m(as[\<mapsto>]bs)(a\<mapsto>b)"
using set_take_subset by (fastforce simp add: map_upd_upds_conv_if)

lemma map_upds_apply_nontin [simp]:
  "x \<notin> set xs \<Longrightarrow> (f(xs[\<mapsto>]ys)) x = f x"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma fun_upds_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs@zs[\<mapsto>]ys) = m(xs[\<mapsto>]ys)"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma fun_upds_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs[\<mapsto>]ys@zs) = m(xs[\<mapsto>]ys)"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma restrict_map_upds[simp]:
  "\<lbrakk> length xs = length ys; set xs \<subseteq> D \<rbrakk>
    \<Longrightarrow> m(xs [\<mapsto>] ys)|`D = (m|`(D - set xs))(xs [\<mapsto>] ys)"
proof (induct xs arbitrary: m ys)
  case (Cons a xs)
  then show ?case
  proof (cases ys)
    case (Cons z zs)
    with Cons.hyps Cons.prems show ?thesis
      apply (simp add: insert_absorb flip: Diff_insert)
      apply (auto simp add: map_upd_upds_conv_if)
      done
  qed auto
qed auto

subsection \<open>@{term [source] dom}\<close>

lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
  by (auto simp: dom_def)

lemma domI: "m a = Some b \<Longrightarrow> a \<in> dom m"
  by (simp add: dom_def)
(* declare domI [intro]? *)

lemma domD: "a \<in> dom m \<Longrightarrow> \<exists>b. m a = Some b"
  by (cases "m a") (auto simp add: dom_def)

lemma domIff [iff, simp del, code_unfold]: "a \<in> dom m \<longleftrightarrow> m a \<noteq> None"
  by (simp add: dom_def)

lemma dom_empty [simp]: "dom empty = {}"
  by (simp add: dom_def)

lemma dom_fun_upd [simp]:
  "dom(f(x := y)) = (if y = None then dom f - {x} else insert x (dom f))"
  by (auto simp: dom_def)

lemma dom_if:
  "dom (\<lambda>x. if P x then f x else g x) = dom f \<inter> {x. P x} \<union> dom g \<inter> {x. \<not> P x}"
  by (auto split: if_splits)

lemma dom_map_of_conv_image_fst:
  "dom (map_of xys) = fst ` set xys"
  by (induct xys) (auto simp add: dom_if)

lemma dom_map_of_zip [simp]: "length xs = length ys \<Longrightarrow> dom (map_of (zip xs ys)) = set xs"
  by (induct rule: list_induct2) (auto simp: dom_if)

lemma finite_dom_map_of: "finite (dom (map_of l))"
  by (induct l) (auto simp: dom_def insert_Collect [symmetric])

lemma dom_map_upds [simp]:
  "dom(m(xs[\<mapsto>]ys)) = set(take (length ys) xs) \<union> dom m"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma dom_map_add [simp]: "dom (m ++ n) = dom n \<union> dom m"
  by (auto simp: dom_def)

lemma dom_override_on [simp]:
  "dom (override_on f g A) =
    (dom f  - {a. a \<in> A - dom g}) \<union> {a. a \<in> A \<inter> dom g}"
  by (auto simp: dom_def override_on_def)

lemma map_add_dom_app_simps:
  "m \<in> dom l2 \<Longrightarrow> (l1 ++ l2) m = l2 m"
  "m \<notin> dom l1 \<Longrightarrow> (l1 ++ l2) m = l2 m"
  "m \<notin> dom l2 \<Longrightarrow> (l1 ++ l2) m = l1 m"
  by (auto simp add: map_add_def split: option.split_asm)

lemma dom_const [simp]:
  "dom (\<lambda>x. Some (f x)) = UNIV"
  by auto

(* Due to John Matthews - could be rephrased with dom *)
lemma finite_map_freshness:
  "finite (dom (f :: 'a \<rightharpoonup> 'b)) \<Longrightarrow> \<not> finite (UNIV :: 'a set) \<Longrightarrow>
   \<exists>x. f x = None"
  by (bestsimp dest: ex_new_if_finite)

lemma dom_minus:
  "f x = None \<Longrightarrow> dom f - insert x A = dom f - A"
  unfolding dom_def by simp

lemma insert_dom:
  "f x = Some y \<Longrightarrow> insert x (dom f) = dom f"
  unfolding dom_def by auto

lemma map_of_map_keys:
  "set xs = dom m \<Longrightarrow> map_of (map (\<lambda>k. (k, the (m k))) xs) = m"
  by (rule ext) (auto simp add: map_of_map_restrict restrict_map_def)

lemma map_of_eqI:
  assumes set_eq: "set (map fst xs) = set (map fst ys)"
  assumes map_eq: "\<forall>k\<in>set (map fst xs). map_of xs k = map_of ys k"
  shows "map_of xs = map_of ys"
proof (rule ext)
  fix k show "map_of xs k = map_of ys k"
  proof (cases "map_of xs k")
    case None
    then have "k \<notin> set (map fst xs)" by (simp add: map_of_eq_None_iff)
    with set_eq have "k \<notin> set (map fst ys)" by simp
    then have "map_of ys k = None" by (simp add: map_of_eq_None_iff)
    with None show ?thesis by simp
  next
    case (Some v)
    then have "k \<in> set (map fst xs)" by (auto simp add: dom_map_of_conv_image_fst [symmetric])
    with map_eq show ?thesis by auto
  qed
qed

lemma map_of_eq_dom:
  assumes "map_of xs = map_of ys"
  shows "fst ` set xs = fst ` set ys"
proof -
  from assms have "dom (map_of xs) = dom (map_of ys)" by simp
  then show ?thesis by (simp add: dom_map_of_conv_image_fst)
qed

lemma finite_set_of_finite_maps:
  assumes "finite A" "finite B"
  shows "finite {m. dom m = A \<and> ran m \<subseteq> B}" (is "finite ?S")
proof -
  let ?S' = "{m. \<forall>x. (x \<in> A \<longrightarrow> m x \<in> Some ` B) \<and> (x \<notin> A \<longrightarrow> m x = None)}"
  have "?S = ?S'"
  proof
    show "?S \<subseteq> ?S'" by (auto simp: dom_def ran_def image_def)
    show "?S' \<subseteq> ?S"
    proof
      fix m assume "m \<in> ?S'"
      hence 1: "dom m = A" by force
      hence 2: "ran m \<subseteq> B" using \<open>m \<in> ?S'\<close> by (auto simp: dom_def ran_def)
      from 1 2 show "m \<in> ?S" by blast
    qed
  qed
  with assms show ?thesis by(simp add: finite_set_of_finite_funs)
qed

subsection \<open>@{term [source] ran}\<close>

lemma ranI: "m a = Some b \<Longrightarrow> b \<in> ran m"
  by (auto simp: ran_def)
(* declare ranI [intro]? *)

lemma ran_empty [simp]: "ran empty = {}"
  by (auto simp: ran_def)

lemma ran_map_upd [simp]:  "m a = None \<Longrightarrow> ran(m(a\<mapsto>b)) = insert b (ran m)"
  unfolding ran_def
  by force

lemma fun_upd_None_if_notin_dom[simp]: "k \<notin> dom m \<Longrightarrow> m(k := None) = m"
  by auto

lemma ran_map_upd_Some:
  "\<lbrakk> m x = Some y; inj_on m (dom m); z \<notin> ran m \<rbrakk> \<Longrightarrow> ran(m(x := Some z)) = ran m - {y} \<union> {z}"
by(force simp add: ran_def domI inj_onD)

lemma ran_map_add:
  assumes "dom m1 \<inter> dom m2 = {}"
  shows "ran (m1 ++ m2) = ran m1 \<union> ran m2"
proof
  show "ran (m1 ++ m2) \<subseteq> ran m1 \<union> ran m2"
    unfolding ran_def by auto
next
  show "ran m1 \<union> ran m2 \<subseteq> ran (m1 ++ m2)"
  proof -
    have "(m1 ++ m2) x = Some y" if "m1 x = Some y" for x y
      using assms map_add_comm that by fastforce
    moreover have "(m1 ++ m2) x = Some y" if "m2 x = Some y" for x y
      using assms that by auto
    ultimately show ?thesis
      unfolding ran_def by blast
  qed
qed

lemma finite_ran:
  assumes "finite (dom p)"
  shows "finite (ran p)"
proof -
  have "ran p = (\<lambda>x. the (p x)) ` dom p"
    unfolding ran_def by force
  from this \<open>finite (dom p)\<close> show ?thesis by auto
qed

lemma ran_distinct:
  assumes dist: "distinct (map fst al)"
  shows "ran (map_of al) = snd ` set al"
  using assms
proof (induct al)
  case Nil
  then show ?case by simp
next
  case (Cons kv al)
  then have "ran (map_of al) = snd ` set al" by simp
  moreover from Cons.prems have "map_of al (fst kv) = None"
    by (simp add: map_of_eq_None_iff)
  ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed

lemma ran_map_of_zip:
  assumes "length xs = length ys" "distinct xs"
  shows "ran (map_of (zip xs ys)) = set ys"
using assms by (simp add: ran_distinct set_map[symmetric])

lemma ran_map_option: "ran (\<lambda>x. map_option f (m x)) = f ` ran m"
  by (auto simp add: ran_def)

subsection \<open>@{term [source] graph}\<close>

lemma in_graphI: "m k = Some v \<Longrightarrow> (k, v) \<in> graph m"
  unfolding graph_def by blast

lemma in_graphD: "(k, v) \<in> graph m \<Longrightarrow> m k = Some v"
  unfolding graph_def by blast

lemma graph_map_upd[simp]: "graph (m(k \<mapsto> v)) = insert (k, v) (graph (m(k := None)))"
  unfolding graph_def by (auto split: if_splits)

lemma graph_fun_upd_None: "graph (m(k := None)) = {e \<in> graph m. fst e \<noteq> k}"
  unfolding graph_def by (auto split: if_splits)

lemma graph_restrictD:
  assumes "(k, v) \<in> graph (m |` A)"
  shows "k \<in> A" and "m k = Some v"
  using assms unfolding graph_def
  by (auto simp: restrict_map_def split: if_splits)

lemma graph_map_comp[simp]: "graph (m1 \<circ>\<^sub>m m2) = graph m2 O graph m1"
  unfolding graph_def by (auto simp: map_comp_Some_iff relcomp_unfold)

lemma graph_map_add: "dom m1 \<inter> dom m2 = {} \<Longrightarrow> graph (m1 ++ m2) = graph m1 \<union> graph m2"
  unfolding graph_def using map_add_comm by force

lemma graph_eq_to_snd_dom: "graph m = (\<lambda>x. (x, the (m x))) ` dom m"
  unfolding graph_def dom_def by force

lemma fst_graph_eq_dom: "fst ` graph m = dom m"
  unfolding graph_eq_to_snd_dom by force

lemma graph_domD: "x \<in> graph m \<Longrightarrow> fst x \<in> dom m"
  using fst_graph_eq_dom by (metis imageI)

lemma snd_graph_ran: "snd ` graph m = ran m"
  unfolding graph_def ran_def by force

lemma graph_ranD: "x \<in> graph m \<Longrightarrow> snd x \<in> ran m"
  using snd_graph_ran by (metis imageI)

lemma finite_graph_map_of: "finite (graph (map_of al))"
  unfolding graph_eq_to_snd_dom finite_dom_map_of
  using finite_dom_map_of by blast

lemma graph_map_of_if_distinct_dom: "distinct (map fst al) \<Longrightarrow> graph (map_of al) = set al"
  unfolding graph_def by auto

lemma finite_graph_iff_finite_dom[simp]: "finite (graph m) = finite (dom m)"
  by (metis graph_eq_to_snd_dom finite_imageI fst_graph_eq_dom)

lemma inj_on_fst_graph: "inj_on fst (graph m)"
  unfolding graph_def inj_on_def by force

subsection \<open>\<open>map_le\<close>\<close>

lemma map_le_empty [simp]: "empty \<subseteq>\<^sub>m g"
  by (simp add: map_le_def)

lemma upd_None_map_le [simp]: "f(x := None) \<subseteq>\<^sub>m f"
  by (force simp add: map_le_def)

lemma map_le_upd[simp]: "f \<subseteq>\<^sub>m g ==> f(a := b) \<subseteq>\<^sub>m g(a := b)"
  by (fastforce simp add: map_le_def)

lemma map_le_imp_upd_le [simp]: "m1 \<subseteq>\<^sub>m m2 \<Longrightarrow> m1(x := None) \<subseteq>\<^sub>m m2(x \<mapsto> y)"
  by (force simp add: map_le_def)

lemma map_le_upds [simp]:
  "f \<subseteq>\<^sub>m g \<Longrightarrow> f(as [\<mapsto>] bs) \<subseteq>\<^sub>m g(as [\<mapsto>] bs)"
proof (induct as arbitrary: f g bs)
  case (Cons a as)
  then show ?case
    by (cases bs) (use Cons in auto)
qed auto

lemma map_le_implies_dom_le: "(f \<subseteq>\<^sub>m g) \<Longrightarrow> (dom f \<subseteq> dom g)"
  by (fastforce simp add: map_le_def dom_def)

lemma map_le_refl [simp]: "f \<subseteq>\<^sub>m f"
  by (simp add: map_le_def)

lemma map_le_trans[trans]: "\<lbrakk> m1 \<subseteq>\<^sub>m m2; m2 \<subseteq>\<^sub>m m3\<rbrakk> \<Longrightarrow> m1 \<subseteq>\<^sub>m m3"
  by (auto simp add: map_le_def dom_def)

lemma map_le_antisym: "\<lbrakk> f \<subseteq>\<^sub>m g; g \<subseteq>\<^sub>m f \<rbrakk> \<Longrightarrow> f = g"
  unfolding map_le_def
  by (metis ext domIff)

lemma map_le_map_add [simp]: "f \<subseteq>\<^sub>m g ++ f"
  by (fastforce simp: map_le_def)

lemma map_le_iff_map_add_commute: "f \<subseteq>\<^sub>m f ++ g \<longleftrightarrow> f ++ g = g ++ f"
  by (fastforce simp: map_add_def map_le_def fun_eq_iff split: option.splits)

lemma map_add_le_mapE: "f ++ g \<subseteq>\<^sub>m h \<Longrightarrow> g \<subseteq>\<^sub>m h"
  by (fastforce simp: map_le_def map_add_def dom_def)

lemma map_add_le_mapI: "\<lbrakk> f \<subseteq>\<^sub>m h; g \<subseteq>\<^sub>m h \<rbrakk> \<Longrightarrow> f ++ g \<subseteq>\<^sub>m h"
  by (auto simp: map_le_def map_add_def dom_def split: option.splits)

lemma map_add_subsumed1: "f \<subseteq>\<^sub>m g \<Longrightarrow> f++g = g"
by (simp add: map_add_le_mapI map_le_antisym)

lemma map_add_subsumed2: "f \<subseteq>\<^sub>m g \<Longrightarrow> g++f = g"
by (metis map_add_subsumed1 map_le_iff_map_add_commute)

lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs by (auto split: if_split_asm)
next
  assume ?lhs
  then obtain v where v: "f x = Some v" by auto
  show ?rhs
  proof
    show "f = [x \<mapsto> v]"
    proof (rule map_le_antisym)
      show "[x \<mapsto> v] \<subseteq>\<^sub>m f"
        using v by (auto simp add: map_le_def)
      show "f \<subseteq>\<^sub>m [x \<mapsto> v]"
        using \<open>dom f = {x}\<close> \<open>f x = Some v\<close> by (auto simp add: map_le_def)
    qed
  qed
qed

lemma map_add_eq_empty_iff[simp]:
  "(f++g = empty) \<longleftrightarrow> f = empty \<and> g = empty"
by (metis map_add_None)

lemma empty_eq_map_add_iff[simp]:
  "(empty = f++g) \<longleftrightarrow> f = empty \<and> g = empty"
by(subst map_add_eq_empty_iff[symmetric])(rule eq_commute)

subsection \<open>Various\<close>

lemma set_map_of_compr:
  assumes distinct: "distinct (map fst xs)"
  shows "set xs = {(k, v). map_of xs k = Some v}"
  using assms
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  obtain k v where "x = (k, v)" by (cases x) blast
  with Cons.prems have "k \<notin> dom (map_of xs)"
    by (simp add: dom_map_of_conv_image_fst)
  then have *: "insert (k, v) {(k, v). map_of xs k = Some v} =
    {(k', v'). (map_of xs(k \<mapsto> v)) k' = Some v'}"
    by (auto split: if_splits)
  from Cons have "set xs = {(k, v). map_of xs k = Some v}" by simp
  with * \<open>x = (k, v)\<close> show ?case by simp
qed

lemma eq_key_imp_eq_value:
  "v1 = v2"
  if "distinct (map fst xs)" "(k, v1) \<in> set xs" "(k, v2) \<in> set xs"
proof -
  from that have "inj_on fst (set xs)"
    by (simp add: distinct_map)
  moreover have "fst (k, v1) = fst (k, v2)"
    by simp
  ultimately have "(k, v1) = (k, v2)"
    by (rule inj_onD) (fact that)+
  then show ?thesis
    by simp
qed

lemma map_of_inject_set:
  assumes distinct: "distinct (map fst xs)" "distinct (map fst ys)"
  shows "map_of xs = map_of ys \<longleftrightarrow> set xs = set ys" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  moreover from \<open>distinct (map fst xs)\<close> have "set xs = {(k, v). map_of xs k = Some v}"
    by (rule set_map_of_compr)
  moreover from \<open>distinct (map fst ys)\<close> have "set ys = {(k, v). map_of ys k = Some v}"
    by (rule set_map_of_compr)
  ultimately show ?rhs by simp
next
  assume ?rhs show ?lhs
  proof
    fix k
    show "map_of xs k = map_of ys k"
    proof (cases "map_of xs k")
      case None
      with \<open>?rhs\<close> have "map_of ys k = None"
        by (simp add: map_of_eq_None_iff)
      with None show ?thesis by simp
    next
      case (Some v)
      with distinct \<open>?rhs\<close> have "map_of ys k = Some v"
        by simp
      with Some show ?thesis by simp
    qed
  qed
qed

lemma finite_Map_induct[consumes 1, case_names empty update]:
  assumes "finite (dom m)"
  assumes "P Map.empty"
  assumes "\<And>k v m. finite (dom m) \<Longrightarrow> k \<notin> dom m \<Longrightarrow> P m \<Longrightarrow> P (m(k \<mapsto> v))"
  shows "P m"
  using assms(1)
proof(induction "dom m" arbitrary: m rule: finite_induct)
  case empty
  then show ?case using assms(2) unfolding dom_def by simp
next
  case (insert x F)
  then have "finite (dom (m(x:=None)))" "x \<notin> dom (m(x:=None))" "P (m(x:=None))"
    by (metis Diff_insert_absorb dom_fun_upd)+
  with assms(3)[OF this] show ?case
    by (metis fun_upd_triv fun_upd_upd option.exhaust)
qed

hide_const (open) Map.empty Map.graph

end


(*  Title:     HOL/Probability/Weak_Convergence.thy
    Authors:   Jeremy Avigad (CMU), Johannes Hölzl (TUM)
*)

section \<open>Weak Convergence of Functions and Distributions\<close>

text \<open>Properties of weak convergence of functions and measures, including the portmanteau theorem.\<close>

theory Weak_Convergence
  imports Distribution_Functions
begin

section \<open>Weak Convergence of Functions\<close>

definition
  weak_conv :: "(nat \<Rightarrow> (real \<Rightarrow> real)) \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> bool"
where
  "weak_conv F_seq F \<equiv> \<forall>x. isCont F x \<longrightarrow> (\<lambda>n. F_seq n x) \<longlonglongrightarrow> F x"

section \<open>Weak Convergence of Distributions\<close>

definition
  weak_conv_m :: "(nat \<Rightarrow> real measure) \<Rightarrow> real measure \<Rightarrow> bool"
where
  "weak_conv_m M_seq M \<equiv> weak_conv (\<lambda>n. cdf (M_seq n)) (cdf M)"

section \<open>Skorohod's theorem\<close>

locale right_continuous_mono =
  fixes f :: "real \<Rightarrow> real" and a b :: real
  assumes cont: "\<And>x. continuous (at_right x) f"
  assumes mono: "mono f"
  assumes bot: "(f \<longlongrightarrow> a) at_bot"
  assumes top: "(f \<longlongrightarrow> b) at_top"
begin

abbreviation I :: "real \<Rightarrow> real" where
  "I \<omega> \<equiv> Inf {x. \<omega> \<le> f x}"

lemma pseudoinverse: assumes "a < \<omega>" "\<omega> < b" shows "\<omega> \<le> f x \<longleftrightarrow> I \<omega> \<le> x"
proof
  let ?F = "{x. \<omega> \<le> f x}"
  obtain y where "f y < \<omega>"
    by (metis eventually_happens' trivial_limit_at_bot_linorder order_tendstoD(2) bot \<open>a < \<omega>\<close>)
  with mono have bdd: "bdd_below ?F"
    by (auto intro!: bdd_belowI[of _ y] elim: mono_invE[OF _ less_le_trans])

  have ne: "?F \<noteq> {}"
    using order_tendstoD(1)[OF top \<open>\<omega> < b\<close>]
    by (auto dest!: eventually_happens'[OF trivial_limit_at_top_linorder] intro: less_imp_le)

  show "\<omega> \<le> f x \<Longrightarrow> I \<omega> \<le> x"
    by (auto intro!: cInf_lower bdd)

  { assume *: "I \<omega> \<le> x"
    have "\<omega> \<le> (INF s\<in>{x. \<omega> \<le> f x}. f s)"
      by (rule cINF_greatest[OF ne]) auto
    also have "\<dots> = f (I \<omega>)"
      using continuous_at_Inf_mono[OF mono cont ne bdd] ..
    also have "\<dots> \<le> f x"
      using * by (rule monoD[OF \<open>mono f\<close>])
    finally show "\<omega> \<le> f x" . }
qed

lemma pseudoinverse': "\<forall>\<omega>\<in>{a<..<b}. \<forall>x. \<omega> \<le> f x \<longleftrightarrow> I \<omega> \<le> x"
  by (intro ballI allI impI pseudoinverse) auto

lemma mono_I: "mono_on {a <..< b} I"
  unfolding mono_on_def by (metis order.trans order.refl pseudoinverse')

end

locale cdf_distribution = real_distribution
begin

abbreviation "C \<equiv> cdf M"

sublocale right_continuous_mono C 0 1
  by standard
     (auto intro: cdf_nondecreasing cdf_is_right_cont cdf_lim_at_top_prob cdf_lim_at_bot monoI)

lemma measurable_C[measurable]: "C \<in> borel_measurable borel"
  by (intro borel_measurable_mono mono)

lemma measurable_CI[measurable]: "I \<in> borel_measurable (restrict_space borel {0<..<1})"
  by (intro borel_measurable_mono_on_fnc mono_I)

lemma emeasure_distr_I: "emeasure (distr (restrict_space lborel {0<..<1::real}) borel I) UNIV = 1"
  by (simp add: emeasure_distr space_restrict_space emeasure_restrict_space )

lemma distr_I_eq_M: "distr (restrict_space lborel {0<..<1::real}) borel I = M" (is "?I = _")
proof (intro cdf_unique ext)
  let ?\<Omega> = "restrict_space lborel {0<..<1}::real measure"
  interpret \<Omega>: prob_space ?\<Omega>
    by (auto simp add: emeasure_restrict_space space_restrict_space intro!: prob_spaceI)
  show "real_distribution ?I"
    by auto

  fix x
  have "cdf ?I x = measure lborel {\<omega>\<in>{0<..<1}. \<omega> \<le> C x}"
    by (subst cdf_def)
       (auto simp: pseudoinverse[symmetric] measure_distr space_restrict_space measure_restrict_space
             intro!: arg_cong2[where f="measure"])
  also have "\<dots> = measure lborel {0 <..< C x}"
    using cdf_bounded_prob[of x] AE_lborel_singleton[of "C x"]
    by (auto intro!: arg_cong[where f=enn2real] emeasure_eq_AE simp: measure_def)
  also have "\<dots> = C x"
    by (simp add: cdf_nonneg)
  finally show "cdf (distr ?\<Omega> borel I) x = C x" .
qed standard

end

context
  fixes \<mu> :: "nat \<Rightarrow> real measure"
    and M :: "real measure"
  assumes \<mu>: "\<And>n. real_distribution (\<mu> n)"
  assumes M: "real_distribution M"
  assumes \<mu>_to_M: "weak_conv_m \<mu> M"
begin

(* state using obtains? *)
theorem Skorohod:
 "\<exists> (\<Omega> :: real measure) (Y_seq :: nat \<Rightarrow> real \<Rightarrow> real) (Y :: real \<Rightarrow> real).
    prob_space \<Omega> \<and>
    (\<forall>n. Y_seq n \<in> measurable \<Omega> borel) \<and>
    (\<forall>n. distr \<Omega> borel (Y_seq n) = \<mu> n) \<and>
    Y \<in> measurable \<Omega> lborel \<and>
    distr \<Omega> borel Y = M \<and>
    (\<forall>x \<in> space \<Omega>. (\<lambda>n. Y_seq n x) \<longlonglongrightarrow> Y x)"
proof -
  interpret \<mu>: cdf_distribution "\<mu> n" for n
    unfolding cdf_distribution_def by (rule \<mu>)
  interpret M: cdf_distribution M
    unfolding cdf_distribution_def by (rule M)

  have conv: "measure M {x} = 0 \<Longrightarrow> (\<lambda>n. \<mu>.C n x) \<longlonglongrightarrow> M.C x" for x
    using \<mu>_to_M M.isCont_cdf by (auto simp: weak_conv_m_def weak_conv_def)

  let ?\<Omega> = "restrict_space lborel {0<..<1} :: real measure"
  have "prob_space ?\<Omega>"
    by (auto simp: space_restrict_space emeasure_restrict_space intro!: prob_spaceI)
  interpret \<Omega>: prob_space ?\<Omega>
    by fact

  have Y_distr: "distr ?\<Omega> borel M.I = M"
    by (rule M.distr_I_eq_M)

  have Y_cts_cnv: "(\<lambda>n. \<mu>.I n \<omega>) \<longlonglongrightarrow> M.I \<omega>"
    if \<omega>: "\<omega> \<in> {0<..<1}" "isCont M.I \<omega>" for \<omega> :: real
  proof (intro limsup_le_liminf_real)
    show "liminf (\<lambda>n. \<mu>.I n \<omega>) \<ge> M.I \<omega>"
      unfolding le_Liminf_iff
    proof safe
      fix B :: ereal assume B: "B < M.I \<omega>"
      then show "\<forall>\<^sub>F n in sequentially. B < \<mu>.I n \<omega>"
      proof (cases B)
        case (real r)
        with B have r: "r < M.I \<omega>"
          by simp
        then obtain x where x: "r < x" "x < M.I \<omega>" "measure M {x} = 0"
          using open_minus_countable[OF M.countable_support, of "{r<..<M.I \<omega>}"] by auto
        then have Fx_less: "M.C x < \<omega>"
          using M.pseudoinverse' \<omega> not_less by blast

        have "\<forall>\<^sub>F n in sequentially. \<mu>.C n x < \<omega>"
          using order_tendstoD(2)[OF conv[OF x(3)] Fx_less] .
        then have "\<forall>\<^sub>F n in sequentially. x < \<mu>.I n \<omega>"
          by eventually_elim (insert \<omega> \<mu>.pseudoinverse[symmetric], simp add: not_le[symmetric])
        then show ?thesis
          by eventually_elim (insert x(1), simp add: real)
      qed auto
    qed

    have *: "limsup (\<lambda>n. \<mu>.I n \<omega>) \<le> M.I \<omega>'"
      if \<omega>': "0 < \<omega>'" "\<omega>' < 1" "\<omega> < \<omega>'" for \<omega>' :: real
    proof (rule dense_ge_bounded)
      fix B' assume "ereal (M.I \<omega>') < B'" "B' < ereal (M.I \<omega>' + 1)"
      then obtain B where "M.I \<omega>' < B" and [simp]: "B' = ereal B"
        by (cases B') auto
      then obtain y where y: "M.I \<omega>' < y" "y < B" "measure M {y} = 0"
        using open_minus_countable[OF M.countable_support, of "{M.I \<omega>'<..<B}"] by auto
      then have "\<omega>' \<le> M.C (M.I \<omega>')"
        using M.pseudoinverse' \<omega>' by (metis greaterThanLessThan_iff order_refl)
      also have "... \<le> M.C y"
        using M.mono y unfolding mono_def by auto
      finally have Fy_gt: "\<omega> < M.C y"
        using \<omega>'(3) by simp

      have "\<forall>\<^sub>F n in sequentially. \<omega> \<le> \<mu>.C n y"
        using order_tendstoD(1)[OF conv[OF y(3)] Fy_gt] by eventually_elim (rule less_imp_le)
      then have 2: "\<forall>\<^sub>F n in sequentially. \<mu>.I n \<omega> \<le> ereal y"
        by simp (subst \<mu>.pseudoinverse'[rule_format, OF \<omega>(1), symmetric])
      then show "limsup (\<lambda>n. \<mu>.I n \<omega>) \<le> B'"
        using \<open>y < B\<close>
        by (intro Limsup_bounded[rotated]) (auto intro: le_less_trans elim: eventually_mono)
    qed simp

    have **: "(M.I \<longlongrightarrow> ereal (M.I \<omega>)) (at_right \<omega>)"
      using \<omega>(2) by (auto intro: tendsto_within_subset simp: continuous_at)
    show "limsup (\<lambda>n. \<mu>.I n \<omega>) \<le> M.I \<omega>"
      using \<omega>
      by (intro tendsto_lowerbound[OF **])
         (auto intro!: exI[of _ 1] * simp: eventually_at_right[of _ 1])
  qed

  let ?D = "{\<omega>\<in>{0<..<1}. \<not> isCont M.I \<omega>}"
  have D_countable: "countable ?D"
    using mono_on_ctble_discont[OF M.mono_I] by (simp add: at_within_open[of _ "{0 <..< 1}"] cong: conj_cong)
  hence D: "emeasure ?\<Omega> ?D = 0"
    using emeasure_lborel_countable[OF D_countable]
    by (subst emeasure_restrict_space) auto

  define Y' where "Y' \<omega> = (if \<omega> \<in> ?D then 0 else M.I \<omega>)" for \<omega>
  have Y'_AE: "AE \<omega> in ?\<Omega>. Y' \<omega> = M.I \<omega>"
    by (rule AE_I [OF _ D]) (auto simp: space_restrict_space sets_restrict_space_iff Y'_def)

  define Y_seq' where "Y_seq' n \<omega> = (if \<omega> \<in> ?D then 0 else \<mu>.I n \<omega>)" for n \<omega>
  have Y_seq'_AE: "\<And>n. AE \<omega> in ?\<Omega>. Y_seq' n \<omega> = \<mu>.I n \<omega>"
    by (rule AE_I [OF _ D]) (auto simp: space_restrict_space sets_restrict_space_iff Y_seq'_def)

  have Y'_cnv: "\<forall>\<omega>\<in>{0<..<1}. (\<lambda>n. Y_seq' n \<omega>) \<longlonglongrightarrow> Y' \<omega>"
    by (auto simp: Y'_def Y_seq'_def Y_cts_cnv)

  have [simp]: "Y_seq' n \<in> borel_measurable ?\<Omega>" for n
    by (rule measurable_discrete_difference[of "\<mu>.I n" _ _ ?D])
       (insert \<mu>.measurable_CI[of n] D_countable, auto simp: sets_restrict_space Y_seq'_def)
  moreover have "distr ?\<Omega> borel (Y_seq' n) = \<mu> n" for n
    using \<mu>.distr_I_eq_M [of n] Y_seq'_AE [of n]
    by (subst distr_cong_AE[where f = "Y_seq' n" and g = "\<mu>.I n"], auto)
  moreover have [simp]: "Y' \<in> borel_measurable ?\<Omega>"
    by (rule measurable_discrete_difference[of M.I _ _ ?D])
       (insert M.measurable_CI D_countable, auto simp: sets_restrict_space Y'_def)
  moreover have "distr ?\<Omega> borel Y' = M"
    using M.distr_I_eq_M Y'_AE
    by (subst distr_cong_AE[where f = Y' and g = M.I], auto)
  ultimately have "prob_space ?\<Omega> \<and> (\<forall>n. Y_seq' n \<in> borel_measurable ?\<Omega>) \<and>
    (\<forall>n. distr ?\<Omega> borel (Y_seq' n) = \<mu> n) \<and> Y' \<in> measurable ?\<Omega> lborel \<and> distr ?\<Omega> borel Y' = M \<and>
    (\<forall>x\<in>space ?\<Omega>. (\<lambda>n. Y_seq' n x) \<longlonglongrightarrow> Y' x)"
    using Y'_cnv \<open>prob_space ?\<Omega>\<close> by (auto simp: space_restrict_space)
  thus ?thesis by metis
qed

text \<open>
  The Portmanteau theorem, that is, the equivalence of various definitions of weak convergence.
\<close>

theorem weak_conv_imp_bdd_ae_continuous_conv:
  fixes
    f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  assumes
    discont_null: "M ({x. \<not> isCont f x}) = 0" and
    f_bdd: "\<And>x. norm (f x) \<le> B" and
    [measurable]: "f \<in> borel_measurable borel"
  shows
    "(\<lambda> n. integral\<^sup>L (\<mu> n) f) \<longlonglongrightarrow> integral\<^sup>L M f"
proof -
  have "0 \<le> B"
    using norm_ge_zero f_bdd by (rule order_trans)
  note Skorohod
  then obtain Omega Y_seq Y where
    ps_Omega [simp]: "prob_space Omega" and
    Y_seq_measurable [measurable]: "\<And>n. Y_seq n \<in> borel_measurable Omega" and
    distr_Y_seq: "\<And>n. distr Omega borel (Y_seq n) = \<mu> n" and
    Y_measurable [measurable]: "Y \<in> borel_measurable Omega" and
    distr_Y: "distr Omega borel Y = M" and
    YnY: "\<And>x :: real. x \<in> space Omega \<Longrightarrow> (\<lambda>n. Y_seq n x) \<longlonglongrightarrow> Y x"  by force
  interpret prob_space Omega by fact
  have *: "emeasure Omega (Y -` {x. \<not> isCont f x} \<inter> space Omega) = 0"
    by (subst emeasure_distr [symmetric, where N=borel]) (auto simp: distr_Y discont_null)
  have *: "AE x in Omega. (\<lambda>n. f (Y_seq n x)) \<longlonglongrightarrow> f (Y x)"
    by (rule AE_I [OF _ *]) (auto intro: isCont_tendsto_compose YnY)
  show ?thesis
    by (auto intro!: integral_dominated_convergence[where w="\<lambda>x. B"]
             simp: f_bdd * integral_distr distr_Y_seq [symmetric] distr_Y [symmetric])
qed

theorem weak_conv_imp_integral_bdd_continuous_conv:
  fixes f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  assumes
    "\<And>x. isCont f x" and
    "\<And>x. norm (f x) \<le> B"
  shows
    "(\<lambda> n. integral\<^sup>L (\<mu> n) f) \<longlonglongrightarrow> integral\<^sup>L M f"
  using assms
  by (intro weak_conv_imp_bdd_ae_continuous_conv)
     (auto intro!: borel_measurable_continuous_onI continuous_at_imp_continuous_on)

theorem weak_conv_imp_continuity_set_conv:
  fixes f :: "real \<Rightarrow> real"
  assumes [measurable]: "A \<in> sets borel" and "M (frontier A) = 0"
  shows "(\<lambda>n. measure (\<mu> n) A) \<longlonglongrightarrow> measure M A"
proof -
  interpret M: real_distribution M by fact
  interpret \<mu>: real_distribution "\<mu> n" for n by fact

  have "(\<lambda>n. (\<integral>x. indicator A x \<partial>\<mu> n) :: real) \<longlonglongrightarrow> (\<integral>x. indicator A x \<partial>M)"
    by (intro weak_conv_imp_bdd_ae_continuous_conv[where B=1])
       (auto intro: assms simp: isCont_indicator)
  then show ?thesis
    by simp
qed

end

definition
  cts_step :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real"
where
  "cts_step a b x \<equiv> if x \<le> a then 1 else if x \<ge> b then 0 else (b - x) / (b - a)"

lemma cts_step_uniformly_continuous:
  assumes [arith]: "a < b"
  shows "uniformly_continuous_on UNIV (cts_step a b)"
  unfolding uniformly_continuous_on_def
proof clarsimp
  fix e :: real assume [arith]: "0 < e"
  let ?d = "min (e * (b - a)) (b - a)"
  have "?d > 0"
    by (auto simp add: field_simps)
  moreover have "dist x' x < ?d \<Longrightarrow> dist (cts_step a b x') (cts_step a b x) < e" for x x'
    by (auto simp: dist_real_def divide_simps cts_step_def)
  ultimately show "\<exists>d > 0. \<forall>x x'. dist x' x < d \<longrightarrow> dist (cts_step a b x') (cts_step a b x) < e"
    by blast
qed

lemma (in real_distribution) integrable_cts_step: "a < b \<Longrightarrow> integrable M (cts_step a b)"
  by (rule integrable_const_bound [of _ 1]) (auto simp: cts_step_def[abs_def])

lemma (in real_distribution) cdf_cts_step:
  assumes [arith]: "x < y"
  shows "cdf M x \<le> integral\<^sup>L M (cts_step x y)" and "integral\<^sup>L M (cts_step x y) \<le> cdf M y"
proof -
  have "cdf M x = integral\<^sup>L M (indicator {..x})"
    by (simp add: cdf_def)
  also have "\<dots> \<le> expectation (cts_step x y)"
    by (intro integral_mono integrable_cts_step)
       (auto simp: cts_step_def less_top[symmetric] split: split_indicator)
  finally show "cdf M x \<le> expectation (cts_step x y)" .
next
  have "expectation (cts_step x y) \<le> integral\<^sup>L M (indicator {..y})"
    by (intro integral_mono integrable_cts_step)
       (auto simp: cts_step_def less_top[symmetric] split: split_indicator)
  also have "\<dots> = cdf M y"
    by (simp add: cdf_def)
  finally show "expectation (cts_step x y) \<le> cdf M y" .
qed

context
  fixes M_seq :: "nat \<Rightarrow> real measure"
    and M :: "real measure"
  assumes distr_M_seq [simp]: "\<And>n. real_distribution (M_seq n)"
  assumes distr_M [simp]: "real_distribution M"
begin

theorem continuity_set_conv_imp_weak_conv:
  fixes f :: "real \<Rightarrow> real"
  assumes *: "\<And>A. A \<in> sets borel \<Longrightarrow> M (frontier A) = 0 \<Longrightarrow> (\<lambda> n. (measure (M_seq n) A)) \<longlonglongrightarrow> measure M A"
  shows "weak_conv_m M_seq M"
proof -
  interpret real_distribution M by simp
  show ?thesis
    by (auto intro!: * simp: frontier_real_atMost isCont_cdf emeasure_eq_measure weak_conv_m_def weak_conv_def cdf_def2)
qed

theorem integral_cts_step_conv_imp_weak_conv:
  assumes integral_conv: "\<And>x y. x < y \<Longrightarrow> (\<lambda>n. integral\<^sup>L (M_seq n) (cts_step x y)) \<longlonglongrightarrow> integral\<^sup>L M (cts_step x y)"
  shows "weak_conv_m M_seq M"
  unfolding weak_conv_m_def weak_conv_def
proof (clarsimp)
  interpret real_distribution M by (rule distr_M)
  fix x assume "isCont (cdf M) x"
  hence left_cont: "continuous (at_left x) (cdf M)"
    unfolding continuous_at_split ..
  { fix y :: real assume [arith]: "x < y"
    have "limsup (\<lambda>n. cdf (M_seq n) x) \<le> limsup (\<lambda>n. integral\<^sup>L (M_seq n) (cts_step x y))"
      by (auto intro!: Limsup_mono always_eventually real_distribution.cdf_cts_step)
    also have "\<dots> = integral\<^sup>L M (cts_step x y)"
      by (intro lim_imp_Limsup) (auto intro: integral_conv)
    also have "\<dots> \<le> cdf M y"
      by (simp add: cdf_cts_step)
    finally have "limsup (\<lambda>n. cdf (M_seq n) x) \<le> cdf M y" .
  } note * = this
  { fix y :: real assume [arith]: "x > y"
    have "cdf M y \<le> ereal (integral\<^sup>L M (cts_step y x))"
      by (simp add: cdf_cts_step)
    also have "\<dots> = liminf (\<lambda>n. integral\<^sup>L (M_seq n) (cts_step y x))"
      by (intro lim_imp_Liminf[symmetric]) (auto intro: integral_conv)
    also have "\<dots> \<le> liminf (\<lambda>n. cdf (M_seq n) x)"
      by (auto intro!: Liminf_mono always_eventually real_distribution.cdf_cts_step)
    finally have "liminf (\<lambda>n. cdf (M_seq n) x) \<ge> cdf M y" .
  } note ** = this

  have "limsup (\<lambda>n. cdf (M_seq n) x) \<le> cdf M x"
  proof (rule tendsto_lowerbound)
    show "\<forall>\<^sub>F i in at_right x. limsup (\<lambda>xa. ereal (cdf (M_seq xa) x)) \<le> ereal (cdf M i)"
      by (subst eventually_at_right[of _ "x + 1"]) (auto simp: * intro: exI [of _ "x+1"])
  qed (insert cdf_is_right_cont, auto simp: continuous_within)
  moreover have "cdf M x \<le> liminf (\<lambda>n. cdf (M_seq n) x)"
  proof (rule tendsto_upperbound)
    show "\<forall>\<^sub>F i in at_left x. ereal (cdf M i) \<le> liminf (\<lambda>xa. ereal (cdf (M_seq xa) x))"
      by (subst eventually_at_left[of "x - 1"]) (auto simp: ** intro: exI [of _ "x-1"])
  qed (insert left_cont, auto simp: continuous_within)
  ultimately show "(\<lambda>n. cdf (M_seq n) x) \<longlonglongrightarrow> cdf M x"
    by (elim limsup_le_liminf_real)
qed

theorem integral_bdd_continuous_conv_imp_weak_conv:
  assumes
    "\<And>f. (\<And>x. isCont f x) \<Longrightarrow> (\<And>x. abs (f x) \<le> 1) \<Longrightarrow> (\<lambda>n. integral\<^sup>L (M_seq n) f::real) \<longlonglongrightarrow> integral\<^sup>L M f"
  shows
    "weak_conv_m M_seq M"
  apply (rule integral_cts_step_conv_imp_weak_conv [OF assms])
  apply (rule continuous_on_interior)
  apply (rule uniformly_continuous_imp_continuous)
  apply (rule cts_step_uniformly_continuous)
  apply (auto simp: cts_step_def)
  done

end

end


theory Chapter4
imports "HOL-IMP.ASM"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text\<open>
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
\<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text\<open>
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
\<close>

fun set :: "'a tree \<Rightarrow> 'a set"  where
(* your definition/proof here *)

fun ord :: "int tree \<Rightarrow> bool"  where
(* your definition/proof here *)

text\<open> Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
\<close>

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
(* your definition/proof here *)

text\<open> Prove correctness of @{const ins}: \<close>

lemma set_ins: "set(ins x t) = {x} \<union> set t"
(* your definition/proof here *)

theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
\<close>

inductive palindrome :: "'a list \<Rightarrow> bool" where
(* your definition/proof here *)

text \<open> and prove \<close>

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
We could also have defined @{const star} as follows:
\<close>

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

text\<open>
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
\<close>

lemma "star' r x y \<Longrightarrow> star r x y"
(* your definition/proof here *)

lemma "star r x y \<Longrightarrow> star' r x y"
(* your definition/proof here *)

text\<open>
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
\<close>

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
(* your definition/proof here *)

text\<open>
Correct and prove the following claim:
\<close>

lemma "star r x y \<Longrightarrow> iter r n x y"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
\<close>

datatype alpha = a | b

text\<open>
If you think of @{const a} and @{const b} as \<open>\<close>@{text "("}'' and  \<open>\<close>@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
\<close>

inductive S :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

inductive T :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

lemma TS: "T w \<Longrightarrow> S w"
(* your definition/proof here *)

lemma ST: "S w \<Longrightarrow> T w"
(* your definition/proof here *)

corollary SeqT: "S w \<longleftrightarrow> T w"
(* your definition/proof here *)

text\<open>
\endexercise
\<close>
(* your definition/proof here *)
text\<open>
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
\<close>

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* your definition/proof here *)

lemma aval_rel_aval: "aval_rel a s v \<Longrightarrow> aval a s = v"
(* your definition/proof here *)

lemma aval_aval_rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
(* your definition/proof here *)

corollary "aval_rel a s v \<longleftrightarrow> aval a s = v"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
\<close>

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: \<close>

lemma "ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
(* your definition/proof here *)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)

text \<open> Prove that @{text ok} correctly computes the final stack size: \<close>

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
(* your definition/proof here *)

text \<open>
Lemma @{thm [source] length_Suc_conv} may come in handy.

Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
\<close>

end


theory Kleene_Fixed_Point
  imports Complete_Relations
begin

section \<open>Iterative Fixed Point Theorem\<close>

text \<open>Kleene's fixed-point theorem states that,
for a pointed directed complete partial order $\tp{A,\SLE}$
and a Scott-continuous map $f: A \to A$,
the supremum of $\set{f^n(\bot) \mid n\in\Nat}$ exists in $A$ and is a least
fixed point.
Mashburn \<^cite>\<open>"mashburn83"\<close> generalized the result so that
$\tp{A,\SLE}$ is a $\omega$-complete partial order
and $f$ is $\omega$-continuous.

In this section we further generalize the result and show that
for $\omega$-complete relation $\tp{A,\SLE}$
and for every bottom element $\bot \in A$,
the set $\set{f^n(\bot) \mid n\in\Nat}$ has suprema (not necessarily unique, of
course) and,
they are quasi-fixed points.
Moreover, if $(\SLE)$ is attractive, then the suprema are precisely the least
quasi-fixed points.\<close>

subsection \<open>Scott Continuity, $\omega$-Completeness, $\omega$-Continuity\<close>

text \<open>In this Section, we formalize $\omega$-completeness, Scott continuity and $\omega$-continuity.
We then prove that a Scott continuous map is $\omega$-continuous and that an $\omega$-continuous
map is ``nearly'' monotone.\<close>

context
  fixes A :: "'a set" and less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

definition "omega_continuous f \<equiv>
  f ` A \<subseteq> A \<and>
  (\<forall>c :: nat \<Rightarrow> 'a. \<forall> b \<in> A.
  range c \<subseteq> A \<longrightarrow>
  monotone (\<le>) (\<sqsubseteq>) c \<longrightarrow>
  extreme_bound A (\<sqsubseteq>) (range c) b \<longrightarrow> extreme_bound A (\<sqsubseteq>) (f ` range c) (f b))"

lemmas omega_continuousI[intro?] =
  omega_continuous_def[unfolded atomize_eq, THEN iffD2, unfolded conj_imp_eq_imp_imp, rule_format]

lemmas omega_continuousDdom =
  omega_continuous_def[unfolded atomize_eq, THEN iffD1, unfolded conj_imp_eq_imp_imp, THEN conjunct1]

lemmas omega_continuousD =
  omega_continuous_def[unfolded atomize_eq, THEN iffD1, unfolded conj_imp_eq_imp_imp, THEN conjunct2, rule_format]

lemmas omega_continuousE[elim] =
  omega_continuous_def[unfolded atomize_eq, THEN iffD1, elim_format, unfolded conj_imp_eq_imp_imp, rule_format]

lemma omega_continuous_imp_mono_refl:
  assumes cont: "omega_continuous f"
    and x: "x \<in> A" and y: "y \<in> A"
    and xy: "x \<sqsubseteq> y" and xx: "x \<sqsubseteq> x" and yy: "y \<sqsubseteq> y"
  shows "f x \<sqsubseteq> f y"
proof-
  define c :: "nat \<Rightarrow> 'a" where "c \<equiv> \<lambda>i. if i = 0 then x else y"
  from x y xx xy yy have c: "range c \<subseteq> A" "monotone (\<le>) (\<sqsubseteq>) c"
    by (auto simp: c_def intro!: monotoneI)
  have "extreme_bound A (\<sqsubseteq>) (range c) y" using xy yy x y by (auto simp: c_def)
  then have fboy: "extreme_bound A (\<sqsubseteq>) (f ` range c) (f y)" using c cont y by auto
  then show "f x \<sqsubseteq> f y" by (auto simp: c_def)
qed

definition "scott_continuous f \<equiv>
  f ` A \<subseteq> A \<and>
  (\<forall>X s. X \<subseteq> A \<longrightarrow> directed X (\<sqsubseteq>) \<longrightarrow> X \<noteq> {} \<longrightarrow> extreme_bound A (\<sqsubseteq>) X s \<longrightarrow> extreme_bound A (\<sqsubseteq>) (f ` X) (f s))"

lemmas scott_continuousI[intro?] =
  scott_continuous_def[unfolded atomize_eq, THEN iffD2, unfolded conj_imp_eq_imp_imp, rule_format]

lemmas scott_continuousE =
  scott_continuous_def[unfolded atomize_eq, THEN iffD1, elim_format, unfolded conj_imp_eq_imp_imp, rule_format]

lemma scott_continuous_imp_mono_refl:
  assumes scott: "scott_continuous f"
    and x: "x \<in> A" and y: "y \<in> A" and xy: "x \<sqsubseteq> y" and yy: "y \<sqsubseteq> y"
  shows "f x \<sqsubseteq> f y"
proof-
  define D where "D \<equiv> {x,y}"
  from x y xy yy have dir_D: "D \<subseteq> A" "directed D (\<sqsubseteq>)" "D \<noteq> {}"
    by (auto simp: D_def intro!: bexI[of _ y] directedI)
  have "extreme_bound A (\<sqsubseteq>) D y" using xy yy x y by (auto simp: D_def)
  then have fboy: "extreme_bound A (\<sqsubseteq>) (f ` D) (f y)" using dir_D scott by (auto elim!: scott_continuousE)
  then show "f x \<sqsubseteq> f y" by (auto simp: D_def)
qed

lemma scott_continuous_imp_omega_continuous:
  assumes scott: "scott_continuous f" shows "omega_continuous f"
proof
  from scott show "f ` A \<subseteq> A" by (auto elim!: scott_continuousE)
  fix c :: "nat \<Rightarrow> 'a"
  assume mono: "monotone (\<le>) (\<sqsubseteq>) c" and c: "range c \<subseteq> A"
  from monotone_directed_image[OF mono[folded monotone_on_UNIV] order.directed] scott c
  show "extreme_bound A (\<sqsubseteq>) (range c) b \<Longrightarrow> extreme_bound A (\<sqsubseteq>) (f ` range c) (f b)" for b
    by (auto elim!: scott_continuousE)
qed

end

subsection \<open>Existence of Iterative Fixed Points\<close>

text \<open>The first part of Kleene's theorem demands to prove that the set
$\set{f^n(\bot) \mid n \in \Nat}$ has a supremum and
that all such are quasi-fixed points. We prove this claim without assuming
anything on the relation $\SLE$ besides $\omega$-completeness and one bottom element.\<close>

(*
no_notation power (infixr "^" 80)
*)
notation compower ("_^_"[1000,1000]1000)

lemma mono_funpow: assumes f: "f ` A \<subseteq> A" and mono: "monotone_on A r r f"
  shows "monotone_on A r r (f^n)"
proof (induct n)
  case 0
  show ?case using monotone_on_id by (auto simp: id_def)
next
  case (Suc n)
  with funpow_dom[OF f] show ?case
    by (auto intro!: monotone_onI monotone_onD[OF mono] elim!:monotone_onE)
qed

no_notation bot ("\<bottom>")

context
  fixes A and less_eq (infix "\<sqsubseteq>" 50) and bot ("\<bottom>") and f
  assumes bot: "\<bottom> \<in> A" "\<forall>q \<in> A. \<bottom> \<sqsubseteq> q"
  assumes cont: "omega_continuous A (\<sqsubseteq>) f"
begin

interpretation less_eq_notations.

private lemma f: "f ` A \<subseteq> A" using cont by auto

private abbreviation(input) "Fn \<equiv> {f^n \<bottom> |. n :: nat}"

private lemma fn_ref: "f^n \<bottom> \<sqsubseteq> f^n \<bottom>" and fnA: "f^n \<bottom> \<in> A"
proof (atomize(full), induct n)
  case 0
  from bot show ?case by simp
next
  case (Suc n)
  then have fn: "f^n \<bottom> \<in> A" and fnfn: "f^n \<bottom> \<sqsubseteq> f^n \<bottom>" by auto
  from f fn omega_continuous_imp_mono_refl[OF cont fn fn fnfn fnfn fnfn]
  show ?case by auto
qed

private lemma FnA: "Fn \<subseteq> A" using fnA by auto

private lemma fn_monotone: "monotone (\<le>) (\<sqsubseteq>) (\<lambda>n. f^n \<bottom>)"
proof
  fix n m :: nat
  assume "n \<le> m"
  from le_Suc_ex[OF this] obtain k where m: "m = n + k" by auto
  from bot fn_ref fnA omega_continuous_imp_mono_refl[OF cont]
  show "f^n \<bottom> \<sqsubseteq> f^m \<bottom>" by (unfold m, induct n, auto)
qed

private lemma Fn: "Fn = range (\<lambda>n. f^n \<bottom>)" by auto

theorem kleene_qfp:
  assumes q: "extreme_bound A (\<sqsubseteq>) Fn q"
  shows "f q \<sim> q"
proof
  have fq: "extreme_bound A (\<sqsubseteq>) (f ` Fn) (f q)"
    apply (unfold Fn)
    apply (rule omega_continuousD[OF cont])
    using FnA fn_monotone q by (unfold Fn, auto)
  with bot have nq: "f^n \<bottom> \<sqsubseteq> f q" for n
    by(induct n, auto simp: extreme_bound_iff)
  then show "q \<sqsubseteq> f q" using f q by blast
  have "f (f^n \<bottom>) \<in> Fn" for n by (auto intro!: exI[of _ "Suc n"])
  then have "f ` Fn \<subseteq> Fn" by auto
  from extreme_bound_mono[OF this fq q]
  show "f q \<sqsubseteq> q".
qed

lemma ex_kleene_qfp:
  assumes comp: "omega_complete A (\<sqsubseteq>)"
  shows "\<exists>p. extreme_bound A (\<sqsubseteq>) Fn p"
  using fn_monotone
  apply (intro comp[unfolded omega_complete_def, THEN completeD, OF FnA])
  by fast

subsection \<open>Iterative Fixed Points are Least.\<close>
text \<open>Kleene's theorem also states that the quasi-fixed point found this way is a least one.
Again, attractivity is needed to prove this statement.\<close>

lemma kleene_qfp_is_least:
  assumes attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes q: "extreme_bound A (\<sqsubseteq>) Fn q"
  shows "extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>) q"
proof(safe intro!: extremeI kleene_qfp[OF q])
  from q
  show "q \<in> A" by auto
  fix c assume c: "c \<in> A" and cqfp: "f c \<sim> c"
  {
    fix n::nat
    have "f^n \<bottom> \<sqsubseteq> c"
    proof(induct n)
      case 0
      show ?case using bot c by auto
    next
      case IH: (Suc n)
      have "c \<sqsubseteq> c" using attract cqfp c by auto
      with IH have "f^(Suc n) \<bottom> \<sqsubseteq> f c"
        using omega_continuous_imp_mono_refl[OF cont] fn_ref fnA c by auto
      then show ?case using attract cqfp c fnA by blast
    qed
  }
  then show "q \<sqsubseteq> c" using q c by auto
qed

lemma kleene_qfp_iff_least:
  assumes comp: "omega_complete A (\<sqsubseteq>)"
  assumes attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes dual_attract: "\<forall>p \<in> A. \<forall>q \<in> A. \<forall>x \<in> A. p \<sim> q \<longrightarrow> q \<sqsubseteq> x \<longrightarrow> p \<sqsubseteq> x"
  shows "extreme_bound A (\<sqsubseteq>) Fn = extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>)"
proof (intro ext iffI kleene_qfp_is_least[OF attract])
  fix q
  assume q: "extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>) q"
  from q have qA: "q \<in> A" by auto
  from q have qq: "q \<sqsubseteq> q" by auto
  from q have fqq: "f q \<sim> q" by auto
  from ex_kleene_qfp[OF comp]
  obtain k where k: "extreme_bound A (\<sqsubseteq>) Fn k" by auto
  have qk: "q \<sim> k"
  proof
    from kleene_qfp[OF k] q k
    show "q \<sqsubseteq> k" by auto
    from kleene_qfp_is_least[OF _ k] q attract
    show "k \<sqsubseteq> q" by blast
  qed
  show "extreme_bound A (\<sqsubseteq>) Fn q"
  proof (intro extreme_boundI,safe)
    fix n
    show "f^n \<bottom> \<sqsubseteq> q"
    proof (induct n)
      case 0
      from bot q show ?case by auto
    next
      case S:(Suc n)
      from fnA f have fsnbA: "f (f^n \<bottom>) \<in> A" by auto
      have fnfn: "f^n \<bottom> \<sqsubseteq> f^n \<bottom>" using fn_ref by auto
      have "f (f^n \<bottom>) \<sqsubseteq> f q"
        using omega_continuous_imp_mono_refl[OF cont fnA qA S fnfn qq] by auto
      then show ?case using fsnbA qA attract fqq by auto
    qed
  next
    fix x
    assume "bound Fn (\<sqsubseteq>) x" and x: "x \<in> A"
    with k have kx: "k \<sqsubseteq> x" by auto
    with dual_attract[rule_format, OF _ _ x qk] q k
    show "q \<sqsubseteq> x" by auto
  next
    from q show "q \<in> A" by auto
  qed
qed

end

context attractive begin

interpretation less_eq_notations.

theorem kleene_qfp_is_dual_extreme:
  assumes comp: "omega_complete A (\<sqsubseteq>)"
    and cont: "omega_continuous A (\<sqsubseteq>) f" and bA: "b \<in> A" and bot: "\<forall>x \<in> A. b \<sqsubseteq> x"
  shows "extreme_bound A (\<sqsubseteq>) {f^n b |. n :: nat} = extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>)"
  apply (rule kleene_qfp_iff_least[OF bA bot cont comp])
  using cont[THEN omega_continuousDdom]
  by (auto dest: sym_order_trans order_sym_trans)

end

corollary(in antisymmetric) kleene_fp:
  assumes cont: "omega_continuous A (\<sqsubseteq>) f"
    and b: "b \<in> A" "\<forall>x \<in> A. b \<sqsubseteq> x"
    and p: "extreme_bound A (\<sqsubseteq>) {f^n b |. n :: nat} p"
  shows "f p = p"
  using kleene_qfp[OF b cont] p cont[THEN omega_continuousDdom]
  by (auto 2 3 intro!:antisym)

no_notation compower ("_^_"[1000,1000]1000)

end