theory Partitions_Ext
  imports
    Vickrey_Clarke_Groves.Partitions
begin

(*
definition is_partition_generalization :: "'a set set \<Rightarrow> bool" where
  "is_partition_generalization \<C> \<equiv> \<forall>C1\<in>\<C>. \<forall>C2\<in>\<C>. C1 \<noteq> C2 \<longrightarrow> C1 \<inter> C2 = {}"

definition is_partition_generalization_of :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
  "is_partition_generalization_of A \<C> \<equiv> is_partition_generalization \<C> \<and> \<Union> \<C> = A"

definition is_partition :: "'a set set \<Rightarrow> bool" where
  "is_partition \<C> \<equiv> is_partition_generalization \<C> \<and> {} \<notin> \<C>"

definition is_partition_of :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
  "is_partition_of A \<C> \<equiv> is_partition \<C> \<and> \<Union> \<C> = A"

lemma
  shows "is_partition_of A \<C> \<longleftrightarrow> is_partition_generalization_of A \<C> \<and> {} \<notin> \<C>"
  by (auto simp add: is_partition_of_def is_partition_def is_partition_generalization_of_def)
*)

lemma is_partition_of_imp_pairwise_disjnt:
  assumes "\<C> partitions A"
  shows "pairwise disjnt \<C>"
  using assms
  unfolding is_partition_of_def is_non_overlapping_def pairwise_def disjnt_def
  by meson

lemma is_partition_of_imp_card_eq:
  assumes "Ball \<C> finite"
  assumes "\<C> partitions A"
  shows "sum card \<C> = card A"
  using assms card_Union_disjoint
  by (fastforce simp add: is_partition_of_def intro: is_partition_of_imp_pairwise_disjnt)

end


theory Homework4_3
imports Main "~~/src/HOL/Library/Code_Char"
begin

  (*
    ISSUED: Wednesday, October 11
    DUE: Wednesday, October 18, 11:59pm
    POINTS: 10 bonus

    This is a bonus homework, worth 10 bonus points.
    Note that this homework is not too difficult to solve!
    All proofs can be found by following the standard heuristics presented
      in the lecture (including occasional use of sledgehammer).
    Of course, you may also try to use Isar.

    Even if you cannot solve everything, there are parts that can be solved
    independently, and you can skip proofs with sorry
    and try to work on the next sub-task.
  *)

  (*
    In this homework, we are going to implement a simple globbing algorithm,
    i.e., a function that decides whether, e.g., \<open>*.thy\<close> matches \<open>Homework.thy\<close>.
  *)

  section \<open>Parsing of Patterns\<close>

  hide_const (open) Char

  (*
    Internally, we represent a glob pattern by a list of symbols, each symbol
    either being a character to be matched literally, or a star to be matched
    by any sequence of characters:
  *)
  datatype symbol = Char char | Star
  type_synonym pattern = "symbol list"

  (*
    However, the input shall be a string, using \<open>*\<close> to represent any number
    of symbols.

    Thus a single character of the string is parsed by the following function:
  *)
  definition parse_symbol :: "char \<Rightarrow> symbol" where
    "parse_symbol x = (if x=CHR ''*'' then Star else Char x)"

  (*
    Unfortunately, it has become a common habit to write special
    characters in file names. In order to be general, we want to allow an
    escape character in our glob patterns. As \ is hard to type in Isabelle
    strings, we choose ! as escape character. That is, whatever character
    follows ! will be interpreted literally. An ! at the end of the string
    has no special meaning.

    The parser effectively maps parse_symbol over the input,
    adding some special case to handle the escape character.

    Replace the \<open>undefined\<close> gaps by meaningful code!
  *)

  fun parse :: "string \<Rightarrow> pattern" where
    "parse [] = []"
  | "parse (x#xs) = (
      if x=CHR ''!'' then
        (case xs of
          [] \<Rightarrow> undefined     (* Escape character is last character of string*)
        | y#ys \<Rightarrow> undefined   (* Escaped character *)
      ) else
        undefined  )"         (* Unescaped character *)

  (* Test cases *)
  (* No escape characters *)
  value \<open>parse ''*.thy'' = [Star, Char CHR ''.'', Char CHR ''t'', Char CHR ''h'', Char CHR ''y'']\<close>

  (* Escaping a * *)
  value \<open>parse ''A!*.*'' = [Char CHR ''A'', Char CHR ''*'', Char CHR ''.'', Star]\<close>

  (* Escaping a !, escaping a *, ! as last character has no special meaning *)
  value \<open>parse ''*.c!!!*!'' = [Star, Char CHR ''.'', Char CHR ''c'', Char CHR ''!'', Char CHR ''*'', Char CHR ''!''] \<close>

  (*
    In order to show that our parser makes sense, we also define a pretty-printer,
    which translates a given list of symbols to a string, which, when parsed, yields
    the given list of symbols again \<open>parse (pretty syms) = syms\<close>.
    Thus, we can be sure that every list of symbols has a string representation.

    As pretty-printer output shall be pretty, do only insert escape characters
    where necessary, with one exception: You shall still escape a ! at the end
    of the string, also this would not be necessary. (It will make the code
    cleaner, and the pretty-printer does not rely on the somewhat odd handling
    of escape-characters at the end of the string! )

    Fill in the gaps of the pretty-printer function:
  *)

  fun pretty :: "pattern \<Rightarrow> string" where
    "pretty [] = undefined"
  | "pretty (Char x#xs) = (
      if undefined then (* Check whether character has to be escaped *)
        CHR ''!''#x#pretty xs
      else
        undefined)"
  | "pretty (Star#xs) = undefined"

  (* Test cases *)
  value \<open>pretty [Star,Char CHR ''x''] = ''*x''\<close>
  value \<open>pretty [Char CHR ''*''] = ''!*''\<close>
  value \<open>pretty [Char CHR ''!'',Char CHR ''!'',Char CHR ''!''] = ''!!!!!!''\<close>
    (* The pretty printer should not exploit the special case of ! at the end of the string.
      That is, also the last ! character should be escaped! *)

  (* Proof that, for any pattern \<open>syms\<close>, parsing its pretty-print yields
      the pattern again.

    Hint: pretty uses a complex pattern \<longrightarrow> computation induction!
    Hint: unfold definitions if necessary, by adding the _def-lemma to the simpset.
  *)
  lemma "parse (pretty syms) = syms" sorry

  section \<open>Matching\<close>

  (*
    Next, we want to define the semantics of a pattern.
    This can be elegantly done by inductive predicates as follows:

    Single symbol match:
      (C) The symbol Char c matches the string [c].
      (S) The symbol Star matches any string

      (E) The empty pattern matches the empty string
      (A) If symbol s matches xs, and pattern ss matches ys, then pattern s#ss matches xs@ys
  *)

  inductive matchc :: "symbol \<Rightarrow> string \<Rightarrow> bool" where
    C[simp, intro]: "matchc (Char c) [c]"
  | S[simp, intro]: "matchc Star _"

  inductive match :: "pattern \<Rightarrow> string \<Rightarrow> bool" where
    E[simp]: "match [] []"
  | A: "match undefined undefined"
      (* Replace this by the rule (A) from the above textual description *)

  (* We can use forward reasoning to explicitly derive matches:
      The errors in the text below should go away once you have defined
      the parse function and added an A rule.

  *)
  lemma "match (parse ''H*d'') ''Hello World''"
    using A[OF C[of "CHR ''H''"] A[OF S[of "''ello Worl''"] A[OF C[of "CHR ''d''"] E]]]
      (* Note: If your rule A has the premises the other way round, the above
        will yield an error. In this case, it's probably the best to swap
        the premises of your rule A.
      *)
    by (simp add: parse_symbol_def)

  (* FALLBACK: If you did not manage to write the parser, the pattern can
    be parsed manually:
  *)
  lemma "match [Char CHR ''H'', Star, Char CHR ''d''] ''Hello World''"
    using A[OF C[of "CHR ''H''"] A[OF S[of "''ello Worl''"] A[OF C[of "CHR ''d''"] E]]]
    by simp

  (* Use the same technique to derive the following match! *)
  lemma "match (parse ''*.thy'') ''Scratch.thy''"
    sorry

  (* FALLBACK: If you have already proved the above lemma, just delete this fallback
      lemma ... no need to prove the same thing again.
      If your parser does not work, try to prove this fallback
        lemma ... it does not depend on the parser.
  *)
  lemma "match [Star,Char CHR ''.'', Char CHR ''t'', Char CHR ''h'', Char CHR ''y''] ''Scratch.thy''"
    sorry

  subsection \<open>Equations for Match\<close>
  (*
    In a next step, we want to derive recursion equations for match.

    Show that the following equations hold!

    Hint: Case distinction (elim:) should be enough, sledgehammer may help to
      finish the proofs.
  *)

  lemma match_empty[simp]: "match [] xs \<longleftrightarrow> xs=[]"
    sorry

  lemma match_cons[simp]: "match (s#ss) xs \<longleftrightarrow> (\<exists>xs1 xs2. xs=xs1@xs2 \<and> matchc s xs1 \<and> match ss xs2)"
    sorry

  (* Having proved the above equations, we can actually use induction on the
    list of symbols to reason about match.

    Prove the following lemma by structural induction on a suitable
    list-typed variable!

    Hint: Generalization will be required.
    Hint: Sledgehammer might help to complete the proof.
  *)
  lemma match_append[simp]:
    "match (ss1@ss2) xs \<longleftrightarrow> (\<exists>xs1 xs2. xs=xs1@xs2 \<and> match ss1 xs1 \<and> match ss2 xs2)"
    sorry

