section \<open>Quickstart Guide\<close>
theory Quickstart_Guide
imports "../IMP2"
begin

  subsection \<open>Introductory Examples\<close>
  text \<open>IMP2 provides commands to define program snippets or procedures together with their specification.\<close>

  procedure_spec div_ab (a,b) returns c
    assumes \<open>b\<noteq>0\<close>
    ensures \<open>c=a\<^sub>0 div b\<^sub>0\<close>
    defines \<open>c = a/b\<close>
    by vcg_cs

  text \<open>The specification consists of the signature (name, parameters, return variables),
    precondition, postcondition, and program text.\<close>

  text \<open>
    \<^descr>[Signature] The procedure name and variable names must be valid Isabelle names.
      The \<open>returns\<close> declaration is optional, by default, nothing is returned.
      Multiple values can be returned by \<open>returns (x\<^sub>1,...,x\<^sub>n)\<close>.

    \<^descr>[Precondition] An Isabelle formula. Parameter names are valid variables.
    \<^descr>[Postcondition] An Isabelle formula over the return variables, and parameter names suffixed with \<open>\<^sub>0\<close>.
    \<^descr>[Program Text] The procedure body, in a C-like syntax.
  \<close>

  text \<open>The @{command procedure_spec} command will open a proof to show that the program satisfies the specification.
    The default way of discharging this goal is by using IMP2's verification condition generator, followed by
    manual discharging of the generated VCs as necessary.

    Note that the @{method vcg_cs} method will apply @{method clarsimp} to all generated VCs, which, in our case,
    already solves them. You can use @{method vcg} to get the raw VCs.
  \<close>

  text \<open>If the VCs have been discharged, @{command procedure_spec} adds prologue and epilogue code
    for parameter passing, defines a constant for the procedure, and lifts the pre- and postcondition
    over the constant definition.
  \<close>
  thm div_ab_spec \<comment> \<open>Final theorem proved\<close>
  thm div_ab_def  \<comment> \<open>Constant definition, with parameter passing code\<close>

  text \<open>The final theorem has the form \<^term>\<open>HT_mods \<pi> vs P c Q\<close>,
    where \<open>\<pi>\<close> is an arbitrary procedure environment,
    \<open>vs\<close> is a syntactic approximation of the (global) variables modified by the procedure,
    \<open>P,Q\<close> are the pre- and postcondition, lifted over the parameter passing code,
    and \<open>c\<close> is the defined constant for the procedure.

    The precondition is a function \<^typ>\<open>state\<Rightarrow>bool\<close>. It starts with a series of variable bindings
    that map program variables to logical variables,
    followed by precondition that was specified, wrapped in a \<^const>\<open>BB_PROTECT\<close> constant,
    which serves as a tag for the VCG, and is defined as the identity (@{thm BB_PROTECT_def}).

    The final theorem is declared to the VCG, such that the specification will be
    used automatically for calls to this procedure.
  \<close>

  procedure_spec use_div_ab(a) returns r assumes \<open>a\<noteq>0\<close> ensures \<open>r=1\<close> defines \<open>r = div_ab(a,a)\<close> by vcg_cs

  subsubsection \<open>Variant and Invariant Annotations\<close>

  text \<open>Loops must be annotated with variants and invariants.\<close>
  procedure_spec mult_ab(a,b) returns c assumes \<open>True\<close> ensures "c=a\<^sub>0*b\<^sub>0"
  defines \<open>
    if (a<0) {a = -a; b = -b};
    c=0;
    while (a>0)
      @variant \<open>a\<close>
      @invariant \<open>0\<le>a \<and> a\<le>\<bar>a\<^sub>0\<bar> \<and> c = ( \<bar>a\<^sub>0\<bar> - a) * b\<^sub>0 * sgn a\<^sub>0\<close>
    {
      c=c+b;
      a=a-1
    }
  \<close>
    apply vcg_cs
     apply (auto simp: algebra_simps)
    done

  text \<open>The variant and invariant can use the program variables.
    Variables suffixed with \<open>\<^sub>0\<close> refer to the values of parameters at the start of the program.

    The variant must be an expression of type \<^typ>\<open>int\<close>, which decreases with every loop iteration and is always \<open>\<ge>0\<close>.

    \<^bold>\<open>Pitfall\<close>: If the variant has a more general type, e.g., \<^typ>\<open>'a\<close>, an explicit type annotation
      must be added. Otherwise, you'll get an ugly error message directly from Isabelle's type checker!
  \<close>

  subsubsection \<open>Recursive Procedures\<close>
  text \<open>IMP2 supports mutually recursive procedures. All procedures of a mutually recursive specification
    have to be specified and proved simultaneously.

    Each procedure has to be annotated with a variant over the parameters.
    On a recursive call, the variant of the callee for the arguments must be smaller than the
    variant of the caller (for its initial arguments).

    Recursive invocations inside the specification have to be tagged by the \<open>rec\<close> keyword.
  \<close>

  recursive_spec
    odd_imp(n) returns b assumes "n\<ge>0" ensures \<open>b\<noteq>0 \<longleftrightarrow> odd n\<^sub>0\<close> variant \<open>n\<close>
    defines \<open>if (n==0) b=0 else b=rec even_imp(n-1)\<close>
  and
    even_imp(n) returns b assumes "n\<ge>0" ensures \<open>b\<noteq>0 \<longleftrightarrow> even n\<^sub>0\<close> variant \<open>n\<close>
    defines \<open>if (n==0) b=1 else b=rec odd_imp(n-1)\<close>
    by vcg_cs

  text \<open>After proving the VCs, constants are defined as usual, and the correctness theorems
    are lifted and declared to the VCG for future use.\<close>
  thm odd_imp_spec even_imp_spec

  subsection \<open>The VCG\<close>
  text \<open>The VCG is designed to produce human-readable VCs.
    It takes care of presenting the VCs with reasonable variable names,
    and a location information from where a VC originates.
  \<close>

  procedure_spec mult_ab'(a,b) returns c assumes \<open>True\<close> ensures "c=a\<^sub>0*b\<^sub>0"
  defines \<open>
    if (a<0) {a = -a; b = -b};
    c=0;
    while (a>0)
      @variant \<open>a\<close>
      @invariant \<open>0\<le>a \<and> a\<le>\<bar>a\<^sub>0\<bar> \<and> c = ( \<bar>a\<^sub>0\<bar> - a) * b\<^sub>0 * sgn a\<^sub>0\<close>
    {
      c=c+b;
      a=a-1
    }
  \<close>
  apply vcg
  text \<open>The \<^term>\<open>\<paragraph>xxx\<close> tags in the premises give a hint to the origin of each VC.
    Moreover, the variable names are derived from the actual variable names in the program.\<close>
  by (auto simp: algebra_simps)

  (* program-spec, procedure-spec   *)

  subsection \<open>Advanced Features\<close>

  subsubsection \<open>Custom Termination Relations\<close>
  text \<open>Both for loops and recursive procedures, a custom termination relation can be specified, with the
  \<open>relation\<close> annotation. The variant must be a function into the domain of this relation.

  \<^bold>\<open>Pitfall\<close>: You have to ensure, by type annotations, that the most general type of
    the relation and variant fit together. Otherwise, ugly low-level errors will be the result.
  \<close>

  procedure_spec mult_ab''(a,b) returns c assumes \<open>True\<close> ensures "c=a\<^sub>0*b\<^sub>0"
  defines \<open>
    if (a<0) {a = -a; b = -b};
    c=0;
    while (a>0)
      @relation \<open>measure nat\<close>
      @variant \<open>a\<close>
      @invariant \<open>0\<le>a \<and> a\<le>\<bar>a\<^sub>0\<bar> \<and> c = ( \<bar>a\<^sub>0\<bar> - a) * b\<^sub>0 * sgn a\<^sub>0\<close>
    {
      c=c+b;
      a=a-1
    }
  \<close>
  by vcg_cs (auto simp: algebra_simps)

  recursive_spec relation \<open>measure nat\<close>
    odd_imp'(n) returns b assumes "n\<ge>0" ensures \<open>b\<noteq>0 \<longleftrightarrow> odd n\<^sub>0\<close> variant \<open>n\<close>
    defines \<open>if (n==0) b=0 else b=rec even_imp'(n-1)\<close>
  and
    even_imp'(n) returns b assumes "n\<ge>0" ensures \<open>b\<noteq>0 \<longleftrightarrow> even n\<^sub>0\<close> variant \<open>n\<close>
    defines \<open>if (n==0) b=1 else b=rec odd_imp'(n-1)\<close>
    by vcg_cs

  subsubsection \<open>Partial Correctness\<close>
  text \<open>IMP2 supports partial correctness proofs only for while-loops.
    Recursive procedures must always be proved totally correct\<^footnote>\<open>Adding partial correctness for recursion
      is possible, however, compared to total correctness, showing that the prove rule is sound
      requires some effort that we have not (yet) invested.\<close>\<close>

  procedure_spec (partial) nonterminating() returns a assumes True ensures \<open>a=0\<close> defines
    \<open>while (a\<noteq>0) @invariant \<open>True\<close>
      a=a-1\<close>
    by vcg_cs

  subsubsection \<open>Arrays\<close>
  text \<open>IMP2 provides one-dimensional arrays of integers, which are indexed by integers.
    Arrays do not have to be declared or allocated. By default, every index maps to zero.

    In the specifications, arrays are modeled as functions of type \<^typ>\<open>int\<Rightarrow>int\<close>.
  \<close>

  lemma array_sum_aux: "l\<^sub>0\<le>l \<Longrightarrow> {l\<^sub>0..<l + 1} = insert l {l\<^sub>0..<l}" for l\<^sub>0 l :: int by auto

  procedure_spec array_sum(a,l,h) returns s assumes "l\<le>h" ensures \<open>s = (\<Sum>i=l\<^sub>0..<h\<^sub>0. a\<^sub>0 i)\<close> defines
    \<open> s=0;
      while (l<h)
        @variant \<open>h-l\<close>
        @invariant \<open>l\<^sub>0\<le>l \<and> l\<le>h \<and> s = (\<Sum>i=l\<^sub>0..<l. a i)\<close>
      { s = s+a[l]; l=l+1 } \<close>
    apply vcg_cs
    apply (simp add: array_sum_aux)
    done

  subsection \<open>Proving Techniques\<close>

  text \<open>This section contains a small collection of techniques to tackle large proofs.\<close>

  subsubsection \<open>Auxiliary Lemmas\<close>
  text \<open>Prove auxiliary lemmas, and try to keep the actual proof of the specification small.
    As a rule of thumb: All VCs that cannot be solved by a simple @{method auto} invocation
    should go to an auxiliary lemma.

    The auxiliary lemma may either re-state the whole VC, or only prove the ``essence'' of the VC,
    such that the rest of its proof becomes automatic again.
    See the @{const array_sum} program above for an example or the latter case.

    \<^bold>\<open>Pitfall\<close> When extracting auxiliary lemmas, it is too easy to get too general types, which
      may render the lemmas unprovable. As an example, omitting the explicit type constraints
      from @{thm [source] "array_sum_aux"} will yield an unprovable statement.
  \<close>

  subsubsection \<open>Inlining\<close>
  text \<open>More complex procedure bodies can be modularized by either splitting them into
    multiple procedures, or using inlining and @{command program_spec} to explicitly prove a
    specification for a part of a program. Cf.\ the insertion sort example for the latter technique. \<close>

  subsubsection \<open>Functional Refinement\<close>
  text \<open>
    Sometimes, it makes sense to state the algorithm functionally first, and then prove that
    the implementation behaves like the functional program, and, separately, that the functional
    program is correct. Cf.\ the mergesort example.
  \<close>

  subsubsection \<open>Data Refinement\<close>
  text \<open>Moreover, it sometimes makes sense to abstract the concrete variables to abstract types,
    over which the algorithm is then specified. For example, an array \<open>a\<close> with a range \<open>l..<h\<close> can
    be understood as a list. Or an array can be used as a bitvector set.
    Cf.\ the mergesort and dedup examples. \<close>

  subsection \<open>Troubleshooting\<close>
  text \<open>We list a few common problems and their solutions here\<close>

  subsubsection \<open>Invalid Variables in Annotations\<close>
  text \<open>Undeclared variables in annotations are highlighted, however, no warning or error is produced.
  Usually, the generated VCs will not be provable. The most common mistake is to
  forget the \<open>\<^sub>0\<close> suffix when referring to parameter values in (in)variants and postconditions.\<close>

  text \<open>Note the highlighting of unused variables in the following example\<close>
  procedure_spec foo(x1,x2) returns y assumes "x1>x2+x3" ensures "y = x1\<^sub>0+x2" defines \<open>
      y=0;
    while (x1>0)
      @variant \<open>y + x3\<close>
      @invariant \<open>y>x3\<close>
      {
        x1=x2
      }
  \<close>
  oops

  text \<open>Even worse, if the most general type of an annotation becomes too general,
    as free variables have type \<^typ>\<open>'a\<close> by default, you will see an internal type error.

    Try replacing the variant or invariant with a free variable in the above example.
  \<close> (* TODO: Is there an expects-error unit-test command in Isabelle already? *)

  subsubsection \<open>Wrong Annotations\<close>
  text \<open>For total correctness, you must annotate a loop variant and invariant.
    For partial correctness, you must annotate an invariant, but \<^bold>\<open>no variant\<close>.

    When not following this rule, the VCG will get stuck in an internal state
  \<close>

  procedure_spec (partial) foo () assumes True ensures True defines \<open>
    while (n>0) @variant \<open>n\<close> @invariant \<open>True\<close>
    { n=n-1 }
  \<close>
    apply vcg
    oops

  subsubsection \<open>Calls to Undefined Procedures\<close>
  text \<open>Calling an undefined procedure usually results in a type error, as the procedure
    name gets interpreted as an Isabelle term, e.g., either it refers to an existing constant,
    or is interpreted as a free variable\<close>

  (* term \<open>\<^imp>\<open> undefined() \<close>\<close> (* Type unification failed *) *)

  subsection \<open>Missing Features\<close>
  text \<open>This is an (incomplete) list of missing features.\<close>

  subsubsection \<open>Elaborate Warnings and Errors\<close>
  text \<open>Currently, the IMP2 tools only produce minimal error and warning messages.
    Quite often, the user sees the raw error message as produced by Isabelle unfiltered,
    including all internal details of the tools.
  \<close>

  subsubsection \<open>Static Type Checking\<close>
  text \<open>We do no static type checking at all.
    In particular, we do not check, nor does our semantic enforce, that procedures are called
    with the same number of arguments as they were declared.
    Programs that violate this convention may even have provable properties, as argument
    and parameter passing is modeled as macros on top of the semantics, and the semantics has no
    notion of failure.
  \<close>

  subsubsection \<open>Structure Types\<close>
  text \<open>Every variable is an integer arrays. Plain integer variables are implemented as
    macros on top of this, by referring to index \<open>0\<close>.

    The most urgent addition to increase usability would be record types.
    With them, we could model encapsulation and data refinement more explicitly, by
    collecting all parts of a data structure in a single (record-typed) variable.

    An easy way of adding record types would follow a similar route as arrays,
    modeling values of variables as a recursive tree-structured datatype.

    @{theory_text [display] \<open>datatype val = PRIM int | STRUCT "fname \<Rightarrow> val" | ARRAY "int \<Rightarrow> val"\<close>}

    However, for modeling the semantics, we most likely want to introduce an explicit error state,
    to distinguish type errors (e.g. accessing a record field of an integer value) from nontermination.
    \<close>

  subsubsection \<open>Function Calls as Expressions\<close>
  text \<open>Currently, function calls are modeled as statements, and thus, cannot be nested into
    expressions. Doing so would require to simultaneously specify the semantics of
    commands and expressions, which makes things more complex.

    As the language is intended to be simple, we have not done this.
  \<close>

  subsubsection \<open>Ghost Variables\<close>
  text \<open>Ghost variables are a valuable tool for expressing (data) refinement,
    and hinting the VCG towards the abstract algorithm structure.

    We believe that we can add ghost variables with annotations on top of the VCG,
    without actually changing the program semantics.
  \<close>

  subsubsection \<open>Concurrency\<close>
  text \<open>IMP2 is a single threaded language.
    We have no current plans to add concurrency, as this would greatly complicate both the
    semantics and the VCG, which is contrary to the goal of a simple language for educational
    purposes.
  \<close>

  subsubsection \<open>Pointers and Memory\<close>
  text \<open>Adding pointers and memory allocation to IMP2 is theoretically possible, but, again,
    this would complicate the semantics and the VCG.

    However, as the author has some experience in VCGs using separation logic, he might actually
    add pointers and memory allocation to IMP2 in the near future.
  \<close>

