(*****************************************************************************
 * Featherweight-OCL --- A Formal Semantics for UML-OCL Version OCL 2.5
 *                       for the OMG Standard.
 *                       http://www.brucker.ch/projects/hol-testgen/
 *
 * UML_Types.thy --- Types definitions.
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2012-2015 Université Paris-Saclay, Univ. Paris-Sud, France
 *               2013-2015 IRT SystemX, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

chapter\<open>Formalization I: OCL Types and Core Definitions \label{sec:focl-types}\<close>

theory    UML_Types
imports   HOL.Transcendental
keywords "Assert" :: thy_decl
     and "Assert_local" :: thy_decl
begin

section\<open>Preliminaries\<close>
subsection\<open>Notations for the Option Type\<close>

text\<open>
  First of all, we will use a more compact notation for the library
  option type which occur all over in our definitions and which will make
  the presentation more like a textbook:
\<close>

no_notation ceiling  ("\<lceil>_\<rceil>") (* For Real Numbers only ... Otherwise has unfortunate side-effects on syntax. *)
no_notation floor  ("\<lfloor>_\<rfloor>") (* For Real Numbers only ... Otherwise has unfortunate side-effects on syntax. *)

type_notation option ("\<langle>_\<rangle>\<^sub>\<bottom>") (* NOTE: "_\<^sub>\<bottom>" also works *)
notation Some ("\<lfloor>(_)\<rfloor>")
notation None ("\<bottom>")

text\<open>These commands introduce an alternative, more compact notation for the type constructor
 @{typ "'\<alpha> option"}, namely @{typ "\<langle>'\<alpha>\<rangle>\<^sub>\<bottom>"}. Furthermore, the constructors @{term "Some X"} and
 @{term "None"} of the type @{typ "'\<alpha> option"}, namely @{term "\<lfloor>X\<rfloor>"} and @{term "\<bottom>"}.\<close>

text\<open>
  The following function (corresponding to @{term the} in the Isabelle/HOL library)
  is defined as the inverse of the injection @{term Some}.
\<close>
fun    drop :: "'\<alpha> option \<Rightarrow> '\<alpha>" ("\<lceil>(_)\<rceil>")
where  drop_lift[simp]: "\<lceil>\<lfloor>v\<rfloor>\<rceil> = v"

text\<open>The definitions for the constants and operations based on functions
will be geared towards a format that Isabelle can check to be a ``conservative''
(\ie, logically safe) axiomatic definition. By introducing an explicit
interpretation function (which happens to be defined just as the identity
since we are using a shallow embedding of OCL into HOL), all these definitions
can be rewritten into the conventional semantic textbook format.
To say it in other words: The interpretation function \<open>Sem\<close> as defined
below is just a textual marker for presentation purposes, i.e. intended for readers
used to conventional textbook notations on semantics. Since we use a ``shallow embedding'',
i.e. since we represent the syntax of OCL directly by HOL constants, the interpretation function
is semantically not only superfluous, but from an Isabelle perspective strictly in
the way for certain consistency checks performed by the definitional packages.
\<close>

definition Sem :: "'a \<Rightarrow> 'a" ("I\<lbrakk>_\<rbrakk>")
where "I\<lbrakk>x\<rbrakk> \<equiv> x"

subsection\<open>Common Infrastructure for all OCL Types \label{sec:focl-common-types}\<close>

text \<open>In order to have the possibility to nest collection types,
  such that we can give semantics to expressions like \<open>Set{Set{\<two>},null}\<close>,
  it is necessary to introduce a uniform interface for types having
  the \<open>invalid\<close> (= bottom) element. The reason is that we impose
  a data-invariant on raw-collection \inlineisar|types_code| which assures
  that the \<open>invalid\<close> element is not allowed inside the collection;
  all raw-collections of this form were identified with the \<open>invalid\<close> element
  itself. The construction requires that the new collection type is
  not comparable with the raw-types (consisting of nested option type constructions),
  such that the data-invariant must be expressed in terms of the interface.
  In a second step, our base-types will be shown to be instances of this interface.
\<close>

text\<open>
  This uniform interface consists in a type class requiring the existence
  of a bot and a null element. The construction proceeds by
  abstracting the null (defined by \<open>\<lfloor> \<bottom> \<rfloor>\<close> on
  \<open>'a option option\<close>) to a \<open>null\<close> element, which may
  have an arbitrary semantic structure, and an undefinedness element \<open>\<bottom>\<close>
  to an abstract undefinedness element \<open>bot\<close> (also written
  \<open>\<bottom>\<close> whenever no confusion arises). As a consequence, it is necessary
  to redefine the notions of invalid, defined, valuation etc.
  on top of this interface.\<close>

text\<open>
  This interface consists in two abstract type classes \<open>bot\<close>
  and \<open>null\<close> for the class of all types comprising a bot and a
  distinct null element.\<close>

class   bot =
   fixes   bot :: "'a"
   assumes nonEmpty : "\<exists> x. x \<noteq> bot"

class      null = bot +
   fixes   null :: "'a"
   assumes null_is_valid : "null \<noteq> bot"

subsection\<open>Accommodation of Basic Types to the Abstract Interface\<close>

text\<open>
  In the following it is shown that the ``option-option'' type is
  in fact in the \<open>null\<close> class and that function spaces over these
  classes again ``live'' in these classes. This motivates the default construction
  of the semantic domain for the basic types (\inlineocl{Boolean},
  \inlineocl{Integer}, \inlineocl{Real}, \ldots).
\<close>

instantiation   option  :: (type)bot
begin
   definition bot_option_def: "(bot::'a option) \<equiv> (None::'a option)"
   instance proof show        "\<exists>x::'a option. x \<noteq> bot"
                  by(rule_tac x="Some x" in exI, simp add:bot_option_def)
            qed
end

instantiation   option  :: (bot)null
begin
   definition null_option_def: "(null::'a::bot option) \<equiv>  \<lfloor> bot \<rfloor>"
   instance proof  show        "(null::'a::bot option) \<noteq> bot"
                   by( simp add : null_option_def bot_option_def)
            qed
end

instantiation "fun"  :: (type,bot) bot
begin
   definition bot_fun_def: "bot \<equiv> (\<lambda> x. bot)"
   instance proof  show "\<exists>(x::'a \<Rightarrow> 'b). x \<noteq> bot"
                   apply(rule_tac x="\<lambda> _. (SOME y. y \<noteq> bot)" in exI, auto)
                   apply(drule_tac x=x in fun_cong,auto simp:bot_fun_def)
                   apply(erule contrapos_pp, simp)
                   apply(rule some_eq_ex[THEN iffD2])
                   apply(simp add: nonEmpty)
                   done
            qed
end

instantiation "fun"  :: (type,null) null
begin
 definition null_fun_def: "(null::'a \<Rightarrow> 'b::null) \<equiv> (\<lambda> x. null)"
 instance proof
              show "(null::'a \<Rightarrow> 'b::null) \<noteq> bot"
              apply(auto simp: null_fun_def bot_fun_def)
              apply(drule_tac x=x in fun_cong)
              apply(erule contrapos_pp, simp add: null_is_valid)
            done
          qed
end

text\<open>A trivial consequence of this adaption of the interface is that
abstract and concrete versions of null are the same on base types
(as could be expected).\<close>

subsection\<open>The Common Infrastructure of Object Types (Class Types) and States.\<close>

text\<open>Recall that OCL is a textual extension of the UML; in particular, we use OCL as means to
annotate UML class models. Thus, OCL inherits a notion of \emph{data} in the UML: UML class
models provide classes, inheritance, types of objects, and subtypes connecting them along
the inheritance hierarchie.
\<close>

text\<open>For the moment, we formalize the most common notions of objects, in particular
the existance of object-identifiers (oid) for each object under which it can
be referenced in a \emph{state}.\<close>

type_synonym oid = nat

text\<open>We refrained from the alternative:
\begin{isar}[mathescape]
$\text{\textbf{type-synonym}}$ $\mathit{oid = ind}$
\end{isar}
which is slightly more abstract but non-executable.
\<close>

text\<open>\emph{States} in UML/OCL are a pair of
\begin{itemize}
\item a partial map from oid's to elements of an \emph{object universe},
      \ie{} the set of all possible object representations.
\item and an oid-indexed family of \emph{associations}, \ie{} finite relations between
      objects living in a state. These relations can be n-ary which we model by nested lists.
\end{itemize}
For the moment we do not have to describe the concrete structure of the object universe and denote
it by the  polymorphic variable \<open>'\<AA>\<close>.\<close>

record ('\<AA>)state =
             heap   :: "oid \<rightharpoonup> '\<AA> "
             assocs :: "oid \<rightharpoonup> ((oid list) list) list"

text\<open>In general, OCL operations are functions implicitly depending on a pair
of pre- and post-state, \ie{} \emph{state transitions}. Since this will be reflected in our
representation of OCL Types within HOL, we need to introduce the foundational concept of an
object id (oid), which is just some infinite set, and some abstract notion of state.\<close>

type_synonym ('\<AA>)st = "'\<AA> state \<times> '\<AA> state"

text\<open>We will require for all objects that there is a function that
projects the oid of an object in the state (we will settle the question how to define
this function later). We will use the Isabelle type class mechanism~\cite{haftmann.ea:constructive:2006}
to capture this:\<close>

class object =  fixes oid_of :: "'a \<Rightarrow> oid"

text\<open>Thus, if needed, we can constrain the object universe to objects by adding
the following type class constraint:\<close>
typ "'\<AA> :: object"

text\<open>The major instance needed are instances constructed over options: once an object,
options of objects are also objects.\<close>
instantiation   option  :: (object)object
begin
   definition oid_of_option_def: "oid_of x = oid_of (the x)"
   instance ..
end

subsection\<open>Common Infrastructure for all OCL Types (II): Valuations as OCL Types\<close>
text\<open>Since OCL operations in general depend on pre- and post-states, we will
represent OCL types as \emph{functions} from pre- and post-state to some
HOL raw-type that contains exactly the data in the OCL type --- see below.
This gives rise to the idea that we represent OCL types by \emph{Valuations}.
\<close>
text\<open>Valuations are functions from a state pair (built upon
data universe @{typ "'\<AA>"}) to an arbitrary null-type (\ie, containing
at least a destinguished \<open>null\<close> and \<open>invalid\<close> element).\<close>

type_synonym ('\<AA>,'\<alpha>) val = "'\<AA> st \<Rightarrow> '\<alpha>::null"

text\<open>The definitions for the constants and operations based on valuations
will be geared towards a format that Isabelle can check to be a ``conservative''
(\ie, logically safe) axiomatic definition. By introducing an explicit
interpretation function (which happens to be defined just as the identity
since we are using a shallow embedding of OCL into HOL), all these definitions
can be rewritten into the conventional semantic textbook format  as follows:\<close>

subsection\<open>The fundamental constants 'invalid' and 'null' in all OCL Types\<close>

text\<open>As a consequence of semantic domain definition, any OCL type will
have the two semantic constants \<open>invalid\<close> (for exceptional, aborted
computation) and \<open>null\<close>:
\<close>

definition invalid :: "('\<AA>,'\<alpha>::bot) val"
where     "invalid \<equiv> \<lambda> \<tau>. bot"

text\<open>This conservative Isabelle definition of the polymorphic constant
@{const invalid} is equivalent with the textbook definition:\<close>

lemma textbook_invalid: "I\<lbrakk>invalid\<rbrakk>\<tau> = bot"
by(simp add: invalid_def Sem_def)

text \<open>Note that the definition :
{\small
\begin{isar}[mathescape]
definition null    :: "('$\mathfrak{A}$,'\<alpha>::null) val"
where     "null    \<equiv> \<lambda> \<tau>. null"
\end{isar}
} is not  necessary since we defined the entire function space over null types
again as null-types; the crucial definition is @{thm "null_fun_def"}.
Thus, the polymorphic constant @{const null} is simply the result of
a general type class construction. Nevertheless, we can derive the
semantic textbook definition for the OCL null constant based on the
abstract null:
\<close>

lemma textbook_null_fun: "I\<lbrakk>null::('\<AA>,'\<alpha>::null) val\<rbrakk> \<tau> = (null::('\<alpha>::null))"
by(simp add: null_fun_def Sem_def)

section\<open>Basic OCL Value Types\<close>

text \<open>The structure of this section roughly follows the structure of Chapter
11 of the OCL standard~\cite{omg:ocl:2012}, which introduces the OCL
Library.\<close>

text\<open>The semantic domain of the (basic) boolean type is now defined as the Standard:
the space of valuation to @{typ "bool option option"}, \ie{} the Boolean base type:\<close>

type_synonym Boolean\<^sub>b\<^sub>a\<^sub>s\<^sub>e  = "bool option option"
type_synonym ('\<AA>)Boolean = "('\<AA>,Boolean\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"

text\<open>Because of the previous class definitions, Isabelle type-inference establishes that
@{typ "('\<AA>)Boolean"} lives actually both in the type class @{term bot} and @{term null};
this type is sufficiently rich to contain at least these two elements.
Analogously we build:\<close>
type_synonym Integer\<^sub>b\<^sub>a\<^sub>s\<^sub>e  = "int option option"
type_synonym ('\<AA>)Integer = "('\<AA>,Integer\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"

type_synonym String\<^sub>b\<^sub>a\<^sub>s\<^sub>e  = "string option option"
type_synonym ('\<AA>)String = "('\<AA>,String\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"

type_synonym Real\<^sub>b\<^sub>a\<^sub>s\<^sub>e = "real option option"
type_synonym ('\<AA>)Real = "('\<AA>,Real\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"

text\<open>Since @{term "Real"} is again a basic type, we define its semantic domain
as the valuations over \<open>real option option\<close> --- i.e. the mathematical type of real numbers.
The HOL-theory for \<open>real\<close> ``Real'' transcendental numbers such as $\pi$ and $e$ as well as
infrastructure to reason over infinite convergent Cauchy-sequences (it is thus possible, in principle,
to reason in Featherweight OCL that the sum of inverted two-s exponentials is actually 2.

If needed, a code-generator to compile \<open>Real\<close> to floating-point
numbers can be added; this allows for mapping reals to an efficient machine representation;
of course, this feature would be logically unsafe.\<close>

text\<open>For technical reasons related to the Isabelle type inference for type-classes
(we don't get the properties in the right order that class instantiation provides them,
if we would follow the previous scheme), we give a slightly atypic definition:\<close>

typedef Void\<^sub>b\<^sub>a\<^sub>s\<^sub>e = "{X::unit option option. X = bot \<or> X = null }" by(rule_tac x="bot" in exI, simp)

type_synonym ('\<AA>)Void = "('\<AA>,Void\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"

section\<open>Some OCL Collection Types\<close>

text\<open>For the semantic construction of the collection types, we have two goals:
\begin{enumerate}
\item we want the types to be \emph{fully abstract}, \ie, the type should not
      contain junk-elements that are not representable by OCL expressions, and
\item we want a possibility to nest collection types (so, we want the
      potential of talking about \<open>Set(Set(Sequences(Pairs(X,Y))))\<close>).
\end{enumerate}
The former principle rules out the option to define \<open>'\<alpha> Set\<close> just by
 \<open>('\<AA>, ('\<alpha> option option) set) val\<close>. This would allow sets to contain
junk elements such as \<open>{\<bottom>}\<close> which we need to identify with undefinedness
itself. Abandoning fully abstractness of rules would later on produce all sorts
of problems when quantifying over the elements of a type.
However, if we build an own type, then it must conform to our abstract interface
in order to have nested types: arguments of type-constructors must conform to our
abstract interface, and the result type too.
\<close>

subsection\<open>The Construction of the Pair Type (Tuples)\<close>

text\<open>The core of an own type construction is done via a type
  definition which provides the base-type \<open>('\<alpha>, '\<beta>) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<close>. It
  is shown that this type ``fits'' indeed into the abstract type
  interface discussed in the previous section.\<close>

typedef (overloaded) ('\<alpha>, '\<beta>) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e = "{X::('\<alpha>::null \<times> '\<beta>::null) option option.
                                           X = bot \<or> X = null \<or> (fst\<lceil>\<lceil>X\<rceil>\<rceil> \<noteq> bot \<and> snd\<lceil>\<lceil>X\<rceil>\<rceil> \<noteq> bot)}"
                            by (rule_tac x="bot" in exI, simp)

text\<open>We ``carve'' out from the concrete type @{typ "('\<alpha>::null \<times> '\<beta>::null) option option"}
the new fully abstract type, which will not contain representations like @{term "\<lfloor>\<lfloor>(\<bottom>,a)\<rfloor>\<rfloor>"}
or @{term "\<lfloor>\<lfloor>(b,\<bottom>)\<rfloor>\<rfloor>"}. The type constuctor \<open>Pair{x,y}\<close> to be defined later will
identify these with @{term "invalid"}.
\<close>

instantiation   Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null,null)bot
begin
   definition bot_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(bot_class.bot :: ('a::null,'b::null) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e None"

   instance proof show "\<exists>x::('a,'b) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e. x \<noteq> bot"
                  apply(rule_tac x="Abs_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>None\<rfloor>" in exI)
                  by(simp add: bot_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def  Abs_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject  null_option_def bot_option_def)
            qed
end

instantiation   Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null,null)null
begin
   definition null_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(null::('a::null,'b::null) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor> None \<rfloor>"

   instance proof show "(null::('a::null,'b::null) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<noteq> bot"
                  by(simp add: bot_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def null_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject
                               null_option_def bot_option_def)
            qed
end

text\<open>...  and lifting this type to the format of a valuation gives us:\<close>
type_synonym    ('\<AA>,'\<alpha>,'\<beta>) Pair  = "('\<AA>, ('\<alpha>,'\<beta>) Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"
type_notation   Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e ("Pair'(_,_')")

subsection\<open>The Construction of the Set Type\<close>

text\<open>The core of an own type construction is done via a type
  definition which provides the raw-type \<open>'\<alpha> Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<close>. It
  is shown that this type ``fits'' indeed into the abstract type
  interface discussed in the previous section. Note that we make
  no restriction whatsoever to \emph{finite} sets; while with
  the standards type-constructors only finite sets can be denoted,
  there is the possibility to define in fact infinite
  type constructors in \FOCL (c.f. \autoref{sec:type-extensions}).\<close>

typedef (overloaded) '\<alpha> Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e ="{X::('\<alpha>::null) set option option. X = bot \<or> X = null \<or> (\<forall>x\<in>\<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> bot)}"
          by (rule_tac x="bot" in exI, simp)

instantiation   Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null)bot
begin

   definition bot_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(bot::('a::null) Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e None"

   instance proof show "\<exists>x::'a Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e. x \<noteq> bot"
                  apply(rule_tac x="Abs_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>None\<rfloor>" in exI)
                  by(simp add: bot_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject null_option_def bot_option_def)
            qed
end

instantiation   Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null)null
begin

   definition null_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(null::('a::null) Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor> None \<rfloor>"

   instance proof show "(null::('a::null) Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<noteq> bot"
                  by(simp add:null_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject
                              null_option_def bot_option_def)
            qed
end

text\<open>...  and lifting this type to the format of a valuation gives us:\<close>
type_synonym    ('\<AA>,'\<alpha>) Set  = "('\<AA>, '\<alpha> Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"
type_notation   Set\<^sub>b\<^sub>a\<^sub>s\<^sub>e ("Set'(_')")

subsection\<open>The Construction of the Bag Type\<close>
text\<open>The core of an own type construction is done via a type
  definition which provides the raw-type \<open>'\<alpha> Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<close>
  based on multi-sets from the \HOL library. As in Sets, it
  is shown that this type ``fits'' indeed into the abstract type
  interface discussed in the previous section, and as in sets, we make
  no restriction whatsoever to \emph{finite} multi-sets; while with
  the standards type-constructors only finite sets can be denoted,
  there is the possibility to define in fact infinite
  type constructors in \FOCL (c.f. \autoref{sec:type-extensions}).
  However, while several \<open>null\<close> elements are possible in a Bag, there
  can't be no bottom (invalid) element in them.
\<close>

typedef (overloaded) '\<alpha> Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e ="{X::('\<alpha>::null \<Rightarrow> nat) option option. X = bot \<or> X = null \<or> \<lceil>\<lceil>X\<rceil>\<rceil> bot = 0 }"
          by (rule_tac x="bot" in exI, simp)

instantiation   Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null)bot
begin

   definition bot_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(bot::('a::null) Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e None"

   instance proof show "\<exists>x::'a Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e. x \<noteq> bot"
                  apply(rule_tac x="Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>None\<rfloor>" in exI)
                  by(simp add: bot_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject
                               null_option_def bot_option_def)
            qed
end

instantiation   Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null)null
begin

   definition null_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(null::('a::null) Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor> None \<rfloor>"

   instance proof show "(null::('a::null) Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<noteq> bot"
                  by(simp add:null_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject
                              null_option_def bot_option_def)
            qed
end

text\<open>...  and lifting this type to the format of a valuation gives us:\<close>
type_synonym    ('\<AA>,'\<alpha>) Bag  = "('\<AA>, '\<alpha> Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"
type_notation   Bag\<^sub>b\<^sub>a\<^sub>s\<^sub>e ("Bag'(_')")

subsection\<open>The Construction of the Sequence Type\<close>

text\<open>The core of an own type construction is done via a type
  definition which provides the base-type \<open>'\<alpha> Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<close>. It
  is shown that this type ``fits'' indeed into the abstract type
  interface discussed in the previous section.\<close>

typedef (overloaded) '\<alpha> Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e ="{X::('\<alpha>::null) list option option.
                                        X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> bot)}"
          by (rule_tac x="bot" in exI, simp)

instantiation   Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null)bot
begin

   definition bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(bot::('a::null) Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e None"

   instance proof show "\<exists>x::'a Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e. x \<noteq> bot"
                  apply(rule_tac x="Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>None\<rfloor>" in exI)
                  by(auto simp:bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject
                               null_option_def bot_option_def)
            qed
end

instantiation   Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (null)null
begin

   definition null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def: "(null::('a::null) Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<equiv> Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor> None \<rfloor>"

   instance proof show "(null::('a::null) Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<noteq> bot"
                  by(auto simp:bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject
                               null_option_def bot_option_def)
            qed
end

text\<open>...  and lifting this type to the format of a valuation gives us:\<close>
type_synonym    ('\<AA>,'\<alpha>) Sequence  = "('\<AA>, '\<alpha> Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e) val"
type_notation   Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e ("Sequence'(_')")

subsection\<open>Discussion: The Representation of UML/OCL Types in Featherweight OCL\<close>
text\<open>In the introduction, we mentioned that there is an ``injective representation
mapping'' between the types of OCL and the types of Featherweight OCL (and its
meta-language: HOL). This injectivity is at the heart of our representation technique
--- a so-called \emph{shallow embedding} --- and means: OCL types were mapped one-to-one
to types in HOL, ruling out a resentation where
everything is mapped on some common HOL-type, say ``OCL-expression'', in which we
would have to sort out the typing of OCL and its impact on the semantic representation
function in an own, quite heavy side-calculus.
\<close>

text\<open>After the previous sections, we are now able to exemplify this representation as follows:

\begin{table}[htbp]
   \centering
   \begin{tabu}{lX[,c,]}
      \toprule
      OCL Type & HOL Type \\
      \midrule
      \inlineocl|Boolean|  & @{typ  "('\<AA>)Boolean"} \\
      \inlineocl|Boolean -> Boolean| & @{typ  "('\<AA>)Boolean \<Rightarrow> ('\<AA>)Boolean"} \\
      \inlineocl|(Integer,Integer) -> Boolean| & @{typ  "('\<AA>)Integer \<Rightarrow> ('\<AA>)Integer \<Rightarrow> ('\<AA>)Boolean"} \\
      \inlineocl|Set(Integer)| & @{typ "('\<AA>,Integer\<^sub>b\<^sub>a\<^sub>s\<^sub>e)Set"} \\
      \inlineocl|Set(Integer)-> Real| & @{typ "('\<AA>,Integer\<^sub>b\<^sub>a\<^sub>s\<^sub>e)Set \<Rightarrow> ('\<AA>)Real"} \\
      \inlineocl|Set(Pair(Integer,Boolean))| & @{typ "('\<AA>,(Integer\<^sub>b\<^sub>a\<^sub>s\<^sub>e, Boolean\<^sub>b\<^sub>a\<^sub>s\<^sub>e)Pair\<^sub>b\<^sub>a\<^sub>s\<^sub>e)Set"} \\
      \inlineocl|Set(<T>)| & @{typ "('\<AA>,'\<alpha>::null)Set"} \\
      \bottomrule
   \end{tabu}
   \caption{Correspondance between \OCL types and \HOL types}
   \label{tab:types}
\end{table}
We do not formalize the representation map here; however, its principles are quite straight-forward:
\begin{enumerate}
\item cartesion products of arguments were curried,
\item constants of type \inlineocl{T} were mapped to valuations over the
      HOL-type for \inlineocl{T},
\item functions \inlineocl{T -> T'} were mapped to functions in HOL, where
      \inlineocl{T} and  \inlineocl{T'}  were mapped to the valuations for them, and
\item the arguments of type constructors  \inlineocl{Set(T)} remain corresponding HOL base-types.
\end{enumerate}

\<close>

text\<open>Note, furthermore, that our construction of ``fully abstract types'' (no junk, no confusion)
assures that the logical equality to be defined in the next section works correctly and comes
as element of the ``lingua franca'', \ie{} HOL.\<close>

(*<*)
section\<open>Miscelleaneous: ML assertions\<close>

text\<open>We introduce here a new command \emph{Assert} similar as \emph{value} for proving
 that the given term in argument is a true proposition. The difference with \emph{value} is that
\emph{Assert} fails if the normal form of the term evaluated is not equal to @{term True}.
Moreover, in case \emph{value} could not normalize the given term, as another strategy of reduction
 we try to prove it with a single ``simp'' tactic.\<close>

ML\<open>
fun disp_msg title msg status = title ^ ": '" ^ msg ^ "' " ^ status

fun lemma msg specification_theorem concl in_local thy =
  SOME
    (in_local (fn lthy =>
           specification_theorem Thm.theoremK NONE (K I) Binding.empty_atts [] []
             (Element.Shows [(Binding.empty_atts, [(concl lthy, [])])])
             false lthy
        |> Proof.global_terminal_proof
             ((Method.Combinator ( Method.no_combinator_info
                                 , Method.Then
                                 , [Method.Basic (fn ctxt => SIMPLE_METHOD (asm_full_simp_tac ctxt 1))]),
               (Position.none, Position.none)), NONE))
              thy)
  handle ERROR s =>
    (warning s; writeln (disp_msg "KO" msg "failed to normalize"); NONE)

fun outer_syntax_command command_spec theory in_local =
  Outer_Syntax.command command_spec "assert that the given specification is true"
    (Parse.term >> (fn elems_concl => theory (fn thy =>
      case
        lemma "nbe" (Specification.theorem true)
          (fn lthy =>
            let val expr = Nbe.dynamic_value lthy (Syntax.read_term lthy elems_concl)
                val thy = Proof_Context.theory_of lthy
                open HOLogic in
            if Sign.typ_equiv thy (fastype_of expr, @{typ "prop"}) then
              expr
            else mk_Trueprop (mk_eq (@{term "True"}, expr))
            end)
          in_local
          thy
      of  NONE =>
            let val attr_simp = "simp" in
            case lemma attr_simp (Specification.theorem_cmd true) (K elems_concl) in_local thy of
               NONE => raise (ERROR "Assertion failed")
             | SOME thy =>
                (writeln (disp_msg "OK" "simp" "finished the normalization");
                 thy)
            end
        | SOME thy => thy)))

val () = outer_syntax_command @{command_keyword Assert} Toplevel.theory Named_Target.theory_map
val () = outer_syntax_command @{command_keyword Assert_local} (Toplevel.local_theory NONE NONE) I
\<close>
(*>*)

end


theory Topological_Dioid
  imports Dioid
begin

sublocale dioid \<subseteq> order_topology "dioid_canonic_order D" "dioid_canonic_strict_order D"
"generate_topology (range (ord.lessThan (dioid_canonic_strict_order D)) \<union>
   range (ord.greaterThan (dioid_canonic_strict_order D)))"
proof
  show P1 : "\<And>x y. (x <\<^bsub>D\<^esub> y) = (x \<le>\<^bsub>D\<^esub> y \<and> \<not> y \<le>\<^bsub>D\<^esub> x)"
    unfolding dioid_canonic_strict_order_def dioid_canonic_order_def factor_def apply auto
  proof (rule ccontr)
    fix x y z assume xyz : "x \<noteq> x \<oplus> y" "y \<in> carrier D" "x \<in> carrier D" "z \<in> carrier D" "x = x\<oplus>y\<oplus>z"
    from this have "\<zero> = y \<oplus> z "
      using a_comm_cancel_monoid
      by (metis add.m_assoc add.m_closed cancel r_zero zero_closed)
    hence A : "y \<le> \<zero>"
      unfolding dioid_canonic_order_def
      using xyz by auto
    moreover have B : "\<zero> \<le> y"
      unfolding dioid_canonic_order_def
      using xyz zero_closed add.Units_one_closed add.unit_divides
      by presburger
    ultimately have "\<zero> = y"
      using partial_order.le_antisym[OF canonically_ordered] xyz(2) zero_closed
      by (metis (no_types, lifting) gorder.select_convs(1) partial_object.select_convs(1))
    hence "x = x \<oplus> y" using xyz by auto
    thus False using xyz by auto
  qed
  show "\<And>x. x \<le>\<^bsub>D\<^esub> x" unfolding dioid_canonic_order_def by auto
  show "\<And>x y z. x \<le>\<^bsub>D\<^esub> y \<Longrightarrow> y \<le>\<^bsub>D\<^esub> z \<Longrightarrow> x \<le>\<^bsub>D\<^esub> z" unfolding dioid_canonic_order_def apply auto
    using add.divides_trans by blast
  show "\<And>x y. x \<le>\<^bsub>D\<^esub> y \<Longrightarrow> y \<le>\<^bsub>D\<^esub> x \<Longrightarrow> x = y"
    using partial_order.le_antisym[OF canonically_ordered] P1 apply simp
    unfolding dioid_canonic_order_def
    by blast
  show "generate_topology (range (ord.lessThan (dioid_canonic_strict_order D)) \<union>
                           range (ord.greaterThan (dioid_canonic_strict_order D))) =
        generate_topology (range (ord.lessThan (dioid_canonic_strict_order D)) \<union>
                           range (ord.greaterThan (dioid_canonic_strict_order D)))"
    by simp
qed

lemma (in dioid) topological_dioid :
"class.order_topology (dioid_canonic_order D) (dioid_canonic_strict_order D)
(generate_topology (range (ord.lessThan (dioid_canonic_strict_order D)) \<union>
   range (ord.greaterThan (dioid_canonic_strict_order D))))"
  using order_topology_axioms.

typedef 'a kr = "{R :: 'a ring. dioid R}"
proof
  fix x :: 'a
  show "(\<lparr>carrier =  {x}, monoid.mult = \<lambda>x y. y, one = x, zero = x, add = \<lambda>x y. y\<rparr>) \<in> {R. dioid R}"
  proof
    show "dioid \<lparr>carrier = {x}, monoid.mult = \<lambda>x y. y, one = x, zero = x, add = \<lambda>x y. y\<rparr>"
      apply unfold_locales apply auto unfolding dioid_canonic_order_def factor_def apply simp.
  qed
qed

datatype 'a extension = Infinity | Elt 'a

type_synonym N_ext = "nat extension"

instantiation  extension :: (plus) plus
begin
fun plus_extension where
"Infinity +  b  = Infinity "|
"a + Infinity = Infinity"|
"(Elt a) + (Elt b) = Elt (a + b)"
instance ..
end

record 'a top_dioid = "('a extension) ring" +
infinity :: " 'a extension" ("\<infinity>")

end


(*File: IMP.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory IMP imports Main begin
section \<open>The language IMP\<close>

text\<open>\label{sec:IMP}In this section we define a simple imperative programming
language. Syntax and operational semantics are as in \<^cite>\<open>"Winskel93"\<close>,
except that we enrich the language with a single unnamed,
parameterless procedure. Both, this section and the following one
merely set the basis for the development described in the later
sections and largely follow the approach to formalize program logics
advocated by Kleymann, Nipkow, and others - see for example
\<^cite>\<open>"KleymannPhD" and "Nipkow-CSL02" and "Nipkow-AFP-AHL"\<close>.\<close>

subsection\<open>Syntax\<close>

text\<open>We start from unspecified categories of program variables and
values.\<close>

typedecl Var
typedecl Val

text\<open>Arithmetic expressions are inductively built up from variables,
values, and binary operators which are modeled as meta-logical
functions over values. Similarly, boolean expressions are built up
from arithmetic expressions using binary boolean operators which are
modeled as functions of the ambient logic HOL.\<close>

datatype Expr =
   varE Var
 | valE Val
 | opE "Val \<Rightarrow> Val \<Rightarrow> Val" Expr Expr

datatype BExpr = compB "Val \<Rightarrow> Val \<Rightarrow> bool" Expr Expr

text\<open>Commands are the usual ones for an imperative language, plus the
command $\mathit{Call}$ which stands for the invocation of a single
(unnamed, parameterless) procedure.\<close>

datatype IMP =
    Skip
  | Assign Var Expr
  | Comp IMP IMP
  | While BExpr IMP
  | Iff BExpr IMP IMP
  | Call

text\<open>The body of this procedure is identified by the following
constant.\<close>

consts body :: IMP

subsection\<open>Dynamic semantics\<close>

text\<open>States are given by stores - in our case, HOL functions
mapping program variables to values.\<close>

type_synonym State = "Var \<Rightarrow> Val"

definition update :: "State \<Rightarrow> Var \<Rightarrow> Val \<Rightarrow> State"
where "update s x v = (\<lambda> y . if x=y then v else s y)"

text\<open>The evaluation of expressions is defined inductively, as
standard.\<close>

primrec evalE::"Expr \<Rightarrow> State \<Rightarrow> Val"
where
"evalE (varE x) s = s x" |
"evalE (valE v) s = v" |
"evalE (opE f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

primrec evalB::"BExpr \<Rightarrow> State \<Rightarrow> bool"
where
"evalB (compB f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

text\<open>The operational semantics is a standard big-step relation, with
a height index that facilitates the Kleymann-Nipkow-style~\<^cite>\<open>"KleymannPhD" and "Nipkow-CSL02"\<close>
soundness proof of the program logic.\<close>

inductive_set Semn :: "(State \<times> IMP \<times> nat \<times> State) set" where
 SemSkip: "(s,Skip,1,s) : Semn"

| SemAssign:
  "\<lbrakk> t = update s x (evalE e s)\<rbrakk> \<Longrightarrow> (s,Assign x e,1,t):Semn"

| SemComp:
  "\<lbrakk> (s,c1,n,r):Semn; (r,c2,m,t):Semn; k=(max n m)+1\<rbrakk>
   \<Longrightarrow> (s,Comp c1 c2,k,t):Semn"

| SemWhileT:
  "\<lbrakk>evalB b s; (s,c,n,r):Semn; (r,While b c,m,t):Semn;
       k=((max n m)+1)\<rbrakk>
   \<Longrightarrow> (s,While b c,k,t):Semn"

| SemWhileF: "\<lbrakk>\<not> (evalB b s); t=s\<rbrakk> \<Longrightarrow> (s,While b c,1,t):Semn"

| SemTrue:
  "\<lbrakk>evalB b s; (s,c1,n,t):Semn \<rbrakk> \<Longrightarrow> (s,Iff b c1 c2,n+1,t):Semn"

| SemFalse:
  "\<lbrakk>\<not> (evalB b s); (s,c2,n,t):Semn\<rbrakk> \<Longrightarrow> (s,Iff b c1 c2,n+1,t):Semn"

| SemCall: "(s,body,n,t):Semn \<Longrightarrow> (s,Call,n+1,t):Semn"
(*
 SemSkip:  "(s,Skip \<longrightarrow>\<^sub>1 s"
 SemAssign:"\<lbrakk> t = update s x (evalE e s)\<rbrakk> \<Longrightarrow> s,(Assign x e) \<longrightarrow>\<^sub>1 t"
SemComp:  "\<lbrakk> s,c1 \<longrightarrow>\<^sub>n r; r,c2 \<longrightarrow>\<^sub>m t; k=(max n m)+1\<rbrakk>
          \<Longrightarrow> s,(Comp c1 c2) \<longrightarrow>\<^sub>k t"
 SemWhileT:"\<lbrakk>evalB b s; s,c \<longrightarrow>\<^sub>n r; r,(While b c) \<longrightarrow>\<^sub>m t;
             k=((max n m)+1)\<rbrakk>
          \<Longrightarrow> s,(While b c) \<longrightarrow>\<^sub>k t"
 SemWhileF:"\<lbrakk>\<not> (evalB b s); t=s\<rbrakk> \<Longrightarrow> s,(While b c) \<longrightarrow>\<^sub>1 t"
 SemTrue:  "\<lbrakk>evalB b s; s,c1 \<longrightarrow>\<^sub>n t\<rbrakk> \<Longrightarrow> s,(Iff b c1 c2) \<longrightarrow>\<^sub>(n+1) t"
 SemFalse: "\<lbrakk>\<not> (evalB b s); s,c2 \<longrightarrow>\<^sub>n t\<rbrakk>
          \<Longrightarrow> s,(Iff b c1 c2) \<longrightarrow>\<^sub>(n+1) t"
 SemCall:  "\<lbrakk> s,body \<longrightarrow>\<^sub>n t\<rbrakk> \<Longrightarrow> s,Call \<longrightarrow>\<^sub>(n+1) t"
*)

abbreviation
SemN  :: "[State, IMP, nat, State] \<Rightarrow> bool"   (" _ , _ \<rightarrow>\<^sub>_  _ ")
where
"s,c \<rightarrow>\<^sub>n t == (s,c,n,t) : Semn"

text\<open>Often, the height index does not matter, so we define a notion
hiding it.\<close>

definition Sem :: "[State, IMP, State] \<Rightarrow> bool" ("_ , _ \<Down> _ " 1000)
where "s,c \<Down> t = (\<exists> n. s,c \<rightarrow>\<^sub>n t)"

text\<open>Inductive elimination rules for the (indexed) dynamic semantics:\<close>

inductive_cases Sem_eval_cases:
 "s,Skip \<rightarrow>\<^sub>n t"
 "s,(Assign x e) \<rightarrow>\<^sub>n t"
 "s,(Comp c1 c2) \<rightarrow>\<^sub>n t"
 "s,(While b c) \<rightarrow>\<^sub>n t"
 "s,(Iff b c1 c2) \<rightarrow>\<^sub>n t"
 "s, Call \<rightarrow>\<^sub>n t"

(*<*)
lemma Sem_no_zero_height_derivsAux: "\<forall> s t. ((s, c \<rightarrow>\<^sub>0 t) --> False)"
by (induct_tac c, auto elim: Sem_eval_cases)
(*>*)

text\<open>An induction on $c$ shows that no derivations of height
$0$ exist.\<close>

lemma Sem_no_zero_height_derivs: "(s, c \<rightarrow>\<^sub>0 t) ==> False"
(*<*)by (insert Sem_no_zero_height_derivsAux, fastforce)(*>*)

(*<*)
lemma SemnDeterm[rule_format]:
"(s, c \<rightarrow>\<^sub>n t) ==> (\<forall> r m . (s, c \<rightarrow>\<^sub>m r) --> m=n \<and> r=t)"
apply (erule Semn.induct)
apply(clarsimp, elim Sem_eval_cases, simp)
(*Assign*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
(*Comp*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
(*WhileT*)
apply (rule allI)+ apply rule
apply (rotate_tac 3) apply (erule thin_rl)
apply (erule Sem_eval_cases) apply clarify
  apply (rotate_tac -4)
  apply (erule_tac x=rb in allE) apply (erule_tac x=na in allE) apply clarsimp
  apply clarify
(*WhileF*)
apply (rule allI)+ apply rule
apply (erule Sem_eval_cases) apply clarify
  apply simp
(*True*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
apply fast
(*False*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply fast
apply simp
(*Call*)
apply clarify
apply(elim Sem_eval_cases)
apply simp
done
(*>*)

text\<open>The proof of determinism is by induction on the
      (indexed) operational semantics.\<close>

lemma SemDeterm: "\<lbrakk>s, c \<Down> t; s, c \<Down> r\<rbrakk> \<Longrightarrow> r=t"
(*<*)
apply (simp add: Sem_def, clarsimp)
apply (drule SemnDeterm, assumption)
apply simp
done
(*>*)

text\<open>End of theory IMP\<close>
end


(*  Title:      HOL/MicroJava/BV/LBVSpec.thy
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>The Lightweight Bytecode Verifier\<close>

theory LBVSpec
imports SemilatAlg Opt
begin

type_synonym
  's certificate = "'s list"

primrec merge :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> nat \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's \<Rightarrow> 's"
where
  "merge cert f r T pc []     x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
                                  if pc'=pc+1 then s' \<squnion>\<^sub>f x
                                  else if s' \<sqsubseteq>\<^sub>r cert!pc' then x
                                  else T)"

definition wtl_inst :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow>
              's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
where
  "wtl_inst cert f r T step pc s = merge cert f r T pc (step pc s) (cert!(pc+1))"

definition wtl_cert :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
              's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
where
  "wtl_cert cert f r T B step pc s =
  (if cert!pc = B then
    wtl_inst cert f r T step pc s
  else
    if s \<sqsubseteq>\<^sub>r cert!pc then wtl_inst cert f r T step pc (cert!pc) else T)"

primrec wtl_inst_list :: "'a list \<Rightarrow> 's certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
                    's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
where
  "wtl_inst_list []     cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s =
    (let s' = wtl_cert cert f r T B step pc s in
      if s' = T \<or> s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"

definition cert_ok :: "'s certificate \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> 's set \<Rightarrow> bool"
where
  "cert_ok cert n T B A \<longleftrightarrow> (\<forall>i < n. cert!i \<in> A \<and> cert!i \<noteq> T) \<and> (cert!n = B)"

definition bottom :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
where
  "bottom r B \<longleftrightarrow> (\<forall>x. B \<sqsubseteq>\<^sub>r x)"

locale lbv = Semilat +
  fixes T :: "'a" ("\<top>")
  fixes B :: "'a" ("\<bottom>")
  fixes step :: "'a step_type"
  assumes top: "top r \<top>"
  assumes T_A: "\<top> \<in> A"
  assumes bot: "bottom r \<bottom>"
  assumes B_A: "\<bottom> \<in> A"

  fixes merge :: "'a certificate \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a"
  defines mrg_def: "merge cert \<equiv> LBVSpec.merge cert f r \<top>"

  fixes wti :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wti_def: "wti cert \<equiv> wtl_inst cert f r \<top> step"

  fixes wtc :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wtc_def: "wtc cert \<equiv> wtl_cert cert f r \<top> \<bottom> step"

  fixes wtl :: "'b list \<Rightarrow> 'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wtl_def: "wtl ins cert \<equiv> wtl_inst_list ins cert f r \<top> \<bottom> step"

lemma (in lbv) wti:
  "wti c pc s = merge c pc (step pc s) (c!(pc+1))"
  (*<*) by (simp add: wti_def mrg_def wtl_inst_def) (*>*)

lemma (in lbv) wtc:
  "wtc c pc s = (if c!pc = \<bottom> then wti c pc s else if s \<sqsubseteq>\<^sub>r c!pc then wti c pc (c!pc) else \<top>)"
  (*<*) by (unfold wtc_def wti_def wtl_cert_def) rule (*>*)

lemma cert_okD1 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<in> A"
  (*<*) by (unfold cert_ok_def) fast (*>*)

lemma cert_okD2 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> c!n = B"
  (*<*) by (simp add: cert_ok_def) (*>*)

lemma cert_okD3 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> B \<in> A \<Longrightarrow> pc < n \<Longrightarrow> c!Suc pc \<in> A"
  (*<*) by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2) (*>*)

declare Let_def [simp]

subsection "more semilattice lemmas"

lemma (in lbv) sup_top [simp, elim]:
  assumes x: "x \<in> A"
  shows "x \<squnion>\<^sub>f \<top> = \<top>"
(*<*)
proof -
  from top have "x \<squnion>\<^sub>f \<top> \<sqsubseteq>\<^sub>r \<top>" ..
  moreover from x T_A have "\<top> \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f \<top>" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in lbv) plusplussup_top [simp, elim]:
  "set xs \<subseteq> A \<Longrightarrow> xs \<Squnion>\<^bsub>f\<^esub> \<top> = \<top>"
  by (induct xs) auto

lemma (in Semilat) pp_ub1':
  assumes S: "snd`set S \<subseteq> A"
  assumes y: "y \<in> A" and ab: "(a, b) \<in> set S"
  shows "b \<sqsubseteq>\<^sub>r map snd [(p', t') \<leftarrow> S . p' = a] \<Squnion>\<^bsub>f\<^esub> y"
(*<*)
proof -
  from S have "\<forall>(x,y) \<in> set S. y \<in> A" by auto
  with Semilat_axioms show ?thesis using y ab by (rule ub1')
qed
(*>*)

lemma (in lbv) bottom_le [simp, intro!]: "\<bottom> \<sqsubseteq>\<^sub>r x"
  by (insert bot) (simp add: bottom_def)

lemma (in lbv) le_bottom [simp]: "x \<sqsubseteq>\<^sub>r \<bottom> = (x = \<bottom>)"
  by (blast intro: antisym_r)

subsection "merge"

lemma (in lbv) merge_Nil [simp]:
  "merge c pc [] x = x" by (simp add: mrg_def)

lemma (in lbv) merge_Cons [simp]:
  "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
                                        else if snd l \<sqsubseteq>\<^sub>r c!fst l then x
                                        else \<top>)"
  by (simp add: mrg_def split_beta)

lemma (in lbv) merge_Err [simp]:
  "snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss \<top> = \<top>"
  by (induct ss) auto

lemma (in lbv) merge_not_top:
  "\<And>x. snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss x \<noteq> \<top> \<Longrightarrow>
  \<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc')"
  (is "\<And>x. ?set ss \<Longrightarrow> ?merge ss x \<Longrightarrow> ?P ss")
(*<*)
proof (induct ss)
  show "?P []" by simp
next
  fix x ls l
  assume "?set (l#ls)" then obtain set: "snd`set ls \<subseteq> A" by simp
  assume merge: "?merge (l#ls) x"
  moreover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  ultimately
  obtain x' where merge': "?merge ls x'" by simp
  assume "\<And>x. ?set ls \<Longrightarrow> ?merge ls x \<Longrightarrow> ?P ls" hence "?P ls" using set merge' .
  moreover
  from merge set
  have "pc' \<noteq> pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'" by (simp split: if_split_asm)
  ultimately show "?P (l#ls)" by simp
qed
(*>*)

lemma (in lbv) merge_def:
  shows
  "\<And>x. x \<in> A \<Longrightarrow> snd`set ss \<subseteq> A \<Longrightarrow>
  merge c pc ss x =
  (if \<forall>(pc',s') \<in> set ss. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc' then
    map snd [(p',t') \<leftarrow> ss. p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x
  else \<top>)"
  (is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?merge ss x = ?if ss x" is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?P ss x")
(*<*)
proof (induct ss)
  fix x show "?P [] x" by simp
next
  fix x assume x: "x \<in> A"
  fix l::"nat \<times> 'a" and ls
  assume "snd`set (l#ls) \<subseteq> A"
  then obtain l: "snd l \<in> A" and ls: "snd`set ls \<subseteq> A" by auto
  assume "\<And>x. x \<in> A \<Longrightarrow> snd`set ls \<subseteq> A \<Longrightarrow> ?P ls x"
  hence IH: "\<And>x. x \<in> A \<Longrightarrow> ?P ls x" using ls by iprover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  hence "?merge (l#ls) x = ?merge ls
    (if pc'=pc+1 then s' \<squnion>\<^sub>f x else if s' \<sqsubseteq>\<^sub>r c!pc' then x else \<top>)"
    (is "?merge (l#ls) x = ?merge ls ?if'")
    by simp
  also have "\<dots> = ?if ls ?if'"
  proof -
    from l have "s' \<in> A" by simp
    with x have "s' \<squnion>\<^sub>f x \<in> A" by simp
    with x T_A have "?if' \<in> A" by auto
    hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
  qed
  also have "\<dots> = ?if (l#ls) x"
    proof (cases "\<forall>(pc', s')\<in>set (l#ls). pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'")
      case True
      hence "\<forall>(pc', s')\<in>set ls. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'" by auto
      moreover
      from True have
        "map snd [(p',t') \<leftarrow> ls . p'=pc+1] \<Squnion>\<^bsub>f\<^esub> ?if' =
        (map snd [(p',t') \<leftarrow> l#ls . p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x)"
        by simp
      ultimately
      show ?thesis using True by simp
    next
      case False
      moreover
      from ls have "set (map snd [(p', t') \<leftarrow> ls . p' = Suc pc]) \<subseteq> A" by auto
      ultimately show ?thesis by auto
    qed
  finally show "?P (l#ls) x" .
qed
(*>*)

lemma (in lbv) merge_not_top_s:
  assumes x:  "x \<in> A" and ss: "snd`set ss \<subseteq> A"
  assumes m:  "merge c pc ss x \<noteq> \<top>"
  shows "merge c pc ss x = (map snd [(p',t') \<leftarrow> ss. p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x)"
(*<*)
proof -
  from ss m have "\<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc')"
    by (rule merge_not_top)
  with x ss m show ?thesis by - (drule merge_def, auto split: if_split_asm)
qed
(*>*)

subsection "wtl-inst-list"

lemmas [iff] = not_Err_eq

lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
  by (simp add: wtl_def)

lemma (in lbv) wtl_Cons [simp]:
  "wtl (i#is) c pc s =
  (let s' = wtc c pc s in if s' = \<top> \<or> s = \<top> then \<top> else wtl is c (pc+1) s')"
  by (simp add: wtl_def wtc_def)

lemma (in lbv) wtl_Cons_not_top:
  "wtl (i#is) c pc s \<noteq> \<top> =
  (wtc c pc s \<noteq> \<top> \<and> s \<noteq> T \<and> wtl is c (pc+1) (wtc c pc s) \<noteq> \<top>)"
  by (auto simp del: split_paired_Ex)

lemma (in lbv) wtl_top [simp]:  "wtl ls c pc \<top> = \<top>"
  by (cases ls) auto

lemma (in lbv) wtl_not_top:
  "wtl ls c pc s \<noteq> \<top> \<Longrightarrow> s \<noteq> \<top>"
  by (cases "s=\<top>") auto

lemma (in lbv) wtl_append [simp]:
  "\<And>pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
  by (induct a) auto

lemma (in lbv) wtl_take:
  "wtl is c pc s \<noteq> \<top> \<Longrightarrow> wtl (take pc' is) c pc s \<noteq> \<top>"
  (is "?wtl is \<noteq> _ \<Longrightarrow> _")
(*<*)
proof -
  assume "?wtl is \<noteq> \<top>"
  hence "?wtl (take pc' is @ drop pc' is) \<noteq> \<top>" by simp
  thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed
(*>*)

lemma take_Suc:
  "\<forall>n. n < length l \<longrightarrow> take (Suc n) l = (take n l)@[l!n]" (is "?P l")
(*<*)
proof (induct l)
  show "?P []" by simp
next
  fix x xs assume IH: "?P xs"
  show "?P (x#xs)"
  proof (intro strip)
    fix n assume "n < length (x#xs)"
    with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
      by (cases n, auto)
  qed
qed
(*>*)

lemma (in lbv) wtl_Suc:
  assumes suc: "pc+1 < length is"
  assumes wtl: "wtl (take pc is) c 0 s \<noteq> \<top>"
  shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
(*<*)
proof -
  from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
  with suc wtl show ?thesis by (simp add: min_def)
qed
(*>*)

lemma (in lbv) wtl_all:
  assumes all: "wtl is c 0 s \<noteq> \<top>" (is "?wtl is \<noteq> _")
  assumes pc:  "pc < length is"
  shows  "wtc c pc (wtl (take pc is) c 0 s) \<noteq> \<top>"
(*<*)
proof -
  from pc have "0 < length (drop pc is)" by simp
  then  obtain i r where Cons: "drop pc is = i#r"
    by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
  hence "i#r = drop pc is" ..
  with all have take: "?wtl (take pc is@i#r) \<noteq> \<top>" by simp
  from pc have "is!pc = drop pc is ! 0" by simp
  with Cons have "is!pc = i" by simp
  with take pc show ?thesis by (auto simp add: min_def split: if_split_asm)
qed
(*>*)

subsection "preserves-type"

lemma (in lbv) merge_pres:
  assumes s0: "snd`set ss \<subseteq> A" and x: "x \<in> A"
  shows "merge c pc ss x \<in> A"
(*<*)
proof -
  from s0 have "set (map snd [(p', t') \<leftarrow> ss . p'=pc+1]) \<subseteq> A" by auto
  with x semilat Semilat_axioms  have "(map snd [(p', t') \<leftarrow> ss . p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x) \<in> A"
    by (auto intro!: plusplus_closed)
  with s0 x show ?thesis by (simp add: merge_def T_A)
qed
(*>*)

lemma pres_typeD2:
  "pres_type step n A \<Longrightarrow> s \<in> A \<Longrightarrow> p < n \<Longrightarrow> snd`set (step p s) \<subseteq> A"
  by auto (drule pres_typeD)

lemma (in lbv) wti_pres [intro?]:
  assumes pres: "pres_type step n A"
  assumes cert: "c!(pc+1) \<in> A"
  assumes s_pc: "s \<in> A" "pc < n"
  shows "wti c pc s \<in> A"
(*<*)
proof -
  from pres s_pc have "snd`set (step pc s) \<subseteq> A" by (rule pres_typeD2)
  with cert show ?thesis by (simp add: wti merge_pres)
qed
(*>*)

lemma (in lbv) wtc_pres:
  assumes "pres_type step n A"
  assumes "c!pc \<in> A" and "c!(pc+1) \<in> A"
  assumes "s \<in> A" and "pc < n"
  shows "wtc c pc s \<in> A"
(*<*)
proof -
  have "wti c pc s \<in> A" using assms(1,3-5) ..
  moreover have "wti c pc (c!pc) \<in> A" using assms(1,3,2,5) ..
  ultimately show ?thesis using T_A by (simp add: wtc)
qed
(*>*)

lemma (in lbv) wtl_pres:
  assumes pres: "pres_type step (length is) A"
  assumes cert: "cert_ok c (length is) \<top> \<bottom> A"
  assumes s:    "s \<in> A"
  assumes all:  "wtl is c 0 s \<noteq> \<top>"
  shows "pc < length is \<Longrightarrow> wtl (take pc is) c 0 s \<in> A"
  (is "?len pc \<Longrightarrow> ?wtl pc \<in> A")
(*<*)
proof (induct pc)
  from s show "?wtl 0 \<in> A" by simp
next
  fix n assume Suc_n: "Suc n < length is"
  hence n1: "n+1 < length is" by simp
  then obtain n: "n < length is" by simp
  assume "n < length is \<Longrightarrow> ?wtl n \<in> A"
  hence "?wtl n \<in> A" using n .
  from pres _ _ this n
  have "wtc c n (?wtl n) \<in> A"
  proof (rule wtc_pres)
    from cert n show "c!n \<in> A" by (rule cert_okD1)
    from cert n1 show "c!(n+1) \<in> A" by (rule cert_okD1)
  qed
  also
  from all n have "?wtl n \<noteq> \<top>" by - (rule wtl_take)
  with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
  finally  show "?wtl (Suc n) \<in> A" by simp
qed
(*>*)

end


theory Optimized_Agg
  imports Monitor
begin

type_synonym 'a agg_map = "(event_data tuple, 'a) mapping"

datatype aggaux' = CntAux nat

datatype aggaux = CntAux "nat agg_map" | SumAux "(nat \<times> event_data) agg_map" | MinAux "event_data table"
  | MaxAux "event_data table" | MedAux "event_data table"

definition group_multiset where
  "group_multiset k b f X = (let group = Set.filter (\<lambda>x. drop b x = k) X in
                      (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group)"

definition valid_aggmap :: "(event_data list \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> Formula.trm \<Rightarrow> (event_data option list, 'a) mapping \<Rightarrow> event_data option list set \<Rightarrow> bool" where
  "valid_aggmap g b f m X \<longleftrightarrow> (\<forall>k. k \<in> (drop b) ` X \<longleftrightarrow> k \<in> Mapping.keys m) \<and>
                    (\<forall>k. k \<in> Mapping.keys m \<longrightarrow> Mapping.lookup m k =
                    (let M = group_multiset k b f X
                    in Some (g (flatten_multiset M))))"

fun valid_maggaux :: "aggargs \<Rightarrow> aggaux \<Rightarrow> event_data table \<Rightarrow> bool" where
  "valid_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> aux X =
  (finite X \<and>
  (let aggtype = fst \<omega> in case aux of
      CntAux m \<Rightarrow>
        (aggtype = Formula.Agg_Cnt) \<and>
        (valid_aggmap (\<lambda>k. length k) b f m X)
    | SumAux m \<Rightarrow> (aggtype = Formula.Agg_Sum \<or> aggtype = Formula.Agg_Avg) \<and>
                  (let y0 = (if aggtype = Formula.Agg_Sum then snd \<omega> else EInt 0) in
                  (valid_aggmap (\<lambda>k. (length k, foldl plus y0 k)) b f m X))
    | MinAux t \<Rightarrow> (aggtype = Formula.Agg_Min) \<and> t = X
    | MaxAux t \<Rightarrow> (aggtype = Formula.Agg_Max) \<and> t = X
    | MedAux t \<Rightarrow> (aggtype = Formula.Agg_Med) \<and> t = X))"

fun init_maggaux :: "aggargs \<Rightarrow> aggaux" where
  "init_maggaux args =
  (let aggtype = fst (aggargs_\<omega> args) in case aggtype of
      Formula.Agg_Cnt \<Rightarrow> CntAux Mapping.empty
    | Formula.Agg_Sum \<Rightarrow> SumAux Mapping.empty
    | Formula.Agg_Min \<Rightarrow> MinAux {}
    | Formula.Agg_Max \<Rightarrow> MaxAux {}
    | Formula.Agg_Avg \<Rightarrow> SumAux Mapping.empty
    | Formula.Agg_Med \<Rightarrow> MedAux {})"

fun insert_cnt :: "aggargs \<Rightarrow> nat agg_map \<Rightarrow> event_data tuple \<Rightarrow> nat agg_map" where
  "insert_cnt args m t = (let group = drop (aggargs_b args) t
                       in case (Mapping.lookup m group) of
                        Some i \<Rightarrow> Mapping.update group (i + 1) m
                      | None \<Rightarrow> Mapping.update group 1 m)"

fun insert_sum :: "aggargs \<Rightarrow> event_data \<Rightarrow> (nat \<times> event_data) agg_map \<Rightarrow> event_data tuple \<Rightarrow> (nat \<times> event_data) agg_map" where
  "insert_sum args y0 m t = (let group = drop (aggargs_b args) t;
                                         term = meval_trm (aggargs_f args) t
                                     in case (Mapping.lookup m group) of
                        Some (cnt, agg_sum) \<Rightarrow> Mapping.update group (cnt + 1, agg_sum + term) m
                      | None \<Rightarrow> Mapping.update group (1, y0 + term) m)"

fun insert_maggaux :: "aggargs \<Rightarrow> event_data table \<Rightarrow> aggaux \<Rightarrow> aggaux" where
  "insert_maggaux args data aux = (case aux of
    CntAux m \<Rightarrow> CntAux (foldl (insert_cnt args) m (csorted_list_of_set data))
  | SumAux m \<Rightarrow> let y0 = snd (aggargs_\<omega> args) in SumAux (foldl (insert_sum args y0) m (csorted_list_of_set data))
  | MinAux t \<Rightarrow> MinAux (t \<union> data)
  | MaxAux t \<Rightarrow> MaxAux (t \<union> data)
  | MedAux t \<Rightarrow> MedAux (t \<union> data))"

fun delete_cnt :: "nat \<Rightarrow> nat agg_map \<Rightarrow> event_data tuple \<Rightarrow> nat agg_map" where
  "delete_cnt b m t = (let group = drop b t
                       in case (Mapping.lookup m group) of
                         Some i \<Rightarrow> (if i = 1 then Mapping.delete group m
                                    else Mapping.update group (i - 1) m)
                       | None \<Rightarrow> m)"

fun delete_sum :: "aggargs \<Rightarrow> (nat \<times> event_data) agg_map \<Rightarrow> event_data tuple \<Rightarrow> (nat \<times> event_data) agg_map" where
  "delete_sum args m t = (let group = drop (aggargs_b args) t;
                              term = meval_trm (aggargs_f args) t
                          in case (Mapping.lookup m group) of
                            Some (cnt, agg_sum) \<Rightarrow> (if cnt = 1 then Mapping.delete group m
                                                    else Mapping.update group (cnt - 1, agg_sum - term) m)
                          | None \<Rightarrow> m)"

fun delete_maggaux :: "aggargs \<Rightarrow> event_data table \<Rightarrow> aggaux \<Rightarrow> aggaux" where
  "delete_maggaux args data aux = (case aux of
    CntAux m \<Rightarrow> CntAux (foldl (delete_cnt (aggargs_b args)) m (csorted_list_of_set data))
  | SumAux m \<Rightarrow> SumAux (foldl (delete_sum args) m (csorted_list_of_set data))
  | MinAux t \<Rightarrow> MinAux (t - data)
  | MaxAux t \<Rightarrow> MaxAux (t - data)
  | MedAux t \<Rightarrow> MedAux (t - data))"

fun result_maggaux :: "aggargs \<Rightarrow> aggaux \<Rightarrow> event_data table" where
  "result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> aux = (case aux of
    CntAux m \<Rightarrow> (if g0 \<and> Mapping.keys m = {}
                then singleton_table n y (eval_agg_op \<omega> {})
                else (\<lambda>k. (case Mapping.lookup m k of
                             Some i \<Rightarrow> k[y:=Some (EInt (integer_of_int i))]
                           | None \<Rightarrow> k))` Mapping.keys m)
  | SumAux m \<Rightarrow> (if g0 \<and> Mapping.keys m = {}
                      then singleton_table n y (eval_agg_op \<omega> {})
                      else if fst \<omega> = Formula.Agg_Sum
                      then (\<lambda>k. (case Mapping.lookup m k of
                                   Some (_, agg_sum) \<Rightarrow> k[y:=Some agg_sum]
                                 | None \<Rightarrow> k)) ` Mapping.keys m
                      else (\<lambda>k. (case Mapping.lookup m k of
                                   Some (cnt, agg_sum) \<Rightarrow> k[y:=Some (EFloat ((double_of_event_data agg_sum) / (double_of_int cnt)))]
                                 | None \<Rightarrow> k)) ` Mapping.keys m)
  | MinAux t \<Rightarrow> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> t
  | MaxAux t \<Rightarrow> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> t
  | MedAux t \<Rightarrow> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> t)"

lemma valid_init_maggaux_unfolded: "safe_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> \<Longrightarrow> valid_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (init_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr>) {}"
  by (cases "fst \<omega>") (auto simp add:valid_aggmap_def)

lemma valid_init_maggaux: "safe_aggargs args \<Longrightarrow> valid_maggaux args (init_maggaux args) {}"
  using valid_init_maggaux_unfolded by (cases args) fast

primrec iter_f :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  where
    "iter_f f 0 t y0 = y0"
  | "iter_f f (Suc n) t y0 = f t (iter_f f n t y0)"

lemma iter_f_comm:
  assumes commute_f: "comp_fun_commute f"
  shows "iter_f f n1 t1 (iter_f f n2 t2 y0) = iter_f f n2 t2 (iter_f f n1 t1 y0)"
proof(induction n1)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case sorry
qed

lemma fold_flatten_multiset:
  assumes finite_m: "finite M"
  assumes commute_f: "comp_fun_commute f"
  shows "fold f (flatten_multiset M) y0  = Finite_Set.fold (\<lambda> (t, m) y. iter_f f (the_enat m) t y) y0 M"
proof -
  interpret comp_fun_commute "\<lambda> (t, m) y. iter_f f (the_enat m) t y"
    using iter_f_comm[of f] commute_f
    by unfold_locales auto
  obtain c where c_def: "ID ccompare = Some (c :: (event_data \<times> enat) comparator)"
    by (simp add: ID_def ccompare_prod_def ccompare_event_data_def ccompare_enat_def split:if_splits option.splits)
  note c = ID_ccompare'[OF c_def]
  note c_class = comparator.linorder[OF c]
  show ?thesis
    using finite_m
  proof(induction M)
    case empty
    then show ?case
      using linorder.sorted_list_of_set_empty[OF c_class]
      by (auto simp add:flatten_multiset_def csorted_list_of_set_def c_def)
  next
    case (insert x F)
    obtain t m where "x = (t, m)"
      by (cases x) auto
    then show ?case
      using insert(1-2) insert(3)[symmetric] linorder.sorted_list_of_set_insert[OF c_class]
      apply(simp add:flatten_multiset_def csorted_list_of_set_def c_def) sorry
  qed
qed

lemma length_fold: "length xs = fold (\<lambda> _ n. n + 1) xs 0"
  by (induction xs) (auto simp:fold_commute_apply)

lemma iter_f_len: "iter_f (\<lambda> _. Suc) m t y = y + m"
  by (induction m) auto

lemma length_flatten_multiset:
  assumes "finite M"
  shows "length (flatten_multiset M) = Finite_Set.fold (\<lambda> (t, m) y. y + (the_enat m)) 0 M"
  using length_fold[of "flatten_multiset M"] by (simp add: fold_flatten_multiset assms comp_fun_commute.intro iter_f_len)

lemma valid_insert_cnt_unfolded:
  assumes valid_before: "valid_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (CntAux m) X"
  and correct_type: "type_restr \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> {elem}"
  and disjoint: "elem \<notin> X"
shows "valid_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr>
        (CntAux (insert_cnt \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> m elem)) (X \<union> {elem})"
proof -
  define updated_map where "updated_map = insert_cnt \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> m elem"
  define updated_data where "updated_data = X \<union> {elem}"
  interpret comp_fun_commute "\<lambda>(t, m) y. y + the_enat m"
    by(unfold_locales) auto
  have valid_finite: "finite updated_data" using valid_before by (auto simp:updated_data_def)
  have valid_key_invariant: "\<And>k. k \<in> (drop b) ` updated_data \<longleftrightarrow> k \<in> Mapping.keys updated_map"
  proof (rule iffI)
    fix k
    assume assm: "k \<in> (drop b) ` updated_data"
    show "k \<in>  Mapping.keys updated_map"
      using valid_before assm
      unfolding updated_map_def updated_data_def
      by (cases "k \<in> (drop b) ` X") (auto simp: valid_aggmap_def Let_def split:option.splits)
  next
    fix k
    assume assm: "k \<in> Mapping.keys updated_map"
    show "k \<in> (drop b) ` updated_data"
      using valid_before assm
      unfolding updated_map_def updated_data_def
      by (cases "k \<in> Mapping.keys m") (auto simp: valid_aggmap_def Let_def split:option.splits)
  qed
  have valid_value_invariant: "\<And>k. k \<in> Mapping.keys updated_map \<longrightarrow> Mapping.lookup updated_map k =
          (let group = Set.filter (\<lambda>x. drop b x = k) updated_data;
           M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group
          in Some (length (flatten_multiset M)))"
  proof rule
    fix k
    define group where "group = Set.filter (\<lambda>x. drop b x = k) updated_data"
    define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
    define old_group where "old_group = Set.filter (\<lambda>x. drop b x = k) X"
    define old_M where "old_M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) old_group))) ` meval_trm f ` old_group"
    assume assm: "k \<in> Mapping.keys updated_map"
    show "Mapping.lookup updated_map k =
          (let group = Set.filter (\<lambda>x. drop b x = k) updated_data;
           M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group
          in Some (length (flatten_multiset M)))"
    proof (cases "k \<in> Mapping.keys m")
      case False
      then have map_val: "Mapping.lookup updated_map k = Some 1"
        using assm by (auto simp: updated_map_def keys_is_none_rep Let_def lookup_update' split:option.splits)
      have "drop b elem = k"
        using assm False
        by(auto simp: updated_map_def Let_def split:option.splits)
      then have group_single_elem: "group = {elem}"
        using False valid_before image_iff
        by(fastforce simp: group_def updated_data_def valid_aggmap_def)
      then have "M = insert (meval_trm f elem, enat 1) {}"
        using group_single_elem unfolding M_def Set.filter_def ecard_def by (auto cong: conj_cong)
      then have "length(flatten_multiset M) = 1"
        using length_flatten_multiset[of M] Finite_Set.comp_fun_commute.fold_insert by(auto)
      then show ?thesis using map_val by (simp add: M_def local.group_def)
    next
      case True
      then show ?thesis sorry

    qed
  qed
  show ?thesis using valid_value_invariant valid_key_invariant valid_finite valid_before
    by (auto simp add:updated_data_def valid_aggmap_def updated_map_def group_multiset_def Let_def)
qed

lemma valid_aggmap_empty_data: "valid_aggmap g b f m X \<Longrightarrow> X = {} \<longleftrightarrow> Mapping.keys m = {}"
  by (auto simp:valid_aggmap_def)

lemma flatten_multiset_not_empty:
  assumes valid_map: "valid_aggmap g b f m X"
  and finite: "finite X"
  and in_map: "k \<in> Mapping.keys m"
  shows "flatten_multiset (group_multiset k b f X) \<noteq> []"
proof -
  define M where "M = group_multiset k b f X"
  obtain c where c_def: "ID ccompare = Some (c :: (event_data \<times> enat) comparator)"
    by (simp add: ID_def ccompare_prod_def ccompare_event_data_def ccompare_enat_def split:if_splits option.splits)
  note c = ID_ccompare'[OF c_def]
  note c_class = comparator.linorder[OF c]
  define M_list where "M_list = linorder.sorted_list_of_set (le_of_comp c) M"
  obtain elem where elem_prop: "elem \<in> X \<and> drop b elem = k" using in_map valid_map imageE[of k "drop b" X] by (auto simp: valid_aggmap_def)
  then obtain m where m_prop: "(meval_trm f elem, m) \<in> M"
    by (auto simp: group_multiset_def Let_def valid_aggmap_def M_def) fastforce
  define group where "group = Set.filter (\<lambda>x. meval_trm f x = meval_trm f elem) (Set.filter (\<lambda>x. drop b x = k) X)"
  then have "elem \<in> group" using elem_prop by (auto simp: group_def)
  moreover have finite_g: "finite group" using finite by (auto simp: group_def)
  ultimately have "ecard group \<noteq> 0" by (auto simp:ecard_def zero_enat_def)
  then have m_pos: "m > 0 \<and> m \<noteq> \<infinity>"
    using elem_prop m_prop finite_g  by (auto simp: M_def group_multiset_def Let_def group_def ecard_def)
  then have "the_enat m > 0"
    apply(auto simp: the_enat_def)
    using enat_0_iff(1) by blast
  then obtain n where n_def: "the_enat m = Suc n" using gr0_implies_Suc by auto
  have finite_m: "finite M" using finite by (auto simp: M_def group_multiset_def Let_def)
  then have "(meval_trm f elem, m) \<in> set (linorder.sorted_list_of_set (le_of_comp c) M)"
    using m_prop linorder.set_sorted_list_of_set[OF c_class] by auto
  then show ?thesis
    using finite_m n_def by (simp add:flatten_multiset_def csorted_list_of_set_def c_def M_def) force
qed

lemma valid_result_maggaux_unfolded: "valid_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> aux X
                                  \<Longrightarrow> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> aux
                                    = eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
proof(induction aux)
  case(SumAux m)
  then show ?case
  proof (cases "g0 \<and> X = {}")
    case True
    then show ?thesis unfolding eval_aggargs_def eval_agg_def using SumAux
      by (auto simp add: valid_aggmap_def)
  next
    case False
    then have assm_map: "\<not>(g0 \<and> Mapping.keys m = {})" using valid_aggmap_empty_data[of _ b f m X] SumAux by force
    have assm_reg: "\<not>(g0 \<and> X = {})" using False by auto
    show ?thesis
    proof (cases "fst \<omega> = Formula.Agg_Sum")
      case True
      show ?thesis
      proof (rule set_eqI, rule iffI)
      fix result
      assume "result \<in> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (SumAux m)"
      then obtain k where k_assm: "k \<in> Mapping.keys m \<and> result = (case Mapping.lookup m k of
                                                      Some (_, agg_sum) \<Rightarrow> k[y:=Some agg_sum]
                                                    | None \<Rightarrow> k)" using assm_map True by auto
      define group where "group = Set.filter (\<lambda>x. drop b x = k) X"
      define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
      have "Mapping.lookup m k = Some (length (flatten_multiset M), foldl plus (snd \<omega>) (flatten_multiset M))"
        using SumAux k_assm True by (simp add: M_def group_def Let_def lookup_default_def valid_aggmap_def group_multiset_def)
      then have "result = k[y:= Some (eval_agg_op \<omega> M)]"
        using k_assm True by auto (metis eval_agg_op.simps(4) prod.collapse)
      then show "result \<in> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
        using k_assm SumAux by (auto simp add: M_def group_def Let_def eval_agg_def eval_aggargs_def valid_aggmap_def)
    next
      fix result
      assume "result \<in> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
      then obtain k where k_assm: "(k \<in> (drop b) ` X \<and> result = (let group = Set.filter (\<lambda>x. drop b x = k) X;
                                                                   M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group
                                                                 in k[y:=Some (eval_agg_op \<omega> M)]))"
        unfolding eval_aggargs_def eval_agg_def empty_table_def using False by auto
      define group where "group = Set.filter (\<lambda>x. drop b x = k) X"
      define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
      have key_in_map: "k \<in> Mapping.keys m"
        using SumAux by (auto simp add:valid_aggmap_def) (metis k_assm)
      then have "Mapping.lookup m k = Some (length (flatten_multiset M), foldl plus (snd \<omega>) (flatten_multiset M))"
        using SumAux True by (simp add: M_def group_def Let_def lookup_default_def valid_aggmap_def group_multiset_def)
      then have "result = (case Mapping.lookup m k of
                            Some (_, agg_sum) \<Rightarrow> k[y:=Some agg_sum]
                          | None \<Rightarrow> k)"
        using True k_assm unfolding M_def group_def by auto (metis (no_types, lifting) eval_agg_op.simps(4) prod.exhaust_sel)
      then show  "result \<in> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (SumAux m)"
        using key_in_map True by auto
    qed
    next
      case False
      then have agg_type: "fst \<omega> = Formula.Agg_Avg" using SumAux by auto
      obtain aux where aux_def: "\<omega> = (Formula.Agg_Avg, aux)" using agg_type
        by (simp add: prod_eq_iff)
      show ?thesis
      proof (rule set_eqI, rule iffI)
      fix result
      assume "result \<in> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (SumAux m)"
      then obtain k where k_assm: "k \<in> Mapping.keys m \<and> result = (case Mapping.lookup m k of
                                                      Some (cnt, agg_sum) \<Rightarrow> k[y:=Some (EFloat ((double_of_event_data agg_sum) / (double_of_int cnt)))]
                                                    | None \<Rightarrow> k)" using assm_map agg_type by auto
      define group where "group = Set.filter (\<lambda>x. drop b x = k) X"
      define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
      have not_empty: "flatten_multiset M \<noteq> []"
        using flatten_multiset_not_empty[of _ b f m X k] SumAux k_assm False
        by (auto simp: Let_def M_def group_multiset_def group_def)
      have "Mapping.lookup m k = Some (length (flatten_multiset M), foldl plus (EInt 0) (flatten_multiset M))"
        using SumAux k_assm agg_type by (simp add: M_def group_def Let_def lookup_default_def valid_aggmap_def group_multiset_def)
      then have "result = k[y:= Some (eval_agg_op \<omega> M)]"
        using k_assm agg_type not_empty SumAux aux_def
        by(auto simp add:valid_aggmap_def Let_def M_def group_def group_multiset_def split:list.splits)
      then show "result \<in> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
        using k_assm SumAux by (auto simp add: M_def group_def Let_def eval_agg_def eval_aggargs_def valid_aggmap_def)
    next
      fix result
      assume "result \<in> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
      then obtain k where k_assm: "(k \<in> (drop b) ` X \<and> result = (let group = Set.filter (\<lambda>x. drop b x = k) X;
                                                                   M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group
                                                                 in k[y:=Some (eval_agg_op \<omega> M)]))"
        unfolding eval_aggargs_def eval_agg_def empty_table_def using assm_reg by auto
      define group where "group = Set.filter (\<lambda>x. drop b x = k) X"
      define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
      have "k \<in> Mapping.keys m" using k_assm SumAux
      by (metis (no_types, lifting) aggaux.simps(27) valid_aggmap_def valid_maggaux.simps)
      then have not_empty: "flatten_multiset M \<noteq> []"
        using flatten_multiset_not_empty[of _ b f m X k] SumAux k_assm False
        unfolding group_multiset_def Let_def M_def group_def by fastforce
      have key_in_map: "k \<in> Mapping.keys m"
        using SumAux by (auto simp add:valid_aggmap_def) (metis k_assm)
      then have "Mapping.lookup m k = Some (length (flatten_multiset M), foldl plus (EInt 0) (flatten_multiset M))"
        using SumAux False by (simp add: M_def group_def Let_def lookup_default_def valid_aggmap_def group_multiset_def)
      then have "result = (case Mapping.lookup m k of
                             Some (cnt, agg_sum) \<Rightarrow> k[y:=Some (EFloat ((double_of_event_data agg_sum) / (double_of_int cnt)))]
                          | None \<Rightarrow> k)"
        using False k_assm not_empty aux_def unfolding M_def group_def
        by(auto simp: Let_def split:list.splits)
      then show  "result \<in> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (SumAux m)"
        using key_in_map False by auto
    qed
  qed