section \<open>Functional Implementation of a (naive) Globbing Algorithm\<close>

  (* A disadvantage of inductive predicates is that they yield no simp-lemmas
    that could be used to evaluate a function.

    For example, the following command does not yield the expected result, but
    evaluation gets stuck early:
  *)
  value "match (parse ''*.thy'') ''Scratch.thy''"

  subsection \<open>Deriving Structural Equations\<close>

  (* A first step to a functional implementation is to prove
    structural equations for the inductive predicate. We have already done this
      for match, now we do the same for matchc!

    Hint: The equations are not recursive, i.e., matchc does not occur on the right hand side.
  *)
  lemma matchc_Char[simp]: "matchc (Char c) xs \<longleftrightarrow> undefined"
    oops

  lemma matchc_Star[simp]: "matchc Star xs \<longleftrightarrow> True"
    oops

  (* Having derived the recursion equations, we can define a function
    with the same equations. (If termination can be proved)

    Use the same right hand sides as above!
  *)
  fun fmatchc :: "symbol \<Rightarrow> string \<Rightarrow> bool" where
    "fmatchc (Char c) xs \<longleftrightarrow> undefined"
  | "fmatchc (Star) _ \<longleftrightarrow> undefined"

  (*
    Prove that the functional version equals the inductive one.
    Hint: As we have shown the same recursion equations for matchc and fmatchc,
      this can be directly proved by induction over the symbol
      (or, equivalently, case-distinction over the symbol)

  *)
  lemma fmatchc_eq_matchc: "fmatchc s xs = matchc s xs"
    oops

  (* Do the same for match: Define fmatch, based on the recursion
    equations that we have derived earlier.

    Hint: Be sure to use fmatch and fmatchc also on the right hand sides!
  *)
  thm match_empty match_cons

  fun fmatch :: "symbol list \<Rightarrow> char list \<Rightarrow> bool" where
    "fmatch _ _ = undefined"

  (*
    Hints: Induction, you'll need generalization on some variable,
      do not forget to use fmatchc_eq_matchc!
  *)
  lemma fmatch_eq_match: "fmatch ss xs = match ss xs"
    sorry

  subsection \<open>Naive Iteration over all possible List-Splits\<close>

  (*
    Let's test how close we are to an executable algorithm:
  *)
  value "fmatch (parse ''*.thy'') ''Scratch.thy''" (* Fails! *)

  (* The problem is that the term \<open>\<exists>xs1 xs2. \<dots>\<close> cannot be evaluated.

    In the next step, we design a function to decide a term of the form:
      \<open>(\<exists>xs1 xs2. xs = xs1 @ xs2 \<and> P xs1 \<and> Q xs2)\<close> for predicates P Q.

    The idea is to exhaustively test all possibilities for the split of
    xs into xs1 and xs2.

    For that purpose, we start with the split []@xs.
    If this satisfies P and Q, we are done. Otherwise, we append
    the first character of xs to the first part of the split, and continue.

    E.g., for xs=[1,2,3], we would test, in that order:
      P [] \<and> Q [1,2,3]
      P [1] \<and> Q [2,3]
      P [1,2] \<and> Q [3]
      P [1,2,3] \<and> Q []

    Write a recursive function ex_split, such that
      ex_split P Q [] xs \<longleftrightarrow> (\<exists>xs1 xs2. xs=xs1@xs2 \<and> P (xs1) \<and> Q xs2)

    Hint: The function can be defined with two equations
      "ex_split P Q xs [] \<longleftrightarrow> \<dots>"
    | "ex_split P Q xs (y#ys) \<longleftrightarrow> \<dots>"

    Do not use any quantifiers on the right hand sides!
  *)

  fun ex_split :: "('a list \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
    "ex_split _ _ _ _ = undefined"

  (* Show that ex_split does the right thing.
    Hint: You will need to generalize the lemma such that induction works!
  *)
  lemma ex_split_eq: "ex_split P Q [] xs \<longleftrightarrow> (\<exists>xs1 xs2. xs=xs1@xs2 \<and> P (xs1) \<and> Q xs2)"
    oops

  subsection \<open>Combining Everything to Executable Matcher\<close>

  (* Now, you should be able to define the following function: *)
  fun fmatch' where
    "fmatch' [] s \<longleftrightarrow> s=[]"
  | "fmatch' (p#ps) s \<longleftrightarrow> ex_split (fmatchc p) (fmatch' ps) [] s"

  (* And show that it equals fmatch *)
  lemma fmatch'_eq_fmatch: "fmatch' p s = fmatch p s"
    sorry

  (* A simple forward reasoning step yields the overall correctness lemma: *)
  lemmas fmatch'_correct = trans[OF fmatch'_eq_fmatch fmatch_eq_match]

  (* Test Cases *)
  value "fmatch' (parse '''') ''''"
  value "fmatch' (parse ''*'') ''''"
  value "fmatch' (parse ''*******a*****'') ''abc''"
  value "fmatch' (parse ''*.thy'') ''Homework1.thy''"
  value "fmatch' (parse ''*!!.thy'') ''Homework!.thy''"
  value "fmatch' (parse ''*o*.thy'') ''Homework1.thy''"
  value "fmatch' (parse ''*o*.thy'') ''Parser.thy'' = False"
  value "fmatch' (parse ''H*d!!'') ''Hello World!''"
  value "fmatch' (parse ''F!*.*'') ''F*.cpp''"
  value "fmatch' (parse ''H*o*r*1.thy'') ''Homework1.thy''"