end


theory LRE_Beh_16012023_034057
imports "Z_Machines.Z_Machine"
begin

subsection \<open> Introduction \<close>

text \<open> This theory file is to model the LRE_Beh state machine in Z Machine notations.\<close>

notation undefined ("???")

subsection \<open> type definition \<close>

datatype ('s, 'e) tag =
  State (ofState: 's) | Event (ofEvent: 'e)

abbreviation "is_Event x \<equiv> \<not> is_State x"

type_synonym ('s, 'e) rctrace = "('s, 'e) tag list"

definition wf_rcstore :: "('s, 'e) rctrace \<Rightarrow> 's \<Rightarrow> 's option \<Rightarrow> bool" where
[z_defs]: "wf_rcstore tr st final = (
     length(tr) > 0
   \<and> tr ! ((length tr) -1) = State st
   \<and> (final \<noteq> None \<longrightarrow> (\<forall>i<length tr. tr ! i = State (the final) \<longrightarrow> i= (length tr) -1))
   \<and> (filter is_State tr) ! (length (filter is_State tr) -1) = State  st)"

enumtype St = OCM | MOM | HCM | CAM | initial
definition [z_defs]: "St = {OCM, MOM, HCM, CAM, initial}"

enumtype Evt = endTask | reqOCM | reqMOM | reqVel | advVel | position
definition "Evt = {endTask, reqOCM, reqMOM, reqVel, advVel, position}"

consts StaticObsDist :: "integer"
consts MinSafeDist :: "integer"
consts HCMVel :: "integer"
consts MOMVel :: "integer"
consts Obsts :: "(integer\<times>integer) list"
consts ReqV :: "(integer\<times>integer) set"

text \<open> function definition \<close>

consts maneuv :: " (integer\<times>integer) \<Rightarrow> (integer\<times>integer)"
consts setVel :: " (integer\<times>integer) \<times> integer \<Rightarrow>(integer\<times>integer)"
consts dist :: " (integer\<times>integer) \<times> (integer\<times>integer) list \<Rightarrow>integer"
consts CDA :: " (integer\<times>integer) \<times> (integer\<times>integer) list \<times> (integer\<times>integer) \<Rightarrow>integer"
consts inOPEZ :: " (integer\<times>integer) \<Rightarrow> bool"

subsection \<open> State Space \<close>

zstore LRE_Beh =
  pos :: "(integer\<times>integer)"
  vel :: "(integer\<times>integer)"
  reqV :: "(integer\<times>integer)"

  st::"St"
  tr :: "(St, Evt) tag list"
  triggers:: "Evt set"
  where inv:
    "wf_rcstore tr st (Some final)"

subsection \<open> Operations \<close>

zoperation InitialToOCM =
  over LRE_Beh
  pre "st= initial"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation OCMToMOM =
  over LRE_Beh
  pre "st= OCM \<and> ((vel.1 * vel.1) + (vel.2 * vel.2))\<le>(3 * 3) \<and> dist(pos, Obsts)>10 \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= MOM
          ,vel\<Zprime> =setVel(vel, MOMVel)
         ,tr\<Zprime> =tr @ [Event reqMOM]@ [Event advVel] @ [State MOM]
         ,triggers\<Zprime> = {endTask, reqOCM}
         ]"

zoperation MOMToOCM =
  over LRE_Beh
  pre "st= MOM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation HCMToOCM =
  over LRE_Beh
  pre "st= HCM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation MOMToHCM =
  over LRE_Beh
  pre "st= MOM \<and> ((vel.1 * vel.1) + (vel.2 * vel.2))>(3 * 3) \<and> dist(pos, Obsts)\<le>StaticObsDist \<and> CDA(pos, Obsts, vel)>MinSafeDist \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= HCM
          ,vel\<Zprime> =setVel(vel, HCMVel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State HCM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToOCM_1 =
  over LRE_Beh
  pre "st= MOM \<and> inOPEZ(pos) \<and> (CDA(pos, Obsts, vel)>MinSafeDist \<or> dist(pos, Obsts)>StaticObsDist)"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation HCMToOCM_1 =
  over LRE_Beh
  pre "st= HCM \<and> inOPEZ(pos) \<and> (CDA(pos, Obsts, vel)>MinSafeDist \<or> dist(pos, Obsts)>StaticObsDist)"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation HCMToMOM =
  over LRE_Beh
  pre "st= HCM \<and> dist(pos, Obsts)>StaticObsDist \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= MOM
          ,vel\<Zprime> =setVel(vel, MOMVel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State MOM]
         ,triggers\<Zprime> = {endTask, reqOCM}
         ]"

zoperation OCMToOCM =
  over LRE_Beh
  params reqV_input \<in> "ReqV"
  pre "st= OCM"
  update "[st\<Zprime>= OCM
         ,reqV\<Zprime> =reqV_input
         ,vel\<Zprime> = reqV_input
         ,tr\<Zprime> =tr @ [Event reqVel]@ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation MOMToOCM_2 =
  over LRE_Beh
  pre "st= MOM"
  update "[st\<Zprime>= OCM
         ,vel\<Zprime> = (0, 0)
         ,tr\<Zprime> =tr @ [Event endTask]@ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation HCMToCAM =
  over LRE_Beh
  pre "st= HCM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToCAM =
  over LRE_Beh
  pre "st= MOM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation CAMToOCM =
  over LRE_Beh
  pre "st= CAM \<and> CDA(pos, Obsts, vel)>MinSafeDist"
  update "[st\<Zprime>= OCM
         ,vel\<Zprime> = (0, 0)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation CAMToOCM_1 =
  over LRE_Beh
  pre "st= CAM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqVel, reqMOM}
         ]"

zoperation CAMToCAM =
  over LRE_Beh
  pre "st= CAM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToCAM_1 =
  over LRE_Beh
  pre "st= MOM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation HCMToCAM_1 =
  over LRE_Beh
  pre "st= HCM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation CAMToCAM_1 =
  over LRE_Beh
  pre "st= CAM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

definition Init :: "LRE_Beh subst" where
  [z_defs]:
  "Init =
  [st\<leadsto> ,
   tr\<leadsto> ,
   triggers\<leadsto> ,
   ]"
(*To be filled in by user*)

zmachine LRE_BehMachine =
  init Init
  invariant LRE_Beh_inv
  operations  InitialToOCM OCMToMOM MOMToOCM HCMToOCM MOMToHCM MOMToOCM_1 HCMToOCM_1 HCMToMOM OCMToOCM MOMToOCM_2 HCMToCAM MOMToCAM CAMToOCM CAMToOCM_1 CAMToCAM MOMToCAM_1 HCMToCAM_1 CAMToCAM_1

subsection \<open> Structural Invariants \<close>

lemma Init_inv [hoare_lemmas]: "Init establishes LRE_Beh_inv"
  by zpog_full

lemma InitialToOCM_inv [hoare_lemmas]: "InitialToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma OCMToMOM_inv [hoare_lemmas]: "OCMToMOM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_inv [hoare_lemmas]: "MOMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToOCM_inv [hoare_lemmas]: "HCMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToHCM_inv [hoare_lemmas]: "MOMToHCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_1_inv [hoare_lemmas]: "MOMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToOCM_1_inv [hoare_lemmas]: "HCMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToMOM_inv [hoare_lemmas]: "HCMToMOM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma OCMToOCM_inv [hoare_lemmas]: "OCMToOCM (reqV) preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_2_inv [hoare_lemmas]: "MOMToOCM_2() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToCAM_inv [hoare_lemmas]: "HCMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToCAM_inv [hoare_lemmas]: "MOMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToOCM_inv [hoare_lemmas]: "CAMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToOCM_1_inv [hoare_lemmas]: "CAMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToCAM_inv [hoare_lemmas]: "CAMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToCAM_1_inv [hoare_lemmas]: "MOMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToCAM_1_inv [hoare_lemmas]: "HCMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToCAM_1_inv [hoare_lemmas]: "CAMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

