(*<*)
theory Refine_Monadic_Userguide
imports "../Refine_Dflt_Only_ICF"
begin
(*>*)

text_raw {* \isasection{Old Monadic Refinement Framework Userguide}*}

section {* Introduction *}
text {*
  This is the old userguide from Refine-Monadic. It contains the
  manual approach of using the mondaic refinement framework with the
  Isabelle Collection Framework. An alternative, more simple approach is
  provided by the Automatic Refinement Framework and the
  Generic Collection Framework.

  The Isabelle/HOL refinement framework is a library that supports
  program and data refinement.

  Programs are specified using a nondeterminism monad:
  An element of the monad type is either a set of results, or
  the special element @{term "FAIL"}, that indicates a failed assertion.

  The bind-operation of the monad applies a function to all elements of the
  result-set, and joins all possible results.

  On the monad type, an ordering @{text "\<le>"} is defined, that is lifted subset
  ordering, where @{term "FAIL"} is the greatest element. Intuitively,
  @{term "S\<le>S'"} means that program @{text "S"} refines program @{text "S'"},
  i.e., all results of @{text "S"} are also results of @{text "S'"}, and
  @{text "S"} may only fail if @{text "S'"} also fails.
*}

section {* Guided Tour *}
text {*
  In this section, we provide a small example program development in our
  framework. All steps of the development are heavily commented.
*}

subsection {* Defining Programs *}
text {*
  A program is defined using the Haskell-like do-notation, that is provided by
  the Isabelle/HOL library. We start with a simple example, that iterates
  over a set of numbers, and computes the maximum value and the sum of
  all elements.
*}

definition sum_max :: "nat set \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE (\<lambda>(V,s,m). V\<noteq>{}) (\<lambda>(V,s,m). do {
      x\<leftarrow>SPEC (\<lambda>x. x\<in>V);
      let V=V-{x};
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

text {*
  The type of the nondeterminism monad is @{typ "'a nres"}, where @{typ "'a"}
  is the type of the results. Note that this program has only one possible
  result, however, the order in which we iterate over the elements of the set
  is unspecified.

  This program uses the following statements provided by our framework:
  While-loops, bindings, return, and specification. We briefly explain the
  statements here. A complete reference can be found in
  Section~\ref{sec:stmt_ref}.

  A while-loop has the form @{term "WHILE b f \<sigma>\<^sub>0"}, where @{term "b"} is the
  continuation condition, @{term "f"} is the loop body, and @{term "\<sigma>\<^sub>0"} is
  the initial state. In our case, the state used for the loop is a triple
  @{term "(V,s,m)"}, where @{term "V"} is the set of remaining elements,
  @{term "s"} is the sum of the elements seen so far, and @{term "m"} is
  the maximum of the elements seen so far.
  The @{term "WHILE b f \<sigma>\<^sub>0"} construct describes a partially correct loop,
  i.e., it describes only those results that can be reached by finitely many
  iterations, and ignores infinite paths of the loop. In order to
  prove total correctness, the construct @{term "WHILE\<^sub>T b f \<sigma>\<^sub>0"} is used. It
  fails if there exists an infinite execution of the loop.

  A binding @{term [source] "do {x\<leftarrow>(S\<^sub>1::'a nres); S\<^sub>2}"} nondeterministically
  chooses a result of
  @{term "S\<^sub>1"}, binds it to variable @{term "x"}, and then continues with
  @{term "S\<^sub>2"}. If @{term "S\<^sub>1"} is @{const "FAIL"}, the
  bind statement also fails.

  The syntactic form @{term [source] "do { let x=V; (S::'a \<Rightarrow> 'b nres)}"}
  assigns the value @{text "V"} to variable @{text "x"}, and continues with
  @{text "S"}.

  The return statement @{term "RETURN x"} specifies precisely the result
  @{text "x"}.

  The specification statement @{term "SPEC \<Phi>"} describes all results that
  satisfy the predicate @{text "\<Phi>"}. This is the source of nondeterminism in
  programs, as there may be more than one such result. In our case, we describe
  any element of set @{text "V"}.

  Note that these statement are shallowly embedded into Isabelle/HOL, i.e.,
  they are ordinary Isabelle/HOL constants. The main advantage is, that any
  other construct and datatype from Isabelle/HOL may be used inside programs.
  In our case, we use Isabelle/HOL's predefined operations on sets and natural
  numbers. Another advantage is that extending the framework with new commands
  becomes fairly easy.
*}

subsection {* Proving Programs Correct *}
text {*
  The next step in the program development is to prove the program correct
  w.r.t.\ a specification. In refinement notion, we have to prove that the
  program @{text "S"} refines a specification @{text "\<Phi>"} if the precondition
  @{text "\<Psi>"} holds, i.e., @{term "\<Psi> \<Longrightarrow> S \<le> SPEC \<Phi>"}.

  For our purposes, we prove that @{const "sum_max"} really computes the sum
  and the maximum.
*}

text {*
  As usual, we have to think of a loop invariant first. In our case, this
  is rather straightforward. The main complication is introduced by the
  partially defined @{text "Max"}-operator of the Isabelle/HOL standard library.
  *}
definition "sum_max_invar V\<^sub>0 \<equiv> \<lambda>(V,s::nat,m).
             V\<subseteq>V\<^sub>0
           \<and> s=\<Sum>(V\<^sub>0-V)
           \<and> m=(if (V\<^sub>0-V)={} then 0 else Max (V\<^sub>0-V))
           \<and> finite (V\<^sub>0-V)"

text {*
  We have extracted the most complex verification condition
  --- that the invariant is preserved by the loop body --- to
  an own lemma. For complex proofs, it is always a good idea to do that,
  as it makes the proof more readable.
  *}
lemma sum_max_invar_step:
  assumes "x\<in>V" "sum_max_invar V\<^sub>0 (V,s,m)"
  shows "sum_max_invar V\<^sub>0 (V-{x},s+x,max m x)"
  txt {* In our case the proof is rather straightforward, it only
    requires the lemma @{thm [source] it_step_insert_iff}, that handles
    the @{term "(V\<^sub>0-(V-{x}))"} terms that occur in the invariant. *}
  using assms unfolding sum_max_invar_def by (auto simp: it_step_insert_iff)

text {*
  The correctness is now proved by first invoking the verification condition
  generator, and then discharging the verification conditions by
  @{text "auto"}. Note that we have to apply the
  @{thm [source] sum_max_invar_step} lemma, {\em before} we unfold the
  definition of the invariant to discharge the remaining verification
  conditions.
  *}
theorem sum_max_correct:
  assumes PRE: "V\<noteq>{}"
  shows "sum_max V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V \<and> m=Max V)"
  txt {*
    The precondition @{text "V\<noteq>{}"} is necessary, as the
    @{text "Max"}-operator from Isabelle/HOL's standard library is not defined
    for empty sets.
    *}
  using PRE unfolding sum_max_def
  apply (intro WHILE_rule[where I="sum_max_invar V"] refine_vcg) -- "Invoke vcg"
  txt {* Note that we have explicitely instantiated
    the rule for the while-loop with the invariant. If this is not done,
    the verification condition generator will stop at the WHILE-loop.
    *}
  apply (auto intro: sum_max_invar_step) -- "Discharge step"
  unfolding sum_max_invar_def -- "Unfold invariant definition"
  apply (auto) -- "Discharge remaining goals"
  done

text {*
  In this proof, we specified the invariant explicitely.
  Alternatively, we may annotate the invariant at the while loop,
  using the syntax @{term "WHILE\<^bsup>I\<^esup> b f \<sigma>\<^sub>0"}. Then, the verification condition
  generator will use the annotated invariant automatically.
*}

text_raw{*\paragraph{Total Correctness}*}
text {*
  Now, we reformulate our program to use a total correct while loop,
  and annotate the invariant at the loop. The invariant is strengthened by
  stating that the set of elements is finite.
*}

definition "sum_max'_invar V\<^sub>0 \<sigma> \<equiv>
  sum_max_invar V\<^sub>0 \<sigma>
  \<and> (let (V,_,_)=\<sigma> in finite (V\<^sub>0-V))"

definition sum_max' :: "nat set \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max' V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE\<^sub>T\<^bsup>sum_max'_invar V\<^esup> (\<lambda>(V,s,m). V\<noteq>{}) (\<lambda>(V,s,m). do {
      x\<leftarrow>SPEC (\<lambda>x. x\<in>V);
      let V=V-{x};
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

theorem sum_max'_correct:
  assumes NE: "V\<noteq>{}" and FIN: "finite V"
  shows "sum_max' V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V \<and> m=Max V)"
  using NE FIN unfolding sum_max'_def
  apply (intro refine_vcg) -- "Invoke vcg"

  txt {* This time, the verification condition generator uses the annotated
    invariant. Moreover, it leaves us with a variant. We have to specify a
    well-founded relation, and show that the loop body respects this
    relation. In our case, the set @{text "V"} decreases in each step, and
    is initially finite. We use the relation @{const "finite_psubset"} and the
    @{const "inv_image"} combinator from the Isabelle/HOL standard library.*}
  apply (subgoal_tac "wf (inv_image finite_psubset fst)",
    assumption) -- "Instantiate variant"
  apply simp -- "Show variant well-founded"

  unfolding sum_max'_invar_def -- "Unfold definition of invariant"
  apply (auto intro: sum_max_invar_step) -- "Discharge step"

  unfolding sum_max_invar_def -- "Unfold definition of invariant completely"
  apply (auto intro: finite_subset) -- "Discharge remaining goals"
  done

subsection {* Refinement *}
text {*
  The next step in the program development is to refine the initial program
  towards an executable program. This usually involves both, program refinement
  and data refinement. Program refinement means changing the structure of the
  program. Usually, some specification statements are replaced by more concrete
  implementations. Data refinement means changing the used data types towards
  implementable data types.

  In our example, we implement the set @{text "V"} with a distinct list,
  and replace the specification statement @{term "SPEC (\<lambda>x. x\<in>V)"} by
  the head operation on distinct lists. For the lists, we use
  the list-set data structure provided by the Isabelle Collection Framework
  \cite{L09_collections,LL10}.

  For this example, we write the refined program ourselves.
  An automation of this task can be achieved with the automatic refinement tool,
  which is available as a prototype in Refine-Autoref. Usage examples are in
  ex/Automatic-Refinement.
*}

definition sum_max_impl :: "nat ls \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max_impl V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE (\<lambda>(V,s,m). \<not>ls.isEmpty V) (\<lambda>(V,s,m). do {
      x\<leftarrow>RETURN (the (ls.sel V (\<lambda>x. True)));
      let V=ls.delete x V;
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

text {*
  Note that we replaced the operations on sets by the respective operations
  on lists (with the naming scheme @{text "ls.xxx"}). The specification
  statement was replaced by @{term "the (ls.sel V (\<lambda>x. True))"}, i.e.,
  selection of an element that satisfies the predicate @{term "(\<lambda>x. True)"}.
  As @{const "ls.sel"} returns an option datatype, we extract the value with
  @{const "the"}. Moreover, we omitted the loop invariant, as we don't need it
  any more.
*}

text {*
  Next, we have to show that our concrete pogram actually refines
  the abstract one.
*}
theorem sum_max_impl_refine:
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar"
  shows "sum_max_impl V \<le> \<Down>Id (sum_max V')"
  txt {*
    Let @{text "R"} be a
    {\em refinement relation\footnote{Also called coupling invariant.}},
    that relates concrete and abstract values.

    Then, the function @{term "\<Down>R"} maps a result-set over abstract values to
    the greatest result-set over concrete values that is compatible
    w.r.t.\ @{text "R"}. The value @{const "FAIL"} is mapped to itself.

    Thus, the proposition @{term "S \<le> \<Down>R S'"} means, that @{text "S"} refines
    @{text "S'"} w.r.t.\ @{text "R"}, i.e., every value in the result of
    @{text "S"} can be abstracted to a value in the result of @{text "S'"}.

    Usually, the refinement relation consists of an invariant @{text "I"} and
    an abstraction function @{text "\<alpha>"}. In this case, we may use the
    @{term "build_rel I \<alpha>"}-function to define the refinement relation.

    In our example, we assume that the input is in the refinement relation
    specified by list-sets, and show that the output is in the identity
    relation. We use the identity here, as we do not change the datatypes of
    the output.
    *}

  txt {* The proof is done automatically by the refinement verification
    condition generator.
    Note that the theory @{text "Collection_Bindings"} sets up all the
    necessary lemmas to discharge refinement conditions for the collection
    framework. *}
  using assms unfolding sum_max_impl_def sum_max_def
  apply (refine_rcg) -- "Decompose combinators, generate data refinement goals"

  apply (refine_dref_type) -- "Type-based heuristics to instantiate data
    refinement goals"
  apply (auto simp add:
    ls.correct refine_hsimp refine_rel_defs) -- "Discharge proof obligations"
  done