end


theory Qp
  imports p_adic_fields
          Localization
          Extended_OAG
begin

abbreviation nonzero_padic_ints :: "nat \<Rightarrow> padic_int set"
  where "nonzero_padic_ints p \<equiv> {x. x \<in> (padic_set p) \<and> x \<noteq> (padic_zero p)}"

lemma nonzero_is_monoid:
  assumes "prime p"
  shows "submonoid (padic_int p) (nonzero_padic_ints p)"
proof
  show 0: "\<And>x y. x \<in> carrier (padic_int p) \<Longrightarrow> y \<in> carrier (padic_int p) \<Longrightarrow> x \<otimes>\<^bsub>(padic_int p)\<^esub> y \<in> carrier (padic_int p)"
    using padic_int_is_domain
    by (metis assms monoid.select_convs(1)
        not_prime_0 padic_mult_mem partial_object.select_convs(1))
  show "\<And>x y z. x \<in> carrier  (padic_int p) \<Longrightarrow>
                 y \<in> carrier (padic_int p) \<Longrightarrow>
                 z \<in> carrier  (padic_int p)\<Longrightarrow>
          x \<otimes>\<^bsub> (padic_int p)\<^esub> y \<otimes>\<^bsub> (padic_int p)\<^esub> z = x \<otimes>\<^bsub> (padic_int p)\<^esub> (y \<otimes>\<^bsub> (padic_int p)\<^esub> z)"
    using assms padic_mult_assoc by auto
  show "\<one>\<^bsub>(padic_int p)\<^esub> \<in> carrier (padic_int p)"
    by (metis assms monoid.select_convs(2) not_prime_0
        padic_one_mem partial_object.select_convs(1))
  show "\<And>x. x \<in> carrier (padic_int p) \<Longrightarrow> \<one>\<^bsub>(padic_int p)\<^esub> \<otimes>\<^bsub>(padic_int p)\<^esub> x = x"
    using assms padic_one_id by auto
  show "\<And>x. x \<in> carrier (padic_int p) \<Longrightarrow> x \<otimes>\<^bsub>(padic_int p)\<^esub> \<one>\<^bsub>(padic_int p)\<^esub> = x"
    by (meson assms cring_def monoid.r_one padic_int_is_cring ring_def)
  show "nonzero_padic_ints p \<subseteq> carrier (padic_int p)"
    by (simp add: subset_iff)
  show "\<And>x y. x \<in> nonzero_padic_ints p \<Longrightarrow>
        y \<in> nonzero_padic_ints p \<Longrightarrow>
         x \<otimes>\<^bsub>(padic_int p)\<^esub> y \<in> nonzero_padic_ints p"
    using 0 assms padic_no_zero_divisors by auto
  show " \<one>\<^bsub>padic_int p\<^esub> \<in> nonzero_padic_ints p"
    by (metis (mono_tags, lifting) \<open>\<one>\<^bsub>padic_int p\<^esub> \<in> carrier (padic_int p)\<close>
        assms domain.one_not_zero mem_Collect_eq padic_int_is_domain
        partial_object.select_convs(1) ring_record_simps(11))
qed

lemma thing:
  assumes "prime p"
  shows "eq_obj_rng_of_frac (padic_int p) (nonzero_padic_ints p)"
proof-
  have 0: "cring (padic_int p)" using padic_int_is_domain
    using assms padic_int_is_cring by blast
  have 1: "submonoid (padic_int p) (nonzero_padic_ints p)"
    using assms nonzero_is_monoid by auto
  show ?thesis using 0 1
    using cring_def eq_obj_rng_of_frac.intro
      mult_submonoid_of_crng_def mult_submonoid_of_rng_def by blast