subsection \<open> Safety Requirements \<close>

zexpr R1 is ""

lemma  "Init establishes R1"
  by zpog_full

lemma "InitialToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "OCMToMOM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToHCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToMOM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "OCMToOCM (reqV) preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM_2() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

definition [z_defs]: "LRE_Beh_axioms = ()"

lemma LRE_Beh_deadlock_free: "LRE_Beh_axioms  \<Longrightarrow> deadlock_free LRE_BehMachine"
  unfolding LRE_BehMachine_def
  by deadlock_free
end


section \<open>Matrices\<close>
theory IICF_Matrix
imports "../../Sepref"
begin
  subsection \<open>Relator and Interface\<close>
  definition [to_relAPP]: "mtx_rel A \<equiv> nat_rel \<times>\<^sub>r nat_rel \<rightarrow> A"

  lemma mtx_rel_id[simp]: "\<langle>Id\<rangle>mtx_rel = Id" unfolding mtx_rel_def by auto

  type_synonym 'a mtx = "nat\<times>nat \<Rightarrow> 'a"
  sepref_decl_intf 'a i_mtx is "nat\<times>nat \<Rightarrow> 'a"

  definition op_mtx_new :: "'a mtx \<Rightarrow> 'a mtx" where [simp]: "op_mtx_new c \<equiv> c"

  sepref_decl_op (no_def) mtx_new: "op_mtx_new" :: "(nat_rel\<times>\<^sub>rnat_rel \<rightarrow> A) \<rightarrow> \<langle>A\<rangle>mtx_rel"
    apply (rule fref_ncI) unfolding op_mtx_new_def[abs_def] mtx_rel_def
    by parametricity

  (* TODO: Ad-hoc rule *)
  lemma mtx_init_adhoc_frame_match_rule[sepref_frame_match_rules]:
    "hn_val (nat_rel\<times>\<^sub>rnat_rel \<rightarrow> A) x y \<turnstile> hn_val (nat_rel\<times>\<^sub>rnat_rel \<rightarrow> the_pure (pure A)) x y"
    by simp

  definition op_mtx_copy :: "'a mtx \<Rightarrow> 'a mtx" where [simp]: "op_mtx_copy c \<equiv> c"

  sepref_decl_op (no_def) mtx_copy: "op_mtx_copy" :: "\<langle>A\<rangle>mtx_rel \<rightarrow> \<langle>A\<rangle>mtx_rel" .

  sepref_decl_op mtx_get: "\<lambda>(c::'a mtx) ij. c ij" :: "\<langle>A\<rangle>mtx_rel \<rightarrow> (nat_rel\<times>\<^sub>rnat_rel) \<rightarrow> A"
    apply (rule fref_ncI) unfolding mtx_rel_def
    by parametricity

  sepref_decl_op mtx_set: "fun_upd::'a mtx \<Rightarrow> _" :: "\<langle>A\<rangle>mtx_rel \<rightarrow> (nat_rel\<times>\<^sub>rnat_rel) \<rightarrow> A \<rightarrow> \<langle>A\<rangle>mtx_rel"
    apply (rule fref_ncI)
    unfolding mtx_rel_def
  proof goal_cases case 1
    have [param]: "((=), (=)) \<in> nat_rel \<times>\<^sub>r nat_rel \<rightarrow> nat_rel \<times>\<^sub>r nat_rel \<rightarrow> bool_rel" by simp
    show ?case by parametricity
  qed

  definition mtx_nonzero :: "_ mtx \<Rightarrow> (nat\<times>nat) set" where "mtx_nonzero m \<equiv> {(i,j). m (i,j)\<noteq>0}"

  sepref_decl_op mtx_nonzero: "mtx_nonzero" :: "\<langle>A\<rangle>mtx_rel \<rightarrow> \<langle>nat_rel\<times>\<^sub>rnat_rel\<rangle>set_rel"
    where "IS_ID (A::(_\<times>(_::zero)) set)"
  proof goal_cases
    case 1
    assume "IS_ID A"
    hence U: "A=Id" by (simp only: IS_ID_def)
    have [param]: "((=),(=))\<in>A\<rightarrow>A\<rightarrow>bool_rel" using U by simp
    show ?case
      apply (rule fref_ncI)
      unfolding mtx_rel_def
      apply parametricity
      unfolding U by simp_all
  qed

  subsection \<open>Patterns\<close>
  lemma pat_amtx_get: "c$e\<equiv>op_mtx_get$'c$'e" by simp
  lemma pat_amtx_set: "fun_upd$c$e$v\<equiv>op_mtx_set$'c$'e$'v" by simp

  lemmas amtx_pats[pat_rules] = pat_amtx_get pat_amtx_set

  subsection \<open>Pointwise Operations\<close>
  subsubsection \<open>Auxiliary Definitions and Lemmas\<close>
  locale pointwise_op =
    fixes f :: "'p \<Rightarrow> 's \<Rightarrow> 's"
    fixes q :: "'s \<Rightarrow> 'p \<Rightarrow> 'a"
    assumes upd_indep1[simp, intro]: "p\<noteq>p' \<Longrightarrow> q (f p s) p' = q s p'"
    assumes upd_indep2[simp, intro]: "p\<noteq>p' \<Longrightarrow> q (f p (f p' s)) p = q (f p s) p"
  begin
    lemma pointwise_upd_fold: "distinct ps \<Longrightarrow>
      q (fold f ps s) p = (if p\<in>set ps then q (f p s) p else q s p)"
      by (induction ps arbitrary: s) auto

  end

  lemma pointwise_fun_fold:
    fixes f :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
    fixes s :: "'a \<Rightarrow> 'b"
    assumes indep1: "\<And>x x' s. x \<noteq> x' \<Longrightarrow> f x s x' = s x'"
    assumes indep2:  "\<And>x x' s. x \<noteq> x' \<Longrightarrow> f x (f x' s) x = f x s x"
    assumes [simp]: "distinct xs"
    shows "fold f xs s x = (if x \<in> set xs then f x s x else s x)"
  proof -
    interpret pointwise_op f "\<lambda>s. s"
      by unfold_locales fact+

    show ?thesis
      using pointwise_upd_fold[of xs s x]
      by auto
  qed

  lemma list_prod_divmod_eq: "List.product [0..<M] [0..<N] = map (\<lambda>i. (i div N, i mod N)) [0..<N*M]"
  proof -
    have [simp]: "i < m*n \<Longrightarrow> (i::nat) div n < m" for i m n
      by (metis mult.commute div_eq_0_iff div_mult2_eq gr_implies_not_zero mult_not_zero)

    have [simp]: "i<N*M \<Longrightarrow> N>0 \<and> M>0" for i
      by (cases N; cases M; auto)

    show ?thesis
      by (rule nth_equalityI) (auto simp add: product_nth algebra_simps)
  qed

  lemma nfoldli_prod_divmod_conv:
    "nfoldli (List.product [0..<N] [0..<M]) ctd (\<lambda>(i,j). f i j) = nfoldli [0..<N*M] ctd (\<lambda>i. f (i div M) (i mod M))"
    apply (intro ext)
    apply (subst list_prod_divmod_eq)
    apply (simp add: nfoldli_map)
    apply (fo_rule cong)+
    apply (auto simp: algebra_simps)
    done

  lemma nfoldli_prod_divmod_conv':
    "nfoldli [0..<M] ctd (\<lambda>i. nfoldli [0..<N] ctd (f i)) = nfoldli [0..<N*M] ctd (\<lambda>i. f (i div N) (i mod N))"
    apply (intro ext)
    apply (subst nfoldli_nfoldli_prod_conv)
    by (simp add: nfoldli_prod_divmod_conv algebra_simps)

  lemma foldli_prod_divmod_conv':
    "foldli [0..<M] ctd (\<lambda>i. foldli [0..<N] ctd (f i)) = foldli [0..<N*M] ctd (\<lambda>i. f (i div N) (i mod N))"
    (is "?lhs=?rhs")
  proof -
    have "RETURN (?lhs s) = RETURN (?rhs s)" for s
      apply (subst foldli_eq_nfoldli)+
      apply (subst nfoldli_prod_divmod_conv')
      ..
    thus ?thesis by auto
  qed

  lemma fold_prod_divmod_conv': "fold (\<lambda>i. fold (f i) [0..<N]) [0..<M] = fold (\<lambda>i. f (i div N) (i mod N)) [0..<N*M]"
    using foldli_prod_divmod_conv'[of M "\<lambda>_. True" N f, THEN fun_cong]
    apply (intro ext)
    apply (simp add: foldli_foldl foldl_conv_fold)
    done

  lemma mtx_nonzero_cases[consumes 0, case_names nonzero zero]:
    obtains "(i,j)\<in>mtx_nonzero m" | "m (i,j) = 0"
    by (auto simp: mtx_nonzero_def)

  subsubsection \<open>Unary Pointwise\<close>
  definition mtx_pointwise_unop :: "(nat\<times>nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a mtx \<Rightarrow> 'a mtx" where
    "mtx_pointwise_unop f m \<equiv> \<lambda>(i,j). f (i,j) (m(i,j))"

  context fixes f :: "nat\<times>nat \<Rightarrow> 'a \<Rightarrow> 'a" begin
    sepref_register "PR_CONST (mtx_pointwise_unop f)" :: "'a i_mtx \<Rightarrow> 'a i_mtx"

  subsubsection \<open>Binary Pointwise\<close>
  definition mtx_pointwise_binop :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a mtx \<Rightarrow> 'a mtx \<Rightarrow> 'a mtx" where
    "mtx_pointwise_binop f m n \<equiv> \<lambda>(i,j). f (m(i,j)) (n(i,j))"
  context fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" begin
    sepref_register "PR_CONST (mtx_pointwise_binop f)" :: "'a i_mtx \<Rightarrow> 'a i_mtx \<Rightarrow> 'a i_mtx"
    lemma [def_pat_rules]: "mtx_pointwise_binop$f \<equiv> UNPROTECT (mtx_pointwise_binop f)" by simp
  end

  locale mtx_pointwise_binop_loc =
    fixes N :: nat and M :: nat
    fixes f :: "'a::{zero} \<Rightarrow> 'a \<Rightarrow> 'a"
    assumes pres_zero[simp]: "f 0 0 = 0"
  begin
    definition "opr_fold_impl m n \<equiv> fold (\<lambda>i. fold (\<lambda>j m. m( (i,j) := f (m(i,j)) (n(i,j)) )) [0..<M]) [0..<N] m"

    lemma opr_fold_impl_eq:
      assumes "mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}"
      assumes "mtx_nonzero n \<subseteq> {0..<N}\<times>{0..<M}"
      shows "mtx_pointwise_binop f m n = opr_fold_impl m n"
      apply (rule ext)
      unfolding opr_fold_impl_def
      apply (simp add: fold_fold_prod_conv)
      apply (subst pointwise_fun_fold)
      apply (auto simp: mtx_pointwise_binop_def distinct_product) [3]
      apply clarsimp
      subgoal for a b
        apply (cases a b m rule: mtx_nonzero_cases; cases a b n rule: mtx_nonzero_cases)
        using assms
        apply (auto simp: mtx_pointwise_binop_def)
        done
      done

    lemma opr_fold_impl_refine: "(uncurry opr_fold_impl, uncurry (mtx_pointwise_binop f)) \<in> [\<lambda>(m,n). mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M} \<and> mtx_nonzero n \<subseteq> {0..<N}\<times>{0..<M}]\<^sub>f Id\<times>\<^sub>rId \<rightarrow> Id"
      apply (rule frefI)
      using opr_fold_impl_eq
      by auto

  end

  locale mtx_pointwise_binop_gen_impl = mtx_pointwise_binop_loc +
    fixes assn :: "'a mtx \<Rightarrow> 'i \<Rightarrow> assn"
    fixes A :: "'a \<Rightarrow> 'ai \<Rightarrow> assn"
    fixes get_impl :: "'i \<Rightarrow> nat\<times>nat \<Rightarrow> 'ai Heap"
    fixes set_impl :: "'i \<Rightarrow> nat\<times>nat \<Rightarrow> 'ai \<Rightarrow> 'i Heap"
    fixes fi :: "'ai \<Rightarrow> 'ai \<Rightarrow> 'ai Heap"
    assumes assn_range: "rdomp assn m \<Longrightarrow> mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}"
    assumes get_impl_hnr:
      "(uncurry get_impl,uncurry (RETURN oo op_mtx_get)) \<in> assn\<^sup>k *\<^sub>a (prod_assn (nbn_assn N) (nbn_assn M))\<^sup>k \<rightarrow>\<^sub>a A"
    assumes set_impl_hnr:
      "(uncurry2 set_impl,uncurry2 (RETURN ooo op_mtx_set)) \<in> assn\<^sup>d *\<^sub>a (prod_assn (nbn_assn N) (nbn_assn M))\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a assn"
    assumes fi_hnr:
      "(uncurry fi,uncurry (RETURN oo f)) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a A"
  begin

    lemma this_loc: "mtx_pointwise_binop_gen_impl N M f assn A get_impl set_impl fi"
      by unfold_locales

    context
      notes [[sepref_register_adhoc f N M]]
      notes [intf_of_assn] = intf_of_assnI[where R=assn and 'a="'a i_mtx"]
      notes [sepref_import_param] = IdI[of N] IdI[of M]
      notes [sepref_fr_rules] = get_impl_hnr set_impl_hnr fi_hnr
    begin
      sepref_thm opr_fold_impl1 is "uncurry (RETURN oo opr_fold_impl)" :: "assn\<^sup>d*\<^sub>aassn\<^sup>k \<rightarrow>\<^sub>a assn"
        unfolding opr_fold_impl_def[abs_def]
        by sepref

    end

    concrete_definition (in -) mtx_pointwise_binop_fold_impl1
      uses mtx_pointwise_binop_gen_impl.opr_fold_impl1.refine_raw is "(uncurry ?f,_)\<in>_"
    prepare_code_thms (in -) mtx_pointwise_binop_fold_impl1_def

    lemma op_hnr[sepref_fr_rules]: "(uncurry (mtx_pointwise_binop_fold_impl1 N M get_impl set_impl fi), uncurry (RETURN oo PR_CONST (mtx_pointwise_binop f))) \<in> assn\<^sup>d *\<^sub>a assn\<^sup>k \<rightarrow>\<^sub>a assn"
      unfolding PR_CONST_def
      apply (rule hfref_weaken_pre'[OF _ mtx_pointwise_binop_fold_impl1.refine[OF this_loc,FCOMP opr_fold_impl_refine]])
      apply (auto dest: assn_range)
      done

  end

  subsubsection \<open>Compare Pointwise\<close>
  definition mtx_pointwise_cmpop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a mtx \<Rightarrow> 'a mtx \<Rightarrow> bool" where
    "mtx_pointwise_cmpop f g m n \<equiv> (\<forall>i j. f (m(i,j)) (n(i,j))) \<and> (\<exists>i j. g (m(i,j)) (n(i,j)))"
  context fixes f g :: "'a \<Rightarrow> 'a \<Rightarrow> bool" begin
    sepref_register "PR_CONST (mtx_pointwise_cmpop f g)" :: "'a i_mtx \<Rightarrow> 'a i_mtx \<Rightarrow> bool"
    lemma [def_pat_rules]: "mtx_pointwise_cmpop$f$g \<equiv> UNPROTECT (mtx_pointwise_cmpop f g)" by simp
  end

  (* TODO: Move *)
  lemma mtx_nonzeroD:
    "\<lbrakk>\<not>i<N; mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}\<rbrakk> \<Longrightarrow> m(i,j) = 0"
    "\<lbrakk>\<not>j<M; mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}\<rbrakk> \<Longrightarrow> m(i,j) = 0"
    by (auto simp: mtx_nonzero_def)

  locale mtx_pointwise_cmpop_loc =
    fixes N :: nat and M :: nat
    fixes f g :: "'a::{zero} \<Rightarrow> 'a \<Rightarrow> bool"
    assumes pres_zero[simp]: "f 0 0 = True" "g 0 0 = False"
  begin
    definition "opr_fold_impl m n \<equiv> do {
      s \<leftarrow> nfoldli (List.product [0..<N] [0..<M]) (\<lambda>s. s\<noteq>2) (\<lambda>(i,j) s. do {
        if f (m(i,j)) (n(i,j)) then
          if s=0 then
            if g (m(i,j)) (n(i,j)) then RETURN 1 else RETURN s
          else
            RETURN s

        else RETURN 2
      }) (0::nat);
      RETURN (s=1)
    }"

    lemma opr_fold_impl_eq:
      assumes "mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}"
      assumes "mtx_nonzero n \<subseteq> {0..<N}\<times>{0..<M}"
      shows "opr_fold_impl m n \<le> RETURN (mtx_pointwise_cmpop f g m n)"
    proof -
      have "(\<forall>i<N. \<forall>j<M. f (m (i, j)) (n (i, j))) \<Longrightarrow> f (m (i, j)) (n (i, j))" for i j
        apply (cases "i<N"; cases "j<M")
        using assms by (auto simp: mtx_nonzeroD)
      moreover have "g (m (i, j)) (n (i, j)) \<Longrightarrow> (\<exists>i<N. \<exists>j<M. g (m (i, j)) (n (i, j)))" for i j
        apply (cases "i<N"; cases "j<M")
        using assms by (auto simp: mtx_nonzeroD)
      ultimately have EQ: "mtx_pointwise_cmpop f g m n
        \<longleftrightarrow> (\<forall>i<N. \<forall>j<M. f (m(i,j)) (n(i,j))) \<and> (\<exists>i<N. \<exists>j<M. g (m(i,j)) (n(i,j)))"
        unfolding mtx_pointwise_cmpop_def by meson

      have aux: "List.product [0..<N] [0..<M] = l1 @ (i, j) # l2 \<Longrightarrow> i<N \<and> j<M" for l1 i j l2
      proof -
        assume "List.product [0..<N] [0..<M] = l1 @ (i, j) # l2"
        hence "(i,j)\<in>set (List.product [0..<N] [0..<M])" by simp
        thus ?thesis by simp
      qed

      show ?thesis
        unfolding opr_fold_impl_def
        apply (refine_vcg
          nfoldli_rule[where I="\<lambda>l1 _ s.
              if s=2 then \<exists>i<N. \<exists>j<M. \<not>f (m(i,j)) (n(i,j))
              else (
                (s=0 \<or> s=1) \<and>
                (\<forall>(i,j)\<in>set l1. f (m(i,j)) (n(i,j))) \<and>
                (s=1 \<longleftrightarrow> (\<exists>(i,j)\<in>set l1. g (m(i,j)) (n(i,j))))
              )"]
          )
        apply (vc_solve dest: aux solve: asm_rl simp: EQ) [6]
        apply (fastforce simp: EQ)
        done
    qed

    lemma opr_fold_impl_refine:
      "(uncurry opr_fold_impl, uncurry (RETURN oo mtx_pointwise_cmpop f g)) \<in> [\<lambda>(m,n). mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M} \<and> mtx_nonzero n \<subseteq> {0..<N}\<times>{0..<M}]\<^sub>f Id\<times>\<^sub>rId \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
      apply (rule frefI)
      using opr_fold_impl_eq
      by (auto intro: nres_relI)

  end

  locale mtx_pointwise_cmpop_gen_impl = mtx_pointwise_cmpop_loc +
    fixes assn :: "'a mtx \<Rightarrow> 'i \<Rightarrow> assn"
    fixes A :: "'a \<Rightarrow> 'ai \<Rightarrow> assn"
    fixes get_impl :: "'i \<Rightarrow> nat\<times>nat \<Rightarrow> 'ai Heap"
    fixes fi :: "'ai \<Rightarrow> 'ai \<Rightarrow> bool Heap"
    fixes gi :: "'ai \<Rightarrow> 'ai \<Rightarrow> bool Heap"
    assumes assn_range: "rdomp assn m \<Longrightarrow> mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}"
    assumes get_impl_hnr:
      "(uncurry get_impl,uncurry (RETURN oo op_mtx_get)) \<in> assn\<^sup>k *\<^sub>a (prod_assn (nbn_assn N) (nbn_assn M))\<^sup>k \<rightarrow>\<^sub>a A"
    assumes fi_hnr:
      "(uncurry fi,uncurry (RETURN oo f)) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    assumes gi_hnr:
      "(uncurry gi,uncurry (RETURN oo g)) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  begin

    lemma this_loc: "mtx_pointwise_cmpop_gen_impl N M f g assn A get_impl fi gi"
      by unfold_locales

    context
      notes [[sepref_register_adhoc f g N M]]
      notes [intf_of_assn] = intf_of_assnI[where R=assn and 'a="'a i_mtx"]
      notes [sepref_import_param] = IdI[of N] IdI[of M]
      notes [sepref_fr_rules] = get_impl_hnr fi_hnr gi_hnr
    begin
      sepref_thm opr_fold_impl1 is "uncurry opr_fold_impl" :: "assn\<^sup>d*\<^sub>aassn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
        unfolding opr_fold_impl_def[abs_def] nfoldli_nfoldli_prod_conv[symmetric]
        by sepref

    end

    concrete_definition (in -) mtx_pointwise_cmpop_fold_impl1
      uses mtx_pointwise_cmpop_gen_impl.opr_fold_impl1.refine_raw is "(uncurry ?f,_)\<in>_"
    prepare_code_thms (in -) mtx_pointwise_cmpop_fold_impl1_def

    lemma op_hnr[sepref_fr_rules]: "(uncurry (mtx_pointwise_cmpop_fold_impl1 N M get_impl fi gi), uncurry (RETURN oo PR_CONST (mtx_pointwise_cmpop f g))) \<in> assn\<^sup>d *\<^sub>a assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
      unfolding PR_CONST_def
      apply (rule hfref_weaken_pre'[OF _ mtx_pointwise_cmpop_fold_impl1.refine[OF this_loc,FCOMP opr_fold_impl_refine]])
      apply (auto dest: assn_range)
      done

  end

end


(*  Title:       Implementing accessibility using the collection framework
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> Accessibility computations using the collection framework \<close>

theory Accessible_Impl
imports Main Accessible
        "Collections/ICF/Collections"
begin

definition (in StdSet) accessible_abort_impl where
  "accessible_abort_impl exit succ_list rs wl =
   WORKLISTT
    (\<lambda>s. \<not> (fst s))
    (\<lambda>s e.
       if (memb e (snd s)) then
         (RETURN (s, []))
       else
         RETURN ((exit e, ins e (snd s)), succ_list e)
     ) ((False, rs), wl)"

lemma (in StdSet) accessible_abort_impl_correct :
assumes succ_list_OK: "\<And>q. set (succ_list q) = {q'. (q,q') \<in> R}"
    and invar_rs: "invar rs"
shows "accessible_abort_impl exit succ_list rs wl \<le>
         \<Down>(WORKLISTIT_refine_rel (build_rel (\<lambda>s. (fst s, \<alpha> (snd s))) (\<lambda>s. invar (snd s))) Id)
       (accessible_worklist exit R (\<alpha> rs) wl)"
unfolding accessible_abort_impl_def accessible_worklist_def WORKLISTT_def
apply (rule WORKLISTIT_refine)
apply (simp only: br_sv)
apply (simp_all add: invar_rs list_all2_refl in_br_conv)
apply (auto simp add: correct invar_rs succ_list_OK pw_le_iff
                      refine_pw_simps list_all2_eq[symmetric]
                      refine_hsimp in_br_conv)
done

definition (in StdSet) accessible_abort_code where
  "accessible_abort_code exit succ_list rs wl =
   worklist (\<lambda>s. \<not> fst s)
   (\<lambda>s e.
       if memb e (snd s) then (s, [])
       else ((exit e, ins e (snd s)), succ_list e))
   ((False, rs), wl)"

lemma (in StdSet) accessible_abort_code_aux:
  "RETURN (accessible_abort_code exit succ_list rs wl) \<le>
   accessible_abort_impl exit succ_list rs wl"
unfolding accessible_abort_impl_def accessible_abort_code_def
by (rule refine_transfer)+

lemma (in StdSet) accessible_abort_code_correct :
fixes R :: "('x \<times> 'x) set"
assumes fin_res: "finite (accessible_restrict R (\<alpha> rs) (set wl))"
    and succ_list_OK: "\<And>q. set (succ_list q) = {q'. (q,q') \<in> R}"
    and invar_rs: "invar rs"
shows "let ((ex, rs'), wl') = accessible_abort_code exit succ_list rs wl in
    accessible_restrict R (\<alpha> rs') (set wl') =
    accessible_restrict R (\<alpha> rs) (set wl) \<and>
    ((\<forall>x. x \<in> \<alpha> rs' \<longrightarrow> x \<in> \<alpha> rs \<or> \<not> exit x) \<longrightarrow> wl' = []) \<and>
    (\<exists>x. x \<in> \<alpha> rs' \<and> x \<notin> \<alpha> rs \<and> exit x) = ex \<and> invar rs'"
proof -
  note accessible_abort_code_aux
  also note accessible_abort_impl_correct [OF succ_list_OK invar_rs]
  also note accessible_worklist_thm[OF fin_res, of "exit"]
  finally show ?thesis
    apply (erule_tac RETURN_ref_SPECD)
    apply (simp add: Image_iff Bex_def case_prod_beta list_all2_eq[symmetric] in_br_conv
      refine_hsimp)
  done
qed

subsection \<open> Accessibility \<close>

definition (in StdSet) accessible_restrict_impl where
  "accessible_restrict_impl succ_list rs wl =
   do {
     (res, _) \<leftarrow> WORKLISTT  (\<lambda>_. True)
       (\<lambda>s e.
         if (memb e s) then
           (RETURN (s, []))
         else
           RETURN (ins e s, succ_list e)
       ) (rs, wl);
       RETURN res
     }"

lemma (in StdSet) accessible_restrict_impl_correct :
shows "accessible_restrict_impl succ_list rs wl \<le> \<Down>Id
       (do {((_, res), _) \<leftarrow> (accessible_abort_impl (\<lambda>_. False) succ_list rs wl); RETURN res})"
unfolding accessible_abort_impl_def accessible_restrict_impl_def WORKLISTT_def
apply (rule bind_refine [where R' = "WORKLISTIT_refine_rel (build_rel (Pair False) (\<lambda>_. True)) Id"])
apply (rule WORKLISTIT_refine)
apply (simp only: br_sv)
apply (auto simp add: list_all2_eq[symmetric] pw_le_iff refine_pw_simps
  refine_hsimp in_br_conv)
done

schematic_goal (in StdSet) accessible_restrict_code_aux2:
  "RETURN ?code \<le>
   accessible_restrict_impl succ_list rs wl"
unfolding accessible_restrict_impl_def
apply (rule refine_transfer)+
done

definition (in StdSet) accessible_restrict_code where
  "accessible_restrict_code succ_list rs wl =
   (let (res, _) = (worklist (\<lambda>s. True)
   (\<lambda>s e.
       if memb e s then (s, [])
       else (ins e s, succ_list e))
   (rs, wl)) in res)"

lemma (in StdSet) accessible_restrict_code_aux:
  "RETURN (accessible_restrict_code succ_list rs wl) \<le>
   accessible_restrict_impl succ_list rs wl"
using accessible_restrict_code_aux2 [of succ_list rs wl]
unfolding accessible_restrict_code_def by simp

lemma (in StdSet) accessible_restrict_code_correct :
fixes R :: "('x \<times> 'x) set"
fixes succ_list rs wl
defines "rs' \<equiv> accessible_restrict_code succ_list rs wl"
assumes fin_res: "finite (accessible_restrict R (\<alpha> rs) (set wl))"
    and succ_list_OK: "\<And>q. set (succ_list q) = {q'. (q,q') \<in> R}"
    and invar_rs: "invar rs"
shows "invar rs' \<and>
       \<alpha> rs' = accessible_restrict R (\<alpha> rs) (set wl)"
proof -
  note step1 = order_trans [OF accessible_restrict_code_aux
                   accessible_restrict_impl_correct [of succ_list rs wl, simplified]]

  note abort_impl_OK = accessible_abort_impl_correct [OF succ_list_OK invar_rs]
  note step2 = ref_two_step [OF abort_impl_OK accessible_worklist_thm, OF fin_res,
    of "\<lambda>_. False"]

  have step3: "do {((_, res), _) \<leftarrow> accessible_abort_impl (\<lambda>_. False) succ_list rs wl; RETURN res}
        \<le> \<Down> (build_rel \<alpha> invar) (do {((_, res), _) \<leftarrow> SPEC (\<lambda>((ex, rs'), wl').
           (accessible_restrict R rs' (set wl') =
            accessible_restrict R (\<alpha> rs) (set wl)) \<and>
           ex = (\<exists>e\<in>rs' - \<alpha> rs. False) \<and> (\<not> ex \<longrightarrow> wl' = [])); RETURN res})"
    apply (rule bind_refine [OF step2, where
       f = "\<lambda>((_, res), _). RETURN res" and f' = "\<lambda>((_, res), _). RETURN res" and
       R = "build_rel \<alpha> invar" ])
    apply (auto simp del: br_def)
    apply (simp add: in_br_conv)
  done

  have step4 : "(do {((_, res), _) \<leftarrow> SPEC (\<lambda>((ex, rs'), wl').
           (accessible_restrict R rs' (set wl') =
           accessible_restrict R (\<alpha> rs) (set wl)) \<and>
           (ex = (\<exists>e\<in>rs' - \<alpha> rs. False)) \<and> (\<not> ex \<longrightarrow> wl' = [])); RETURN res})
           \<le> SPEC (\<lambda>res. res = accessible_restrict R (\<alpha> rs) (set wl))"
    apply (rule bind_rule)
    apply (simp add: subset_iff)
  done

  note step5 = ref_two_step [OF order_trans [OF step1 step3] step4]
  thus ?thesis
     apply (erule_tac RETURN_ref_SPECD)
     apply (simp add: Image_iff Let_def rs'_def in_br_conv)
  done
qed

lemma (in StdSet) accessible_restrict_code_correct2 :
assumes fin_res: "finite (accessible R (set wl))"
    and succ_list_OK: "\<And>q. set (succ_list q) = {q'. (q,q') \<in> R}"
shows "let rs = accessible_restrict_code succ_list (empty ()) wl in
    invar rs \<and>
    \<alpha> rs = accessible R (set wl)"
using accessible_restrict_code_correct [of R "empty ()" wl succ_list] assms
by (simp add: correct accessible_restrict_def)

subsection \<open> Check for reachability \<close>

definition (in StdSet) in_accessible_restrict_code where
"in_accessible_restrict_code P succ_list rs wl =
 fst (fst (accessible_abort_code P succ_list rs wl))"

lemma (in StdSet) in_accessible_restrict_code_correct :
fixes R :: "('x \<times> 'x) set"
assumes fin_res: "finite (accessible_restrict R (\<alpha> rs) (set wl))"
    and succ_list_OK: "\<And>q. set (succ_list q) = {q'. (q,q') \<in> R}"
    and invar_rs: "invar rs"
shows "in_accessible_restrict_code P succ_list rs wl \<longleftrightarrow>
       (\<exists>e\<in>accessible_restrict R (\<alpha> rs) (set wl) - (\<alpha> rs). P e)"
proof -
  obtain ex rs' wl' where [simp]: "accessible_abort_code P succ_list rs wl = ((ex, rs'), wl')"
    by (metis prod.exhaust)

  have [simp]: "in_accessible_restrict_code P succ_list rs wl = ex"
    unfolding in_accessible_restrict_code_def by simp

  note abort_OK = accessible_abort_code_correct [OF fin_res succ_list_OK invar_rs, of P]

  show ?thesis
  proof (cases ex)
    case True note [simp] = this

    from abort_OK obtain e where "P e" and "e \<in> \<alpha> rs'" "e \<notin> \<alpha> rs" by simp blast
    from `e \<in> \<alpha> rs'` have "e \<in> accessible_restrict R (\<alpha> rs') (set wl')"
      unfolding accessible_restrict_def by simp
    with abort_OK have "e \<in> accessible_restrict R (\<alpha> rs) (set wl)" by simp
    with `P e` `e \<notin> \<alpha> rs` show ?thesis by simp blast
  next
    case False with abort_OK show ?thesis by auto
  qed
qed

lemma (in StdSet) in_accessible_restrict_code_correct2 :
fixes R :: "('x \<times> 'x) set"
assumes fin_res: "finite (accessible R (set wl))"
    and succ_list_OK: "\<And>q. set (succ_list q) = {q'. (q,q') \<in> R}"
shows "in_accessible_restrict_code P succ_list (empty ()) wl \<longleftrightarrow>
       (\<exists>e\<in>accessible R (set wl). P e)"
using in_accessible_restrict_code_correct [of R "empty ()" wl succ_list P] assms
by (simp add: correct accessible_restrict_def)

subsection \<open>Code Generation\<close>

definition "accessible_abort_code = ls.accessible_abort_code"
declare accessible_abort_code_def [symmetric, code_unfold]
declare ls.accessible_abort_code_def [folded accessible_abort_code_def, code]

definition "accessible_restrict_code = ls.accessible_restrict_code"
declare accessible_restrict_code_def [symmetric, code_unfold]
declare ls.accessible_restrict_code_def [folded accessible_restrict_code_def, code]

definition "in_accessible_restrict_code = ls.in_accessible_restrict_code"
declare in_accessible_restrict_code_def [symmetric, code_unfold]
declare ls.in_accessible_restrict_code_def [folded in_accessible_restrict_code_def, code]

export_code accessible_abort_code accessible_restrict_code in_accessible_restrict_code in SML

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2020         |
            |                  April 2020  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory RS
imports Norm_seq
begin

(*****************************************************************

         1. Definition of Restriction Spaces (RS)
         2. RS ==> MS
         3. Metric Fixed point induction
         4.

 *****************************************************************)

(*
  It was defined by ("_ .|. _" [55,56] 55) until Isabelle 2007,
  but it was changed because it caused many syntactic ambiguity
  in Isabelle 2008.
*)

(******** X-symbols ********)
(*
notation (xsymbols) restriction ("_ \<down> _" [84,900] 84)

Isabelle 2005
syntax (output)
  "_restriction" :: "'a::ms0 => nat => 'a::ms0"  ("_ .|. _" [55,56] 55)

syntax (xsymbols)
  "_restriction" :: "'a::ms0 => nat => 'a::ms0"  ("_ \<down> _" [55,56] 55)

translations
  "x \<down> n"  == "x .|. n"
*)

(**********************************************************
                  restriction space (rs)
 **********************************************************)

(* isabelle2009-1
consts
  restriction :: "'a::ms0 => nat => 'a::ms0"  ("_ .|. _" [84,900] 84)

axclass rs < ms0
  zero_eq_rs: "ALL (x::'a::ms0) (y::'a::ms0). x .|. 0 = y .|. 0"
  min_rs    : "ALL (x::'a::ms0) (m::nat) (n::nat).
                     (x .|. m) .|. n = x .|. (min m n)"
  diff_rs   : "ALL (x::'a::ms0) (y::'a::ms0).
                     (x ~= y) --> (EX n. x .|. n ~= y .|. n)"
*)

class rs0 =
fixes restriction :: "'a => nat => 'a"  ("_ .|. _" [84,900] 84)

(* class rs = rs0 + ms0 + *)

class rs = rs0 +
assumes
  zero_eq_rs: "ALL x y. x .|. 0 = y .|. 0"
assumes
  min_rs    : "ALL x m n.
                     (x .|. m) .|. n = x .|. (min m n)"
assumes
  diff_rs   : "ALL x y.
                     (x ~= y) --> (EX n. x .|. n ~= y .|. n)"

declare zero_eq_rs [simp]

lemma diff_rs_Suc:
  "ALL n (x::'a::rs) y. x .|. n ~= y .|. n --> (EX m. n = Suc m) "
apply (rule allI)
apply (induct_tac n)
by (auto)

(**********************************************************
            restriction space --> metric space
 **********************************************************)

definition
  distance_nat_set :: "('a::rs * 'a::rs) => nat set"
  where
  distance_nat_set_def :
     "distance_nat_set xy ==
      {n. ((fst xy) .|. n) = ((snd xy) .|. n)}"

definition
  distance_nat     :: "('a::rs * 'a::rs) => nat"
  where
  distance_nat_def :
     "distance_nat xy == Max (distance_nat_set xy)"

definition
  distance_rs_set  :: "('a::rs * 'a::rs) => real set"
  where
  distance_rs_set_def :
     "distance_rs_set xy == {(1/2)^n |n. n:distance_nat_set xy}"

(*
defs (overloaded)
  distance_rs_def : "distance xy == GLB (distance_rs_set xy)"
*)

definition
  distance_rs :: "('a::rs * 'a::rs) => real"
  where
  distance_rs_def: "distance_rs xy == GLB (distance_rs_set xy)"

(**********************************************************
             complete restriction space (crs)
 **********************************************************)

class ms0_rs =  ms0 + rs +
assumes
  to_distance_rs: "distance (xy::('a::{ms0,rs}) * 'a) = distance_rs xy"

class ms_rs =  ms + ms0_rs
class cms_rs = cms + ms_rs

(**********************************************************
                        RS lemmas
 **********************************************************)

(*** contraposition of diff_rs ***)

lemma contra_diff_rs:
    "[| ALL n. (x::'a::rs) .|. n = y .|. n |] ==> (x = y)"
apply (erule contrapos_pp)
by (simp add: diff_rs)

(*** diff_rs inv ***)

lemma contra_diff_rs_inv:
    "[| (x::'a::rs) .|. n ~= y .|. n |] ==> (x ~= y)"
apply (auto)
done

(*** zero distance ***)

lemma distance_rs_zero[simp]:
  "distance_rs ((x::'a::rs), x) = 0"
apply (simp add: distance_rs_def distance_rs_set_def)
apply (simp add: distance_nat_set_def)
by (simp add: zero_GLB_pow)

(*---------------------------*
 |       equal-preserv       |
 *---------------------------*)

lemma rest_equal_preserve:
  "[| (x::'a::rs) .|. n = y .|. n ; m <= n |] ==> x .|. m = y .|. m"
apply (insert min_rs)
apply (drule_tac x="x" in spec)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (insert min_rs)
apply (drule_tac x="y" in spec)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
by (simp add: min_is)

lemma rest_equal_preserve_Suc:
  "(x::'a::rs) .|. Suc n = y .|. Suc n ==> x .|. n = y .|. n"
apply (rule rest_equal_preserve)
by (auto)

lemma rest_nonequal_preserve:
  "[| (x::'a::rs) .|. m ~= y .|. m ; m <= n |] ==> x .|. n ~= y .|. n"
apply (erule contrapos_pp)
apply (simp)
apply (rule rest_equal_preserve)
by (simp_all)

(*---------------------------*
 |  distance_nat_set hasMAX  |
 *---------------------------*)

lemma distance_nat_set_hasMAX :
  "(x::'a::rs) ~= y ==> (distance_nat_set (x,y)) hasMAX"
apply (insert EX_MIN_nat[of "{m. x .|. m ~= y .|. m}"])
apply (simp add: diff_rs)
apply (erule exE)
apply (simp add: isMIN_def)

apply (insert diff_rs_Suc)
apply (drule_tac x="n" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp)
apply (erule exE)

 (* m must be the max *)

apply (simp add: hasMAX_def)
apply (rule_tac x="m" in exI)
apply (simp add: distance_nat_set_def isMAX_def)

apply (case_tac "x .|. m = y .|. m")
 apply (simp add: isUB_def)
 apply (intro allI impI)

 apply (simp add: isLB_def)
 apply (erule conjE)
 apply (case_tac "Suc m <= ya")
 apply (rotate_tac 3)
 apply (erule contrapos_pp)

 apply (rule rest_nonequal_preserve)
 apply (simp_all)
 apply (force)

      (* x .|. m ~= y .|. m *)  (* --> contradict for MIN *)
 apply (simp add: isLB_def)
 apply (erule conjE)
 apply (drule_tac x="m" in spec)
 apply (simp)
done

(*---------------------------*
 |     isMAX <--> isGLB      |
 *---------------------------*)

lemma to_distance_rsMAX_isGLB:
 "n isMAX distance_nat_set ((x::'a::rs), y)
  ==> (1/2)^n isGLB distance_rs_set (x, y)"
apply (simp add: distance_rs_set_def)
apply (simp add: isGLB_def isLB_def)
apply (rule conjI)

 (* LB *)
 apply (intro allI impI)
 apply (simp add: isMAX_def isUB_def)
 apply (elim conjE exE)
 apply (drule_tac x="na" in spec)
 apply (simp add: power_decreasing)

 (* GLB *)
 apply (intro allI impI)
 apply (drule_tac x="(1 / 2) ^ n" in spec)
 apply (drule mp)
 apply (rule_tac x="n" in exI, simp_all)
 apply (simp add: isMAX_def)
done

(*---------------------------*
 |    distance_set hasGLB    |
 *---------------------------*)

lemma distance_rs_set_hasGLB :
  "(distance_rs_set ((x::'a::rs),y)) hasGLB"
apply (simp add: hasGLB_def)

apply (case_tac "x = y")
apply (simp add: distance_rs_set_def)
apply (simp add: distance_nat_set_def)
apply (rule_tac x="0" in exI)
apply (simp add: zero_isGLB_pow)

apply (insert distance_nat_set_hasMAX[of x y])
apply (simp add: hasMAX_def)
apply (erule exE)
apply (rule_tac x="(1/2)^xa" in exI)
by (simp add: to_distance_rsMAX_isGLB)

(*---------------------------*
 |       MAX <--> GLB        |
 *---------------------------*)

lemma distance_rs_nat_lm:
  "[| (x::'a::rs) ~= y ; distance_nat (x,y) = n ; distance_rs (x,y) = r |]
   ==> r = (1 / 2) ^ n"
apply (simp add: distance_nat_def MAX_iff distance_nat_set_hasMAX)
apply (simp add: distance_rs_def  GLB_iff distance_rs_set_hasGLB)
apply (insert to_distance_rsMAX_isGLB[of n x y])
by (simp add: GLB_unique)

lemma distance_iff1:
  "(x::'a::rs) ~= y
   ==> distance_rs (x,y) = (1 / 2) ^ (distance_nat (x,y))"
by (simp add: distance_rs_nat_lm)

lemma distance_iff2:
  "(y::'a::rs) ~= x
   ==> distance_rs (x,y) = (1 / 2) ^ (distance_nat (x,y))"
apply (rule distance_iff1)
by (force)

lemmas distance_iff = distance_iff1 distance_iff2

(*---------------------------*
 |       less than 1B        |
 *---------------------------*)

lemma distance_rs_less_one:
  "distance_rs ((x::'a::rs), y) <= 1"
apply (case_tac "x=y", simp)
apply (simp add: distance_iff)
apply (rule order_trans)
apply (subgoal_tac "(1 / 2) ^ distance_nat (x, y) <= (1 / 2) ^ 0")
apply (assumption)
apply (rule power_decreasing)
apply (simp_all)
done

(*---------------------------*
 |      distance_nat iff     |
 *---------------------------*)

lemma isMAX_distance_nat1 :
  "(x::'a::rs) ~= y ==> (n isMAX distance_nat_set (x,y)) = (distance_nat (x,y) = n)"
apply (simp add: distance_nat_def)
by (simp add: distance_nat_set_hasMAX MAX_iff)

lemmas distance_nat_isMAX1 = isMAX_distance_nat1[THEN sym]

lemma distance_nat_isMAX_sym1:
  "(x::'a::rs) ~= y ==> (n = distance_nat (x,y)) = (n isMAX distance_nat_set (x,y))"
by (auto simp add: isMAX_distance_nat1)

lemma isMAX_distance_nat2 :
  "(y::'a::rs) ~= x ==> (n isMAX distance_nat_set (x,y)) = (distance_nat (x,y) = n)"
apply (rule isMAX_distance_nat1)
by (auto)

lemmas distance_nat_isMAX2 = isMAX_distance_nat2[THEN sym]

lemma distance_nat_isMAX_sym2:
  "(y::'a::rs) ~= x ==> (n = distance_nat (x,y)) = (n isMAX distance_nat_set (x,y))"
by (auto simp add: isMAX_distance_nat2)

lemmas distance_nat_iff = distance_nat_isMAX1 distance_nat_isMAX_sym1
                          distance_nat_isMAX2 distance_nat_isMAX_sym2

(*** for insert ***)

lemma distance_nat_is:
  "(x::'a::rs) ~= y ==> distance_nat (x,y) isMAX distance_nat_set (x,y)"
apply (insert distance_nat_isMAX1[of x y "distance_nat (x,y)"])
by (simp)

(*============================================================*
 |                                                            |
 |         (restriction space ==> metric space)               |
 |                                                            |
 |    instance x :: (type) rs ==> instance x :: (type) ms     |
 |                                                            |
 |               by  positive_rs                              |
 |                   diagonal_rs                              |
 |                   symmetry_rs                              |
 |                   triangle_inequality_rs                   |
 |                                                            |
 *============================================================*)

(*** positive_rs ***)

lemma positive_rs[simp]: "0 <= distance_rs (x::'a::rs,y)"
apply (case_tac "x = y")
by (simp_all add: distance_iff)
(*
in Isabelle2007
by (simp_all add: distance_iff zero_le_power)
*)

(*** diagonal_rs ***)

lemma diagonal_rs_only_if: "(distance_rs((x::'a::rs),y) = 0) ==> (x = y)"
apply (case_tac "x = y", simp)
by (simp add: distance_iff)

lemma diagonal_rs: "(distance_rs((x::'a::rs),y) = 0) = (x = y)"
apply (rule iffI)
apply (simp add: diagonal_rs_only_if)
by (simp)

lemma diagonal_rs_neq: "((x::'a::rs) ~= y) ==> 0 < distance_rs((x::'a::rs), y)"
apply (case_tac "distance_rs(x, y) = 0")
apply (simp add: diagonal_rs)
apply (insert positive_rs[of x y])
apply (simp (no_asm_simp))
done

(*** symmetry_rs ***)

lemma symmetry_nat_lm:
  "[| (x::'a::rs) ~= y;
      distance_nat (x,y) = n; distance_nat (y,x) = m |] ==> n = m"
apply (simp add: distance_nat_iff)
apply (rule MAX_unique)
apply (simp)
by (simp add: isMAX_def isUB_def distance_nat_set_def)

lemma symmetry_nat:
  "(x::'a::rs) ~= y ==> distance_nat (x,y) = distance_nat (y,x)"
by (simp add: symmetry_nat_lm)

lemma symmetry_rs: "distance_rs((x::'a::rs),y) = distance_rs(y,x)"
apply (case_tac "x = y", simp)
apply (simp add: distance_iff)
by (insert symmetry_nat[of x y], simp)

(*** triangle_inequality_rs ***)

lemma triangle_inequality_nat_lm:
  "[| (x::'a::rs) ~= y ; y ~= z ; x ~= z ;
      distance_nat (x,z) = n1 ;
      distance_nat (x,y) = n2 ;
      distance_nat (y,z) = n3 |]
   ==> min n2 n3 <= n1"
apply (simp add: distance_nat_iff)
apply (simp add: distance_nat_set_def)
apply (simp add: isMAX_def)

apply (subgoal_tac "min n3 n2 = min n2 n3")
apply (subgoal_tac "x .|. min n2 n3 = z .|. min n3 n2")
apply (simp add: isUB_def)

(* FOR x .|. min n2 n3 = z .|. min n3 n2 *)

apply (insert min_rs)
apply (frule_tac x="x" in spec)
apply (frule_tac x="y" in spec)
apply (frule_tac x="y" in spec)
apply (drule_tac x="z" in spec)

apply (drule_tac x="n2" in spec)
apply (drule_tac x="n2" in spec)
apply (drule_tac x="n3" in spec)
apply (drule_tac x="n3" in spec)

apply (drule_tac x="n3" in spec)
apply (drule_tac x="n3" in spec)
apply (drule_tac x="n2" in spec)
apply (drule_tac x="n2" in spec)
apply (simp)

by (simp add: min_def)

lemma triangle_inequality_nat:
  "[| (x::'a::rs) ~= y ; y ~= z ; x ~= z |]
   ==> min (distance_nat (x,y)) (distance_nat (y,z)) <= distance_nat (x,z)"
by (simp add: triangle_inequality_nat_lm)

lemma triangle_inequality_neq:
  "[| (x::'a::rs) ~= y ; y ~= z ; x ~= z |]
   ==> distance_rs (x,z) <= max (distance_rs (x,y)) (distance_rs (y,z))"
apply (simp add: distance_iff)
apply (insert triangle_inequality_nat[of x y z], simp)

apply (case_tac "distance_nat (x, y) <= distance_nat (y, z)")
 apply (simp add: min_is)
 apply (subgoal_tac "((1::real) / 2) ^ distance_nat (y, z)
                  <= (1 / 2) ^ distance_nat (x, y)")
 apply (simp add: max_is)
 apply (simp) (* modified for Isabelle2020 *)

 (* ~ distance_nat (x, y) <= distance_nat (y, z) *)
 apply (simp add: min_is)
 apply (subgoal_tac "((1::real) / 2) ^ distance_nat (x, y)
                  <= (1 / 2) ^ distance_nat (y, z)")
 apply (simp add: max_is)
 apply (simp) (* modified for Isabelle2020 *)
done

lemma triangle_inequality_max:
  "distance_rs ((x::'a::rs),z) <= max (distance_rs (x,y)) (distance_rs (y,z))"
apply (case_tac "x = y", simp add: max_is)
apply (case_tac "y = z", simp add: max_is)
apply (case_tac "x = z", simp add: max_def)
by (simp add: triangle_inequality_neq)

(*** triangle_inequality ***)

lemma triangle_inequality_rs:
  "distance_rs ((x::'a::rs),z) <= distance_rs (x,y) + distance_rs (y,z)"

apply (insert triangle_inequality_max[of x z y])
apply (subgoal_tac "max (distance_rs (x, y)) (distance_rs (y, z))
                      <= distance_rs (x, y) + distance_rs (y, z)")
apply (blast intro: order_trans)
by (simp)

(**********************************************************
                 .|. <--> distance_nat
 **********************************************************)

(*---------------------------*
 |  distance_nat satisfies   |
 *---------------------------*)

lemma distance_nat_rest:
  "[| (x::'a::rs) ~= y ; distance_nat (x, y) = n |]
    ==> x .|. n = y .|. n"
apply (simp add: distance_nat_iff)
apply (simp add: isMAX_def)
by (simp add: distance_nat_set_def)

(*---------------------------*
 |    distance_nat is max    |
 *---------------------------*)

lemma distance_nat_rest_Suc:
  "[| (x::'a::rs) ~= y ; distance_nat (x, y) = n |]
    ==> x .|. (Suc n) ~= y .|. (Suc n)"
apply (simp add: distance_nat_iff)
apply (simp add: isMAX_def isUB_def)
apply (simp add: distance_nat_set_def)
apply (case_tac "x .|. Suc n ~=
                 y .|. Suc n", simp)
apply (erule conjE)
apply (drule_tac x="Suc n" in spec)
by (simp)

(*---------------------------*
 |     distance_nat_le       |
 *---------------------------*)

(* 1 only if *)

lemma distance_nat_le_1_only_if:
  "[| (x::'a::rs) ~= y ; x .|. n = y .|. n |] ==> n <= distance_nat (x,y)"
apply (insert distance_nat_is[of x y])
apply (simp add: isMAX_def isUB_def)
apply (erule conjE)
apply (drule_tac x="n" in spec)
apply (drule mp)

apply (simp add: distance_nat_set_def)
by (simp)

(* 1 if *)

lemma distance_nat_le_1_if:
  "[| (x::'a::rs) ~= y ; n <= distance_nat (x,y) |] ==> x .|. n = y .|. n"
apply (insert distance_nat_is[of x y])
apply (simp add: isMAX_def isUB_def)
apply (erule conjE)
apply (simp add: distance_nat_set_def)
apply (rule rest_equal_preserve)
by (simp_all)

(* 1 iff *)

lemma distance_nat_le_1:
  "(x::'a::rs) ~= y ==> (x .|. n = y .|. n) = (n <= distance_nat (x,y))"
apply (rule iffI)
apply (simp add: distance_nat_le_1_only_if)
apply (simp add: distance_nat_le_1_if)
done

(* 2 iff *)

lemma distance_nat_le_2:
  "(x::'a::rs) ~= y
   ==> (x .|. n ~= y .|. n) = (distance_nat (x,y) < n)"
by (auto simp add: distance_nat_le_1)

(*---------------------------*
 |    distance_nat_less      |
 *---------------------------*)

(* 1 only if *)

lemma distance_nat_less_1_only_if:
  "(x::'a::rs) ~= y
   ==> (x::'a::rs) .|. (Suc n) = y .|. (Suc n) ==> n < distance_nat (x,y)"
by (simp add: distance_nat_le_1)

(* 1 if *)

lemma distance_nat_less_1_if:
  "(x::'a::rs) ~= y
   ==> n < distance_nat (x,y) ==> x .|. (Suc n) = y .|. (Suc n)"
apply (insert distance_nat_is[of x y], simp)
apply (simp add: isMAX_def distance_nat_set_def)
apply (rule rest_equal_preserve[of x "distance_nat (x, y)" y "Suc n"])
by (simp_all)

(* 1 iff *)

lemma distance_nat_less_1:
  "(x::'a::rs) ~= y
   ==> (x .|. (Suc n) = y .|. (Suc n)) = (n < distance_nat (x,y)) "
apply (intro allI iffI)
apply (simp add: distance_nat_less_1_only_if)
apply (simp add: distance_nat_less_1_if)
done

(* 2 iff *)

lemma distance_nat_less_2:
  "(x::'a::rs) ~= y
   ==> (x .|. (Suc n) ~= y .|. (Suc n)) = (distance_nat (x,y) <= n)"
by (auto simp add: distance_nat_less_1)

(**********************************************************
                   .|. <--> distance
 **********************************************************)

(*---------------------------*
 |      distance_rs_le       |
 *---------------------------*)

(* 1 only if *)

lemma distance_rs_le_1_only_if:
  "(x::'a::rs) .|. n = y .|. n ==> distance_rs(x,y) <= (1/2)^n"
(*
Isabelle 2007
apply (case_tac "x = y", simp add: zero_le_power)
*)
apply (case_tac "x = y", simp)
apply (simp add: distance_iff)
apply (simp add: distance_nat_le_1)
done

(* 1 if *)

lemma distance_rs_le_1_if:
  "distance_rs((x::'a::rs),y) <= (1/2)^n ==> x .|. n = y .|. n"
apply (case_tac "x = y", simp)
apply (simp add: distance_iff)
apply (simp add: distance_nat_le_1)
done

(* 1 iff *)

lemma distance_rs_le_1:
  "((x::'a::rs) .|. n = y .|. n) = (distance_rs(x,y) <= (1/2)^n)"
apply (rule iffI)
apply (simp add: distance_rs_le_1_only_if)
apply (simp add: distance_rs_le_1_if)
done

(* 2 iff *)

lemma distance_rs_le_2:
  "((x::'a::rs) .|. n ~= y .|. n) = ((1/2)^n < distance_rs(x,y))"
by (auto simp add: distance_rs_le_1)

(*****************************
       distance_rs_less
 *****************************)

(* 1 only if *)

lemma distance_rs_less_1_only_if:
  "(x::'a::rs) .|. (Suc n) = y .|. (Suc n) ==> distance_rs(x,y) < (1/2)^n"
apply (case_tac "x = y", simp)
apply (simp add: distance_rs_le_1)
apply (subgoal_tac "distance_rs (x, y) < distance_rs (x, y) * 2")
apply (simp)
apply (simp)
by (simp add: diagonal_rs_neq)

(* 1 if *)

lemma distance_rs_less_1_if:
  "distance_rs((x::'a::rs),y) < (1/2)^n ==> x .|. (Suc n) = y .|. (Suc n)"
apply (case_tac "x = y", simp)
apply (simp add: distance_iff)
apply (simp add: distance_nat_less_1)  (* modified for Isabelle2020 *)
done

(* 1 iff *)

lemma distance_rs_less_1:
  "((x::'a::rs) .|. (Suc n) = y .|. (Suc n)) = (distance_rs(x,y) < (1/2)^n)"
apply (intro allI iffI)
apply (simp add: distance_rs_less_1_only_if)
apply (simp add: distance_rs_less_1_if)
done

(* 2 iff *)

lemma distance_rs_less_2:
  "((x::'a::rs) .|. (Suc n) ~= y .|. (Suc n)) = ((1/2)^n <= distance_rs(x,y))"
by (auto simp add: distance_rs_less_1)

(*********************************************************************
                   for constructiveness of prefix
 *********************************************************************)

lemma contra_diff_rs_Suc:
      "[| ALL n. (x::'a::rs) .|. (Suc n) = y .|. (Suc n) |] ==> (x = y)"
apply (erule contrapos_pp)
apply (simp)
apply (insert diff_rs)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)

apply (rule rest_nonequal_preserve)
by (auto)

(*---------------------------*
 |    for contractiveness    |
 *---------------------------*)

lemma rest_Suc_dist_half:
  "[| ALL n. ((x1::'a::rs) .|. n = x2 .|. n) =
             ((y1::'a::rs) .|. (Suc n) = y2 .|. (Suc n)) |]
   ==> (1/2) * distance_rs(x1,x2) = distance_rs(y1,y2)"

apply (case_tac "x1 = x2")
 apply (simp)
 apply (subgoal_tac "y1 = y2")  (* ...1 *)
 apply (simp)

 (* 1 *)
 apply (rule contra_diff_rs_Suc, simp)

 (* x1 ~= x2 *)
  apply (case_tac "y1 = y2", simp)
  apply (rotate_tac 1)
  apply (erule contrapos_np)
  apply (rule contra_diff_rs, simp)

 (* x1 ~= x2 & y1 ~= y2 *)
 apply (simp add: distance_iff)

 apply (subgoal_tac
        "distance_nat (y1, y2) = Suc (distance_nat (x1, x2))") (* ... 2 *)
 apply (simp)
 apply (rule order_antisym)

  (* <= *)
  apply (insert nat_zero_or_Suc)
  apply (rotate_tac -1)
  apply (drule_tac x="distance_nat (y1, y2)" in spec)
  apply (erule disjE, simp)
  apply (erule exE, simp)

  apply (simp add: distance_nat_le_1)

  (* => *)
  apply (simp add: distance_nat_le_1)
  apply (drule_tac x="distance_nat (x1, x2)" in spec)
  apply (simp)
done

(*********************************************************************
                  rest_to_dist_pair (fun and pair)
 *********************************************************************)

lemma rest_to_dist_pair:
  "[| xps ~= {} ;
      (ALL n. (ALL x:(xps::(('a::rs) * ('a::rs)) set).
      (fst x) .|. n = (snd x) .|. n) --> ((y1::'b::rs) .|. n = y2 .|. n)) |]
   ==> (EX x. x:xps & distance_rs(y1,y2) <= distance_rs((fst x), (snd x)))"
apply (case_tac "y1 = y2", force)
      (* y1 ~= y2 *)
apply (insert distance_nat_is[of y1 y2], simp)

apply (simp add: distance_iff)
apply (drule_tac x="Suc (distance_nat (y1, y2))" in spec)
apply (simp add: distance_nat_rest_Suc)
apply (erule bexE)
apply (rule_tac x="fst x" in exI)
apply (rule_tac x="snd x" in exI)
apply (simp add: distance_rs_less_2)
done

(*** two sets (e.g. for domT and domF) ***)

lemma rest_to_dist_pair_two:
  "[| xps ~= {} ; yps ~= {} ;
      (ALL n.
       (ALL x:(xps::(('a::rs) * ('a::rs)) set). (fst x) .|. n = (snd x) .|. n) &
       (ALL y:(yps::(('b::rs) * ('b::rs)) set). (fst y) .|. n = (snd y) .|. n)
       --> ((z1::'c::rs) .|. n = z2 .|. n)) |]
   ==> (EX x. x:xps & distance_rs(z1,z2) <= distance_rs((fst x), (snd x))) |
       (EX y. y:yps & distance_rs(z1,z2) <= distance_rs((fst y), (snd y)))"
apply (case_tac "z1 = z2", force)
      (* z1 ~= z2 *)
apply (insert distance_nat_is[of z1 z2], simp)

apply (simp add: distance_iff)
apply (drule_tac x="Suc (distance_nat (z1, z2))" in spec)
apply (simp add: distance_nat_rest_Suc)
apply (elim bexE disjE)

 apply (rule disjI1)
 apply (rule_tac x="fst x" in exI)
 apply (rule_tac x="snd x" in exI)
 apply (simp add: distance_rs_less_2)

 apply (rule disjI2)
 apply (rule_tac x="fst y" in exI)
 apply (rule_tac x="snd y" in exI)
 apply (simp add: distance_rs_less_2)
done

(************************************************************
           .|. <--> distance lemma (different types)
 ************************************************************)

(*** subset ***)

lemma rest_distance_subset:
  "[| ALL n. ((x::'a::rs) .|. n = y .|. n) --> ((X::'b::rs) .|. n = Y .|. n) |]
   ==> distance_rs(X, Y) <= distance_rs(x, y)"
apply (case_tac "X = Y", simp)
apply (case_tac "x = y", simp)
apply (insert contra_diff_rs[of X Y], simp)  (* contradiction *)

      (* x ~= y & X ~= Y *)
apply (simp add: distance_rs_le_1)
apply (simp add: distance_iff)
done

(*** eq ***)

lemma rest_distance_eq:
  "[| ALL n. ((x::'a::rs) .|. n = y .|. n) = ((X::'b::rs) .|. n = Y .|. n) |]
   ==> distance_rs(x, y) = distance_rs(X, Y)"
apply (rule order_antisym)
by (simp_all add: rest_distance_subset)

(*----------------------------------------------------------*
 |                                                          |
 |                  distance = distance_rs                   |
 |                                                          |
 *----------------------------------------------------------*)

(*********************************************************************
                             Limit (ms_rs)
 *********************************************************************)

(*---------------------------*
 |  mini_number_cauchy_rest  |
 *---------------------------*)

lemma mini_number_cauchy_rest:
  "[| ALL (xy::('a::ms_rs * 'a::ms_rs)). distance xy = distance_rs xy ;
      normal (xs::'a::ms_rs infinite_seq) |]
   ==> (ALL n m. k <= n & k <= m --> (xs n) .|. k = (xs m) .|. k)"
apply (intro allI impI)
apply (simp add: normal_def)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)

apply (simp add: distance_rs_le_1)
apply (subgoal_tac "((1::real) / 2) ^ min n m <= (1 / 2) ^ k")
apply (simp (no_asm_simp))  (* modified for Isabelle2020 *)
apply (simp)
done

(*---------------------------*
 |        rest_Limit         |
 *---------------------------*)

lemma rest_Limit:
  "[| ALL (xy::('a::ms_rs * 'a::ms_rs)). distance xy = distance_rs xy ;
      ALL n. y .|. n = (xs n) .|. n |]
   ==> (xs::'a::ms_rs infinite_seq) convergeTo y"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (subgoal_tac "EX n. ((1::real) / 2) ^ n < eps")  (* ... 1 *)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac eps N n)

apply (drule_tac x="n" in spec)
apply (simp add: distance_rs_le_1)

apply (subgoal_tac "((1::real) / 2) ^ n <= (1 / 2) ^ N")  (* ... 2 *)
apply (simp (no_asm_simp))  (* modified for Isabelle2020 *)

(* 2 *)
apply (simp)

(* 1 *)
apply (simp add: pow_convergence)
done

(*----------------------------------------------------------*
 |                                                          |
 |              Metric Fixed point induction                |
 |                                                          |
 |               constructive & continuous                  |
 |                                                          |
 *----------------------------------------------------------*)

definition
  constructive_rs :: "('a::ms_rs => 'b::ms_rs) => bool"
  where
  constructive_rs_def :
     "constructive_rs f ==
        (ALL x y n. x .|. n = y .|. n
                    --> (f x) .|. (Suc n) = (f y) .|. (Suc n))"
definition
  continuous_rs   :: "('a::ms_rs => bool) => bool"
  where
  continuous_rs_def :
     "continuous_rs R ==
          (ALL x. ~ R x --> (EX n. ALL y. y .|. n = x .|. n --> ~ R y))"

(**********************************************************
              Construction --> Contraction
 **********************************************************)

lemma contst_to_contra_alpha:
  "[| ALL (xy::('a::ms_rs * 'a::ms_rs)). distance xy = distance_rs xy ;
      ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
      constructive_rs (f::('a::ms_rs => 'b::ms_rs)) |]
   ==> contraction_alpha f (1/2)"
apply (simp add: contraction_alpha_def map_alpha_def)
apply (intro allI)

apply (case_tac "x=y", simp)
apply (case_tac "f x = f y", simp)

apply (simp add: distance_iff)
apply (simp add: constructive_rs_def)

apply (rotate_tac 1)
apply (drule_tac x="x" in spec)
apply (rotate_tac -1)
apply (drule_tac x="y" in spec)
apply (simp add: distance_nat_le_1)
apply (drule_tac x="distance_nat (x, y)" in spec)
apply (simp)

apply (subgoal_tac
      "((1::real)/2) ^ distance_nat (f x, f y)
    <= ((1::real)/2) ^ (Suc (distance_nat (x, y)))")  (* ... 1 *)
apply (simp)

      (* 1 *)
apply (rule power_decreasing)
by (simp_all)

(*** contractive ***)

lemma contst_to_contra:
  "[| ALL (xy::('a::ms_rs * 'a::ms_rs)). distance xy = distance_rs xy ;
      ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
      constructive_rs (f::('a::ms_rs => 'b::ms_rs)) |]
   ==> contraction f"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
apply (simp add: contst_to_contra_alpha)
done

(**********************************************************
              Construction --> Contraction
 **********************************************************)

lemma contra_alpha_to_contst:
  "[| ALL (xy::('a::ms_rs * 'a::ms_rs)). distance xy = distance_rs xy ;
      ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
     contraction_alpha (f::('a::ms_rs => 'b::ms_rs)) (1/2) |]
   ==> constructive_rs f"
apply (simp add: constructive_rs_def)
apply (intro allI impI)

apply (simp add: contraction_alpha_def map_alpha_def)
apply (rotate_tac 2)
apply (drule_tac x="x" in spec)
apply (rotate_tac -1)
apply (drule_tac x="y" in spec)

by (simp add: distance_rs_le_1)

(*========================================================*
 |            Metric Fixed Point Induction                |
 *========================================================*)

theorem cms_fixpoint_induction:
  "[| ALL (xy::('a::cms_rs * 'a::cms_rs)). distance xy = distance_rs xy ;
      ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
      (R::'a::cms_rs => bool) x ; continuous_rs R ;
      constructive_rs f ; inductivefun R f |]
   ==> f hasUFP & R (UFP f)"
apply (insert Banach_thm[of f x])
apply (simp add: contst_to_contra)
apply (erule conjE)

      (* to use a contradiction *)
apply (case_tac "R (UFP f)", simp)

apply (simp add: continuous_rs_def)
apply (drule_tac x="UFP f" in spec, simp)
apply (erule exE)

apply (simp add: convergeTo_def)
apply (drule_tac x="(1/2)^n" in spec, simp)
apply (elim conjE exE)
apply (drule_tac x="na" in spec, simp)
apply (simp add: distance_rs_less_1[THEN sym])

apply (rotate_tac -2)
apply (drule_tac x="(f ^^ na) x" in spec)      (* isabelle 2009-1 *)
apply (drule mp)
apply (rule rest_equal_preserve_Suc, simp)

by (simp add: inductivefun_all_n)

theorem cms_fixpoint_induction_imp:
  "((ALL (xy::('a::cms_rs * 'a::cms_rs)). distance xy = distance_rs xy) &
    (ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy) &
    (R::'a::cms_rs => bool) x & continuous_rs R &
      constructive_rs f & inductivefun R f)
   --> f hasUFP & R (UFP f)"
by (auto simp add: cms_fixpoint_induction)

theorem cms_fixpoint_induction_R:
  "[| ALL (xy::('a::cms_rs * 'a::cms_rs)). distance xy = distance_rs xy ;
      ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
     (R::'a::cms_rs => bool) x ; continuous_rs R ;
      constructive_rs f ; inductivefun R f |]
   ==> R (UFP f)"
by (simp add: cms_fixpoint_induction)

(*----------------------------------------------------------*
 |                                                          |
 |      !!!     order and restriction space     !!!         |
 |                                                          |
 *----------------------------------------------------------*)

class ms_rs_order0 = ms_rs + order

class ms_rs_order = ms_rs_order0 +
assumes  rs_order_iff:
    "ALL (x::'a::ms_rs_order0) y.
        (ALL n. x .|. n <= y .|. n) = (x <= y)"

(* class ms_rs_order = ms + rs_order *)

class cms_rs_order = cms_rs + ms_rs_order

lemma not_rs_orderI:
 "~ x .|. n <= y .|. n ==> ~ ((x::'a::ms_rs_order) <= y)"
apply (insert rs_order_iff)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
by (auto)

lemma rs_order_if:
 "((x::'a::ms_rs_order) <= y) ==> x .|. n <= y .|. n"
apply (insert rs_order_iff)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
by (auto)

(*----------------------------------------------------------*
 |                                                          |
 |       Fixed point induction for refinement (CMS)         |
 |                                                          |
 *----------------------------------------------------------*)

(************************************************************
             continuity lemma for refinement
 ************************************************************)

lemma continuous_rs_Ref_fun: "continuous_rs (Ref_fun (z::'a::ms_rs_order))"
apply (simp add: continuous_rs_def)
apply (intro allI impI)
apply (simp add: Ref_fun_def)
apply (simp)
apply (subgoal_tac "~ (ALL n. z .|. n <= x .|. n)")
apply (simp)
apply (elim conjE exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rotate_tac -1)
apply (drule sym)
apply (rule not_rs_orderI)
apply (simp)

apply (simp add: rs_order_iff)
done

(************************************************************
         continuity lemma for (Reverse) refinement
 ************************************************************)

lemma continuous_rs_Rev_fun: "continuous_rs (Rev_fun (z::'a::ms_rs_order))"
apply (simp add: continuous_rs_def)
apply (intro allI impI)
apply (simp add: Rev_fun_def)

apply (subgoal_tac "~ (ALL n. x .|. n <= z .|. n)")
apply (simp)
apply (elim conjE exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rotate_tac -1)
apply (drule sym)
apply (rule not_rs_orderI)
apply (simp)

apply (simp add: rs_order_iff)
done

(************************************************************
          Metric Fixed Point Induction for refinement
 ************************************************************)

theorem cms_fixpoint_induction_ref:
  "[| ALL (xy::('a::cms_rs_order * 'a::cms_rs_order)). distance xy = distance_rs xy ;
      ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
      constructive_rs f ; mono f ; X <= f X ; Y = f Y |]
   ==> (X::'a::cms_rs_order) <= Y"
apply (insert cms_fixpoint_induction_imp[of "Ref_fun X" X f])
 apply (drule mp)
  apply (simp)
  apply (rule conjI)
  apply (blast)
  apply (simp add: continuous_rs_Ref_fun)
  apply (simp add: Ref_fun_def)

      (* inductiveness *)
  apply (simp add: inductivefun_def)
  apply (intro allI impI)
  apply (simp add: mono_def)
  apply (rotate_tac 3)
  apply (drule_tac x="X" in spec)
  apply (rotate_tac -1)
  apply (drule_tac x="x" in spec)
  apply (simp)

apply (insert UFP_is[of f])
apply (simp add: isUFP_def)
apply (simp add: Ref_fun_def)
done

(************************************************************
        Metric Fixed Point Induction for refinement (rev)
 ************************************************************)

theorem cms_fixpoint_induction_rev:
 "[| ALL (xy::('a::cms_rs_order * 'a::cms_rs_order)). distance xy = distance_rs xy ;
     ALL (xy::('b::ms_rs * 'b::ms_rs)). distance xy = distance_rs xy ;
     constructive_rs f ; mono f ; f X <= X ; Y = f Y |]
   ==> (Y::'a::cms_rs_order) <= X"
apply (insert cms_fixpoint_induction_imp[of "Rev_fun X" X f])

 apply (drule mp)
  apply (simp)
  apply (rule conjI)
  apply (blast)
  apply (simp add: continuous_rs_Rev_fun)
  apply (simp add: Rev_fun_def)

      (* inductiveness *)
  apply (simp add: inductivefun_def)
  apply (intro allI impI)
  apply (simp add: mono_def)
  apply (rotate_tac 3)
  apply (drule_tac x="x" in spec)
  apply (drule_tac x="X" in spec)
  apply (drule_tac x="X" in spec)
  apply (simp)

apply (insert UFP_is[of f], simp)
apply (simp add: isUFP_def)
apply (simp add: Rev_fun_def)
done

end