qed
next
  case(MinAux x)
  then show ?case by auto
next
  case(MaxAux x)
  then show ?case by auto
next
  case(MedAux x)
  then show ?case by auto
next
  case(CntAux m)
  have agg_type: "fst \<omega> = Formula.Agg_Cnt" using CntAux by auto
  then show ?case
  proof (cases "g0 \<and> X = {}")
    case(True)
    then show ?thesis
      unfolding eval_aggargs_def eval_agg_def
      using CntAux by (auto simp add: valid_aggmap_def)
  next
    case(False)
    then have assm_map: "\<not>(g0 \<and> Mapping.keys m = {})" using CntAux by (auto simp add: valid_aggmap_def)
    show ?thesis
    proof (rule set_eqI, rule iffI)
      fix result
      assume "result \<in> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (CntAux m)"
      then have "\<exists>k. k \<in> Mapping.keys m \<and> result = (case Mapping.lookup m k of
                                                      Some i \<Rightarrow> k[y:=Some (EInt (integer_of_int i))]
                                                    | None \<Rightarrow> k)"
        using assm_map by auto
      then obtain k where k_assm: "k \<in> Mapping.keys m \<and> result = (case Mapping.lookup m k of
                                                      Some i \<Rightarrow> k[y:=Some (EInt (integer_of_int i))]
                                                    | None \<Rightarrow> k)" by blast
      define group where "group = Set.filter (\<lambda>x. drop b x = k) X"
      define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
      have "Mapping.lookup m k = Some (length (flatten_multiset M))"
        using CntAux k_assm
        by (simp add: M_def group_def Let_def lookup_default_def valid_aggmap_def group_multiset_def)
      then have "result = k[y:= Some (eval_agg_op \<omega> M)]"
        using k_assm agg_type
        by (metis eval_agg_op.simps(1) option.simps(5) prod.collapse)
      then show "result \<in> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
        using k_assm CntAux
        by (auto simp add: M_def group_def Let_def eval_agg_def eval_aggargs_def valid_aggmap_def)
    next
      fix result
      assume "result \<in> eval_aggargs \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> X"
      then have "\<exists>k. (k \<in> (drop b) ` X \<and> result = (let group = Set.filter (\<lambda>x. drop b x = k) X;
                                                     M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group
                                                   in k[y:=Some (eval_agg_op \<omega> M)]))"
        unfolding eval_aggargs_def eval_agg_def empty_table_def
        using False by auto
      then obtain k where k_assm: "(k \<in> (drop b) ` X \<and> result = (let group = Set.filter (\<lambda>x. drop b x = k) X;
                                                                   M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group
                                                                 in k[y:=Some (eval_agg_op \<omega> M)]))" by blast
      define group where "group = Set.filter (\<lambda>x. drop b x = k) X"
      define M where "M = (\<lambda>y. (y, ecard (Set.filter (\<lambda>x. meval_trm f x = y) group))) ` meval_trm f ` group"
      have key_in_map: "k \<in> Mapping.keys m"
        using CntAux k_assm by (auto simp add:valid_aggmap_def)
      then have "Mapping.lookup m k = Some (length (flatten_multiset M))"
        using CntAux
        by (simp add: M_def group_def Let_def lookup_default_def valid_aggmap_def group_multiset_def)
      then have "result = (case Mapping.lookup m k of
                             Some i \<Rightarrow> k[y:=Some (EInt (integer_of_int i))]
                           | None \<Rightarrow> k)"
        using agg_type k_assm
        unfolding M_def group_def
        by (metis (no_types, lifting) eval_agg_op.simps(1) option.simps(5) prod.collapse)
      then show  "result \<in> result_maggaux \<lparr>aggargs_cols = cols, aggargs_n = n, aggargs_g0 = g0, aggargs_y = y, aggargs_\<omega> = \<omega>, aggargs_b = b, aggargs_f = f\<rparr> (CntAux m)"
        using key_in_map by auto
    qed
  qed
qed

lemma valid_result_maggaux: "valid_maggaux args aux X \<Longrightarrow> result_maggaux args aux = eval_aggargs args X"
  using valid_result_maggaux_unfolded by (cases args) fast

end


theory ArityAnalysisStack
imports "SestoftConf" "ArityAnalysisSig"
begin

context ArityAnalysis
begin
  fun AEstack :: "Arity list \<Rightarrow> stack \<Rightarrow> AEnv"
    where
      "AEstack _ [] = \<bottom>"
    | "AEstack (a#as) (Alts e1 e2 # S) = Aexp e1\<cdot>a \<squnion> Aexp e2\<cdot>a \<squnion> AEstack as S"
    | "AEstack as (Upd x # S) = esing x\<cdot>(up\<cdot>0) \<squnion> AEstack as S"
    | "AEstack as (Arg x # S) = esing x\<cdot>(up\<cdot>0) \<squnion> AEstack as S"
    | "AEstack as (_ # S) = AEstack as S"
end

context EdomArityAnalysis
begin
  lemma edom_AEstack: "edom (AEstack as S) \<subseteq> fv S"
    by (induction as S rule: AEstack.induct) (auto simp del: fun_meet_simp dest!: set_mp[OF Aexp_edom])
end

end