qed

definition padic_field:: "nat \<Rightarrow> _ ring" where
"padic_field p = eq_obj_rng_of_frac.rec_rng_of_frac (padic_int p) (nonzero_padic_ints p)"

lemma is_ring_padic:
  assumes "prime p"
  shows "ring (padic_field p)"
  using eq_obj_rng_of_frac.rng_rng_of_frac
  by (simp add: eq_obj_rng_of_frac.rng_rng_of_frac assms padic_field_def thing)

definition padic_rel :: "nat \<Rightarrow> _" where
 "padic_rel p  \<equiv> \<lparr>carrier = ((carrier (padic_int p)) \<times> (nonzero_padic_ints p)), eq = \<lambda>(r, s) (r', s'). (\<exists>t \<in> (nonzero_padic_ints p). t \<otimes>\<^bsub>(padic_int p)\<^esub> (s' \<otimes>\<^bsub>(padic_int p)\<^esub> r \<ominus>\<^bsub>(padic_int p)\<^esub> s \<otimes>\<^bsub>(padic_int p)\<^esub> r') = \<zero>\<^bsub>(padic_int p)\<^esub>)\<rparr>"

fun fromSome :: "'a option \<Rightarrow> 'a" where
  "fromSome (Some x) = x"

locale padic =
fixes M
fixes S
fixes rel
assumes "\<exists> (p::nat). (prime p) \<and> M = (padic_int p) \<and> S = nonzero_padic_ints p"
defines "rel \<equiv> \<lparr>carrier = ((carrier M) \<times> S), eq = \<lambda>(r, s) (r', s'). (\<exists>t \<in> S. t \<otimes>\<^bsub>M\<^esub> (s' \<otimes>\<^bsub>M\<^esub> r \<ominus>\<^bsub>M\<^esub> s \<otimes>\<^bsub>M\<^esub> r') = \<zero>\<^bsub>M\<^esub>)\<rparr>"

sublocale padic \<subseteq> submonoid
  using nonzero_is_monoid padic_axioms padic_def by auto

locale padic_integers = submonoid +
  fixes p::nat
  fixes G
  fixes val
  fixes ord
  assumes prime: "prime p"
  assumes ring_def: "M = padic_int p"
  assumes group: "G = int_eoag"
  assumes val: "val = (\<lambda>x. (if (x = \<zero>\<^bsub>M\<^esub>) then (\<infinity>\<^bsub>G\<^esub>) else (Some (padic_val p x))))"
  assumes ord: "ord = padic_val p"

 definition(in padic_integers) nonzero where
"nonzero = (nonzero_padic_ints p)"

lemma(in padic_integers) v_val:
  assumes "x \<noteq> \<zero>\<^bsub>M\<^esub>"
  assumes "x \<in> carrier M"
  shows "val x = Some (ord x)"
  by (simp add: assms(1) ord val)

definition(in padic_integers) max_ideal :: "padic_int set" ("m")  where
"max_ideal = {x \<in> carrier M. (ord x) \<ge> (1::int) \<or> x = \<zero>\<^bsub>M\<^esub>}"

lemma(in padic_integers) max_ideal_is_ideal:
"ideal max_ideal M"
proof(rule idealI)
  show "ring M"
    using cring.axioms(1) padic_int_is_cring
      padic_integers.ring_def padic_integers_axioms prime by blast
  show "subgroup max_ideal (add_monoid M)"
  proof
    show "m \<subseteq> carrier (add_monoid M)"
      using padic_integers.max_ideal_def padic_integers_axioms max_ideal_def by auto
    show "\<And>x y. x \<in> m \<Longrightarrow> y \<in> m \<Longrightarrow> x \<otimes>\<^bsub>add_monoid M\<^esub> y \<in> m"
    proof-
      fix x y
      assume A1: "x \<in> m"
      assume A2: "y \<in> m"
      show "x \<otimes>\<^bsub>add_monoid M\<^esub> y \<in> m"
      proof(cases "x = \<zero>\<^bsub>M\<^esub>")
        case True
        then show ?thesis
          using \<open>ring M\<close> \<open>y \<in> m\<close> max_ideal_def ring.ring_simprules(8) by fastforce
      next case F1: False
        show ?thesis
        proof(cases "y = \<zero>\<^bsub>M\<^esub>")
          case True
          then show ?thesis
          using \<open>ring M\<close> \<open>x \<in> m\<close> max_ideal_def ring.ring_simprules(15) by fastforce
        next case F2: False
          have Cx: "x \<in>carrier M" using A1
            using max_ideal_def by blast
          have Cy: "y \<in>carrier M" using A2
            using max_ideal_def by blast
          show ?thesis
          proof(cases "x \<oplus>\<^bsub>M\<^esub> y = \<zero>\<^bsub>M\<^esub>")
            case True then show ?thesis
              by (simp add: \<open>ring M\<close> max_ideal_def ring.ring_simprules(2))
          next
            case False
            have "ord (x \<otimes>\<^bsub>add_monoid M\<^esub> y) \<ge> min (ord x) (ord y)"
              using ord ring_def False prime
                Cx Cy F1 F2 ultrametric by simp
            then have 0: "ord(x \<otimes>\<^bsub>add_monoid M\<^esub> y) \<ge>1"
              using max_ideal_def A1 A2  F1 F2 by force
            have "ring M"
              by (simp add: \<open>ring M\<close>)
            then have 1: "x \<otimes>\<^bsub>add_monoid M\<^esub> y \<in> carrier M" using Cx Cy
              by (simp add: ring.ring_simprules(1))
            then show ?thesis using 0 1
              using max_ideal_def by blast
          qed
        qed
      qed
    qed
    show "\<one>\<^bsub>add_monoid M\<^esub> \<in> m"
      by (simp add: \<open>ring M\<close> max_ideal_def ring.ring_simprules(2))
    show "\<And>x. x \<in> m \<Longrightarrow> inv\<^bsub>add_monoid M\<^esub> x \<in> m"
      sorry
  qed
  show "\<And>a x. a \<in> m \<Longrightarrow> x \<in> carrier M \<Longrightarrow> x \<otimes>\<^bsub>M\<^esub> a \<in> m"
  proof
    fix a x
    assume A1: "a \<in> m"
    assume A2: "x \<in> carrier M"
    show "x \<otimes>\<^bsub>M\<^esub> a \<in> m"
    proof(cases "x = \<zero>\<^bsub>M\<^esub>")
      case True
      then show ?thesis
        using \<open>a \<in> m\<close> \<open>ring M\<close> \<open>x \<in> carrier M\<close> max_ideal_def
          ring.ring_simprules(24) by fastforce
      next
        case F1: False
        show ?thesis
        proof(cases "a = \<zero>\<^bsub>M\<^esub>")
          case True then show ?thesis
            using \<open>a \<in> m\<close> \<open>ring M\<close> \<open>x \<in> carrier M\<close>
              ring.ring_simprules(25) by fastforce
        next
          case F2: False
          have 0: "a \<in> carrier M"
            using A1 max_ideal_def by blast
          then have 1: "x \<otimes>\<^bsub>M\<^esub> a \<in> carrier M"
            by (simp add: A2 \<open>ring M\<close> ring.ring_simprules(5))
          have 2: "ord (x \<otimes>\<^bsub>M\<^esub> a) = (ord x) + (ord a)"
            using prime 0 A2 F1 F2 val_prod
            by (metis monoid.simps(1) padic_integers.ring_def
                padic_integers_axioms partial_object.select_convs(1)
                ring.simps(1) ord)
          have 3: "ord x \<ge>0"
            using F1 padic_integers.ring_def padic_integers_axioms padic_val_def ord by fastforce
          have 4: "ord a \<ge>1"
            using A1 F2 max_ideal_def by blast
          have "ord (x \<otimes>\<^bsub>M\<^esub> a) \<ge>1"
            using "2" "3" "4" by linarith
          then show ?thesis
            using "1" max_ideal_def by blast
        qed
      qed
      show "\<And>a x. a \<in> m \<Longrightarrow> x \<in> carrier M \<Longrightarrow> m \<subseteq> m"
        by blast
    qed
    show "\<And>a x. a \<in> m \<Longrightarrow> x \<in> carrier M \<Longrightarrow> a \<otimes>\<^bsub>M\<^esub> x \<in> m"
      by (metis (mono_tags, lifting) \<open>\<And>x a. \<lbrakk>a \<in> m; x \<in> carrier M\<rbrakk> \<Longrightarrow> x \<otimes>\<^bsub>M\<^esub> a \<in> m\<close>
          cring.cring_simprules(14) max_ideal_def mem_Collect_eq padic_int_is_cring
          padic_integers.ring_def padic_integers_axioms prime)
  qed


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_20
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun even :: "Nat => bool" where
  "even (Z) = True"