text {*
  Refinement is transitive, so it is easy to show that the concrete
  program meets the specification.
*}
theorem sum_max_impl_correct:
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar" and "V'\<noteq>{}"
  shows "sum_max_impl V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V' \<and> m=Max V')"
proof -
  note sum_max_impl_refine
  also note sum_max_correct
  finally show ?thesis using assms .
qed

text {*
  Just for completeness, we also refine the total correct program in the
  same way.
*}
definition sum_max'_impl :: "nat ls \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max'_impl V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE\<^sub>T (\<lambda>(V,s,m). \<not>ls.isEmpty V) (\<lambda>(V,s,m). do {
      x\<leftarrow>RETURN (the (ls.sel V (\<lambda>x. True)));
      let V=ls.delete x V;
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

theorem sum_max'_impl_refine:
  "(V,V')\<in>build_rel ls.\<alpha> ls.invar \<Longrightarrow> sum_max'_impl V \<le> \<Down>Id (sum_max' V')"
  unfolding sum_max'_impl_def sum_max'_def
  apply refine_rcg
  apply refine_dref_type
  apply (auto simp: refine_hsimp ls.correct refine_rel_defs)
  done

theorem sum_max'_impl_correct:
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar" and "V'\<noteq>{}"
  shows "sum_max'_impl V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V' \<and> m=Max V')"
  using ref_two_step[OF sum_max'_impl_refine sum_max'_correct] assms
  txt {* Note that we do not need the finiteness precondition, as list-sets are
    always finite. However, in order to exploit this, we have to
    unfold the @{text "build_rel"} construct, that relates the list-set on
    the concrete side to the set on the abstract side.
    *}
  apply (auto simp: build_rel_def)
  done

subsection {* Code Generation *}
text {*
  In order to generate code from the above definitions,
  we convert the function defined in our monad to an ordinary, deterministic
  function, for that the Isabelle/HOL code generator can generate code.

  For partial correct algorithms, we can generate code inside a deterministic
  result monad. The domain of this monad is a flat complete lattice, where
  top means a failed assertion and bottom means nontermination. (Note that
  executing a function in this monad will never return bottom,
  but just diverge).
  The construct @{term "nres_of x"} embeds the deterministic into the
  nondeterministic monad.

  Thus, we have to construct a function @{text "?sum_max_code"} such that:
*}
schematic_lemma sum_max_code_aux: "nres_of ?sum_max_code \<le> sum_max_impl V"
  txt {* This is done automatically by the transfer procedure of
    our framework. *}
  unfolding sum_max_impl_def
  apply (refine_transfer)
  done

text {*
  In order to define the function from the above lemma, we can use the
  command @{text "concrete_definition"}, that is provided by our framework:
*}
concrete_definition sum_max_code for V uses sum_max_code_aux

text {* This defines a new constant @{text "sum_max_code"}:*}
thm sum_max_code_def
text {* And proves the appropriate refinement lemma: *}
thm sum_max_code.refine

text {* Note that the @{text "concrete_definition"} command is sensitive to
  patterns of the form @{text "RETURN _"} and @{text "nres_of"}, in which case
  the defined constant will not contain the @{text "RETURN"}
  or @{text "nres_of"}. In any other case, the defined constant will just be
  the left hand side of the refinement statement.
*}

text {* Finally, we can prove a correctness statement that is independent
  from our refinement framework: *}
theorem sum_max_code_correct:
  assumes "ls.\<alpha> V \<noteq> {}"
  shows "sum_max_code V = dRETURN (s,m) \<Longrightarrow> s=\<Sum>(ls.\<alpha> V) \<and> m=Max (ls.\<alpha> V)"
    and "sum_max_code V \<noteq> dFAIL"
  txt {* The proof is done by transitivity, and unfolding some
    definitions: *}
  using nres_correctD[OF order_trans[OF sum_max_code.refine sum_max_impl_correct,
    of V "ls.\<alpha> V"]] assms
  by (auto simp: refine_rel_defs)

text {* For total correctness, the approach is the same. The
  only difference is, that we use @{const "RETURN"} instead
  of @{const "nres_of"}: *}
schematic_lemma sum_max'_code_aux:
  "RETURN ?sum_max'_code \<le> sum_max'_impl V"
  unfolding sum_max'_impl_def
  apply (refine_transfer)
  done

concrete_definition sum_max'_code for V uses sum_max'_code_aux

theorem sum_max'_code_correct:
  "\<lbrakk>ls.\<alpha> V \<noteq> {}\<rbrakk> \<Longrightarrow> sum_max'_code V = (\<Sum>(ls.\<alpha> V), Max (ls.\<alpha> V))"
  using order_trans[OF sum_max'_code.refine sum_max'_impl_correct,
    of V "ls.\<alpha> V"]
  by (auto simp: refine_rel_defs)

text {*
  If we use recursion combinators, a plain function can only be generated,
  if the recursion combinators can be defined. Alternatively, for total correct
  programs, we may generate a (plain) function that internally uses the
  deterministic monad, and then extracts the result.
*}

schematic_lemma sum_max''_code_aux:
  "RETURN ?sum_max''_code \<le> sum_max'_impl V"
  unfolding sum_max'_impl_def
  apply (refine_transfer the_resI) --
   {*Using @{text "the_resI"} for internal monad and result extraction*}
  done

concrete_definition sum_max''_code for V uses sum_max''_code_aux

theorem sum_max''_code_correct:
  "\<lbrakk>ls.\<alpha> V \<noteq> {}\<rbrakk> \<Longrightarrow> sum_max''_code V = (\<Sum>(ls.\<alpha> V), Max (ls.\<alpha> V))"
  using order_trans[OF sum_max''_code.refine sum_max'_impl_correct,
    of V "ls.\<alpha> V"]
  by (auto simp: refine_rel_defs)

text {* Now, we can generate verified code with the Isabelle/HOL code
  generator: *}
export_code sum_max_code sum_max'_code sum_max''_code in SML
export_code sum_max_code sum_max'_code sum_max''_code in OCaml
export_code sum_max_code sum_max'_code sum_max''_code in Haskell
export_code sum_max_code sum_max'_code sum_max''_code in Scala

subsection {* Foreach-Loops *}
text {*
  In the @{text "sum_max"} example above, we used a while-loop to iterate over
  the elements of a set. As this pattern is used commonly, there is
  an abbreviation for it in the refinement framework. The construct
  @{term "FOREACH S f \<sigma>\<^sub>0"} iterates @{text "f::'x\<Rightarrow>'s\<Rightarrow>'s"} for each element
  in @{text "S::'x set"}, starting with state @{text "\<sigma>\<^sub>0::'s"}.

  With foreach-loops, we could have written our example as follows:
*}

definition sum_max_it :: "nat set \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max_it V \<equiv> FOREACH V (\<lambda>x (s,m). RETURN (s+x,max m x)) (0,0)"

theorem sum_max_it_correct:
  assumes PRE: "V\<noteq>{}" and FIN: "finite V"
  shows "sum_max_it V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V \<and> m=Max V)"
  using PRE unfolding sum_max_it_def
  apply (intro FOREACH_rule[where I="\<lambda>it \<sigma>. sum_max_invar V (it,\<sigma>)"] refine_vcg)
  apply (rule FIN) -- "Discharge finiteness of iterated set"
  apply (auto intro: sum_max_invar_step) -- "Discharge step"
  unfolding sum_max_invar_def -- "Unfold invariant definition"
  apply (auto) -- "Discharge remaining goals"
  done

definition sum_max_it_impl :: "nat ls \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max_it_impl V \<equiv> FOREACH (ls.\<alpha> V) (\<lambda>x (s,m). RETURN (s+x,max m x)) (0,0)"
text {* Note: The nondeterminism for iterators is currently resolved at
  transfer phase, where they are replaced by iterators from the ICF. *}

lemma sum_max_it_impl_refine:
  notes [refine] = inj_on_id
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar"
  shows "sum_max_it_impl V \<le> \<Down>Id (sum_max_it V')"
  unfolding sum_max_it_impl_def sum_max_it_def
  txt {* Note that we specified @{text "inj_on_id"} as additional introduction
    rule. This is due to the very general iterator refinement rule, that may
    also change the set over that is iterated. *}
  using assms
  apply refine_rcg -- {* This time, we don't need the
    @{text "refine_dref_type"} heuristics, as no schematic refinement
    relations are generated. *}
  apply (auto simp: refine_hsimp refine_rel_defs)
  done

schematic_lemma sum_max_it_code_aux:
  "RETURN ?sum_max_it_code \<le> sum_max_it_impl V"
  unfolding sum_max_it_impl_def
  apply (refine_transfer)
  done

text {* Note that the transfer method has replaced the iterator by an iterator
  from the Isabelle Collection Framework.*}

thm sum_max_it_code_aux
concrete_definition sum_max_it_code for V uses sum_max_it_code_aux

theorem sum_max_it_code_correct:
  assumes "ls.\<alpha> V \<noteq> {}"
  shows "sum_max_it_code V = (\<Sum>(ls.\<alpha> V), Max (ls.\<alpha> V))"
proof -
  note sum_max_it_code.refine[of V]
  also note sum_max_it_impl_refine[of V "ls.\<alpha> V"]
  also note sum_max_it_correct
  finally show ?thesis using assms by (auto simp: refine_rel_defs)
qed

export_code sum_max_it_code in SML
export_code sum_max_it_code in OCaml
export_code sum_max_it_code in Haskell
export_code sum_max_it_code in Scala

definition "sum_max_it_list \<equiv> sum_max_it_code o ls.from_list"
ML_val {*
  @{code sum_max_it_list} (map @{code nat_of_integer} [1,2,3,4,5])
*}

section {* Pointwise Reasoning *}

text {*
  In this section, we describe how to use pointwise reasoning to prove
  refinement statements and other relations between element of the
  nondeterminism monad.

  Pointwise reasoning is often a powerful tool to show refinement between
  structurally different program fragments.
*}

text {*
  The refinement framework defines the predicates
  @{const "nofail"} and @{const "inres"}.
  @{term "nofail S"} states that @{text "S"} does not fail,
  and @{term "inres S x"} states that one possible result of @{text "S"} is
  @{text "x"} (Note that this includes the case that @{text "S"} fails).

  Equality and refinement can be stated using @{const "nofail"} and
  @{const "inres"}:
  @{thm [display] pw_eq_iff}
  @{thm [display] pw_le_iff}

  Useful corollaries of this lemma are
  @{thm [source] pw_leI}, @{thm [source] pw_eqI}, and @{thm [source] pwD}.

  Once a refinement has been expressed via nofail/inres, the simplifier can be
  used to propagate the nofail and inres predicates inwards over the structure
  of the program. The relevant lemmas are contained in the named theorem
  collection @{text "refine_pw_simps"}.

  As an example, we show refinement of two structurally different programs here,
  both returning some value in a certain range:
*}
lemma "do { ASSERT (fst p > 2); SPEC (\<lambda>x. x\<le>(2::nat)*(fst p + snd p)) }
  \<le> do { let (x,y)=p; z\<leftarrow>SPEC (\<lambda>z. z\<le>x+y);
          a\<leftarrow>SPEC (\<lambda>a. a\<le>x+y); ASSERT (x>2); RETURN (a+z)}"
  apply (rule pw_leI)
  apply (auto simp add: refine_pw_simps split: prod.split)

  apply (rename_tac a b x)
  apply (case_tac "x\<le>a+b")
  apply (rule_tac x=0 in exI)
  apply simp
  apply (rule_tac x="a+b" in exI)
  apply (simp)
  apply (rule_tac x="x-(a+b)" in exI)
  apply simp
  done

section "Arbitrary Recursion (TBD)"
text {*
  While-loops are suited to express tail-recursion.
  In order to express arbitrary recursion, the refinement framework provides
  the nrec-mode for the @{text "partial_function"} command, as well as the fixed
  point combinators @{const "REC"} (partial correctness) and
  @{const "RECT"} (total correctness).

  Examples for @{text "partial_function"} can be found in
  @{text "ex/Refine_Fold"}. Examples for the recursion combinators can be found
  in @{text "ex/Recursion"} and @{text "ex/Nested_DFS"}.
*}

section {* Reference *}
  subsection {* Statements *} text_raw {*\label{sec:stmt_ref}*}
  text {*
    \begin{description}
      \item[@{const "SUCCEED"}] The empty set of results. Least element of
        the refinement ordering.
      \item[@{const "FAIL"}] Result that indicates a failing assertion.
        Greatest element of the refinement ordering.
      \item{@{term "RES X"}} All results from set @{text "X"}.
      \item[@{term "RETURN x"}] Return single result @{text "x"}. Defined in
        terms of @{text "RES"}: @{lemma "RETURN x = RES {x}" by simp}.
      \item[@{term "EMBED r"}] Embed partial-correctness option type, i.e.,
        succeed if @{text "r=None"}, otherwise return value of @{text "r"}.
      \item[@{term "SPEC \<Phi>"}] Specification.
        All results that satisfy predicate @{text "\<Phi>"}. Defined in terms of
        @{term "RES"}: @{lemma "SPEC \<Phi> = RES (Collect \<Phi>)" by simp}
      \item[@{term [source] "bind M f"}] Binding.
        Nondeterministically choose a result from
        @{text "M"} and apply @{text "f"} to it. Note that usually the
        @{text "do"}-notation is used, i.e., @{text "do {x\<leftarrow>M; f x}"} or
        @{text "do {M;f}"} if the result of @{text "M"} is not important.
        If @{text "M"} fails, @{term [source] "bind M f"} also fails.
      \item[@{term "ASSERT \<Phi>"}] Assertion. Fails
        if @{text "\<Phi>"} does not hold, otherwise returns @{text "()"}.
        Note that the default usage with the do-notation is:
        @{term [source] "do {ASSERT \<Phi>; f}"}.

      \item[@{term "ASSUME \<Phi>"}] Assumption. Succeeds
        if @{text "\<Phi>"} does not hold, otherwise returns @{text "()"}. Note that
        the default usage with the do-notation is:
        @{term [source] "do {ASSUME \<Phi>; f}"}.

      \item[@{term "REC body"}] Recursion for partial correctness.
        May be used to express arbitrary recursion. Returns @{text "SUCCEED"} on
        nontermination.
      \item[@{term "RECT body"}] Recursion for total correctness.
        Returns @{text "FAIL"} on nontermination.
      \item[@{term "WHILE b f \<sigma>\<^sub>0"}] Partial correct while-loop.
        Start with state @{text "\<sigma>\<^sub>0"},
        and repeatedly apply @{text "f"} as long as @{text "b"} holds for the
        current state. Non-terminating paths are ignored, i.e., they do not
        contribute a result.
      \item[@{term "WHILE\<^sub>T b f \<sigma>\<^sub>0"}] Total correct while-loop. If there is a
        non-terminating path, the result is @{term "FAIL"}.
      \item[@{term "WHILE\<^bsup>I\<^esup> b f \<sigma>\<^sub>0"}, @{term "WHILE\<^sub>T\<^bsup>I\<^esup> b f \<sigma>\<^sub>0"}] While-loop with
        annotated invariant. It is asserted that the invariant holds.
      \item[@{term "FOREACH S f \<sigma>\<^sub>0"}] Foreach loop.
        Start with state @{text "\<sigma>\<^sub>0"}, and transform
        the state with @{text "f x"} for each element @{text "x\<in>S"}. Asserts that
        @{text "S"} is finite.
      \item[@{term "FOREACH\<^bsup>I\<^esup> S f \<sigma>\<^sub>0"}] Foreach-loop with
        annotated invariant.

        Alternative syntax: @{term "FOREACHi I S f \<sigma>\<^sub>0"}.

        The invariant is a predicate of type
        @{text "I::'a set \<Rightarrow> 'b \<Rightarrow> bool"}, where @{text "I it \<sigma>"} means, that
        the invariant holds for the remaining set of elements @{text "it"} and
        current state @{text "\<sigma>"}.
      \item[@{term "FOREACH\<^sub>C S c f \<sigma>\<^sub>0"}] Foreach-loop with explicit continuation
        condition.

        Alternative syntax: @{term "FOREACHc S c f \<sigma>\<^sub>0"}.

        If @{text "c::'\<sigma>\<Rightarrow>bool"} becomes false for the current state,
        the iteration immediately terminates.
      \item[@{term "FOREACH\<^sub>C\<^bsup>I\<^esup> S c f \<sigma>\<^sub>0"}] Foreach-loop with explicit continuation
        condition and annotated invariant.

        Alternative syntax: @{term "FOREACHci I S c f \<sigma>\<^sub>0"}.
      \item[@{text "partial_function (nrec)"}] Mode of the partial function
        package for the nondeterminism monad.
    \end{description}
    *}

    subsection {* Refinement *}
    text {*
      \begin{description}
        \item{@{term_type "op \<le> :: 'a nres \<Rightarrow> 'a nres \<Rightarrow> bool"}}
          Refinement ordering.
          @{text "S \<le> S'"} means, that every result in
          @{text "S"} is also a result in @{text "S'"}.
          Moreover, @{text "S"} may only fail if @{text "S'"} fails.
          @{text "\<le>"} forms a complete lattice, with least element
          @{text "SUCCEED"} and greatest element @{text "FAIL"}.
        \item{@{term "\<Down>R"}} Concretization. Takes a refinement relation
          @{text "R::('c\<times>'a) set"} that relates concrete to abstract values,
          and returns a concretization function
          @{term "\<Down>R :: 'a nres \<Rightarrow> 'c nres"}.
        \item{@{term "\<Up>R"}} Abstraction. Takes a refinement relation and
          returns an abstraction function.
          The functions @{text "\<Down>R"} and @{text "\<Up>R"} form a Galois-connection,
          i.e., we have: @{text "S \<le> \<Down>R S' \<longleftrightarrow> \<Up>R S \<le> S'"}.
        \item{@{term "build_rel \<alpha> I"}} Builds a refinement relation from
          an abstraction function and an invariant. Those refinement relations
          are always single-valued.
        \item{@{term "nofail S"}} Predicate that states that @{text "S"} does
          not fail.
        \item{@{term "inres S x"}} Predicate that states that @{text "S"}
          includes result @{text "x"}. Note that a failing program includes all
          results.
      \end{description}
      *}

    subsection{* Proof Tools *}
      text {*
        \begin{description}
          \item{Verification Condition Generator:}
            \begin{description}
              \item[Method:] @{text "intro refine_vcg"}
              \item[Attributes:] @{text "refine_vcg"}
            \end{description}

            Transforms a subgoal of the
            form @{text "S \<le> SPEC \<Phi>"} into verification conditions by
            decomposing the structure of @{text "S"}. Invariants for loops
            without annotation must be specified explicitely by instantiating
            the respective proof-rule for the loop construct, e.g.,
            @{text "intro WHILE_rule[where I=\<dots>] refine_vcg"}.

            @{text "refine_vcg"} is a named theorems collection that contains
            the rules that are used by default.

          \item{Refinement Condition Generator:}
            \begin{description}
              \item[Method:] @{text "refine_rcg"} [thms].
              \item[Attributes:] @{text "refine0"}, @{text "refine"},
                @{text "refine2"}.
              \item[Flags:] @{text refine_no_prod_split}.
            \end{description}
            Tries to prove a subgoal of the form @{text "S \<le> \<Down>R S'"} by
            decomposing the structure of @{text "S"} and @{text "S'"}.
            The rules to be used are contained in the theorem collection
            @{text "refine"}. More rules may be passed as argument to the method.
            Rules contained in @{text "refine0"} are always
            tried first, and rules in @{text "refine2"} are tried last.
            Usually, rules that decompose both programs equally
            should be put into @{text "refine"}. Rules that may make big steps,
            without decomposing the program further, should be put into
            @{text "refine0"} (e.g., @{thm [source] Id_refine}). Rules that
            decompose the programs differently and shall be used as last resort
            before giving up should be put into @{text "refine2"}, e.g.,
            @{thm [source] remove_Let_refine}.

            By default, this procedure will invoke the splitter to split
            product types in the goals. This behaviour can be disabled by
            setting the flag @{text "refine_no_prod_split"}.
          \item{Refinement Relation Heuristics:}
            \begin{description}
              \item[Method:] @{text "refine_dref_type"} [(trace)].
              \item[Attributes:] @{text "refine_dref_RELATES"},
                @{text "refine_dref_pattern"}.
              \item[Flags:] @{text "refine_dref_tracing"}.
            \end{description}
            Tries to instantiate schematic refinement relations based on their
            type. By default, this rule is applied to all subgoals.
            Internally, it uses the rules declared as
            @{text "refine_dref_pattern"} to introduce a goal of the form
            @{text "RELATES ?R"}, that is then solved by exhaustively
            applying rules declared as @{text "refine_dref_RELATES"}.

            The flag @{text "refine_dref_tracing"} controls tracing of
            resolving @{text "RELATES"}-goals. Tracing may also be enabled by
            passing (trace) as argument.

          \item{Pointwise Reasoning Simplification Rules:}
            \begin{description}
              \item[Attributes:] @{text "refine_pw_simps"}
            \end{description}
            A theorem collection that contains
            simplification lemmas to push inwards @{term "nofail"} and
            @{term "inres"} predicates into program constructs.

          \item{Refinement Simp Rules:}
            \begin{description}
              \item[Attributes:] @{text "refine_hsimp"}
            \end{description}
            A theorem collection that contains some
            simplification lemmas that are useful to prove membership in
            refinement relations.

          \item{Transfer:}
            \begin{description}
              \item[Method:] @{text "refine_transfer"} [thms]
              \item[Attribute:] @{text "refine_transfer"}
            \end{description}
            Tries to prove a subgoal of the form @{text "\<alpha> f \<le> S"} by
            decomposing the structure of @{text "f"} and @{text "S"}.
            This is usually used in connection
            with a schematic lemma, to generate @{text "f"} from the structure
            of @{text "S"}.

            The theorems declared as @{text "refine_transfer"} are used to do
            the transfer. More theorems may be passed as arguments to the method.
            Moreover, some simplification for nested abstraction
            over product types (@{text "\<lambda>(a,b) (c,d). \<dots>"}) is done, and the
            monotonicity prover is used on monotonicity goals.

            There is a standard setup for @{text "\<alpha>=RETURN"}
            (transfer to plain function for total correct code generation), and
            @{text "\<alpha>=nres_of"} (transfer to deterministic result monad, for
            partial correct code generation).

          \item{Automatic Refinement:}
            \begin{description}
              \item[Method:] @{text "refine_autoref"}
              \item[Attributes:] ...
            \end{description}
            See automatic refinement package for documentation (TBD)

          \item{Concrete Definition:}
            \begin{description}
              \item[Command:]
               @{text "concrete_definition name [attribs] for params uses thm"}
               where @{text "attribs"} and the @{text "for"}-part are optional.

               Declares a new constant from the left-hand side of a refinement
               lemma. Has special handling for left-hand sides of the forms
               @{text "RETURN _"} and @{text "nres_of"}, in which cases those
               topmost functions are not included in the defined constant.

               The refinement lemma is folded with the new constant and
               registered as @{text "name.refine"}.
              \item[Command:]
              @{text "prepare_code_thms thms"} takes a list of definitional
                theorems and sets up lemmas for the code generator for those
                definitions. This includes handling of recursion combinators.
            \end{description}
        \end{description}
        *}

    subsection{* Packages *}
      text {*
        The following parts of the refinement framework are not included
        by default, but can be imported if necessary:
        \begin{description}
          \item{Collection-Bindings:} Sets up refinement rules for the
            Isabelle Collection Framework. With this theory loaded, the
            refinement condition generator will discharge most data refinements
            using the ICF automatically. Moreover, the transfer procedure
            will replace @{text "FOREACH"}-statements by the corresponding
            ICF-iterators.
        \end{description}
        *}

end


(*  Title:      ZF/UNITY/AllocBase.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Common declarations for Chandy and Charpentier's Allocator\<close>

theory AllocBase imports Follows MultisetSum Guar begin

abbreviation (input)
  tokbag   :: i  (* tokbags could be multisets...or any ordered type?*)
where
  "tokbag == nat"

axiomatization
  NbT :: i and  (* Number of tokens in system *)
  Nclients :: i  (* Number of clients *)
where
  NbT_pos: "NbT \<in> nat-{0}" and
  Nclients_pos: "Nclients \<in> nat-{0}"

text\<open>This function merely sums the elements of a list\<close>
consts tokens :: "i =>i"
       item :: i (* Items to be merged/distributed *)
primrec
  "tokens(Nil) = 0"
  "tokens (Cons(x,xs)) = x #+ tokens(xs)"

consts bag_of :: "i => i"
primrec
  "bag_of(Nil)    = 0"
  "bag_of(Cons(x,xs)) = {#x#} +# bag_of(xs)"

text\<open>Definitions needed in Client.thy.  We define a recursive predicate
using 0 and 1 to code the truth values.\<close>
consts all_distinct0 :: "i=>i"
primrec
  "all_distinct0(Nil) = 1"
  "all_distinct0(Cons(a, l)) =
     (if a \<in> set_of_list(l) then 0 else all_distinct0(l))"

definition
  all_distinct  :: "i=>o"  where
   "all_distinct(l) == all_distinct0(l)=1"

definition
  state_of :: "i =>i" \<comment>\<open>coersion from anyting to state\<close>  where
   "state_of(s) == if s \<in> state then s else st0"

definition
  lift :: "i =>(i=>i)" \<comment>\<open>simplifies the expression of programs\<close>  where
   "lift(x) == %s. s`x"

text\<open>function to show that the set of variables is infinite\<close>
consts
  nat_list_inj :: "i=>i"
  var_inj      :: "i=>i"

primrec
  "nat_list_inj(0) = Nil"
  "nat_list_inj(succ(n)) = Cons(n, nat_list_inj(n))"

primrec
  "var_inj(Var(l)) = length(l)"

definition
  nat_var_inj  :: "i=>i"  where
  "nat_var_inj(n) == Var(nat_list_inj(n))"

subsection\<open>Various simple lemmas\<close>

lemma Nclients_NbT_gt_0 [simp]: "0 < Nclients & 0 < NbT"
apply (cut_tac Nclients_pos NbT_pos)
apply (auto intro: Ord_0_lt)
done

lemma Nclients_NbT_not_0 [simp]: "Nclients \<noteq> 0 & NbT \<noteq> 0"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma Nclients_type [simp,TC]: "Nclients\<in>nat"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma NbT_type [simp,TC]: "NbT\<in>nat"
by (cut_tac Nclients_pos NbT_pos, auto)

lemma INT_Nclient_iff [iff]:
     "b\<in>\<Inter>(RepFun(Nclients, B)) \<longleftrightarrow> (\<forall>x\<in>Nclients. b\<in>B(x))"
by (force simp add: INT_iff)

lemma setsum_fun_mono [rule_format]:
     "n\<in>nat ==>
      (\<forall>i\<in>nat. i<n \<longrightarrow> f(i) $\<le> g(i)) \<longrightarrow>
      setsum(f, n) $\<le> setsum(g,n)"
apply (induct_tac "n", simp_all)
apply (subgoal_tac "Finite(x) & x\<notin>x")
 prefer 2 apply (simp add: nat_into_Finite mem_not_refl, clarify)
apply (simp (no_asm_simp) add: succ_def)
apply (subgoal_tac "\<forall>i\<in>nat. i<x\<longrightarrow> f(i) $\<le> g(i) ")
 prefer 2 apply (force dest: leI)
apply (rule zadd_zle_mono, simp_all)
done

lemma tokens_type [simp,TC]: "l\<in>list(A) ==> tokens(l)\<in>nat"
by (erule list.induct, auto)

lemma tokens_mono_aux [rule_format]:
     "xs\<in>list(A) ==> \<forall>ys\<in>list(A). <xs, ys>\<in>prefix(A)
   \<longrightarrow> tokens(xs) \<le> tokens(ys)"
apply (induct_tac "xs")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: prefix_def)
done

lemma tokens_mono: "<xs, ys>\<in>prefix(A) ==> tokens(xs) \<le> tokens(ys)"
apply (cut_tac prefix_type)
apply (blast intro: tokens_mono_aux)
done

lemma mono_tokens [iff]: "mono1(list(A), prefix(A), nat, Le,tokens)"
apply (unfold mono1_def)
apply (auto intro: tokens_mono simp add: Le_def)
done

lemma tokens_append [simp]:
"[| xs\<in>list(A); ys\<in>list(A) |] ==> tokens(xs@ys) = tokens(xs) #+ tokens(ys)"
apply (induct_tac "xs", auto)
done

subsection\<open>The function @{term bag_of}\<close>

lemma bag_of_type [simp,TC]: "l\<in>list(A) ==>bag_of(l)\<in>Mult(A)"
apply (induct_tac "l")
apply (auto simp add: Mult_iff_multiset)
done

lemma bag_of_multiset:
     "l\<in>list(A) ==> multiset(bag_of(l)) & mset_of(bag_of(l))<=A"
apply (drule bag_of_type)
apply (auto simp add: Mult_iff_multiset)
done

lemma bag_of_append [simp]:
    "[| xs\<in>list(A); ys\<in>list(A)|] ==> bag_of(xs@ys) = bag_of(xs) +# bag_of(ys)"
apply (induct_tac "xs")
apply (auto simp add: bag_of_multiset munion_assoc)
done

lemma bag_of_mono_aux [rule_format]:
     "xs\<in>list(A) ==> \<forall>ys\<in>list(A). <xs, ys>\<in>prefix(A)
      \<longrightarrow> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
apply (induct_tac "xs", simp_all, clarify)
apply (frule_tac l = ys in bag_of_multiset)
apply (auto intro: empty_le_MultLe simp add: prefix_def)
apply (rule munion_mono)
apply (force simp add: MultLe_def Mult_iff_multiset)
apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma bag_of_mono [intro]:
     "[|  <xs, ys>\<in>prefix(A); xs\<in>list(A); ys\<in>list(A) |]
      ==> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
apply (blast intro: bag_of_mono_aux)
done

lemma mono_bag_of [simp]:
     "mono1(list(A), prefix(A), Mult(A), MultLe(A,r), bag_of)"
by (auto simp add:  mono1_def bag_of_type)

subsection\<open>The function @{term msetsum}\<close>

lemmas nat_into_Fin = eqpoll_refl [THEN [2] Fin_lemma]

lemma list_Int_length_Fin: "l \<in> list(A) ==> C \<inter> length(l) \<in> Fin(length(l))"
apply (drule length_type)
apply (rule Fin_subset)
apply (rule Int_lower2)
apply (erule nat_into_Fin)
done

lemma mem_Int_imp_lt_length:
     "[|xs \<in> list(A); k \<in> C \<inter> length(xs)|] ==> k < length(xs)"
by (simp add: ltI)

lemma Int_succ_right:
     "A \<inter> succ(k) = (if k \<in> A then cons(k, A \<inter> k) else A \<inter> k)"
by auto

lemma bag_of_sublist_lemma:
     "[|C \<subseteq> nat; x \<in> A; xs \<in> list(A)|]
  ==>  msetsum(\<lambda>i. {#nth(i, xs @ [x])#}, C \<inter> succ(length(xs)), A) =
       (if length(xs) \<in> C then
          {#x#} +# msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A)
        else msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A))"
apply (simp add: subsetD nth_append lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
apply (simp add: Int_succ_right)
apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong, clarify)
apply (subst msetsum_cons)
apply (rule_tac [3] succI1)
apply (blast intro: list_Int_length_Fin subset_succI [THEN Fin_mono, THEN subsetD])
apply (simp add: mem_not_refl)
apply (simp add: nth_type lt_not_refl)
apply (blast intro: nat_into_Ord ltI length_type)
apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
done

lemma bag_of_sublist_lemma2:
     "l\<in>list(A) ==>
  C \<subseteq> nat ==>
  bag_of(sublist(l, C)) =
      msetsum(%i. {#nth(i, l)#}, C \<inter> length(l), A)"
apply (erule list_append_induct)
apply (simp (no_asm))
apply (simp (no_asm_simp) add: sublist_append nth_append bag_of_sublist_lemma munion_commute bag_of_sublist_lemma msetsum_multiset munion_0)
done

lemma nat_Int_length_eq: "l \<in> list(A) ==> nat \<inter> length(l) = length(l)"
apply (rule Int_absorb1)
apply (rule OrdmemD, auto)
done

(*eliminating the assumption C<=nat*)
lemma bag_of_sublist:
     "l\<in>list(A) ==>
  bag_of(sublist(l, C)) = msetsum(%i. {#nth(i, l)#}, C \<inter> length(l), A)"
apply (subgoal_tac " bag_of (sublist (l, C \<inter> nat)) = msetsum (%i. {#nth (i, l) #}, C \<inter> length (l), A) ")
apply (simp add: sublist_Int_eq)
apply (simp add: bag_of_sublist_lemma2 Int_lower2 Int_assoc nat_Int_length_eq)
done

lemma bag_of_sublist_Un_Int:
"l\<in>list(A) ==>
  bag_of(sublist(l, B \<union> C)) +# bag_of(sublist(l, B \<inter> C)) =
      bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
apply (subgoal_tac "B \<inter> C \<inter> length (l) = (B \<inter> length (l)) \<inter> (C \<inter> length (l))")
prefer 2 apply blast
apply (simp (no_asm_simp) add: bag_of_sublist Int_Un_distrib2 msetsum_Un_Int)
apply (rule msetsum_Un_Int)
apply (erule list_Int_length_Fin)+
 apply (simp add: ltI nth_type)
done

lemma bag_of_sublist_Un_disjoint:
     "[| l\<in>list(A); B \<inter> C = 0  |]
      ==> bag_of(sublist(l, B \<union> C)) =
          bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
by (simp add: bag_of_sublist_Un_Int [symmetric] bag_of_multiset)

lemma bag_of_sublist_UN_disjoint [rule_format]:
     "[|Finite(I); \<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j \<longrightarrow> A(i) \<inter> A(j) = 0;
        l\<in>list(B) |]
      ==> bag_of(sublist(l, \<Union>i\<in>I. A(i))) =
          (msetsum(%i. bag_of(sublist(l, A(i))), I, B)) "
apply (simp (no_asm_simp) del: UN_simps
           add: UN_simps [symmetric] bag_of_sublist)
apply (subst  msetsum_UN_disjoint [of _ _ _ "length (l)"])
apply (drule Finite_into_Fin, assumption)
prefer 3 apply force
apply (auto intro!: Fin_IntI2 Finite_into_Fin simp add: ltI nth_type length_type nat_into_Finite)
done

lemma part_ord_Lt [simp]: "part_ord(nat, Lt)"
apply (unfold part_ord_def Lt_def irrefl_def trans_on_def)
apply (auto intro: lt_trans)
done

subsubsection\<open>The function @{term all_distinct}\<close>

lemma all_distinct_Nil [simp]: "all_distinct(Nil)"
by (unfold all_distinct_def, auto)

lemma all_distinct_Cons [simp]:
    "all_distinct(Cons(a,l)) \<longleftrightarrow>
      (a\<in>set_of_list(l) \<longrightarrow> False) & (a \<notin> set_of_list(l) \<longrightarrow> all_distinct(l))"
apply (unfold all_distinct_def)
apply (auto elim: list.cases)
done

subsubsection\<open>The function @{term state_of}\<close>

lemma state_of_state: "s\<in>state ==> state_of(s)=s"
by (unfold state_of_def, auto)
declare state_of_state [simp]

lemma state_of_idem: "state_of(state_of(s))=state_of(s)"

apply (unfold state_of_def, auto)
done
declare state_of_idem [simp]

lemma state_of_type [simp,TC]: "state_of(s)\<in>state"
by (unfold state_of_def, auto)

lemma lift_apply [simp]: "lift(x, s)=s`x"
by (simp add: lift_def)

(** Used in ClientImp **)

lemma gen_Increains_state_of_eq:
     "Increasing(A, r, %s. f(state_of(s))) = Increasing(A, r, f)"
apply (unfold Increasing_def, auto)
done

lemmas Increasing_state_ofD1 =
      gen_Increains_state_of_eq [THEN equalityD1, THEN subsetD]
lemmas Increasing_state_ofD2 =
      gen_Increains_state_of_eq [THEN equalityD2, THEN subsetD]

lemma Follows_state_of_eq:
     "Follows(A, r, %s. f(state_of(s)), %s. g(state_of(s))) =
      Follows(A, r, f, g)"
apply (unfold Follows_def Increasing_def, auto)
done

lemmas Follows_state_ofD1 =
      Follows_state_of_eq [THEN equalityD1, THEN subsetD]
lemmas Follows_state_ofD2 =
      Follows_state_of_eq [THEN equalityD2, THEN subsetD]

lemma nat_list_inj_type: "n\<in>nat ==> nat_list_inj(n)\<in>list(nat)"
by (induct_tac "n", auto)

lemma length_nat_list_inj: "n\<in>nat ==> length(nat_list_inj(n)) = n"
by (induct_tac "n", auto)

lemma var_infinite_lemma:
  "(\<lambda>x\<in>nat. nat_var_inj(x))\<in>inj(nat, var)"
apply (unfold nat_var_inj_def)
apply (rule_tac d = var_inj in lam_injective)
apply (auto simp add: var.intros nat_list_inj_type)
apply (simp add: length_nat_list_inj)
done

lemma nat_lepoll_var: "nat \<lesssim> var"
apply (unfold lepoll_def)
apply (rule_tac x = " (\<lambda>x\<in>nat. nat_var_inj (x))" in exI)
apply (rule var_infinite_lemma)
done

lemma var_not_Finite: "~Finite(var)"
apply (insert nat_not_Finite)
apply (blast intro: lepoll_Finite [OF nat_lepoll_var])
done

lemma not_Finite_imp_exist: "~Finite(A) ==> \<exists>x. x\<in>A"
apply (subgoal_tac "A\<noteq>0")
apply (auto simp add: Finite_0)
done

lemma Inter_Diff_var_iff:
     "Finite(A) ==> b\<in>(\<Inter>(RepFun(var-A, B))) \<longleftrightarrow> (\<forall>x\<in>var-A. b\<in>B(x))"
apply (subgoal_tac "\<exists>x. x\<in>var-A", auto)
apply (subgoal_tac "~Finite (var-A) ")
apply (drule not_Finite_imp_exist, auto)
apply (cut_tac var_not_Finite)
apply (erule swap)
apply (rule_tac B = A in Diff_Finite, auto)
done

lemma Inter_var_DiffD:
     "[| b\<in>\<Inter>(RepFun(var-A, B)); Finite(A); x\<in>var-A |] ==> b\<in>B(x)"
by (simp add: Inter_Diff_var_iff)

(* [| Finite(A); (\<forall>x\<in>var-A. b\<in>B(x)) |] ==> b\<in>\<Inter>(RepFun(var-A, B)) *)
lemmas Inter_var_DiffI = Inter_Diff_var_iff [THEN iffD2]

declare Inter_var_DiffI [intro!]

lemma Acts_subset_Int_Pow_simp [simp]:
     "Acts(F)<= A \<inter> Pow(state*state)  \<longleftrightarrow> Acts(F)<=A"
by (insert Acts_type [of F], auto)

lemma setsum_nsetsum_eq:
     "[| Finite(A); \<forall>x\<in>A. g(x)\<in>nat |]
      ==> setsum(%x. $#(g(x)), A) = $# nsetsum(%x. g(x), A)"
apply (erule Finite_induct)
apply (auto simp add: int_of_add)
done

lemma nsetsum_cong:
     "[| A=B;  \<forall>x\<in>A. f(x)=g(x);  \<forall>x\<in>A. g(x)\<in>nat;  Finite(A) |]
      ==> nsetsum(f, A) = nsetsum(g, B)"
apply (subgoal_tac "$# nsetsum (f, A) = $# nsetsum (g, B)", simp)
apply (simp add: setsum_nsetsum_eq [symmetric] cong: setsum_cong)
done

end


theory Tacticals imports Main begin

text\<open>REPEAT\<close>
lemma "\<lbrakk>P\<longrightarrow>Q; Q\<longrightarrow>R; R\<longrightarrow>S; P\<rbrakk> \<Longrightarrow> S"
apply (drule mp, assumption)
apply (drule mp, assumption)
apply (drule mp, assumption)
apply (assumption)
done

lemma "\<lbrakk>P\<longrightarrow>Q; Q\<longrightarrow>R; R\<longrightarrow>S; P\<rbrakk> \<Longrightarrow> S"
by (drule mp, assumption)+

text\<open>ORELSE with REPEAT\<close>
lemma "\<lbrakk>Q\<longrightarrow>R; P\<longrightarrow>Q; x<5\<longrightarrow>P;  Suc x < 5\<rbrakk> \<Longrightarrow> R"
by (drule mp, (assumption|arith))+

text\<open>exercise: what's going on here?\<close>
lemma "\<lbrakk>P\<and>Q\<longrightarrow>R; P\<longrightarrow>Q; P\<rbrakk> \<Longrightarrow> R"
by (drule mp, (intro conjI)?, assumption+)+

text\<open>defer and prefer\<close>

lemma "hard \<and> (P \<or> ~P) \<and> (Q\<longrightarrow>Q)"
apply (intro conjI)   \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
defer 1   \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply blast+   \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
oops

lemma "ok1 \<and> ok2 \<and> doubtful"
apply (intro conjI)   \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
prefer 3   \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
oops

lemma "bigsubgoal1 \<and> bigsubgoal2 \<and> bigsubgoal3 \<and> bigsubgoal4 \<and> bigsubgoal5 \<and> bigsubgoal6"
apply (intro conjI)   \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
txt\<open>@{subgoals[display,indent=0,margin=65]}
A total of 6 subgoals...
\<close>
oops

(*needed??*)

lemma "(P\<or>Q) \<and> (R\<or>S) \<Longrightarrow> PP"
apply (elim conjE disjE)
oops

lemma "((P\<or>Q) \<and> R) \<and> (Q \<and> (P\<or>S)) \<Longrightarrow> PP"
apply (elim conjE)
oops

lemma "((P\<or>Q) \<and> R) \<and> (Q \<and> (P\<or>S)) \<Longrightarrow> PP"
apply (erule conjE)+
oops

end


section \<open>Classical instantiation of registerss\<close>

(* AXIOM INSTANTIATION (use instantiate_laws.py to generate Laws_Classical.thy)

   domain \<rightarrow> type
   comp_update \<rightarrow> map_comp
   id_update \<rightarrow> Some

   Generic laws about registers \<rightarrow> Generic laws about registers, instantiated classically
*)

theory Axioms_Classical
  imports Main
begin

type_synonym 'a update = \<open>'a \<rightharpoonup> 'a\<close>

lemma id_update_left: "Some \<circ>\<^sub>m a = a"
  by (auto intro!: ext simp add: map_comp_def option.case_eq_if)
lemma id_update_right: "a \<circ>\<^sub>m Some = a"
  by auto

lemma comp_update_assoc: "(a \<circ>\<^sub>m b) \<circ>\<^sub>m c = a \<circ>\<^sub>m (b \<circ>\<^sub>m c)"
  by (auto intro!: ext simp add: map_comp_def option.case_eq_if)

type_synonym ('a,'b) preregister = \<open>'a update \<Rightarrow> 'b update\<close>
definition preregister :: \<open>('a,'b) preregister \<Rightarrow> bool\<close> where
  \<open>preregister F \<longleftrightarrow> (\<exists>g s. \<forall>a m. F a m = (case a (g m) of None \<Rightarrow> None | Some x \<Rightarrow> s x m))\<close>

lemma id_preregister: \<open>preregister id\<close>
  unfolding preregister_def
  apply (rule exI[of _ \<open>\<lambda>m. m\<close>])
  apply (rule exI[of _ \<open>\<lambda>a m. Some a\<close>])
  by (simp add: option.case_eq_if)

lemma preregister_mult_right: \<open>preregister (\<lambda>a. a \<circ>\<^sub>m z)\<close>
  unfolding preregister_def
  apply (rule exI[of _ \<open>\<lambda>m. the (z m)\<close>])
  apply (rule exI[of _ \<open>\<lambda>x m. case z m of None \<Rightarrow> None | _ \<Rightarrow> Some x\<close>])
  by (auto simp add: option.case_eq_if)

lemma preregister_mult_left: \<open>preregister (\<lambda>a. z \<circ>\<^sub>m a)\<close>
  unfolding preregister_def
  apply (rule exI[of _ \<open>\<lambda>m. m\<close>])
  apply (rule exI[of _ \<open>\<lambda>x m. z x\<close>])
  by (auto simp add: option.case_eq_if)

lemma comp_preregister: "preregister (G \<circ> F)" if "preregister F" and \<open>preregister G\<close>
proof -
  from \<open>preregister F\<close>
  obtain sF gF where F: \<open>F a m = (case a (gF m) of None \<Rightarrow> None | Some x \<Rightarrow> sF x m)\<close> for a m
    using preregister_def by blast
  from \<open>preregister G\<close>
  obtain sG gG where G: \<open>G a m = (case a (gG m) of None \<Rightarrow> None | Some x \<Rightarrow> sG x m)\<close> for a m
    using preregister_def by blast
  define s g where \<open>s a m = (case sF a (gG m) of None \<Rightarrow> None | Some x \<Rightarrow> sG x m)\<close>
    and \<open>g m = gF (gG m)\<close> for a m
  have \<open>(G \<circ> F) a m = (case a (g m) of None \<Rightarrow> None | Some x \<Rightarrow> s x m)\<close> for a m
    unfolding F G s_def g_def
    by (auto simp add: option.case_eq_if)
  then show "preregister (G \<circ> F)"
    using preregister_def by blast
qed

definition tensor_update :: \<open>'a update \<Rightarrow> 'b update \<Rightarrow> ('a\<times>'b) update\<close> where
  \<open>tensor_update a b m = (case a (fst m) of None \<Rightarrow> None | Some x \<Rightarrow> (case b (snd m) of None \<Rightarrow> None | Some y \<Rightarrow> Some (x,y)))\<close>

lemma tensor_update_mult: \<open>tensor_update a c \<circ>\<^sub>m tensor_update b d = tensor_update (a \<circ>\<^sub>m b) (c \<circ>\<^sub>m d)\<close>
  by (auto intro!: ext simp add: map_comp_def option.case_eq_if tensor_update_def)

definition update1 :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a update\<close> where
  \<open>update1 x y m = (if m=x then Some y else None)\<close>

lemma update1_extensionality:
  assumes \<open>preregister F\<close>
  assumes \<open>preregister G\<close>
  assumes FGeq: \<open>\<And>x y. F (update1 x y) = G (update1 x y)\<close>
  shows "F = G"
proof (rule ccontr)
  assume neq: \<open>F \<noteq> G\<close>
  then obtain z m where neq': \<open>F z m \<noteq> G z m\<close>
    apply atomize_elim by auto
  obtain gF sF where gsF: \<open>F z m = (case z (gF m) of None \<Rightarrow> None | Some x \<Rightarrow> sF x m)\<close> for z m
    using \<open>preregister F\<close> preregister_def by blast
  obtain gG sG where gsG: \<open>G z m = (case z (gG m) of None \<Rightarrow> None | Some x \<Rightarrow> sG x m)\<close> for z m
    using \<open>preregister G\<close> preregister_def by blast
  consider (abeq) x where \<open>z (gF m) = Some x\<close> \<open>z (gG m) = Some x\<close> \<open>gF m = gG m\<close>
    | (abnone) \<open>z (gG m) = None\<close> \<open>z (gF m) = None\<close>
    | (neqF) x where \<open>gF m \<noteq> gG m\<close> \<open>F z m = Some x\<close>
    | (neqG) y where \<open>gF m \<noteq> gG m\<close> \<open>G z m = Some y\<close>
    | (neqNone) \<open>gF m \<noteq> gG m\<close> \<open>F z m = None\<close> \<open>G z m = None\<close>
    apply atomize_elim by (metis option.exhaust_sel)
  then show False
  proof cases
    case (abeq x)
    then have \<open>F z m = sF x m\<close> and \<open>G z m = sG x m\<close>
      by (simp_all add: gsF gsG)
    moreover have \<open>F (update1 (gF m) x) m = sF x m\<close>
      by (simp add: gsF update1_def)
    moreover have \<open>G (update1 (gF m) x) m = sG x m\<close>
      by (simp add: abeq gsG update1_def)
    ultimately show False
      using FGeq neq' by force
  next
    case abnone
    then show False
      using gsF gsG neq' by force
  next
    case neqF
    moreover
    have \<open>F (update1 (gF m) (the (z (gF m)))) m = F z m\<close>
      by (metis gsF neqF(2) option.case_eq_if option.simps(3) option.simps(5) update1_def)
    moreover have \<open>G (update1 (gF m) (the (z (gF m)))) m = None\<close>
      by (metis gsG neqF(1) option.case_eq_if update1_def)
    ultimately show False
      using FGeq by force
  next
    case neqG
    moreover
    have \<open>G (update1 (gG m) (the (z (gG m)))) m = G z m\<close>
      by (metis gsG neqG(2) option.case_eq_if option.distinct(1) option.simps(5) update1_def)
    moreover have \<open>F (update1 (gG m) (the (z (gG m)))) m = None\<close>
      by (simp add: gsF neqG(1) update1_def)
    ultimately show False
      using FGeq by force
  next
    case neqNone
    with neq' show False
      by fastforce
  qed
qed

lemma tensor_extensionality:
  assumes \<open>preregister F\<close>
  assumes \<open>preregister G\<close>
  assumes FGeq: \<open>\<And>a b. F (tensor_update a b) = G (tensor_update a b)\<close>
  shows "F = G"
proof -
  have \<open>F (update1 x y) = G (update1 x y)\<close> for x y
    using FGeq[of \<open>update1 (fst x) (fst y)\<close> \<open>update1 (snd x) (snd y)\<close>]
    apply (auto intro!:ext simp: tensor_update_def[abs_def] update1_def[abs_def])
    by (smt (z3) assms(1) assms(2) option.case(2) option.case_eq_if preregister_def prod.collapse)
  with assms(1,2) show "F = G"
    by (rule update1_extensionality)
qed

definition "valid_getter_setter g s \<longleftrightarrow>
  (\<forall>b. b = s (g b) b) \<and> (\<forall>a b. g (s a b) = a) \<and> (\<forall>a a' b. s a (s a' b) = s a b)"

definition \<open>register_from_getter_setter g s a m = (case a (g m) of None \<Rightarrow> None | Some x \<Rightarrow> Some (s x m))\<close>
definition \<open>register_apply F a = the o F (Some o a)\<close>
definition \<open>setter F a m = register_apply F (\<lambda>_. a) m\<close> for F :: \<open>'a update \<Rightarrow> 'b update\<close>
definition \<open>getter F m = (THE x. setter F x m = m)\<close> for F :: \<open>'a update \<Rightarrow> 'b update\<close>

lemma
  assumes \<open>valid_getter_setter g s\<close>
  shows getter_of_register_from_getter_setter[simp]: \<open>getter (register_from_getter_setter g s) = g\<close>
    and setter_of_register_from_getter_setter[simp]: \<open>setter (register_from_getter_setter g s) = s\<close>
proof -
  define g' s' where \<open>g' = getter (register_from_getter_setter g s)\<close>
    and \<open>s' = setter (register_from_getter_setter g s)\<close>
  show \<open>s' = s\<close>
    by (auto intro!:ext simp: s'_def setter_def register_apply_def register_from_getter_setter_def)
  moreover show \<open>g' = g\<close>
  proof (rule ext, rename_tac m)
    fix m
    have \<open>g' m = (THE x. s x m = m)\<close>
      by (auto intro!:ext simp: g'_def s'_def[symmetric] \<open>s'=s\<close> getter_def register_apply_def register_from_getter_setter_def)
    moreover have \<open>s (g m) m = m\<close>
      by (metis assms valid_getter_setter_def)
    moreover have \<open>x = x'\<close> if \<open>s x m = m\<close> \<open>s x' m = m\<close> for x x'
      by (metis assms that(1) that(2) valid_getter_setter_def)
    ultimately show \<open>g' m = g m\<close>
      by (simp add: Uniq_def the1_equality')
  qed
qed

definition register :: \<open>('a,'b) preregister \<Rightarrow> bool\<close> where
  \<open>register F \<longleftrightarrow> (\<exists>g s. F = register_from_getter_setter g s \<and> valid_getter_setter g s)\<close>

lemma register_of_id: \<open>register F \<Longrightarrow> F Some = Some\<close>
  by (auto simp add: register_def valid_getter_setter_def register_from_getter_setter_def)

lemma register_id: \<open>register id\<close>
  unfolding register_def
  apply (rule exI[of _ id], rule exI[of _ \<open>\<lambda>a m. a\<close>])
  by (auto intro!: ext simp: option.case_eq_if register_from_getter_setter_def valid_getter_setter_def)

lemma register_tensor_left: \<open>register (\<lambda>a. tensor_update a Some)\<close>
  apply (auto simp: register_def)
  apply (rule exI[of _ fst])
  apply (rule exI[of _ \<open>\<lambda>x' (x,y). (x',y)\<close>])
  by (auto intro!: ext simp add: tensor_update_def valid_getter_setter_def register_from_getter_setter_def option.case_eq_if)

lemma register_tensor_right: \<open>register (\<lambda>a. tensor_update Some a)\<close>
  apply (auto simp: register_def)
  apply (rule exI[of _ snd])
  apply (rule exI[of _ \<open>\<lambda>y' (x,y). (x,y')\<close>])
  by (auto intro!: ext simp add: tensor_update_def valid_getter_setter_def register_from_getter_setter_def option.case_eq_if)

lemma register_preregister: "preregister F" if \<open>register F\<close>
proof -
  from \<open>register F\<close>
  obtain s g where F: \<open>F a m = (case a (g m) of None \<Rightarrow> None | Some x \<Rightarrow> Some (s x m))\<close> for a m
    unfolding register_from_getter_setter_def register_def by blast
  show ?thesis
    unfolding preregister_def
    apply (rule exI[of _ g])
    apply (rule exI[of _ \<open>\<lambda>x m. Some (s x m)\<close>])
    using F by simp
qed

lemma register_comp: "register (G \<circ> F)" if \<open>register F\<close> and \<open>register G\<close>
  for F :: "('a,'b) preregister" and G :: "('b,'c) preregister"
proof -
  from \<open>register F\<close>
  obtain sF gF where F: \<open>F a m = (case a (gF m) of None \<Rightarrow> None | Some x \<Rightarrow> Some (sF x m))\<close>
    and validF: \<open>valid_getter_setter gF sF\<close> for a m
    unfolding register_def register_from_getter_setter_def by blast
  from \<open>register G\<close>
  obtain sG gG where G: \<open>G a m = (case a (gG m) of None \<Rightarrow> None | Some x \<Rightarrow> Some (sG x m))\<close>
    and validG: \<open>valid_getter_setter gG sG\<close> for a m
    unfolding register_def register_from_getter_setter_def by blast
  define s g where \<open>s a m = sG (sF a (gG m)) m\<close> and \<open>g m = gF (gG m)\<close> for a m
  have \<open>(G \<circ> F) a m = (case a (g m) of None \<Rightarrow> None | Some x \<Rightarrow> Some (s x m))\<close> for a m
    by (auto simp add: option.case_eq_if F G s_def g_def)
  moreover have \<open>valid_getter_setter g s\<close>
    using validF validG by (auto simp: valid_getter_setter_def s_def g_def)
  ultimately show "register (G \<circ> F)"
    unfolding register_def register_from_getter_setter_def by blast
qed

lemma register_mult: "register F \<Longrightarrow> F a \<circ>\<^sub>m F b = F (a \<circ>\<^sub>m b)"
  by (auto intro!: ext simp: register_def register_from_getter_setter_def[abs_def] valid_getter_setter_def map_comp_def option.case_eq_if)

definition register_pair ::
  \<open>('a update \<Rightarrow> 'c update) \<Rightarrow> ('b update \<Rightarrow> 'c update) \<Rightarrow> (('a\<times>'b) update \<Rightarrow> 'c update)\<close> where
  \<open>register_pair F G =
    register_from_getter_setter (\<lambda>m. (getter F m, getter G m)) (\<lambda>(a,b) m. setter F a (setter G b m))\<close>

lemma compatible_setter:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes compat: \<open>\<And>a b. F a \<circ>\<^sub>m G b = G b \<circ>\<^sub>m F a\<close>
  shows \<open>setter F x o setter G y = setter G y o setter F x\<close>
  using compat apply (auto intro!: ext simp: setter_def register_apply_def o_def map_comp_def)
  by (smt (verit, best) assms(1) assms(2) option.case_eq_if option.distinct(1) register_def register_from_getter_setter_def)

lemma register_pair_apply:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes \<open>\<And>a b. F a \<circ>\<^sub>m G b = G b \<circ>\<^sub>m F a\<close>
  shows \<open>(register_pair F G) (tensor_update a b) = F a \<circ>\<^sub>m G b\<close>
proof -
  have validF: \<open>valid_getter_setter (getter F) (setter F)\<close> and validG: \<open>valid_getter_setter (getter G) (setter G)\<close>
    by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
  then have F: \<open>F = register_from_getter_setter (getter F) (setter F)\<close> and G: \<open>G = register_from_getter_setter (getter G) (setter G)\<close>
    by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
  have gFsG: \<open>getter F (setter G y m) = getter F m\<close> for y m
  proof -
    have \<open>getter F (setter G y m) = getter F (setter G y (setter F (getter F m) m))\<close>
      using validF by (metis valid_getter_setter_def)
    also have \<open>\<dots> = getter F (setter F (getter F m) (setter G y m))\<close>
      by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) comp_eq_dest_lhs compatible_setter)
    also have \<open>\<dots> = getter F m\<close>
      by (metis validF valid_getter_setter_def)
    finally show ?thesis by -
  qed

  show ?thesis
    apply (subst (2) F, subst (2) G)
    by (auto intro!:ext simp: register_pair_def tensor_update_def map_comp_def option.case_eq_if
              register_from_getter_setter_def gFsG)
qed

lemma register_pair_is_register:
  fixes F :: \<open>'a update \<Rightarrow> 'c update\<close> and G
  assumes [simp]: \<open>register F\<close> and [simp]: \<open>register G\<close>
  assumes compat: \<open>\<And>a b. F a \<circ>\<^sub>m G b = G b \<circ>\<^sub>m F a\<close>
  shows \<open>register (register_pair F G)\<close>
proof -
  have validF: \<open>valid_getter_setter (getter F) (setter F)\<close> and validG: \<open>valid_getter_setter (getter G) (setter G)\<close>
    by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
  then have \<open>valid_getter_setter (\<lambda>m. (getter F m, getter G m)) (\<lambda>(a, b) m. setter F a (setter G b m))\<close>
    apply (simp add: valid_getter_setter_def)
    by (metis (mono_tags, lifting) assms comp_eq_dest_lhs compat compatible_setter)
  then show ?thesis
    by (auto simp: register_pair_def register_def)
qed

end


(*  Title:      HOL/Hoare/Hoare_Logic.thy
    Author:     Leonor Prensa Nieto & Tobias Nipkow
    Copyright   1998 TUM

Sugared semantic embedding of Hoare logic.
Strictly speaking a shallow embedding (as implemented by Norbert Galm
following Mike Gordon) would suffice. Maybe the datatype com comes in useful
later.
*)

theory Hoare_Logic
imports Main
begin

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
  Basic "'a \<Rightarrow> 'a"
| Seq "'a com" "'a com"               ("(_;/ _)"      [61,60] 60)
| Cond "'a bexp" "'a com" "'a com"    ("(1IF _/ THEN _ / ELSE _/ FI)"  [0,0,0] 61)
| While "'a bexp" "'a assn" "'a com"  ("(1WHILE _/ INV {_} //DO _ /OD)"  [0,0,0] 61)

abbreviation annskip ("SKIP") where "SKIP == Basic id"

type_synonym 'a sem = "'a => 'a => bool"

inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) s (f s)"
| "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (c1;c2) s s'"
| "s \<in> b \<Longrightarrow> Sem c1 s s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) s s'"
| "s \<notin> b \<Longrightarrow> Sem c2 s s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) s s'"
| "s \<notin> b \<Longrightarrow> Sem (While b x c) s s"
| "s \<in> b \<Longrightarrow> Sem c s s'' \<Longrightarrow> Sem (While b x c) s'' s' \<Longrightarrow>
   Sem (While b x c) s s'"

inductive_cases [elim!]:
  "Sem (Basic f) s s'" "Sem (c1;c2) s s'"
  "Sem (IF b THEN c1 ELSE c2 FI) s s'"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "Valid p c q \<longleftrightarrow> (!s s'. Sem c s s' --> s : p --> s' : q)"

syntax
  "_assign" :: "idt => 'b => 'a com"  ("(2_ :=/ _)" [70, 65] 61)

syntax
 "_hoare_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
                 ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
syntax ("" output)
 "_hoare"      :: "['a assn,'a com,'a assn] => bool"
                 ("{_} // _ // {_}" [0,55,0] 50)

ML_file "hoare_syntax.ML"
parse_translation \<open>[(@{syntax_const "_hoare_vars"}, K Hoare_Syntax.hoare_vars_tr)]\<close>
print_translation \<open>[(@{const_syntax Valid}, K (Hoare_Syntax.spec_tr' @{syntax_const "_hoare"}))]\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
by (auto simp:Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
by (auto simp:Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
by (auto simp:Valid_def)

lemma CondRule:
 "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
  \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
by (auto simp:Valid_def)

lemma While_aux:
  assumes "Sem (WHILE b INV {i} DO c OD) s s'"
  shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
    s \<in> I \<Longrightarrow> s' \<in> I \<and> s' \<notin> b"
  using assms
  by (induct "WHILE b INV {i} DO c OD" s s') auto

lemma WhileRule:
 "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i c) q"
apply (clarsimp simp:Valid_def)
apply(drule While_aux)
  apply assumption
 apply blast
apply blast
done

lemma Compl_Collect: "-(Collect b) = {x. ~(b x)}"
  by blast

lemmas AbortRule = SkipRule  \<comment> "dummy version"
ML_file "hoare_tac.ML"

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

end


(* Title: Examples/SML_Relativization/Algebra/SML_Rings.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about rings\<close>
theory SML_Rings
  imports
    SML_Semirings
    Complex_Main
begin

subsection\<open>Rings\<close>

subsubsection\<open>Definitions and common properties\<close>

locale ring_ow =
  semiring_ow U plus times + ab_group_add_ow U plus zero minus uminus
  for U :: "'ag set" and plus zero minus uminus times
begin

sublocale semiring_0_cancel_ow ..

end

lemma ring_ow: "class.ring = ring_ow UNIV"
  unfolding class.ring_def ring_ow_def ab_group_add_ow semiring_ow
  by (simp add: conj_commute)

lemma ring_ow_UNIV_axioms: "ring_ow (UNIV::'a::ring set) (+) 0 (-) uminus (*)"
  by (fold ring_ow) (rule ring_class.ring_axioms)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma ring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      (A ===> A) ===>
      (A ===> A ===> A) ===>
      (=)
    )
    (ring_ow (Collect (Domainp A))) class.ring"
  unfolding ring_ow_def class.ring_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end

subsubsection\<open>Relativization\<close>

context ring_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ring_ow_axioms and zero.not_empty
  applying
    [
      OF
        plus_closed'
        zero_closed
        minus_closed'
        add.inverse_closed''
        times_closed'
    ]
begin

tts_lemma right_diff_distrib:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a *\<^sub>o\<^sub>w (b -\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w c"
    is Rings.ring_class.right_diff_distrib.

tts_lemma minus_mult_commute:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w b = a *\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b"
    is Rings.ring_class.minus_mult_commute.

tts_lemma left_diff_distrib:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "(a -\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c"
    is Rings.ring_class.left_diff_distrib.

tts_lemma mult_minus_right:
  assumes "a \<in> U" and "b \<in> U"
  shows "a *\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b = -\<^sub>o\<^sub>w (a *\<^sub>o\<^sub>w b)"
    is Rings.ring_class.mult_minus_right.

tts_lemma minus_mult_right:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w (a *\<^sub>o\<^sub>w b) = a *\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b"
    is Rings.ring_class.minus_mult_right.

tts_lemma minus_mult_minus:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b = a *\<^sub>o\<^sub>w b"
    is Rings.ring_class.minus_mult_minus.

tts_lemma mult_minus_left:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w b = -\<^sub>o\<^sub>w (a *\<^sub>o\<^sub>w b)"
    is Rings.ring_class.mult_minus_left.

tts_lemma minus_mult_left:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w (a *\<^sub>o\<^sub>w b) = -\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w b"
    is Rings.ring_class.minus_mult_left.

tts_lemma ring_distribs:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows
    "a *\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w c"
    "(a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c"
    "(a -\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c"
    "a *\<^sub>o\<^sub>w (b -\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w c"
    is Rings.ring_class.ring_distribs.

tts_lemma eq_add_iff2:
  assumes "a \<in> U" and "e \<in> U" and "c \<in> U" and "b \<in> U" and "d \<in> U"
  shows "(a *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w c = b *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w d) = (c = (b -\<^sub>o\<^sub>w a) *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w d)"
    is Rings.ring_class.eq_add_iff2.

tts_lemma eq_add_iff1:
  assumes "a \<in> U" and "e \<in> U" and "c \<in> U" and "b \<in> U" and "d \<in> U"
  shows "(a *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w c = b *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w d) = ((a -\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w c = d)"
    is Rings.ring_class.eq_add_iff1.

tts_lemma mult_diff_mult:
  assumes "x \<in> U" and "y \<in> U" and "a \<in> U" and "b \<in> U"
  shows "x *\<^sub>o\<^sub>w y -\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w b = x *\<^sub>o\<^sub>w (y -\<^sub>o\<^sub>w b) +\<^sub>o\<^sub>w (x -\<^sub>o\<^sub>w a) *\<^sub>o\<^sub>w b"
    is Real.mult_diff_mult.

end

end

subsection\<open>Commutative rings\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_ring_ow =
  comm_semiring_ow U plus times + ab_group_add_ow U plus zero minus uminus
  for U :: "'ag set" and plus zero minus uminus times
begin

sublocale ring_ow ..
sublocale comm_semiring_0_cancel_ow ..

end

lemma comm_ring_ow: "class.comm_ring = comm_ring_ow UNIV"
  unfolding
    class.comm_ring_def comm_ring_ow_def
    ab_group_add_ow comm_semiring_ow
  by (simp add: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_ring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      (A ===> A) ===>
      (A ===> A ===> A) ===>
      (=)
    )
    (comm_ring_ow (Collect (Domainp A))) class.comm_ring"
  unfolding comm_ring_ow_def class.comm_ring_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end

subsubsection\<open>Relativization\<close>

context comm_ring_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_ring_ow_axioms and zero.not_empty
  applying
    [
      OF
        plus_closed'
        zero_closed
        minus_closed'
        add.inverse_closed''
        times_closed'
    ]
begin

tts_lemma square_diff_square_factored:
  assumes "x \<in> U" and "y \<in> U"
  shows "x *\<^sub>o\<^sub>w x -\<^sub>o\<^sub>w y *\<^sub>o\<^sub>w y = (x +\<^sub>o\<^sub>w y) *\<^sub>o\<^sub>w (x -\<^sub>o\<^sub>w y)"
    is comm_ring_class.square_diff_square_factored.

end

end

subsection\<open>Rings with identity\<close>

subsubsection\<open>Definitions and common properties\<close>

locale ring_1_ow =
  ring_ow U plus zero minus uminus times +
  zero_neq_one_ow U one zero +
  monoid_mult_ow U one times
  for U :: "'ag set" and one times plus zero minus uminus
begin

sublocale semiring_1_cancel_ow ..

end

lemma ring_1_ow: "class.ring_1 = ring_1_ow UNIV"
  unfolding
    class.ring_1_def ring_1_ow_def monoid_mult_ow ring_ow zero_neq_one_ow
  by (force simp: conj_commute)

lemma ring_1_ow_UNIV_axioms:
  "ring_1_ow (UNIV::'a::ring_1 set) 1 (*) (+) 0 (-) uminus"
  by (fold ring_1_ow) (rule ring_1_class.ring_1_axioms)

ud \<open>ring_1.iszero\<close> (\<open>(with _ : \<guillemotleft>iszero\<guillemotright> _)\<close> [1000, 1000] 10)
ud iszero' \<open>iszero\<close>
ud \<open>ring_1.of_int\<close>
  (\<open>(with _ _ _ _ : \<guillemotleft>of'_int\<guillemotright> _)\<close> [1000, 999, 998, 997, 1000] 10)
ud of_int' \<open>of_int\<close>
ud \<open>ring_1.Ints\<close> (\<open>(with _ _ _ _ : \<int>)\<close> [1000, 999, 998, 997] 10)
ud Ints' \<open>Ints\<close>
ud \<open>diffs\<close> (\<open>(with _ _ _ _ : \<guillemotleft>diffs\<guillemotright> _)\<close> [1000, 999, 998, 997, 1000] 10)

ctr parametricity
  in iszero_ow: iszero.with_def
    and of_int_ow: of_int.with_def
    and Ints_ow: Ints.with_def
    and diffs_ow: diffs.with_def

context ring_1_ow
begin

abbreviation iszero where "iszero \<equiv> iszero.with 0\<^sub>o\<^sub>w"
abbreviation of_int where "of_int \<equiv> of_int.with 1\<^sub>o\<^sub>w (+\<^sub>o\<^sub>w) 0\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w)"
abbreviation Ints (\<open>\<guillemotleft>\<int>\<guillemotright>\<close>) where "\<guillemotleft>\<int>\<guillemotright> \<equiv> Ints.with 1\<^sub>o\<^sub>w (+\<^sub>o\<^sub>w) 0\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w)"
notation Ints (\<open>\<guillemotleft>\<int>\<guillemotright>\<close>)

end

context ring_1
begin

lemma Int_ss_UNIV: "\<int> \<subseteq> UNIV" by simp

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma ring_1_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      A ===>
      (A ===> A ===> A) ===>
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      (A ===> A) ===>
      (=)
    )
      (ring_1_ow (Collect (Domainp A))) class.ring_1"
  unfolding ring_1_ow_def class.ring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end

subsubsection\<open>Relativization\<close>

declare dvd.with[ud_with del]
declare dvd'.with[ud_with del]

context ring_1_ow
begin

tts_context
  tts: (?'a to U)
  substituting ring_1_ow_axioms and zero.not_empty
  eliminating through simp
begin

tts_lemma Int_ss_UNIV[simp]: "\<guillemotleft>\<int>\<guillemotright> \<subseteq> U"
  is Int_ss_UNIV.

end

lemma Int_closed[simp,intro]: "a \<in> \<guillemotleft>\<int>\<guillemotright> \<Longrightarrow> a \<in> U" using Int_ss_UNIV by blast

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ring_1_ow_axioms and zero.not_empty
  eliminating through auto
begin

tts_lemma iszero_0: "iszero 0\<^sub>o\<^sub>w"
  is ring_1_class.iszero_0.

tts_lemma not_iszero_1: "\<not> iszero 1\<^sub>o\<^sub>w"
  is ring_1_class.not_iszero_1.

tts_lemma Nats_subset_Ints: "\<guillemotleft>\<nat>\<guillemotright> \<subseteq> \<guillemotleft>\<int>\<guillemotright>"
  is Int.ring_1_class.Nats_subset_Ints.

tts_lemma Ints_1: "1\<^sub>o\<^sub>w \<in> \<guillemotleft>\<int>\<guillemotright>"
  is Int.ring_1_class.Ints_1.

tts_lemma Ints_0: "0\<^sub>o\<^sub>w \<in> \<guillemotleft>\<int>\<guillemotright>"
  is Int.ring_1_class.Ints_0.

tts_lemma not_iszero_neg_1: "\<not> iszero (-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w)"
  is Num.ring_1_class.not_iszero_neg_1.

tts_lemma of_int_1: "of_int 1 = 1\<^sub>o\<^sub>w"
  is Int.ring_1_class.of_int_1.

tts_lemma of_int_0: "of_int 0 = 0\<^sub>o\<^sub>w"
  is Int.ring_1_class.of_int_0.

tts_lemma Ints_of_int: "of_int z \<in> \<guillemotleft>\<int>\<guillemotright>"
  is Int.ring_1_class.Ints_of_int.

tts_lemma Ints_of_nat: "of_nat n \<in> \<guillemotleft>\<int>\<guillemotright>"
  is Int.ring_1_class.Ints_of_nat.

tts_lemma of_int_of_nat_eq:
  shows "local.of_int (with 1 (+) 0 : \<guillemotleft>of_nat\<guillemotright> n) = local.of_nat n"
    is Int.ring_1_class.of_int_of_nat_eq.

tts_lemma of_int_of_bool:
  "of_int (with 1 0 : \<guillemotleft>of_bool\<guillemotright> P) = of_bool P"
  is Int.ring_1_class.of_int_of_bool.

tts_lemma of_int_minus: "of_int (- z) = -\<^sub>o\<^sub>w of_int z"
  is Int.ring_1_class.of_int_minus.

tts_lemma mult_minus1_right:
  assumes "z \<in> U"
  shows "z *\<^sub>o\<^sub>w -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w = -\<^sub>o\<^sub>w z"
    is Num.ring_1_class.mult_minus1_right.

tts_lemma mult_minus1:
  assumes "z \<in> U"
  shows "-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w *\<^sub>o\<^sub>w z = -\<^sub>o\<^sub>w z"
    is Num.ring_1_class.mult_minus1.

tts_lemma eq_iff_iszero_diff:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x = y) = iszero (x -\<^sub>o\<^sub>w y)"
    is Num.ring_1_class.eq_iff_iszero_diff.

tts_lemma minus_in_Ints_iff:
  assumes "x \<in> U"
  shows "(-\<^sub>o\<^sub>w x \<in> \<guillemotleft>\<int>\<guillemotright>) = (x \<in> \<guillemotleft>\<int>\<guillemotright>)"
    is Int.ring_1_class.minus_in_Ints_iff.

tts_lemma mult_of_int_commute:
  assumes "y \<in> U"
  shows "of_int x *\<^sub>o\<^sub>w y = y *\<^sub>o\<^sub>w of_int x"
    is Int.ring_1_class.mult_of_int_commute.

tts_lemma of_int_power:
  "of_int ((with 1 (*) : z ^\<^sub>o\<^sub>w n)) = of_int z ^\<^sub>o\<^sub>w n"
    is Int.ring_1_class.of_int_power.

tts_lemma Ints_minus:
  assumes "a \<in> \<guillemotleft>\<int>\<guillemotright>"
  shows "-\<^sub>o\<^sub>w a \<in> \<guillemotleft>\<int>\<guillemotright>"
    is Int.ring_1_class.Ints_minus.

tts_lemma of_int_diff: "of_int (w - z) = of_int w -\<^sub>o\<^sub>w of_int z"
  is Int.ring_1_class.of_int_diff.

tts_lemma of_int_add: "of_int (w + z) = of_int w +\<^sub>o\<^sub>w of_int z"
  is Int.ring_1_class.of_int_add.

tts_lemma of_int_mult: "of_int (w * z) = of_int w *\<^sub>o\<^sub>w of_int z"
  is Int.ring_1_class.of_int_mult.

tts_lemma power_minus1_even: "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w (2 * n) = 1\<^sub>o\<^sub>w"
  is Power.ring_1_class.power_minus1_even.

tts_lemma Ints_power:
  assumes "a \<in> \<guillemotleft>\<int>\<guillemotright>"
  shows "a ^\<^sub>o\<^sub>w n \<in> \<guillemotleft>\<int>\<guillemotright>"
    is Int.ring_1_class.Ints_power.

tts_lemma of_nat_nat:
  assumes "0 \<le> z"
  shows "of_nat (nat z) = of_int z"
    is Int.ring_1_class.of_nat_nat.

tts_lemma power2_minus:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w 2 = a ^\<^sub>o\<^sub>w 2"
    is Power.ring_1_class.power2_minus.

tts_lemma power_minus1_odd:
  shows "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w Suc (2 * n) = -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w"
    is Power.ring_1_class.power_minus1_odd.

tts_lemma power_minus:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w n = (-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w a ^\<^sub>o\<^sub>w n"
    is Power.ring_1_class.power_minus.

tts_lemma square_diff_one_factored:
  assumes "x \<in> U"
  shows "x *\<^sub>o\<^sub>w x -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w = (x +\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) *\<^sub>o\<^sub>w (x -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w)"
    is Rings.ring_1_class.square_diff_one_factored.

tts_lemma neg_one_even_power:
  assumes "even n"
  shows "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n = 1\<^sub>o\<^sub>w"
    is Parity.ring_1_class.neg_one_even_power.

tts_lemma minus_one_power_iff:
  "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n = (if even n then 1\<^sub>o\<^sub>w else -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w)"
    is Parity.ring_1_class.minus_one_power_iff.

tts_lemma Nats_altdef1: "\<guillemotleft>\<nat>\<guillemotright> = {x \<in> U. \<exists>y\<ge>0. x = of_int y}"
    is Int.ring_1_class.Nats_altdef1.

tts_lemma Ints_induct:
  assumes "q \<in> \<guillemotleft>\<int>\<guillemotright>" and "\<And>z. P (of_int z)"
  shows "P q"
    is Int.ring_1_class.Ints_induct.

tts_lemma of_int_of_nat:
  shows
    "of_int k = (if k < 0 then -\<^sub>o\<^sub>w of_nat (nat (- k)) else of_nat (nat k))"
    is Int.ring_1_class.of_int_of_nat.

tts_lemma Ints_diff:
  assumes "a \<in> \<guillemotleft>\<int>\<guillemotright>" and "b \<in> \<guillemotleft>\<int>\<guillemotright>"
  shows "a -\<^sub>o\<^sub>w b \<in> \<guillemotleft>\<int>\<guillemotright>"
    is Int.ring_1_class.Ints_diff.

tts_lemma Ints_add:
  assumes "a \<in> \<guillemotleft>\<int>\<guillemotright>" and "b \<in> \<guillemotleft>\<int>\<guillemotright>"
  shows "a +\<^sub>o\<^sub>w b \<in> \<guillemotleft>\<int>\<guillemotright>"
    is Int.ring_1_class.Ints_add.

tts_lemma Ints_mult:
  assumes "a \<in> \<guillemotleft>\<int>\<guillemotright>" and "b \<in> \<guillemotleft>\<int>\<guillemotright>"
  shows "a *\<^sub>o\<^sub>w b \<in> \<guillemotleft>\<int>\<guillemotright>"
    is Int.ring_1_class.Ints_mult.

tts_lemma power_minus_even':
  assumes "a \<in> U" and "even n"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w n = a ^\<^sub>o\<^sub>w n"
    is Parity.ring_1_class.power_minus_even.

tts_lemma power_minus_even:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w (2 * n) = a ^\<^sub>o\<^sub>w (2 * n)"
    is Power.ring_1_class.power_minus_even.

tts_lemma power_minus_odd:
  assumes "a \<in> U" and "odd n"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w n = -\<^sub>o\<^sub>w (a ^\<^sub>o\<^sub>w n)"
    is Parity.ring_1_class.power_minus_odd.

tts_lemma uminus_power_if:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w n = (if even n then a ^\<^sub>o\<^sub>w n else -\<^sub>o\<^sub>w (a ^\<^sub>o\<^sub>w n))"
    is Parity.ring_1_class.uminus_power_if.

tts_lemma neg_one_power_add_eq_neg_one_power_diff:
  assumes "k \<le> n"
  shows "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w (n + k) = (-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w (n - k)"
    is Parity.ring_1_class.neg_one_power_add_eq_neg_one_power_diff.

tts_lemma neg_one_odd_power:
  assumes "odd n"
  shows "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n = -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w"
    is Parity.ring_1_class.neg_one_odd_power.

tts_lemma Ints_cases:
  assumes "q \<in> \<guillemotleft>\<int>\<guillemotright>" and "\<And>z. q = of_int z \<Longrightarrow> thesis"
  shows thesis
    is Int.ring_1_class.Ints_cases.

end

end

lemmas [ud_with] = dvd.with dvd'.with

subsection\<open>Commutative rings with identity\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_ring_1_ow =
  comm_ring_ow U plus zero minus uminus times +
  zero_neq_one_ow U one zero +
  comm_monoid_mult_ow U times one
  for U :: "'ag set" and times one plus zero minus uminus
begin

sublocale ring_1_ow ..
sublocale comm_semiring_1_cancel_ow
  by unfold_locales (blast intro: right_diff_distrib)

end

lemma comm_ring_1_ow: "class.comm_ring_1 = comm_ring_1_ow UNIV"
  unfolding
    class.comm_ring_1_def comm_ring_1_ow_def
    comm_monoid_mult_ow comm_ring_ow zero_neq_one_ow
  by (force simp: conj_commute)

lemma comm_ring_1_ow_UNIV_axioms:
  "comm_ring_1_ow (UNIV::'a::comm_ring_1 set) (*) 1 (+) 0 (-) uminus"
  by (fold comm_ring_1_ow) (rule comm_ring_1_class.comm_ring_1_axioms)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_ring_1_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      (A ===> A) ===>
      (=)
    ) (comm_ring_1_ow (Collect (Domainp A))) class.comm_ring_1"
  unfolding comm_ring_1_ow_def class.comm_ring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end

subsubsection\<open>Relativization\<close>

context comm_ring_1_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_ring_1_ow_axioms and zero.not_empty
  applying
    [
      OF
        times_closed'
        one_closed
        plus_closed'
        zero_closed
        minus_closed'
        add.inverse_closed''
    ]
begin

tts_lemma ring_normalization_rules:
  assumes "x \<in> U"
  shows "-\<^sub>o\<^sub>w x = -\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w *\<^sub>o\<^sub>w x" "y \<in> U \<Longrightarrow> x -\<^sub>o\<^sub>w y = x +\<^sub>o\<^sub>w -\<^sub>o\<^sub>w y"
    is comm_ring_1_class.ring_normalization_rules.

tts_lemma left_minus_one_mult_self:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w ((-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w a) = a"
    is Power.comm_ring_1_class.left_minus_one_mult_self.

tts_lemma minus_power_mult_self:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a) ^\<^sub>o\<^sub>w n = a ^\<^sub>o\<^sub>w (2 * n)"
    is Power.comm_ring_1_class.minus_power_mult_self.

tts_lemma minus_one_mult_self: "(-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) ^\<^sub>o\<^sub>w n = 1\<^sub>o\<^sub>w"
  is comm_ring_1_class.minus_one_mult_self.

tts_lemma power2_commute:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x -\<^sub>o\<^sub>w y) ^\<^sub>o\<^sub>w 2 = (y -\<^sub>o\<^sub>w x) ^\<^sub>o\<^sub>w 2"
    is comm_ring_1_class.power2_commute.

tts_lemma minus_dvd_iff:
  assumes "x \<in> U" and "y \<in> U"
  shows "(-\<^sub>o\<^sub>w x \<guillemotleft>dvd\<guillemotright> y) = (x \<guillemotleft>dvd\<guillemotright> y)"
    is comm_ring_1_class.minus_dvd_iff.

tts_lemma dvd_minus_iff:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x \<guillemotleft>dvd\<guillemotright> -\<^sub>o\<^sub>w y) = (x \<guillemotleft>dvd\<guillemotright> y)"
    is comm_ring_1_class.dvd_minus_iff.

tts_lemma dvd_diff:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x \<guillemotleft>dvd\<guillemotright> y" and "x \<guillemotleft>dvd\<guillemotright> z"
  shows "x \<guillemotleft>dvd\<guillemotright> y -\<^sub>o\<^sub>w z"
    is comm_ring_1_class.dvd_diff.

end

end

text\<open>\newpage\<close>

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Definitions about those Combinatorial Auctions which are strict (i.e., which assign all the available goods)\<close>

theory StrictCombinatorialAuction
imports Complex_Main
  Partitions
  MiscTools

begin

subsection \<open>Types\<close>

type_synonym index = "integer"
type_synonym participant = index
type_synonym good = "integer"
type_synonym goods = "good set"
type_synonym price = real
type_synonym bids3 = "((participant \<times> goods) \<times> price) set"
type_synonym bids = "participant \<Rightarrow> goods \<Rightarrow> price"
type_synonym allocation_rel = "(goods \<times> participant) set"
type_synonym allocation = "(participant \<times> goods) set"
type_synonym payments = "participant \<Rightarrow> price"
type_synonym bidvector = "(participant \<times> goods) \<Rightarrow> price"
abbreviation "bidvector (b::bids) == case_prod b"
abbreviation "proceeds (b::bidvector) (allo::allocation) == sum b allo"
abbreviation "winnersOfAllo (a::allocation) == Domain a"
abbreviation "allocatedGoods (allo::allocation) == \<Union> (Range allo)"

(* possible_allocations_rel defines all possible allocations of a set of goods G to a set of participants N:
  injective functions that map sets of goods to their potential buyers, i.e.\ participants.
  Here, we assume that everything gets allocated, i.e. that there is no free disposal.
  This assumption facilitates the paper\<leftrightarrow>algorithm equivalence proof for injective functions.
*)
fun possible_allocations_rel
  where "possible_allocations_rel G N = Union { injections Y N | Y . Y \<in> all_partitions G }"

(* The following abbreviations duplicate the corresponding definitions in RelationProperties.thy. This is done since typically abbreviations are efficient in theorem proving, however, not in code extraction. *)

abbreviation "is_partition_of' P A == (\<Union> P = A \<and> is_non_overlapping P)"
abbreviation "all_partitions' A == {P . is_partition_of' P A}"

abbreviation "possible_allocations_rel' G N == Union{injections Y N | Y . Y \<in> all_partitions' G}"
abbreviation allAllocations where
  "allAllocations N G == converse ` (possible_allocations_rel G N)"

text \<open>algorithmic version of @{const possible_allocations_rel}\<close>
fun possible_allocations_alg :: "goods \<Rightarrow> participant set \<Rightarrow> allocation_rel list"
  where "possible_allocations_alg G N =
         concat [ injections_alg Y N . Y \<leftarrow> all_partitions_alg G ]"

abbreviation "allAllocationsAlg N G ==
              map converse (concat [(injections_alg l N) . l \<leftarrow> all_partitions_list G])"

subsection \<open>VCG mechanism\<close>

(* N is the set of bidders, G the set of goods, and b the bidvector *)
abbreviation "winningAllocationsRel N G b ==
              argmax (sum b) (allAllocations N G)"

(* t is a tie breaking function *)
abbreviation "winningAllocationRel N G t b == t (winningAllocationsRel N G b)"

(* This is the computational version of winningAllocationsRel *)
abbreviation "winningAllocationsAlg N G b == argmaxList (proceeds b) (allAllocationsAlg N G)"

(* This is the computational version of winningAllocationRel *)
definition "winningAllocationAlg N G t b == t (winningAllocationsAlg N G b)"

text \<open>payments\<close>

text \<open>alpha is the maximum sum of bids of all bidders except bidder \<open>n\<close>'s bid, computed over all possible allocations of all goods,
  i.e. the value reportedly generated by value maximization when solved without n's bids\<close>
abbreviation "alpha N G b n == Max ((sum b)`(allAllocations (N-{n}) G))"

(* computational version of alpha *)
abbreviation "alphaAlg N G b n == Max ((proceeds b)`(set (allAllocationsAlg (N-{n}) (G::_ list))))"

(* revenue with participant n removed from winning allocation *)
abbreviation "remainingValueRel N G t b n == sum b ((winningAllocationRel N G t b) -- n)"

(* computational version of remainingValueRel *)
abbreviation "remainingValueAlg N G t b n == proceeds b ((winningAllocationAlg N G t b) -- n)"

(* function to determine payments for each participant *)
abbreviation "paymentsRel N G t == (alpha N G) - (remainingValueRel N G t)"

(* computational version of paymentsRel *)
definition "paymentsAlg N G t == (alphaAlg N G) - (remainingValueAlg N G t)"

end