| "even (S (Z)) = False"
| "even (S (S z2)) = even z2"

theorem property0 :
  "even (length (x y y))"
  oops

end


theory HoareLogic
  imports WeakTrioid
begin

section {* Hoare Calculus - Sequential *}

context weak_trioid
begin

definition hoare_triple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("\<lbrace> _ \<rbrace> _ \<lbrace> _ \<rbrace>" [54,54,54] 53)
  where "\<lbrace>x\<rbrace>y\<lbrace>z\<rbrace> \<equiv> x\<cdot>y \<le> z"

declare hoare_triple_def [simp]

lemma hoare_trivial: "\<lbrace>x\<rbrace>y\<lbrace>x\<cdot>y\<rbrace>"
  by simp

theorem weakening_rule: "\<lbrakk>x \<le> v; \<lbrace>v\<rbrace>y\<lbrace>w\<rbrace>; w \<le> z\<rbrakk> \<Longrightarrow> \<lbrace>x\<rbrace>y\<lbrace>z\<rbrace>"
  by (insert mult_isol[of x v y], auto)

theorem composition_rule: "\<lbrace>x\<rbrace>y\<cdot>y'\<lbrace>z\<rbrace> = (\<exists>x'. \<lbrace>x\<rbrace>y\<lbrace>x'\<rbrace> \<and> \<lbrace>x'\<rbrace>y'\<lbrace>z\<rbrace>)"
  by (auto, metis eq_refl mult_assoc, metis mult_assoc mult_isol order_trans)

theorem skip_rule [simp]: "\<lbrace>x\<rbrace>1\<lbrace>z\<rbrace> \<longleftrightarrow> (x \<le> z)"
  by (simp, metis mult_oner)

corollary skip_true: "\<lbrace>x\<rbrace>1\<lbrace>x\<rbrace>"
  by (simp, metis eq_refl mult_oner)

lemma antitony: "(\<forall>x z. \<lbrace>x\<rbrace>y\<lbrace>z\<rbrace> \<longrightarrow> \<lbrace>x\<rbrace>y'\<lbrace>z\<rbrace>) \<longleftrightarrow> y' \<le> y"
  by (auto, metis eq_refl mult_onel, metis mult_isor order_trans)

lemma extensionality: "(\<forall>x z. \<lbrace>x\<rbrace>y\<lbrace>z\<rbrace> = \<lbrace>x\<rbrace>y'\<lbrace>z\<rbrace>) \<longleftrightarrow> y' = y"
  by (metis antisym antitony)

lemma comp_antitony: "(\<forall>x z w. \<lbrace>x\<rbrace>y\<lbrace>w\<rbrace> \<and> \<lbrace>w\<rbrace>y'\<lbrace>z\<rbrace> \<longrightarrow> \<lbrace>x\<rbrace>y''\<lbrace>z\<rbrace>) = (y'' \<le> y\<cdot>y')"
  by (smt antitony composition_rule)

lemma choice: "\<lbrace>x\<rbrace>y+y'\<lbrace>z\<rbrace> = (\<lbrace>x\<rbrace>y\<lbrace>z\<rbrace> \<and> \<lbrace>x\<rbrace>y'\<lbrace>z\<rbrace>)"
  apply simp
  by (metis (full_types) add_lub mult_distl)

(* Failure needs the mult_annil axiom *)
lemma failure: "\<lbrace>x\<rbrace>0\<lbrace>z\<rbrace>"
  nitpick oops

lemma iteration: "\<lbrace>x\<rbrace>y\<lbrace>x\<rbrace> = \<lbrace>x\<rbrace>y\<^sup>*\<lbrace>x\<rbrace>"
  by (metis antitony hoare_triple_def star_ext star_inductr_var)

lemma iteration2: "\<lbrace>x\<rbrace>y\<lbrace>x\<rbrace> = \<lbrace>x\<rbrace>y\<^sup>+\<lbrace>x\<rbrace>"
  by (metis antitony composition_rule iteration star_trancl trancl_ext)

(* The following lemmas needs the exchange axiom *)
theorem concurrency: "\<lbrakk>\<lbrace>x\<rbrace>y\<lbrace>z\<rbrace>; \<lbrace>x'\<rbrace>y'\<lbrace>z'\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>x\<parallel>x'\<rbrace>y\<parallel>y'\<lbrace>z\<parallel>z'\<rbrace>"
  nitpick oops

theorem frame_rule: "\<lbrace>x\<rbrace>y\<lbrace>z\<rbrace> \<Longrightarrow> \<lbrace>w\<parallel>x\<rbrace>y\<lbrace>w\<parallel>z\<rbrace>"
  nitpick oops

end

(****************************************************************************)

section {* Hoare Calculus - Concurrency *}
context weak_cka
begin

theorem concurrency: "\<lbrakk>\<lbrace>x\<rbrace>y\<lbrace>z\<rbrace>; \<lbrace>x'\<rbrace>y'\<lbrace>z'\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>x\<parallel>x'\<rbrace>y\<parallel>y'\<lbrace>z\<parallel>z'\<rbrace>"
  by (simp, metis exchange order_trans par_double_iso)

theorem frame_rule: "\<lbrace>x\<rbrace>y\<lbrace>z\<rbrace> \<Longrightarrow> \<lbrace>w\<parallel>x\<rbrace>y\<lbrace>w\<parallel>z\<rbrace>"
  by (metis concurrency par_unitl skip_true)

end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_35
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

definition(*fun*) one :: "Nat" where
  "one = S Z"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = Z"
| "t22 (S z) y = t2 y (t22 z y)"

fun exp :: "Nat => Nat => Nat" where
  "exp x (Z) = S Z"
| "exp x (S n) = t22 x (exp x n)"

fun qexp :: "Nat => Nat => Nat => Nat" where
  "qexp x (Z) z = z"
| "qexp x (S n) z = qexp x n (t22 x z)"

theorem property0 :
  "((exp x y) = (qexp x y one))"
  oops

end


theory prop_78
imports Main
        "$HIPSTER_HOME/IsaHipster"

begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun sorted :: "Nat list => bool" where
  "sorted (Nil2) = True"
  | "sorted (Cons2 y (Nil2)) = True"
  | "sorted (Cons2 y (Cons2 y2 ys)) =
       (if le y y2 then sorted (Cons2 y2 ys) else False)"
  fun insort :: "Nat => Nat list => Nat list" where
  "insort x (Nil2) = Cons2 x (Nil2)"
  | "insort x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insort x xs))"
  fun sort :: "Nat list => Nat list" where
  "sort (Nil2) = Nil2"
  | "sort (Cons2 y xs) = insort y (sort xs)"
  (*hipster le sorted insort sort *)

lemma lemma_a [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_aa [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ab [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

lemma unknown [thy_expl]: "insort x (insort y z) = insort y (insort x z)"
oops

lemma unknown [thy_expl]: "insort Z (insort x y) = insort x (insort Z y)"
oops

(*hipster_cond le*)
lemma lemma_ac [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ad [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ae [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma lemma_af [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)

(*hipster insort le*)
lemma lemma_ag [thy_expl]: "insort Z (insort x2 y2) =
insort x2 (insort Z y2)"
by (hipster_induct_schemes insort.simps le.simps)

(*hipster_cond sorted insort*)
lemma lemma_ah [thy_expl]: "sorted (insort Z x4) = sorted x4"
by (hipster_induct_schemes sorted.simps insort.simps)

fun nole:: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
  "nole x y = (\<not> le x y)"

(*hipster_cond nole*)
(*hipster nole le*)
lemma lemma_ai [thy_expl]: "le (S x2) y2 = nole y2 x2"
by (hipster_induct_schemes nole.simps)

lemma lemma_aj [thy_expl]: "nole x2 y2 \<Longrightarrow> le x2 Z = False"
apply(unfold nole.simps)
by (hipster_induct_schemes le.simps)

ML\<open>
  val _ = Local_Defs.unfold_tac
  val _ = Raw_Simplifier.rewrite_goals_rule
  val simple_prover = SINGLE o (fn ctxt => ALLGOALS (resolve_tac (Raw_Simplifier.prems_of ctxt)));
  val _ =   Conv.fconv_rule (Conv.prems_conv ~1 (Raw_Simplifier.rewrite_cterm (true, true, true) simple_prover
    (empty_simpset @{context} addsimps @{thms nole.simps})))
  val _ = Pattern.rewrite_term
\<close>

setup\<open>Hip_Tac_Ops.toggle_full_types @{context} ;\<close>
setup\<open>Hip_Tac_Ops.set_metis_to @{context} 1000;\<close>

lemma lemma_ak [thy_expl]: "sorted y \<Longrightarrow> sorted (insort x y) = True"
by (hipster_induct_schemes sorted.simps nole.simps insort.simps le.simps)
(*
apply(induction y arbitrary: x rule: sorted.induct)
apply(simp_all)
apply(metis nole.simps thy_expl)
by(metis (full_types) thy_expl sorted.simps insort.simps nole.simps)*)

  theorem x0 :
    "sorted (sort xs)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*  Title:      HOL/ex/Code_Binary_Nat_examples.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Simple examples for natural numbers implemented in binary representation.\<close>

theory Code_Binary_Nat_examples
imports Complex_Main "HOL-Library.Code_Binary_Nat"
begin

fun to_n :: "nat \<Rightarrow> nat list"
where
  "to_n 0 = []"
| "to_n (Suc 0) = []"
| "to_n (Suc (Suc 0)) = []"
| "to_n (Suc n) = n # to_n n"

definition naive_prime :: "nat \<Rightarrow> bool"
where
  "naive_prime n \<longleftrightarrow> n \<ge> 2 \<and> filter (\<lambda>m. n mod m = 0) (to_n n) = []"

primrec fac :: "nat \<Rightarrow> nat"
where
  "fac 0 = 1"
| "fac (Suc n) = Suc n * fac n"

primrec harmonic :: "nat \<Rightarrow> rat"
where
  "harmonic 0 = 0"
| "harmonic (Suc n) = 1 / of_nat (Suc n) + harmonic n"

lemma "harmonic 200 \<ge> 5"
  by eval

lemma "(let (q, r) = quotient_of (harmonic 8) in q div r) \<ge> 2"
  by normalization

lemma "naive_prime 89"
  by eval

lemma "naive_prime 89"
  by normalization

lemma "\<not> naive_prime 87"
  by eval

lemma "\<not> naive_prime 87"
  by normalization

lemma "fac 10 > 3000000"
  by eval

lemma "fac 10 > 3000000"
  by normalization

end


section \<open>Data Refinement of Diagrams\<close>

theory DataRefinement
imports Diagram
begin

text\<open>
Next definition introduces the concept of data refinement of $S1$
to $S2$ using the data abstractions $R$ and $R'$.
\<close>

definition
  DataRefinement :: "('a::type \<Rightarrow> 'b::type)
     \<Rightarrow> ('b::type \<Rightarrow> 'c::ord) \<Rightarrow> ('a::type \<Rightarrow> 'd::type)
     \<Rightarrow> ('d::type \<Rightarrow> 'c::ord) \<Rightarrow> bool" where
  "DataRefinement S1 R R' S2 = ((R o S1) \<le> (S2 o R'))"

text\<open>
If $\mathit{demonic}\ Q$ is correct with respect to $p$ and $q$, and
$(\mathit{assert} \ p)\circ (\mathit{demonic}\  Q)$ is data refined
by $S$, then $S$ is correct with respect to $\mathit{angelic}\  R\  p$ and
$\mathit{angelic} \ R' \ q$.
\<close>

theorem data_refinement:
  "mono R \<Longrightarrow> \<Turnstile> p {| S |} q \<Longrightarrow>  DataRefinement S R R' S' \<Longrightarrow>
         \<Turnstile> (R p) {| S' |} (R' q)"
  apply (simp add:  DataRefinement_def Hoare_def le_fun_def)
  apply (drule_tac x = q in spec)
  apply (rule_tac y = "R (S q)" in order_trans)
  apply (drule_tac x = p and y = "S q" in monoD)
  by simp_all

theorem data_refinement2:
  "mono R \<Longrightarrow> \<Turnstile> p {| S |} q \<Longrightarrow>  DataRefinement ({.p.} o S) R R' S' \<Longrightarrow>
         \<Turnstile> (R p) {| S' |} (R' q)"
  apply (simp add:  DataRefinement_def Hoare_def le_fun_def assert_def)
  apply (drule_tac x = q in spec)
  apply (subgoal_tac "p \<sqinter> S q = p")
  apply simp
  apply (rule antisym)
  by simp_all

theorem data_refinement_hoare:
  "mono S \<Longrightarrow> mono D \<Longrightarrow> DataRefinement ({.p.} o [:Q:]) {:R:} D S =
         (\<forall> s . \<Turnstile> {s' . s \<in> R s' \<and> s \<in> p} {| S |} (D ((Q s)::'a::order)))"
  apply (simp add: le_fun_def assert_def angelic_def demonic_def Hoare_def DataRefinement_def)
  apply safe
  apply (simp_all)
  apply (drule_tac x = "Q s" in spec)
  apply auto [1]
  apply (drule_tac x = "xb" in spec)
  apply simp
  apply (simp add: less_eq_set_def le_fun_def)
  apply (drule_tac x = xa in spec)
  apply (simp_all add: mono_def)
  by auto

theorem data_refinement_choice1:
  "DataRefinement S1 D D' S2 \<Longrightarrow> DataRefinement S1 D D' S2' \<Longrightarrow> DataRefinement S1 D D' ( S2 \<sqinter> S2') "
  by (simp add: DataRefinement_def hoare_choice le_fun_def inf_fun_def)

theorem data_refinement_choice2:
  "mono D \<Longrightarrow> DataRefinement S1 D D' S2 \<Longrightarrow> DataRefinement S1' D D' S2' \<Longrightarrow>
     DataRefinement (S1 \<sqinter> S1') D D' (S2 \<sqinter> S2')"
  apply (simp add: DataRefinement_def inf_fun_def le_fun_def)
  apply safe
  apply (rule_tac y = "D (S1 x)" in order_trans)
  apply (drule_tac x = "S1 x \<sqinter> S1' x" and y = "S1 x" in monoD)
  apply simp_all
  apply (rule_tac y = "D (S1' x)" in order_trans)
  apply (drule_tac x = "S1 x \<sqinter> S1' x" and y = "S1' x" in monoD)
  by simp_all

theorem data_refinement_top [simp]:
  "DataRefinement S1 D D' (\<top>::_::order_top)"
  by (simp add: DataRefinement_def le_fun_def top_fun_def)

definition apply_fun::"('a\<Rightarrow>'b\<Rightarrow>'c)\<Rightarrow>('a\<Rightarrow>'b)\<Rightarrow>'a\<Rightarrow>'c" (infixl ".." 5) where
  "(A .. B) = (\<lambda> x . (A x) (B x))"

definition
  "Disjunctive_fun R = (\<forall> i . (R i) \<in> Apply.Disjunctive)"

lemma Disjunctive_Sup:
  "Disjunctive_fun R \<Longrightarrow> (R .. (Sup X)) =  Sup {y . \<exists> x \<in> X . y = (R .. x)}"
  apply (subst fun_eq_iff)
  apply (simp add: apply_fun_def)
  apply safe
  apply (subst (asm) Disjunctive_fun_def)
  apply (drule_tac x = x in spec)
  apply (simp add: Apply.Disjunctive_def)
  apply (subgoal_tac "(R x ` (\<lambda>f. f x) ` X) =((\<lambda>f. f x) ` {y. \<exists>x\<in>X. y = (\<lambda>xa. R xa (x xa))})")
  apply (auto simp add: image_image cong del: SUP_cong_simp)
  done

lemma (in DiagramTermination) disjunctive_SUP_L_P:
  "Disjunctive_fun R \<Longrightarrow> (R .. (SUP_L_P P (pair u i))) =  (SUP_L_P (\<lambda> w . (R .. (P w)))) (pair u i)"
  by (simp add: SUP_L_P_def apply_fun_def Disjunctive_fun_def Apply.Disjunctive_def fun_eq_iff image_comp)

lemma apply_fun_range: "{y. \<exists>x. y = (R .. P x)} = range (\<lambda> x . R .. P x)"
  by (fact full_SetCompr_eq)

theorem (in DiagramTermination) dgr_data_refinement_1:
  "dmono D' \<Longrightarrow> Disjunctive_fun R \<Longrightarrow>
   (\<forall> w i j . \<Turnstile> P w i  {| D(i,j) |} SUP_L_P P (pair w i) j) \<Longrightarrow>
   (\<forall> w i j . DataRefinement ((assert (P w i)) o (D (i,j))) (R i) (R j) (D' (i, j))) \<Longrightarrow>

   \<Turnstile> (R .. (Sup (range P))) {| pt D' |} ((R .. (Sup (range P))) \<sqinter> (-(grd (step D'))))"
  apply (simp add: Disjunctive_Sup apply_fun_range)
  apply (rule hoare_diagram2)
  apply simp_all
  apply safe
  apply (simp add: disjunctive_SUP_L_P [THEN sym])
  apply (simp add: apply_fun_def)
  apply (rule_tac S = "D (i, j)" in data_refinement2)
  by auto

definition
  "DgrDataRefinement1 D R D' = (\<forall> i j . DataRefinement (D (i , j)) (R i) (R j) (D' (i, j)))"

definition
  "DgrDataRefinement2 P D R D' = (\<forall> i j . DataRefinement ({.P i.} o D (i , j)) (R i) (R j) (D' (i, j)))"

theorem DataRefinement_mono:
  "T \<le> S \<Longrightarrow> mono R \<Longrightarrow> DataRefinement S R R' S' \<Longrightarrow> DataRefinement T R R' S' "
  apply (simp add: DataRefinement_def mono_def)
  apply (subst le_fun_def)
  apply (simp add: le_fun_def)
  apply safe
  apply (rule_tac y = "R (S x)" in order_trans)
  by simp_all

definition
  "mono_fun R = (\<forall> i . mono (R i))"

theorem DgrDataRefinement_mono:
  "Q \<le> P \<Longrightarrow> mono_fun R \<Longrightarrow> DgrDataRefinement2 P D R D' \<Longrightarrow> DgrDataRefinement2 Q D R D'"
  apply (simp add: DgrDataRefinement2_def)
  apply auto
  apply (rule_tac S = "{.P i.} o D(i, j)" in DataRefinement_mono)
  apply (simp_all add: le_fun_def assert_def)
  apply safe
  apply (rule_tac y = "Q i" in order_trans)
  by (simp_all add: mono_fun_def)

text\<open>
Next theorem is the diagram version of the data refinement theorem. If the
diagram demonic choice $T$ is correct, and it is refined by $D$, then
$D$ is also correct. One important point in this theorem is that
if the diagram demonic choice $T$ terminates, then $D$ also terminates.
\<close>

theorem (in DiagramTermination) Diagram_DataRefinement1:
  "dmono D \<Longrightarrow> Disjunctive_fun R \<Longrightarrow> \<turnstile> P {| D |} Q \<Longrightarrow> DgrDataRefinement1 D R D' \<Longrightarrow>
      \<turnstile> (R .. P) {| D' |} ((R .. P) \<sqinter> (-(grd (step D'))))"
  apply (unfold Hoare_dgr_def DgrDataRefinement1_def dgr_demonic_def)
  apply safe
  apply (rule_tac x="\<lambda> w . R .. (X w)" in exI)
  apply safe
  apply (unfold disjunctive_SUP_L_P [THEN sym])
  apply (simp add: apply_fun_def)
  apply (rule_tac S = "D (i,j)" and R = "R i" and R' = "R j" in data_refinement)
  by (simp_all add: Disjunctive_Sup apply_fun_range)

lemma comp_left_mono [simp]: "S \<le> S' \<Longrightarrow> S o T \<le> S' o T"
  by (simp add: le_fun_def)

lemma assert_pred_mono [simp]: "p \<le> q \<Longrightarrow> {.p.} \<le> {.q.}"
  apply (simp add: le_fun_def assert_def)
  apply safe
  apply (rule_tac y = p in order_trans)
  by simp_all

theorem (in DiagramTermination) Diagram_DataRefinement2:
  "dmono D \<Longrightarrow> Disjunctive_fun R \<Longrightarrow> \<turnstile> P {| D |} Q \<Longrightarrow> DgrDataRefinement2 P D R D' \<Longrightarrow>
      \<turnstile> (R .. P) {| D' |} ((R .. P) \<sqinter> (-(grd (step D'))))"
  apply (unfold Hoare_dgr_def DgrDataRefinement2_def dgr_demonic_def)
  apply auto
  apply (rule_tac x="\<lambda> w . R .. (X w)" in exI)
  apply safe
  apply (unfold disjunctive_SUP_L_P [THEN sym])
  apply (simp add: apply_fun_def)
  apply (rule_tac S = "D (i,j)" and R = "R i" and R' = "R j" in data_refinement2)
  apply (simp_all add: Disjunctive_Sup)
  apply (rule_tac S = "{.Sup (range X) i.} \<circ> D (i, j)" in DataRefinement_mono)
  apply (rule comp_left_mono)
  apply (rule assert_pred_mono)
  apply (simp add: Sup_fun_def comp_def)
  apply (rule SUP_upper)
  apply (auto simp add: apply_fun_def apply_fun_range image_image fun_eq_iff)
  apply (auto intro!: arg_cong [where f = Sup] arg_cong2 [where f = inf])
  done

lemma "(R'::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Disjunctive \<Longrightarrow>
   DataRefinement S R R' S' \<Longrightarrow> R (- grd S) \<le> - grd S'"
  apply (simp add: DataRefinement_def grd_def le_fun_def)
  apply (drule_tac x = "\<bottom>" in spec)
  by simp

end