(*****************************************************************************
 * Featherweight-OCL --- A Formal Semantics for UML-OCL Version OCL 2.5
 *                       for the OMG Standard.
 *                       http://www.brucker.ch/projects/hol-testgen/
 *
 * UML_Sequence.thy --- Library 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.
 ******************************************************************************)

theory  UML_Sequence
imports "../basic_types/UML_Boolean"
        "../basic_types/UML_Integer"
begin

no_notation None ("\<bottom>")
section\<open>Collection Type Sequence: Operations\<close>

subsection\<open>Basic Properties of the Sequence Type\<close>

text\<open>Every element in a defined sequence is valid.\<close>

lemma Sequence_inv_lemma: "\<tau> \<Turnstile> (\<delta> X) \<Longrightarrow> \<forall>x\<in>set \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (X \<tau>)\<rceil>\<rceil>. x \<noteq> bot"
apply(insert Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e [of "X \<tau>"], simp)
apply(auto simp: OclValid_def defined_def false_def true_def cp_def
                 bot_fun_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def null_fun_def
           split:if_split_asm)
 apply(erule contrapos_pp [of "Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (X \<tau>) = bot"])
 apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject[symmetric], rule Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e, simp)
 apply(simp add: Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_option_def)
apply(erule contrapos_pp [of "Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (X \<tau>) = null"])
apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject[symmetric], rule Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e, simp)
apply(simp add: Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse  null_option_def)
by (simp add: bot_option_def)

subsection\<open>Definition: Strict Equality \label{sec:seq-strict-equality}\<close>

text\<open>After the part of foundational operations on sets, we detail here equality on sets.
Strong equality is inherited from the OCL core, but we have to consider
the case of the strict equality. We decide to overload strict equality in the
same way we do for other value's in OCL:\<close>

overloading
  StrictRefEq \<equiv> "StrictRefEq :: [('\<AA>,'\<alpha>::null)Sequence,('\<AA>,'\<alpha>::null)Sequence] \<Rightarrow> ('\<AA>)Boolean"
begin
  definition StrictRefEq\<^sub>S\<^sub>e\<^sub>q :
    "((x::('\<AA>,'\<alpha>::null)Sequence) \<doteq> y) \<equiv> (\<lambda> \<tau>. if (\<upsilon> x) \<tau> = true \<tau> \<and> (\<upsilon> y) \<tau> = true \<tau>
                                                then (x \<triangleq> y)\<tau>
                                                else invalid \<tau>)"
end

text_raw\<open>\isatagafp\<close>
text\<open>One might object here that for the case of objects, this is an empty definition.
The answer is no, we will restrain later on states and objects such that any object
has its oid stored inside the object (so the ref, under which an object can be referenced
in the store will represented in the object itself). For such well-formed stores that satisfy
this invariant (the WFF-invariant), the referential equality and the
strong equality---and therefore the strict equality on sequences in the sense above---coincides.\<close>
text_raw\<open>\endisatagafp\<close>

text\<open>Property proof in terms of @{term "profile_bin\<^sub>S\<^sub>t\<^sub>r\<^sub>o\<^sub>n\<^sub>g\<^sub>E\<^sub>q_\<^sub>v_\<^sub>v"}\<close>
interpretation  StrictRefEq\<^sub>S\<^sub>e\<^sub>q : profile_bin\<^sub>S\<^sub>t\<^sub>r\<^sub>o\<^sub>n\<^sub>g\<^sub>E\<^sub>q_\<^sub>v_\<^sub>v "\<lambda> x y. (x::('\<AA>,'\<alpha>::null)Sequence) \<doteq> y"
                by unfold_locales (auto simp:  StrictRefEq\<^sub>S\<^sub>e\<^sub>q)

subsection\<open>Constants: mtSequence\<close>
definition mtSequence ::"('\<AA>,'\<alpha>::null) Sequence"  ("Sequence{}")
where     "Sequence{} \<equiv> (\<lambda> \<tau>.  Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>[]::'\<alpha> list\<rfloor>\<rfloor> )"

lemma mtSequence_defined[simp,code_unfold]:"\<delta>(Sequence{}) = true"
apply(rule ext, auto simp: mtSequence_def defined_def null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def
                           bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_fun_def null_fun_def)
by(simp_all add: Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject bot_option_def null_option_def)

lemma mtSequence_valid[simp,code_unfold]:"\<upsilon>(Sequence{}) = true"
apply(rule ext,auto simp: mtSequence_def valid_def null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def
                          bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_fun_def null_fun_def)
by(simp_all add: Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject bot_option_def null_option_def)

lemma mtSequence_rep_set: "\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (Sequence{} \<tau>)\<rceil>\<rceil> = []"
 apply(simp add: mtSequence_def, subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse)
by(simp add: bot_option_def)+

text_raw\<open>\isatagafp\<close>

text\<open>Note that the collection types in OCL allow for null to be included;
  however, there is the null-collection into which inclusion yields invalid.\<close>

text_raw\<open>\endisatagafp\<close>

subsection\<open>Definition: Prepend\<close>
definition OclPrepend   :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>) val] \<Rightarrow> ('\<AA>,'\<alpha>) Sequence"
where     "OclPrepend x y = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<upsilon> y) \<tau> = true \<tau>
                                    then Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor> (y \<tau>)#\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil> \<rfloor>\<rfloor>
                                    else invalid \<tau> )"
notation   OclPrepend   ("_->prepend\<^sub>S\<^sub>e\<^sub>q'(_')")

interpretation OclPrepend:profile_bin\<^sub>d_\<^sub>v OclPrepend "\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>y#\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>\<rfloor>\<rfloor>"
proof -
 have A : "\<And>x y. x \<noteq> bot \<Longrightarrow> x \<noteq> null \<Longrightarrow>  y \<noteq> bot  \<Longrightarrow>
           \<lfloor>\<lfloor>y#\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>\<rfloor>\<rfloor> \<in> {X. X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> bot)}"
          by(auto intro!:Sequence_inv_lemma[simplified OclValid_def
                         defined_def false_def true_def null_fun_def bot_fun_def])

         show "profile_bin\<^sub>d_\<^sub>v OclPrepend (\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>y#\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>\<rfloor>\<rfloor>)"
         apply unfold_locales
          apply(auto simp:OclPrepend_def bot_option_def null_option_def null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def
               bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def)
          apply(erule_tac Q="Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>y#\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>\<rfloor>\<rfloor> = Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e None"
                in contrapos_pp)
          apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject [OF A])
             apply(simp_all add:  null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_option_def)
         apply(erule_tac Q="Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>y#\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>\<rfloor>\<rfloor> = Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>None\<rfloor>"
               in contrapos_pp)
         apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject[OF A])
            apply(simp_all add:  null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def
                                 bot_option_def null_option_def)
         done
qed

syntax
  "_OclFinsequence" :: "args => ('\<AA>,'a::null) Sequence"    ("Sequence{(_)}")
translations
  "Sequence{x, xs}" == "CONST OclPrepend (Sequence{xs}) x"
  "Sequence{x}"     == "CONST OclPrepend (Sequence{}) x "

subsection\<open>Definition: Including\<close>

definition OclIncluding   :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>) val] \<Rightarrow> ('\<AA>,'\<alpha>) Sequence"
where     "OclIncluding x y = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<upsilon> y) \<tau> = true \<tau>
                                    then Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor> \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil>  @ [y \<tau>] \<rfloor>\<rfloor>
                                    else invalid \<tau> )"
notation   OclIncluding   ("_->including\<^sub>S\<^sub>e\<^sub>q'(_')")

interpretation OclIncluding :
               profile_bin\<^sub>d_\<^sub>v OclIncluding "\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ [y]\<rfloor>\<rfloor>"
proof -
 have A : "\<And>x y. x \<noteq> bot \<Longrightarrow> x \<noteq> null \<Longrightarrow>  y \<noteq> bot  \<Longrightarrow>
           \<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ [y]\<rfloor>\<rfloor> \<in> {X. X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> bot)}"
          by(auto intro!:Sequence_inv_lemma[simplified OclValid_def
                         defined_def false_def true_def null_fun_def bot_fun_def])

         show "profile_bin\<^sub>d_\<^sub>v OclIncluding (\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ [y]\<rfloor>\<rfloor>)"
         apply unfold_locales
          apply(auto simp:OclIncluding_def bot_option_def null_option_def null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def
               bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def)
          apply(erule_tac Q="Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ [y]\<rfloor>\<rfloor> = Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e None"
                in contrapos_pp)
          apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject [OF A])
             apply(simp_all add:  null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_option_def)
         apply(erule_tac Q="Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ [y]\<rfloor>\<rfloor> = Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>None\<rfloor>"
               in contrapos_pp)
         apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject[OF A])
            apply(simp_all add:  null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_option_def null_option_def)
         done
qed

lemma [simp,code_unfold] : "(Sequence{}->including\<^sub>S\<^sub>e\<^sub>q(a)) = (Sequence{}->prepend\<^sub>S\<^sub>e\<^sub>q(a))"
  apply(simp add: OclIncluding_def OclPrepend_def mtSequence_def)
  apply(subst (1 2) Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse, simp)
by(metis drop.simps append_Nil)

lemma [simp,code_unfold] : "((S->prepend\<^sub>S\<^sub>e\<^sub>q(a))->including\<^sub>S\<^sub>e\<^sub>q(b)) = ((S->including\<^sub>S\<^sub>e\<^sub>q(b))->prepend\<^sub>S\<^sub>e\<^sub>q(a))"
 proof -
  have A: "\<And>S b \<tau>. S \<noteq> \<bottom> \<Longrightarrow> S \<noteq> null \<Longrightarrow> b \<noteq> \<bottom>  \<Longrightarrow>
                   \<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e S\<rceil>\<rceil> @ [b]\<rfloor>\<rfloor> \<in> {X. X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> \<bottom>)}"
           by(auto intro!:Sequence_inv_lemma[simplified OclValid_def
                                        defined_def false_def true_def null_fun_def bot_fun_def])
  have B: "\<And>S a \<tau>. S \<noteq> \<bottom> \<Longrightarrow> S \<noteq> null \<Longrightarrow> a \<noteq> \<bottom>  \<Longrightarrow>
                   \<lfloor>\<lfloor>a # \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e S\<rceil>\<rceil>\<rfloor>\<rfloor> \<in> {X. X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> \<bottom>)}"
           by(auto intro!:Sequence_inv_lemma[simplified OclValid_def
                                        defined_def false_def true_def null_fun_def bot_fun_def])
 show ?thesis
  apply(simp add: OclIncluding_def OclPrepend_def mtSequence_def, rule ext)
  apply(subst (2 5) cp_defined, simp split:)
  apply(intro conjI impI)
        apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse[OF B],
              (simp add: foundation16[simplified OclValid_def] foundation18'[simplified OclValid_def])+)
        apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse[OF A],
              (simp add: foundation16[simplified OclValid_def] foundation18'[simplified OclValid_def])+)
       apply(simp add: OclIncluding.def_body)
      apply (metis OclValid_def foundation16 invalid_def)
     apply (metis (no_types) OclPrepend.def_body' OclValid_def foundation16)
 by (metis OclValid_def foundation16 invalid_def)+
qed

subsection\<open>Definition: Excluding\<close>
definition OclExcluding   :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>) val] \<Rightarrow> ('\<AA>,'\<alpha>) Sequence"
where     "OclExcluding x y = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<upsilon> y) \<tau> = true \<tau>
                                    then Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor> filter (\<lambda>x. x = y \<tau>)
                                                                   \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil>\<rfloor>\<rfloor>
                                    else invalid \<tau> )"
notation   OclExcluding   ("_->excluding\<^sub>S\<^sub>e\<^sub>q'(_')")

interpretation OclExcluding:profile_bin\<^sub>d_\<^sub>v OclExcluding
                          "\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor> filter (\<lambda>x. x = y) \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x)\<rceil>\<rceil>\<rfloor>\<rfloor>"
proof -
    show "profile_bin\<^sub>d_\<^sub>v OclExcluding (\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor>[x\<leftarrow>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> . x = y]\<rfloor>\<rfloor>)"
         apply unfold_locales
         apply(auto simp:OclExcluding_def bot_option_def null_option_def
                         null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def)
         apply(subst (asm) Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject,
               simp_all add: null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_option_def null_option_def)+
   done
qed

subsection\<open>Definition: Append\<close>
text\<open>Identical to OclIncluding.\<close>
definition OclAppend   :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>) val] \<Rightarrow> ('\<AA>,'\<alpha>) Sequence"
where     "OclAppend = OclIncluding"
notation   OclAppend   ("_->append\<^sub>S\<^sub>e\<^sub>q'(_')")

interpretation OclAppend :
               profile_bin\<^sub>d_\<^sub>v OclAppend "\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ [y]\<rfloor>\<rfloor>"
         apply unfold_locales
 by(auto simp: OclAppend_def bin_def bin'_def
               OclIncluding.def_scheme OclIncluding.def_body)

subsection\<open>Definition: Union\<close>
definition OclUnion   :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>) Sequence] \<Rightarrow> ('\<AA>,'\<alpha>) Sequence"
where     "OclUnion x y = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                                then Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e \<lfloor>\<lfloor> \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil> @
                                                        \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (y \<tau>)\<rceil>\<rceil>\<rfloor>\<rfloor>
                                else invalid \<tau> )"
notation   OclUnion   ("_->union\<^sub>S\<^sub>e\<^sub>q'(_')")

interpretation OclUnion :
               profile_bin\<^sub>d_\<^sub>d OclUnion "\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil> @ \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e y\<rceil>\<rceil>\<rfloor>\<rfloor>"
proof -
   have A : "\<And>x y. x \<noteq> \<bottom> \<Longrightarrow>  x \<noteq> null \<Longrightarrow> \<forall>x\<in>set \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>. x \<noteq> \<bottom> "
            apply(rule Sequence_inv_lemma[of \<tau>])
            by(simp add: defined_def OclValid_def bot_fun_def null_fun_def false_def true_def)
   show "profile_bin\<^sub>d_\<^sub>d OclUnion (\<lambda>x y. Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e\<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e x\<rceil>\<rceil>@\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e y\<rceil>\<rceil>\<rfloor>\<rfloor>)"
   apply unfold_locales
   apply(auto simp:OclUnion_def bot_option_def null_option_def
                   null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def)
   by(subst (asm) Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject,
      simp_all add: bot_option_def null_option_def  Set.ball_Un A null_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def bot_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def)+
qed

subsection\<open>Definition: At\<close>
definition OclAt   :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>) Integer] \<Rightarrow> ('\<AA>,'\<alpha>) val"
where     "OclAt x y = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                             then if  1 \<le> \<lceil>\<lceil>y \<tau>\<rceil>\<rceil> \<and>  \<lceil>\<lceil>y \<tau>\<rceil>\<rceil> \<le> length\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil>
                                  then \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil> ! (nat \<lceil>\<lceil>y \<tau>\<rceil>\<rceil> - 1)
                                  else invalid \<tau>
                             else invalid \<tau> )"
notation   OclAt ("_->at\<^sub>S\<^sub>e\<^sub>q'(_')")
(*TODO Locale - Equivalent*)

subsection\<open>Definition: First\<close>
definition OclFirst   :: "[('\<AA>,'\<alpha>::null) Sequence] \<Rightarrow> ('\<AA>,'\<alpha>) val"
where     "OclFirst x = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> then
                                case \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil> of [] \<Rightarrow> invalid \<tau>
                                                               | x # _ \<Rightarrow> x
                              else invalid \<tau> )"
notation   OclFirst   ("_->first\<^sub>S\<^sub>e\<^sub>q'(_')")
(*TODO Locale - Equivalent*)

subsection\<open>Definition: Last\<close>
definition OclLast   :: "[('\<AA>,'\<alpha>::null) Sequence] \<Rightarrow> ('\<AA>,'\<alpha>) val"
where     "OclLast x = (\<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> then
                               if \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil> = [] then
                                 invalid \<tau>
                               else
                                 last \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>)\<rceil>\<rceil>
                             else invalid \<tau> )"
notation   OclLast   ("_->last\<^sub>S\<^sub>e\<^sub>q'(_')")
(*TODO Locale - Equivalent*)

subsection\<open>Definition: Iterate\<close>

definition OclIterate :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<beta>::null)val,
                           ('\<AA>,'\<alpha>)val\<Rightarrow>('\<AA>,'\<beta>)val\<Rightarrow>('\<AA>,'\<beta>)val] \<Rightarrow> ('\<AA>,'\<beta>)val"
where     "OclIterate S A F = (\<lambda> \<tau>. if (\<delta> S) \<tau> = true \<tau> \<and> (\<upsilon> A) \<tau> = true \<tau>
                                    then (foldr (F) (map (\<lambda>a \<tau>. a) \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (S \<tau>)\<rceil>\<rceil>))(A)\<tau>
                                    else \<bottom>)"
syntax
  "_OclIterateSeq"  :: "[('\<AA>,'\<alpha>::null) Sequence, idt, idt, '\<alpha>, '\<beta>] => ('\<AA>,'\<gamma>)val"
                        ("_ ->iterate\<^sub>S\<^sub>e\<^sub>q'(_;_=_ | _')" (*[71,100,70]50*))
translations
  "X->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = A | P)" == "CONST OclIterate X A (%a. (% x. P))"

(*TODO Locale - Equivalent*)

subsection\<open>Definition: Forall\<close>
definition OclForall     :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>)val\<Rightarrow>('\<AA>)Boolean] \<Rightarrow> '\<AA> Boolean"
where     "OclForall S P = (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = true | x and (P b)))"

syntax
  "_OclForallSeq" :: "[('\<AA>,'\<alpha>::null) Sequence,id,('\<AA>)Boolean] \<Rightarrow> '\<AA> Boolean"    ("(_)->forAll\<^sub>S\<^sub>e\<^sub>q'(_|_')")
translations
  "X->forAll\<^sub>S\<^sub>e\<^sub>q(x | P)" == "CONST UML_Sequence.OclForall X (%x. P)"

(*TODO Locale - Equivalent*)

subsection\<open>Definition: Exists\<close>
definition OclExists     :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>)val\<Rightarrow>('\<AA>)Boolean] \<Rightarrow> '\<AA> Boolean"
where     "OclExists S P = (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = false | x or (P b)))"

syntax
  "_OclExistSeq" :: "[('\<AA>,'\<alpha>::null) Sequence,id,('\<AA>)Boolean] \<Rightarrow> '\<AA> Boolean"    ("(_)->exists\<^sub>S\<^sub>e\<^sub>q'(_|_')")
translations
  "X->exists\<^sub>S\<^sub>e\<^sub>q(x | P)" == "CONST OclExists X (%x. P)"

(*TODO Locale - Equivalent*)

subsection\<open>Definition: Collect\<close>
definition OclCollect     :: "[('\<AA>,'\<alpha>::null)Sequence,('\<AA>,'\<alpha>)val\<Rightarrow>('\<AA>,'\<beta>)val]\<Rightarrow>('\<AA>,'\<beta>::null)Sequence"
where     "OclCollect S P = (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = Sequence{} | x->prepend\<^sub>S\<^sub>e\<^sub>q(P b)))"

syntax
  "_OclCollectSeq" :: "[('\<AA>,'\<alpha>::null) Sequence,id,('\<AA>)Boolean] \<Rightarrow> '\<AA> Boolean"    ("(_)->collect\<^sub>S\<^sub>e\<^sub>q'(_|_')")
translations
  "X->collect\<^sub>S\<^sub>e\<^sub>q(x | P)" == "CONST OclCollect X (%x. P)"

(*TODO Locale - Equivalent*)

subsection\<open>Definition: Select\<close>
definition OclSelect     :: "[('\<AA>,'\<alpha>::null)Sequence,('\<AA>,'\<alpha>)val\<Rightarrow>('\<AA>)Boolean]\<Rightarrow>('\<AA>,'\<alpha>::null)Sequence"
where     "OclSelect S P =
           (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = Sequence{} | if P b then x->prepend\<^sub>S\<^sub>e\<^sub>q(b) else x endif))"

syntax
  "_OclSelectSeq" :: "[('\<AA>,'\<alpha>::null) Sequence,id,('\<AA>)Boolean] \<Rightarrow> '\<AA> Boolean"  ("(_)->select\<^sub>S\<^sub>e\<^sub>q'(_|_')")
translations
  "X->select\<^sub>S\<^sub>e\<^sub>q(x | P)" == "CONST UML_Sequence.OclSelect X (%x. P)"

(*TODO Locale - Equivalent*)

subsection\<open>Definition: Size\<close>
definition OclSize     :: "[('\<AA>,'\<alpha>::null)Sequence]\<Rightarrow>('\<AA>)Integer" ("(_)->size\<^sub>S\<^sub>e\<^sub>q'(')")
where     "OclSize S = (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = \<zero> | x +\<^sub>i\<^sub>n\<^sub>t \<one> ))"

(*TODO Locale - Equivalent*)

subsection\<open>Definition: IsEmpty\<close>
definition OclIsEmpty   :: "('\<AA>,'\<alpha>::null) Sequence \<Rightarrow> '\<AA> Boolean"
where     "OclIsEmpty x =  ((\<upsilon> x and not (\<delta> x)) or ((OclSize x) \<doteq> \<zero>))"
notation   OclIsEmpty     ("_->isEmpty\<^sub>S\<^sub>e\<^sub>q'(')" (*[66]*))

(*TODO Locale - Equivalent*)

subsection\<open>Definition: NotEmpty\<close>

definition OclNotEmpty   :: "('\<AA>,'\<alpha>::null) Sequence \<Rightarrow> '\<AA> Boolean"
where     "OclNotEmpty x =  not(OclIsEmpty x)"
notation   OclNotEmpty    ("_->notEmpty\<^sub>S\<^sub>e\<^sub>q'(')" (*[66]*))

(*TODO Locale - Equivalent*)

subsection\<open>Definition: Any\<close>

definition "OclANY x = (\<lambda> \<tau>.
  if x \<tau> = invalid \<tau> then
    \<bottom>
  else
    case drop (drop (Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e (x \<tau>))) of [] \<Rightarrow> \<bottom>
                                              | l \<Rightarrow> hd l)"
notation   OclANY   ("_->any\<^sub>S\<^sub>e\<^sub>q'(')")

(*TODO Locale - Equivalent*)

subsection\<open>Definition (future operators)\<close>

consts (* abstract set collection operations *)
    OclCount       :: "[('\<AA>,'\<alpha>::null) Sequence,('\<AA>,'\<alpha>) Sequence] \<Rightarrow> '\<AA> Integer"
  (*OclFlatten*)
  (*OclInsertAt*)
  (*OclSubSequence*)
  (*OclIndexOf*)
  (*OclReverse*)
    OclSum         :: " ('\<AA>,'\<alpha>::null) Sequence \<Rightarrow> '\<AA> Integer"

notation  OclCount       ("_->count\<^sub>S\<^sub>e\<^sub>q'(_')" (*[66,65]65*))
notation  OclSum         ("_->sum\<^sub>S\<^sub>e\<^sub>q'(')" (*[66]*))

subsection\<open>Logical Properties\<close>

subsection\<open>Execution Laws with Invalid or Null as Argument\<close>

text\<open>OclIterate\<close>

lemma OclIterate_invalid[simp,code_unfold]:"invalid->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = A | P a x) = invalid"
by(simp add: OclIterate_def false_def true_def, simp add: invalid_def)

lemma OclIterate_null[simp,code_unfold]:"null->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = A | P a x) = invalid"
by(simp add: OclIterate_def false_def true_def, simp add: invalid_def)

lemma OclIterate_invalid_args[simp,code_unfold]:"S->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = invalid | P a x) = invalid"
by(simp add: bot_fun_def invalid_def OclIterate_def defined_def valid_def false_def true_def)

text_raw\<open>\isatagafp\<close>

subsubsection\<open>Context Passing\<close>

lemma cp_OclIncluding:
"(X->including\<^sub>S\<^sub>e\<^sub>q(x)) \<tau> = ((\<lambda> _. X \<tau>)->including\<^sub>S\<^sub>e\<^sub>q(\<lambda> _. x \<tau>)) \<tau>"
by(auto simp: OclIncluding_def StrongEq_def invalid_def
                 cp_defined[symmetric] cp_valid[symmetric])

lemma cp_OclIterate:
     "(X->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = A | P a x)) \<tau> =
                ((\<lambda> _. X \<tau>)->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = A | P a x)) \<tau>"
by(simp add: OclIterate_def cp_defined[symmetric])

lemmas cp_intro''\<^sub>S\<^sub>e\<^sub>q[intro!,simp,code_unfold] =
       cp_OclIncluding [THEN allI[THEN allI[THEN allI[THEN cpI2]], of "OclIncluding"]]

subsubsection\<open>Const\<close>

text_raw\<open>\endisatagafp\<close>

subsection\<open>General Algebraic Execution Rules\<close>
subsubsection\<open>Execution Rules on Iterate\<close>

lemma OclIterate_empty[simp,code_unfold]:"Sequence{}->iterate\<^sub>S\<^sub>e\<^sub>q(a; x = A | P a x) = A"
apply(simp add: OclIterate_def foundation22[symmetric] foundation13,
      rule ext, rename_tac "\<tau>")
apply(case_tac "\<tau> \<Turnstile> \<upsilon> A", simp_all add: foundation18')
apply(simp add: mtSequence_def)
apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse) by auto

text\<open>In particular, this does hold for A = null.\<close>

lemma OclIterate_including[simp,code_unfold]:
assumes strict1 : "\<And>X. P invalid X = invalid"
and     P_valid_arg: "\<And> \<tau>. (\<upsilon> A) \<tau> = (\<upsilon> (P a A)) \<tau>"
and     P_cp    : "\<And> x y \<tau>. P x y \<tau> = P (\<lambda> _. x \<tau>) y \<tau>"
and     P_cp'   : "\<And> x y \<tau>. P x y \<tau> = P x (\<lambda> _. y \<tau>) \<tau>"
shows  "(S->including\<^sub>S\<^sub>e\<^sub>q(a))->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = A | P b x) = S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = P a A| P b x)"
 apply(rule ext)
proof -
 have A: "\<And>S b \<tau>. S \<noteq> \<bottom> \<Longrightarrow> S \<noteq> null \<Longrightarrow> b \<noteq> \<bottom>  \<Longrightarrow>
                  \<lfloor>\<lfloor>\<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e S\<rceil>\<rceil> @ [b]\<rfloor>\<rfloor> \<in> {X. X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> \<bottom>)}"
          by(auto intro!:Sequence_inv_lemma[simplified OclValid_def
                                       defined_def false_def true_def null_fun_def bot_fun_def])
 have P: "\<And>l A A' \<tau>. A \<tau> = A' \<tau> \<Longrightarrow> foldr P l A \<tau> = foldr P l A' \<tau>"
  apply(rule list.induct, simp, simp)
 by(subst (1 2) P_cp', simp)

 fix \<tau>
 show "OclIterate (S->including\<^sub>S\<^sub>e\<^sub>q(a)) A P \<tau> = OclIterate S (P a A) P \<tau>"
  apply(subst cp_OclIterate, subst OclIncluding_def, simp split:)
  apply(intro conjI impI)

   apply(simp add: OclIterate_def)
   apply(intro conjI impI)
     apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse[OF A],
           (simp add: foundation16[simplified OclValid_def] foundation18'[simplified OclValid_def])+)
     apply(rule P, metis P_cp)
    apply (metis P_valid_arg)
   apply(simp add: P_valid_arg[symmetric])
   apply (metis (lifting, no_types) OclIncluding.def_body' OclValid_def foundation16)
  apply(simp add: OclIterate_def defined_def invalid_def bot_option_def bot_fun_def false_def true_def)
  apply(intro impI, simp add: false_def true_def P_valid_arg)
 by (metis P_cp P_valid_arg UML_Types.bot_fun_def cp_valid invalid_def strict1 true_def valid1 valid_def)
qed

lemma OclIterate_prepend[simp,code_unfold]:
assumes strict1 : "\<And>X. P invalid X = invalid"
and     strict2 : "\<And>X. P X invalid = invalid"
and     P_cp    : "\<And> x y \<tau>. P x y \<tau> = P (\<lambda> _. x \<tau>) y \<tau>"
and     P_cp'   : "\<And> x y \<tau>. P x y \<tau> = P x (\<lambda> _. y \<tau>) \<tau>"
shows  "(S->prepend\<^sub>S\<^sub>e\<^sub>q(a))->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = A | P b x) = P a (S->iterate\<^sub>S\<^sub>e\<^sub>q(b; x = A| P b x))"
 apply(rule ext)
proof -
 have B: "\<And>S a \<tau>. S \<noteq> \<bottom> \<Longrightarrow> S \<noteq> null \<Longrightarrow> a \<noteq> \<bottom>  \<Longrightarrow>
                  \<lfloor>\<lfloor>a # \<lceil>\<lceil>Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e S\<rceil>\<rceil>\<rfloor>\<rfloor> \<in> {X. X = bot \<or> X = null \<or> (\<forall>x\<in>set \<lceil>\<lceil>X\<rceil>\<rceil>. x \<noteq> \<bottom>)}"
          by(auto intro!:Sequence_inv_lemma[simplified OclValid_def
                                       defined_def false_def true_def null_fun_def bot_fun_def])
 fix \<tau>
 show "OclIterate (S->prepend\<^sub>S\<^sub>e\<^sub>q(a)) A P \<tau> = P a (OclIterate S A P) \<tau>"
  apply(subst cp_OclIterate, subst OclPrepend_def, simp split:)
  apply(intro conjI impI)

   apply(subst P_cp')
   apply(simp add: OclIterate_def)
   apply(intro conjI impI)
     apply(subst Abs_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inverse[OF B],
           (simp add: foundation16[simplified OclValid_def] foundation18'[simplified OclValid_def])+)
     apply(simp add: P_cp'[symmetric])
     apply(subst P_cp, simp add: P_cp[symmetric])
    apply (metis (no_types) OclPrepend.def_body' OclValid_def foundation16)
   apply (metis P_cp' invalid_def strict2 valid_def)

  apply(subst P_cp',
        simp add: OclIterate_def defined_def invalid_def bot_option_def bot_fun_def false_def true_def,
        intro conjI impI)
     apply (metis P_cp' invalid_def strict2 valid_def)
    apply (metis P_cp' invalid_def strict2 valid_def)
   apply (metis (no_types) P_cp invalid_def strict1 true_def valid1 valid_def)
  apply (metis P_cp' invalid_def strict2 valid_def)
 done
qed

(* < *)

subsection\<open>Test Statements\<close>
(*
Assert   "(\<tau> \<Turnstile> (Sequence{\<lambda>_. \<lfloor>\<lfloor>x\<rfloor>\<rfloor>} \<doteq> Sequence{\<lambda>_. \<lfloor>\<lfloor>x\<rfloor>\<rfloor>}))"
Assert   "(\<tau> \<Turnstile> (Sequence{\<lambda>_. \<lfloor>x\<rfloor>} \<doteq> Sequence{\<lambda>_. \<lfloor>x\<rfloor>}))"
*)

instantiation Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e  :: (equal)equal
begin
  definition "HOL.equal k l \<longleftrightarrow>  (k::('a::equal)Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e) =  l"
  instance   by standard (rule equal_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_def)
end

lemma equal_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_code [code]:
  "HOL.equal k (l::('a::{equal,null})Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e) \<longleftrightarrow> Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e k = Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e l"
  by (auto simp add: equal Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e.Rep_Sequence\<^sub>b\<^sub>a\<^sub>s\<^sub>e_inject)

Assert   "\<tau> \<Turnstile> (Sequence{} \<doteq> Sequence{})"
Assert   "\<tau> \<Turnstile> (Sequence{\<one>,\<two>} \<triangleq> Sequence{}->prepend\<^sub>S\<^sub>e\<^sub>q(\<two>)->prepend\<^sub>S\<^sub>e\<^sub>q(\<one>))"
Assert   "\<tau> \<Turnstile> (Sequence{\<one>,invalid,\<two>} \<triangleq> invalid)"
Assert   "\<tau> \<Turnstile> (Sequence{\<one>,\<two>}->prepend\<^sub>S\<^sub>e\<^sub>q(null) \<triangleq> Sequence{null,\<one>,\<two>})"
Assert   "\<tau> \<Turnstile> (Sequence{\<one>,\<two>}->including\<^sub>S\<^sub>e\<^sub>q(null) \<triangleq> Sequence{\<one>,\<two>,null})"

(*
Assert   "\<not> (\<tau> \<Turnstile> (Sequence{\<one>,\<one>,\<two>} \<doteq> Sequence{\<one>,\<two>}))"
Assert   "\<not> (\<tau> \<Turnstile> (Sequence{\<one>,\<two>} \<doteq> Sequence{\<two>,\<one>}))"
*)

(* > *)

end


(*****************************************************************************
 * HOL-TestGen --- theorem-prover based test case generation
 *                 http://www.brucker.ch/projects/hol-testgen/
 *
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2005-2012 ETH Zurich, Switzerland
 *               2008-2015 Achim D. Brucker, Germany
 *               2009-2017 Université Paris-Sud, France
 *               2015-2017 The University of Sheffield, UK
 *
 * 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.
 ******************************************************************************)

section \<open>Policy Transformation for Testing\<close>
theory
  NormalisationTestSpecification
  imports
    Normalisation
begin

text\<open>
  This theory provides functions and theorems which are useful if one wants to test policy
  which are transformed. Most exist in two versions: one where the domains of the rules
  of the list (which is the result of a transformation) are pairwise disjoint, and one where
  this applies not for the last rule in a list (which is usually a default rules).

  The examples in the firewall case study provide a good documentation how these theories can
  be applied.
\<close>

text\<open>
  This invariant establishes that the domains of a list of rules are pairwise disjoint.
\<close>
fun disjDom where
 "disjDom (x#xs) = ((\<forall>y\<in>(set xs). dom x \<inter> dom y = {}) \<and> disjDom xs)"
|"disjDom [] = True"

fun PUTList :: "('a \<mapsto> 'b) \<Rightarrow> 'a \<Rightarrow> ('a \<mapsto> 'b) list \<Rightarrow> bool"
 where
 "PUTList PUT x (p#ps) = ((x \<in> dom p \<longrightarrow> (PUT x = p x)) \<and> (PUTList PUT x ps))"
|"PUTList PUT x [] = True"

lemma distrPUTL1: "x \<in> dom P \<Longrightarrow> (list2policy PL) x = P x
                             \<Longrightarrow>  (PUTList PUT x PL \<Longrightarrow> (PUT x = P x))"
  apply (induct PL)
   apply (auto simp: list2policy_def dom_def)
  done

lemma PUTList_None: "x \<notin> dom (list2policy list) \<Longrightarrow> PUTList PUT x list"
  apply (induct list)
   apply (auto simp: list2policy_def dom_def)
  done

lemma PUTList_DomMT:
  "(\<forall>y\<in>set list. dom a \<inter> dom y = {}) \<Longrightarrow> x \<in> (dom a) \<Longrightarrow> x \<notin> dom (list2policy list)"
  apply (induct list)
   apply (auto simp: dom_def list2policy_def)
  done

lemma distrPUTL2:
  "x \<in> dom P \<Longrightarrow> (list2policy PL) x = P x  \<Longrightarrow> disjDom PL \<Longrightarrow> (PUT x = P x) \<Longrightarrow> PUTList PUT x PL "
  apply (induct PL)
   apply (simp_all add: list2policy_def)
  apply (auto)[1]
  subgoal for a PL p
    apply (case_tac "x \<in> dom a")
     apply (case_tac "list2policy PL x = P x")
      apply (simp add: list2policy_def)
     apply (rule PUTList_None)
     apply (rule_tac a = a in PUTList_DomMT)
      apply (simp_all add: list2policy_def dom_def)
    done
  done

lemma distrPUTL:
  "\<lbrakk>x \<in> dom P; (list2policy PL) x = P x; disjDom PL\<rbrakk> \<Longrightarrow> (PUT x = P x) = PUTList PUT x PL "
  apply (rule iffI)
   apply (rule distrPUTL2)
      apply (simp_all)
  apply (rule_tac PL = PL in distrPUTL1)
    apply (auto)
  done

text\<open>
  It makes sense to cater for the common special case where the normalisation returns a list
  where the last element is a default-catch-all rule. It seems easier to cater for this globally,
  rather than to require the normalisation procedures to do this.
\<close>

fun gatherDomain_aux where
  "gatherDomain_aux (x#xs) = (dom x \<union> (gatherDomain_aux xs))"
|"gatherDomain_aux [] = {}"

definition gatherDomain where "gatherDomain p = (gatherDomain_aux (butlast p))"

definition PUTListGD where "PUTListGD PUT x p =
  (((x \<notin> (gatherDomain p) \<and> x \<in> dom (last p)) \<longrightarrow> PUT x = (last p) x) \<and>
                          (PUTList PUT x (butlast p)))"

definition disjDomGD where "disjDomGD p = disjDom (butlast p)"

lemma distrPUTLG1: "\<lbrakk>x \<in> dom P; (list2policy PL) x = P x; PUTListGD PUT x PL\<rbrakk> \<Longrightarrow> PUT x = P x"
  apply (induct PL)
   apply (simp_all add: domIff PUTListGD_def disjDomGD_def gatherDomain_def list2policy_def)
  apply (auto simp: dom_def domIff split: if_split_asm)
  done

lemma distrPUTLG2:
  "PL \<noteq> [] \<Longrightarrow> x \<in> dom P \<Longrightarrow> (list2policy (PL)) x = P x \<Longrightarrow> disjDomGD PL \<Longrightarrow>
   (PUT x = P x) \<Longrightarrow> PUTListGD PUT x (PL)"
  apply (simp add: PUTListGD_def disjDomGD_def gatherDomain_def list2policy_def)
  apply (induct PL)
   apply (auto)
  apply (metis PUTList_DomMT PUTList_None domI)
done

lemma distrPUTLG:
  "\<lbrakk>x \<in> dom P; (list2policy PL) x = P x; disjDomGD PL; PL \<noteq> []\<rbrakk> \<Longrightarrow>
  (PUT x = P x) = PUTListGD PUT x PL "
  apply (rule iffI)
   apply (rule distrPUTLG2)
       apply (simp_all)
  apply (rule_tac PL = PL in distrPUTLG1)
    apply (auto)
  done

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section \<open>\isaheader{Map implementation via tries}\<close>
theory TrieMapImpl imports
  Trie2
  "../gen_algo/MapGA"
begin
(*@impl Map
  @type ('k,'v) tm
  @abbrv tm,t
  Maps over keys of type @{typ "'k list"} implemented by tries.
*)

subsection \<open>Operations\<close>

type_synonym ('k, 'v) tm = "('k, 'v) trie"

definition [icf_rec_def]: "tm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = Trie2.lookup,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = (\<lambda>_::unit. Trie2.empty),
  bmap_op_lookup = (\<lambda>k m. Trie2.lookup m k),
  bmap_op_update = Trie2.update,
  bmap_op_update_dj = Trie2.update,
  bmap_op_delete = Trie2.delete,
  bmap_op_list_it = Trie2.iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation tm_basic: StdBasicMap tm_basic_ops
  apply unfold_locales
  apply (simp_all
      add: icf_rec_unf Trie2.finite_dom_lookup Trie2.iteratei_correct
      add: map_upd_eq_restrict)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "tm_ops \<equiv> tm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation tm: StdMap tm_ops
  unfolding tm_ops_def
  by (rule tm_basic.dflt_ops_impl)
interpretation tm: StdMap_no_invar tm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "tm"\<close>

lemma pi_trie_impl[proper_it]:
  shows "proper_it'
    ((Trie_Impl.iteratei) :: _ \<Rightarrow> (_,'\<sigma>a) set_iterator)
    ((Trie_Impl.iteratei) :: _ \<Rightarrow> (_,'\<sigma>b) set_iterator)"
  unfolding Trie_Impl.iteratei_def[abs_def]
proof (rule proper_it'I)
  (*note [[show_types, show_consts]]*)
  fix t :: "('k,'v) Trie.trie"
  {
    fix l and t :: "('k,'v) Trie.trie"
    have "proper_it ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'\<sigma>a) set_iterator)
      ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'\<sigma>b) set_iterator)"
    proof (induct t arbitrary: l)
      case (Trie vo kvs l)

      let ?ITA = "\<lambda>l t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'\<sigma>a) set_iterator"
      let ?ITB = "\<lambda>l t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'\<sigma>b) set_iterator"

      show ?case
        unfolding Trie_Impl.iteratei_postfixed_alt_def
        apply (rule pi_union)
        apply (auto split: option.split intro: icf_proper_iteratorI) []
      proof (rule pi_image)
        define bs where "bs = (\<lambda>(k,t). SOME l'::('k list \<times> 'v) list.
          ?ITA (k#l) t = foldli l' \<and> ?ITB (k#l) t = foldli l')"

        have EQ1: "\<forall>(k,t)\<in>set kvs. ?ITA (k#l) t = foldli (bs (k,t))" and
          EQ2: "\<forall>(k,t)\<in>set kvs. ?ITB (k#l) t = foldli (bs (k,t))"
        proof (safe)
          fix k t
          assume A: "(k,t) \<in> set kvs"
          from Trie.hyps[OF A, of "k#l"] have
            PI: "proper_it (?ITA (k#l) t) (?ITB (k#l) t)"
            by assumption
          obtain l' where
            "?ITA (k#l) t = foldli l'
          \<and> (?ITB (k#l) t) = foldli l'"
            by (blast intro: proper_itE[OF PI])
          thus "?ITA (k#l) t = foldli (bs (k,t))"
            "?ITB (k#l) t = foldli (bs (k,t))"
            unfolding bs_def
            apply auto
            apply (metis (lifting, full_types) someI_ex)
            apply (metis (lifting, full_types) someI_ex)
            done
        qed

        have PEQ1: "set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITA (k#l) t)
          = set_iterator_product (foldli kvs) (\<lambda>kt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ1 by auto
        have PEQ2: "set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITB (k#l) t)
          = set_iterator_product (foldli kvs) (\<lambda>kt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ2 by auto
        show "proper_it
          (set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITA (k#l) t))
          (set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITB (k#l) t))"
          apply (subst PEQ1)
          apply (subst PEQ2)
          apply (auto simp: set_iterator_product_foldli_conv)
          by (blast intro: proper_itI)
      qed
    qed
  } thus "proper_it
      (iteratei_postfixed [] t :: (_,'\<sigma>a) set_iterator)
      (iteratei_postfixed [] t :: (_,'\<sigma>b) set_iterator)" .
qed

lemma pi_trie[proper_it]:
  "proper_it' Trie2.iteratei Trie2.iteratei"
  unfolding Trie2.iteratei_def[abs_def]
  apply (rule proper_it'I)
  apply (intro icf_proper_iteratorI)
  apply (rule proper_it'D)
  by (rule pi_trie_impl)

interpretation pi_trie: proper_it_loc Trie2.iteratei Trie2.iteratei
  apply unfold_locales
  apply (rule pi_trie)
  done

text \<open>Code generator test\<close>
definition "test_codegen \<equiv> (
  tm.add ,
  tm.add_dj ,
  tm.ball ,
  tm.bex ,
  tm.delete ,
  tm.empty ,
  tm.isEmpty ,
  tm.isSng ,
  tm.iterate ,
  tm.iteratei ,
  tm.list_it ,
  tm.lookup ,
  tm.restrict ,
  tm.sel ,
  tm.size ,
  tm.size_abort ,
  tm.sng ,
  tm.to_list ,
  tm.to_map ,
  tm.update ,
  tm.update_dj)"

export_code test_codegen checking SML

end


section \<open>Dyadic Rational Representation of Real\<close>
theory Float_Real
imports
  "~~/src/HOL/Library/Float"
begin
text \<open>\label{sec:floatreal}\<close>

code_datatype real_of_float

abbreviation
  float_of_nat :: "nat \<Rightarrow> float"
where
  "float_of_nat \<equiv> of_nat"

abbreviation
  float_of_int :: "int \<Rightarrow> float"
where
  "float_of_int \<equiv> of_int"

text\<open>Collapse nested embeddings\<close>

text \<open>Operations\<close>

text \<open>Undo code setup for @{term Ratreal}.\<close>

lemma of_rat_numeral_eq [code_abbrev]:
  "real_of_float (numeral w) = Ratreal (numeral w)"
  by simp

lemma zero_real_code [code]:
  "0 = real_of_float 0"
  by simp

lemma one_real_code [code]:
  "1 = real_of_float 1"
  by simp

lemma [code_abbrev]:
  "(real_of_float (of_int a) :: real) = (Ratreal (Rat.of_int a) :: real)"
  by (auto simp: Rat.of_int_def )

lemma [code_abbrev]:
  "real_of_float 0 \<equiv> Ratreal 0"
  by simp

lemma [code_abbrev]:
  "real_of_float 1 = Ratreal 1"
  by simp

lemmas compute_real_of_float[code del]

lemmas [code del] =
  real_equal_code
  real_less_eq_code
  real_less_code
  real_plus_code
  real_times_code
  real_uminus_code
  real_minus_code
  real_inverse_code
  real_divide_code
  real_floor_code
  Float.compute_truncate_down
  Float.compute_truncate_up

lemma real_equal_code [code]:
  "HOL.equal (real_of_float x) (real_of_float y) \<longleftrightarrow> HOL.equal x y"
  by (metis (poly_guards_query) equal real_of_float_inverse)

abbreviation FloatR::"int\<Rightarrow>int\<Rightarrow>real" where
  "FloatR a b \<equiv> real_of_float (Float a b)"

lemma real_less_eq_code' [code]: "real_of_float x \<le> real_of_float y \<longleftrightarrow> x \<le> y"
  and real_less_code' [code]: "real_of_float x < real_of_float y \<longleftrightarrow> x < y"
  and real_plus_code' [code]: "real_of_float x + real_of_float y = real_of_float (x + y)"
  and real_times_code' [code]: "real_of_float x * real_of_float y = real_of_float (x * y)"
  and real_uminus_code' [code]: "- real_of_float x = real_of_float (- x)"
  and real_minus_code' [code]: "real_of_float x - real_of_float y = real_of_float (x - y)"
  and real_inverse_code' [code]: "inverse (FloatR a b) =
    (if FloatR a b = 2 then FloatR 1 (-1) else
    if a = 1 then FloatR 1 (- b) else
    Code.abort (STR ''inverse not of 2'') (\<lambda>_. inverse (FloatR a b)))"
  and real_divide_code' [code]: "FloatR a b / FloatR c d =
    (if FloatR c d = 2 then if a mod 2 = 0 then FloatR (a div 2) b else FloatR a (b - 1) else
    if c = 1 then FloatR a (b - d) else
    Code.abort (STR ''division not by 2'') (\<lambda>_. FloatR a b / FloatR c d))"
  and real_floor_code' [code]: "floor (real_of_float x) = int_floor_fl x"
  and real_abs_code' [code]: "abs (real_of_float x) = real_of_float (abs x)"
  by (auto simp add: int_floor_fl.rep_eq powr_divide2[symmetric] powr_minus inverse_eq_divide)

lemma compute_round_down[code]: "round_down prec (real_of_float f) = real_of_float (float_down prec f)"
  by simp

lemma compute_round_up[code]: "round_up prec (real_of_float f) = real_of_float (float_up prec f)"
  by simp

lemma compute_truncate_down[code]:
  "truncate_down prec (real_of_float f) = real_of_float (float_round_down prec f)"
  by (simp add: Float.float_round_down.rep_eq truncate_down_def)

lemma compute_truncate_up[code]:
  "truncate_up prec (real_of_float f) = real_of_float (float_round_up prec f)"
  by (simp add: float_round_up.rep_eq truncate_up_def)

lemma [code]: "real_divr p (real_of_float x) (real_of_float y) = real_of_float (float_divr p x y)"
  by (simp add: float_divr.rep_eq real_divr_def)

end


section \<open>WebAssembly Base Definitions\<close>

theory Wasm_Base_Defs imports Wasm_Ast Wasm_Type_Abs begin

instantiation i32 :: wasm_int begin instance .. end
instantiation i64 :: wasm_int64 begin instance .. end
instantiation f32 :: wasm_float begin instance .. end
instantiation f64 :: wasm_float begin instance .. end

consts
  (* inter-type conversions *)
  (* float to i32 *)
  ui32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  si32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  ui32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  si32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  ui32_trunc_sat_f32 :: "f32 \<Rightarrow> i32"
  si32_trunc_sat_f32 :: "f32 \<Rightarrow> i32"
  ui32_trunc_sat_f64 :: "f64 \<Rightarrow> i32"
  si32_trunc_sat_f64 :: "f64 \<Rightarrow> i32"
  (* float to i64 *)
  ui64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  si64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  ui64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  si64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  ui64_trunc_sat_f32 :: "f32 \<Rightarrow> i64"
  si64_trunc_sat_f32 :: "f32 \<Rightarrow> i64"
  ui64_trunc_sat_f64 :: "f64 \<Rightarrow> i64"
  si64_trunc_sat_f64 :: "f64 \<Rightarrow> i64"
  (* int to f32 *)
  f32_convert_ui32 :: "i32 \<Rightarrow> f32"
  f32_convert_si32 :: "i32 \<Rightarrow> f32"
  f32_convert_ui64 :: "i64 \<Rightarrow> f32"
  f32_convert_si64 :: "i64 \<Rightarrow> f32"
  (* int to f64 *)
  f64_convert_ui32 :: "i32 \<Rightarrow> f64"
  f64_convert_si32 :: "i32 \<Rightarrow> f64"
  f64_convert_ui64 :: "i64 \<Rightarrow> f64"
  f64_convert_si64 :: "i64 \<Rightarrow> f64"
  (* sign-extending int *)
  i32_extend8_s :: "i32 \<Rightarrow> i32"
  i32_extend16_s :: "i32 \<Rightarrow> i32"
  i64_extend8_s :: "i64 \<Rightarrow> i64"
  i64_extend16_s :: "i64 \<Rightarrow> i64"
  i64_extend32_s :: "i64 \<Rightarrow> i64"
  (* intra-{int/float} conversions *)
  wasm_wrap :: "i64 \<Rightarrow> i32"
  wasm_extend_u :: "i32 \<Rightarrow> i64"
  wasm_extend_s :: "i32 \<Rightarrow> i64"
  wasm_demote :: "f64 \<Rightarrow> f32"
  wasm_promote :: "f32 \<Rightarrow> f64"
  (* boolean encoding *)
  serialise_i32 :: "i32 \<Rightarrow> bytes"
  serialise_i64 :: "i64 \<Rightarrow> bytes"
  serialise_f32 :: "f32 \<Rightarrow> bytes"
  serialise_f64 :: "f64 \<Rightarrow> bytes"
  wasm_bool :: "bool \<Rightarrow> i32"
  int32_minus_one :: i32

  (* memory *)
definition mem_size :: "mem \<Rightarrow> nat" where
  "mem_size m = length (Rep_mem m)"

definition mem_grow :: "mem \<Rightarrow> nat \<Rightarrow> mem" where
  "mem_grow m n = mem_append m (bytes_replicate (n * 64000) 0)"

definition load :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load m n off l = (if (mem_size m \<ge> (n+off+l))
                       then Some (read_bytes m (n+off) l)
                       else None)"

definition sign_extend :: "sx \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" where
  "sign_extend sx l bytes = (let msb = msb (msbyte bytes) in
                          let byte = (case sx of U \<Rightarrow> 0 | S \<Rightarrow> if msb then -1 else 0) in
                          bytes_takefill byte l bytes)"

definition load_packed :: "sx \<Rightarrow> mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load_packed sx m n off lp l = map_option (sign_extend sx l) (load m n off lp)"

definition store :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store m n off bs l = (if (mem_size m \<ge> (n+off+l))
                          then Some (write_bytes m (n+off) (bytes_takefill 0 l bs))
                          else None)"

definition store_packed :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store_packed = store"

consts
  wasm_deserialise :: "bytes \<Rightarrow> t \<Rightarrow> v"
  (* host *)
  host_apply :: "s \<Rightarrow> tf \<Rightarrow> host \<Rightarrow> v list \<Rightarrow> host_state \<Rightarrow> (s \<times> v list) option"

definition typeof :: " v \<Rightarrow> t" where
  "typeof v = (case v of
                 ConstInt32 _ \<Rightarrow> T_i32
               | ConstInt64 _ \<Rightarrow> T_i64
               | ConstFloat32 _ \<Rightarrow> T_f32
               | ConstFloat64 _ \<Rightarrow> T_f64)"

definition option_projl :: "('a \<times> 'b) option \<Rightarrow> 'a option" where
  "option_projl x = map_option fst x"

definition option_projr :: "('a \<times> 'b) option \<Rightarrow> 'b option" where
  "option_projr x = map_option snd x"

definition t_length :: "t \<Rightarrow> nat" where
 "t_length t = (case t of
                  T_i32 \<Rightarrow> 4
                | T_i64 \<Rightarrow> 8
                | T_f32 \<Rightarrow> 4
                | T_f64 \<Rightarrow> 8)"

definition tp_length :: "tp \<Rightarrow> nat" where
 "tp_length tp = (case tp of
                 Tp_i8 \<Rightarrow> 1
               | Tp_i16 \<Rightarrow> 2
               | Tp_i32 \<Rightarrow> 4)"

definition is_int_t :: "t \<Rightarrow> bool" where
 "is_int_t t = (case t of
                  T_i32 \<Rightarrow> True
                | T_i64 \<Rightarrow> True
                | T_f32 \<Rightarrow> False
                | T_f64 \<Rightarrow> False)"

definition is_float_t :: "t \<Rightarrow> bool" where
 "is_float_t t = (case t of
                    T_i32 \<Rightarrow> False
                  | T_i64 \<Rightarrow> False
                  | T_f32 \<Rightarrow> True
                  | T_f64 \<Rightarrow> True)"

definition is_mut :: "tg \<Rightarrow> bool" where
  "is_mut tg = (tg_mut tg = T_mut)"

definition app_unop_i :: "unop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int" where
  "app_unop_i iop c =
     (case iop of
     Ctz \<Rightarrow> int_ctz c
   | Clz \<Rightarrow> int_clz c
   | Popcnt \<Rightarrow> int_popcnt c)"

definition app_unop_f :: "unop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float" where
  "app_unop_f fop c =
                 (case fop of
                    Neg \<Rightarrow> float_neg c
                  | Abs \<Rightarrow> float_abs c
                  | Ceil \<Rightarrow> float_ceil c
                  | Floor \<Rightarrow> float_floor c
                  | Trunc \<Rightarrow> float_trunc c
                  | Nearest \<Rightarrow> float_nearest c
                  | Sqrt \<Rightarrow> float_sqrt c)"

definition app_extendsop_i32 :: "extendsop \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int" where
  "app_extendsop_i32 extendsop c = (case extendsop of
                                    Extend8S \<Rightarrow> int_extend8_s c
                                  | Extend16S \<Rightarrow> int_extend16_s c)"

definition app_extendsop_i64 :: "extendsop \<Rightarrow> 'i::wasm_int64 \<Rightarrow> 'i::wasm_int64" where
  "app_extendsop_i64 extendsop c = (case extendsop of
                                    Extend8S \<Rightarrow> int_extend8_s c
                                  | Extend16S \<Rightarrow> int_extend16_s c
                                  | Extend32S \<Rightarrow> int64_extend32_s c)"

definition app_binop_i :: "binop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> ('i::wasm_int) option" where
  "app_binop_i iop c1 c2 = (case iop of
                              Add \<Rightarrow> Some (int_add c1 c2)
                            | Sub \<Rightarrow> Some (int_sub c1 c2)
                            | Mul \<Rightarrow> Some (int_mul c1 c2)
                            | Div U \<Rightarrow> int_div_u c1 c2
                            | Div S \<Rightarrow> int_div_s c1 c2
                            | Rem U \<Rightarrow> int_rem_u c1 c2
                            | Rem S \<Rightarrow> int_rem_s c1 c2
                            | And \<Rightarrow> Some (int_and c1 c2)
                            | Or \<Rightarrow> Some (int_or c1 c2)
                            | Xor \<Rightarrow> Some (int_xor c1 c2)
                            | Shl \<Rightarrow> Some (int_shl c1 c2)
                            | Shr U \<Rightarrow> Some (int_shr_u c1 c2)
                            | Shr S \<Rightarrow> Some (int_shr_s c1 c2)
                            | Rotl \<Rightarrow> Some (int_rotl c1 c2)
                            | Rotr \<Rightarrow> Some (int_rotr c1 c2))"

definition app_binop_f :: "binop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> ('f::wasm_float) option" where
  "app_binop_f fop c1 c2 = (case fop of
                              Addf \<Rightarrow> Some (float_add c1 c2)
                            | Subf \<Rightarrow> Some (float_sub c1 c2)
                            | Mulf \<Rightarrow> Some (float_mul c1 c2)
                            | Divf \<Rightarrow> Some (float_div c1 c2)
                            | Min \<Rightarrow> Some (float_min c1 c2)
                            | Max \<Rightarrow> Some (float_max c1 c2)
                            | Copysign \<Rightarrow> Some (float_copysign c1 c2))"

definition app_testop_i :: "testop \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_testop_i testop c = (case testop of Eqz \<Rightarrow> int_eqz c)"

definition app_relop_i :: "relop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_relop_i rop c1 c2 = (case rop of
                              Eq \<Rightarrow> int_eq c1 c2
                            | Ne \<Rightarrow> int_ne c1 c2
                            | Lt U \<Rightarrow> int_lt_u c1 c2
                            | Lt S \<Rightarrow> int_lt_s c1 c2
                            | Gt U \<Rightarrow> int_gt_u c1 c2
                            | Gt S \<Rightarrow> int_gt_s c1 c2
                            | Le U \<Rightarrow> int_le_u c1 c2
                            | Le S \<Rightarrow> int_le_s c1 c2
                            | Ge U \<Rightarrow> int_ge_u c1 c2
                            | Ge S \<Rightarrow> int_ge_s c1 c2)"

definition app_relop_f :: "relop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> bool" where
  "app_relop_f rop c1 c2 = (case rop of
                              Eqf \<Rightarrow> float_eq c1 c2
                            | Nef \<Rightarrow> float_ne c1 c2
                            | Ltf \<Rightarrow> float_lt c1 c2
                            | Gtf \<Rightarrow> float_gt c1 c2
                            | Lef \<Rightarrow> float_le c1 c2
                            | Gef \<Rightarrow> float_ge c1 c2)"

definition types_agree :: "t \<Rightarrow> v \<Rightarrow> bool" where
  "types_agree t v = (typeof v = t)"

definition cl_type :: "cl \<Rightarrow> tf" where
  "cl_type cl = (case cl of Func_native _ tf _ _ \<Rightarrow> tf | Func_host tf _ \<Rightarrow> tf)"

definition rglob_is_mut :: "global \<Rightarrow> bool" where
  "rglob_is_mut g = (g_mut g = T_mut)"

definition stypes :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tf" where
  "stypes s i j = ((types ((inst s)!i))!j)"

definition sfunc_ind :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sfunc_ind s i j = ((inst.funcs ((inst s)!i))!j)"

definition sfunc :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl" where
  "sfunc s i j = (funcs s)!(sfunc_ind s i j)"

definition sglob_ind :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sglob_ind s i j = ((inst.globs ((inst s)!i))!j)"

definition sglob :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> global" where
  "sglob s i j = (globs s)!(sglob_ind s i j)"

definition sglob_val :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> v" where
  "sglob_val s i j = g_val (sglob s i j)"

definition smem_ind :: "s \<Rightarrow> nat \<Rightarrow> nat option" where
  "smem_ind s i = (inst.mem ((inst s)!i))"

definition stab_s :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab_s s i j = (let stabinst = ((tab s)!i) in  (if (length (stabinst) > j) then (stabinst!j) else None))"

definition stab :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab s i j = (case (inst.tab ((inst s)!i)) of Some k => stab_s s k j | None => None)"

definition supdate_glob_s :: "s \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob_s s k v = s\<lparr>globs := (globs s)[k:=((globs s)!k)\<lparr>g_val := v\<rparr>]\<rparr>"

definition supdate_glob :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob s i j v = (let k = sglob_ind s i j in supdate_glob_s s k v)"

definition is_const :: "e \<Rightarrow> bool" where
  "is_const e = (case e of Basic (C _) \<Rightarrow> True | _ \<Rightarrow> False)"

definition const_list :: "e list \<Rightarrow> bool" where
  "const_list xs = list_all is_const xs"

inductive store_extension :: "s \<Rightarrow> s \<Rightarrow> bool" where
"\<lbrakk>insts = insts'; fs = fs'; tclss = tclss'; list_all2 (\<lambda>bs bs'. mem_size bs \<le> mem_size bs') bss bss'; gs = gs'\<rbrakk> \<Longrightarrow>
  store_extension \<lparr>s.inst = insts, s.funcs = fs, s.tab = tclss, s.mem = bss, s.globs = gs\<rparr>
                    \<lparr>s.inst = insts', s.funcs = fs', s.tab = tclss', s.mem = bss', s.globs = gs'\<rparr>"

abbreviation to_e_list :: "b_e list \<Rightarrow> e list" ("$* _" 60) where
  "to_e_list b_es \<equiv> map Basic b_es"

abbreviation v_to_e_list :: "v list \<Rightarrow> e list" ("$$* _" 60) where
  "v_to_e_list ves \<equiv> map (\<lambda>v. $C v) ves"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>const_list vs; lholed = (LBase vs es')\<rbrakk> \<Longrightarrow> Lfilled 0 lholed es (vs @ es @ es')"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled_exact :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>lholed = (LBase [] [])\<rbrakk> \<Longrightarrow> Lfilled_exact 0 lholed es es"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled_exact k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled_exact (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

definition load_store_t_bounds :: "a \<Rightarrow> tp option \<Rightarrow> t \<Rightarrow> bool" where
  "load_store_t_bounds a tp t = (case tp of
                                   None \<Rightarrow> 2^a \<le> t_length t
                                 | Some tp \<Rightarrow> 2^a \<le> tp_length tp \<and> tp_length tp < t_length t \<and>  is_int_t t)"

definition cvt_i32 :: "sx option \<Rightarrow> v \<Rightarrow> i32 option" where
  "cvt_i32 sx v = (case v of
                   ConstInt32 c \<Rightarrow> None
                 | ConstInt64 c \<Rightarrow> Some (wasm_wrap c)
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f32 c
                                      | Some S \<Rightarrow> si32_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f64 c
                                      | Some S \<Rightarrow> si32_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_i64 :: "sx option \<Rightarrow> v \<Rightarrow> i64 option" where
  "cvt_i64 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (wasm_extend_u c)
                                      | Some S \<Rightarrow> Some (wasm_extend_s c)
                                      | None \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> None
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f32 c
                                      | Some S \<Rightarrow> si64_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f64 c
                                      | Some S \<Rightarrow> si64_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_f32 :: "sx option \<Rightarrow> v \<Rightarrow> f32 option" where
  "cvt_f32 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> None
                 | ConstFloat64 c \<Rightarrow> Some (wasm_demote c))"

definition cvt_f64 :: "sx option \<Rightarrow> v \<Rightarrow> f64 option" where
  "cvt_f64 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> Some (wasm_promote c)
                 | ConstFloat64 c \<Rightarrow> None)"

definition cvt :: "t \<Rightarrow> sx option \<Rightarrow> v \<Rightarrow> v option" where
  "cvt t sx v = (case t of
                 T_i32 \<Rightarrow> (case (cvt_i32 sx v) of Some c \<Rightarrow> Some (ConstInt32 c) | None \<Rightarrow> None)
               | T_i64 \<Rightarrow> (case (cvt_i64 sx v) of Some c \<Rightarrow> Some (ConstInt64 c) | None \<Rightarrow> None)
               | T_f32 \<Rightarrow> (case (cvt_f32 sx v) of Some c \<Rightarrow> Some (ConstFloat32 c) | None \<Rightarrow> None)
               | T_f64 \<Rightarrow> (case (cvt_f64 sx v) of Some c \<Rightarrow> Some (ConstFloat64 c) | None \<Rightarrow> None))"

definition cvt_i32_sat :: "sx option \<Rightarrow> v \<Rightarrow> i32 option" where
  "cvt_i32_sat sx v = (case v of
                   ConstInt32 c \<Rightarrow> None
                 | ConstInt64 c \<Rightarrow> Some (wasm_wrap c)
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some(ui32_trunc_sat_f32 c)
                                      | Some S \<Rightarrow> Some(si32_trunc_sat_f32 c)
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (ui32_trunc_sat_f64 c)
                                      | Some S \<Rightarrow> Some (si32_trunc_sat_f64 c)
                                      | None \<Rightarrow> None))"

definition cvt_i64_sat :: "sx option \<Rightarrow> v \<Rightarrow> i64 option" where
  "cvt_i64_sat sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (wasm_extend_u c)
                                      | Some S \<Rightarrow> Some (wasm_extend_s c)
                                      | None \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> None
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (ui64_trunc_sat_f32 c)
                                      | Some S \<Rightarrow> Some (si64_trunc_sat_f32 c)
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (ui64_trunc_sat_f64 c)
                                      | Some S \<Rightarrow> Some (si64_trunc_sat_f64 c)
                                      | None \<Rightarrow> None))"

definition cvt_f32_sat :: "sx option \<Rightarrow> v \<Rightarrow> f32 option" where
  "cvt_f32_sat sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> None
                 | ConstFloat64 c \<Rightarrow> Some (wasm_demote c))"

definition cvt_f64_sat :: "sx option \<Rightarrow> v \<Rightarrow> f64 option" where
  "cvt_f64_sat sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> Some (wasm_promote c)
                 | ConstFloat64 c \<Rightarrow> None)"

definition cvt_sat :: "t \<Rightarrow> sx option \<Rightarrow> v \<Rightarrow> v option" where
  "cvt_sat t sx v = (case t of
                 T_i32 \<Rightarrow> (case (cvt_i32_sat sx v) of Some c \<Rightarrow> Some (ConstInt32 c) | None \<Rightarrow> None)
               | T_i64 \<Rightarrow> (case (cvt_i64_sat sx v) of Some c \<Rightarrow> Some (ConstInt64 c) | None \<Rightarrow> None)
               | T_f32 \<Rightarrow> (case (cvt_f32_sat sx v) of Some c \<Rightarrow> Some (ConstFloat32 c) | None \<Rightarrow> None)
               | T_f64 \<Rightarrow> (case (cvt_f64_sat sx v) of Some c \<Rightarrow> Some (ConstFloat64 c) | None \<Rightarrow> None))"

definition bits :: "v \<Rightarrow> bytes" where
  "bits v = (case v of
               ConstInt32 c \<Rightarrow> (serialise_i32 c)
             | ConstInt64 c \<Rightarrow> (serialise_i64 c)
             | ConstFloat32 c \<Rightarrow> (serialise_f32 c)
             | ConstFloat64 c \<Rightarrow> (serialise_f64 c))"

definition bitzero :: "t \<Rightarrow> v" where
  "bitzero t = (case t of
                T_i32 \<Rightarrow> ConstInt32 0
              | T_i64 \<Rightarrow> ConstInt64 0
              | T_f32 \<Rightarrow> ConstFloat32 0
              | T_f64 \<Rightarrow> ConstFloat64 0)"

definition n_zeros :: "t list \<Rightarrow> v list" where
  "n_zeros ts = (map (\<lambda>t. bitzero t) ts)"

lemma is_int_t_exists:
  assumes "is_int_t t"
  shows "t = T_i32 \<or> t = T_i64"
  using assms
  by (cases t) (auto simp add: is_int_t_def)

lemma is_float_t_exists:
  assumes "is_float_t t"
  shows "t = T_f32 \<or> t = T_f64"
  using assms
  by (cases t) (auto simp add: is_float_t_def)

lemma int_float_disjoint: "is_int_t t = -(is_float_t t)"
  by simp (metis is_float_t_def is_int_t_def t.exhaust t.simps(13-16))

lemma stab_unfold:
  assumes "stab s i j = Some cl"
  shows "\<exists>k. inst.tab ((inst s)!i) = Some k \<and> length ((tab s)!k) > j \<and>((tab s)!k)!j = Some cl"
proof -
  obtain k where have_k:"(inst.tab ((inst s)!i)) = Some k"
    using assms
    unfolding stab_def
    by fastforce
  hence s_o:"stab s i j = stab_s s k j"
    using assms
    unfolding stab_def
    by simp
  then obtain stabinst where stabinst_def:"stabinst = ((tab s)!k)"
    by blast
  hence "stab_s s k j = (stabinst!j) \<and> (length stabinst > j)"
    using assms s_o
    unfolding stab_s_def
    by (cases "(length stabinst > j)", auto)
  thus ?thesis
    using have_k stabinst_def assms s_o
    by auto
qed

lemma inj_basic: "inj Basic"
  by (meson e.inject(1) injI)

lemma inj_basic_econst: "inj (\<lambda>v. $C v)"
  by (meson b_e.inject(18) e.inject(1) injI)

lemma to_e_list_1:"[$ a] = $* [a]"
  by simp

lemma to_e_list_2:"[$ a, $ b] = $* [a, b]"
  by simp

lemma to_e_list_3:"[$ a, $ b, $ c] = $* [a, b, c]"
  by simp

lemma v_exists_b_e:"\<exists>ves. ($$*vs) = ($*ves)"
proof (induction vs)
  case (Cons a vs)
  thus ?case
  by (metis list.simps(9))
qed auto

lemma Lfilled_exact_imp_Lfilled:
  assumes "Lfilled_exact n lholed es LI"
  shows "Lfilled n lholed es LI"
  using assms
proof (induction rule: Lfilled_exact.induct)
  case (L0 lholed es)
  thus ?case
    using const_list_def Lfilled.intros(1)
    by fastforce
next
  case (LN vs lholed n es' l es'' k es lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_exact_app_imp_exists_Lfilled:
  assumes "const_list ves"
          "Lfilled_exact n lholed (ves@es) LI"
  shows "\<exists>lholed'. Lfilled n lholed' es LI"
  using assms(2,1)
proof (induction "(ves@es)" LI rule: Lfilled_exact.induct)
  case (L0 lholed)
  show ?case
    using Lfilled.intros(1)[OF L0(2), of _ "[]"]
    by fastforce
next
  case (LN vs lholed n es' l es'' k lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_imp_exists_Lfilled_exact:
  assumes "Lfilled n lholed es LI"
  shows "\<exists>lholed' ves es_c. const_list ves \<and> Lfilled_exact n lholed' (ves@es@es_c) LI"
  using assms Lfilled_exact.intros
  by (induction rule: Lfilled.induct) fastforce+

lemma n_zeros_typeof:
  "n_zeros ts = vs \<Longrightarrow> (ts = map typeof vs)"
proof (induction ts arbitrary: vs)
  case Nil
  thus ?case
    unfolding n_zeros_def
    by simp
next
  case (Cons t ts)
  obtain vs' where "n_zeros ts = vs'"
    using n_zeros_def
    by blast
  moreover
  have "typeof (bitzero t) = t"
    unfolding typeof_def bitzero_def
    by (cases t, simp_all)
  ultimately
  show ?case
    using Cons
    unfolding n_zeros_def
    by auto
qed

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

theory DiskPaxos imports DiskPaxos_Invariant begin

subsection \<open>Inner Module\<close>

record
Istate =
  iinput :: "Proc \<Rightarrow> InputsOrNi"
  ioutput :: "Proc \<Rightarrow> InputsOrNi"
  ichosen :: InputsOrNi
  iallInput :: "InputsOrNi set"

definition IInit :: "Istate \<Rightarrow> bool"
where
  "IInit s =  (range (iinput s) \<subseteq> Inputs
             \<and> ioutput s = (\<lambda>p. NotAnInput)
             \<and> ichosen s = NotAnInput
             \<and> iallInput s = range (iinput s))"

definition IChoose :: "Istate \<Rightarrow> Istate \<Rightarrow> Proc \<Rightarrow> bool"
where
  "IChoose s s' p = (ioutput s p = NotAnInput
                   \<and> (if (ichosen s = NotAnInput)
                        then (\<exists>ip \<in> iallInput s.  ichosen s' = ip
                                            \<and> ioutput s' = (ioutput s) (p := ip))
                        else (  ioutput s' = (ioutput s) (p:= ichosen s)
                               \<and> ichosen s' = ichosen s))
                    \<and> iinput s' = iinput s \<and> iallInput s'= iallInput s)"

definition IFail :: "Istate \<Rightarrow> Istate \<Rightarrow> Proc \<Rightarrow> bool"
where
  "IFail s s' p =   (ioutput s' = (ioutput s) (p:= NotAnInput)
                  \<and> (\<exists>ip \<in> Inputs.  iinput s' = (iinput s)(p:= ip)
                                   \<and> iallInput s' = iallInput s \<union> {ip})
                  \<and> ichosen s' = ichosen s)"

definition INext :: "Istate \<Rightarrow> Istate \<Rightarrow> bool"
  where "INext s s' = (\<exists>p. IChoose s s' p \<or> IFail s s' p)"

definition s2is :: "state \<Rightarrow> Istate"
where
  "s2is s = \<lparr>iinput = inpt s,
             ioutput = outpt s,
             ichosen=chosen s,
             iallInput = allInput s\<rparr>"

theorem R1:
  "\<lbrakk> HInit s; is = s2is s\<rbrakk> \<Longrightarrow> IInit is"
  by(auto simp add: HInit_def IInit_def s2is_def Init_def)

theorem R2b:
  assumes inv: "HInv s"
  and inv': "HInv s'"
  and nxt: "HNext s s'"
  and srel: "is=s2is s \<and> is'=s2is s'"
  shows "(\<exists>p. IFail is is' p \<or> IChoose is is' p) \<or> is = is'"
proof(auto)
  assume chg_vars: "is\<noteq>is'"
  with srel
  have s_change: "   inpt s \<noteq> inpt s' \<or> outpt s \<noteq> outpt s'
                  \<or> chosen s \<noteq> chosen s' \<or> allInput s \<noteq> allInput s'"
    by(auto simp add: s2is_def)
  from inv
  have inv2c5: "\<forall>p.   inpt s p \<in> allInput s
                    \<and> (chosen s = NotAnInput \<longrightarrow> outpt s p = NotAnInput)"
    by(auto simp add: HInv_def HInv2_def Inv2c_def Inv2c_inner_def)
  from nxt s_change inv2c5
  have "inpt s' \<noteq> inpt s \<or> outpt s' \<noteq> outpt s"
    by(auto simp add: HNext_def Next_def HNextPart_def)
  with nxt
  have "\<exists>p. Fail s s' p \<or> EndPhase2 s s' p"
    by(auto simp add: HNext_def Next_def
      StartBallot_def Phase0Read_def Phase1or2Write_def
      Phase1or2Read_def Phase1or2ReadThen_def Phase1or2ReadElse_def
      EndPhase1or2_def EndPhase1_def EndPhase0_def)
  then obtain p where fail_or_endphase2: "Fail s s' p \<or> EndPhase2 s s' p"
    by auto
  from inv
  have inv2c: "Inv2c_inner s p"
    by(auto simp add: HInv_def HInv2_def Inv2c_def)
  from fail_or_endphase2 have "IFail is is' p \<or> IChoose is is' p"
  proof
    assume fail: "Fail s s' p "
    hence phase': "phase s' p = 0"
      and  outpt: "outpt s' = (outpt s) (p:= NotAnInput)"
      by(auto simp add: Fail_def)
    have "IFail is is' p"
    proof -
      from fail srel
      have "ioutput is' = (ioutput is) (p:= NotAnInput)"
        by(auto simp add: Fail_def s2is_def)
      moreover
      from nxt
      have all_nxt: "allInput s'= allInput s \<union> (range (inpt s'))"
        by(auto simp add: HNext_def HNextPart_def)
      from fail srel
      have "\<exists>ip \<in> Inputs.  iinput is' = (iinput is)(p:= ip)"
        by(auto simp add: Fail_def s2is_def)
      then obtain ip where ip_Input: "ip\<in>Inputs" and "iinput is' = (iinput is)(p:= ip)"
        by auto
      with inv2c5 srel all_nxt
      have "  iinput is' = (iinput is)(p:= ip)
        \<and> iallInput is' = iallInput is \<union> {ip}"
        by(auto simp add: s2is_def)
      moreover
      from outpt srel nxt inv2c
      have "ichosen is' = ichosen is"
        by(auto simp add: HNext_def HNextPart_def s2is_def Inv2c_inner_def)
      ultimately
      show ?thesis
        using ip_Input
        by(auto simp add: IFail_def)
    qed
    thus ?thesis
      by auto
  next
    assume endphase2: "EndPhase2 s s' p"
    from endphase2
    have "phase s p =2"
      by(auto simp add: EndPhase2_def)
    with inv2c Ballot_nzero
    have bal_dblk_nzero: "bal(dblock s p)\<noteq> 0"
      by(auto simp add: Inv2c_inner_def)
    moreover
    from inv
    have inv2a_dblock: "Inv2a_innermost s p (dblock s p)"
      by(auto simp add: HInv_def HInv2_def Inv2a_def Inv2a_inner_def blocksOf_def)
    ultimately
    have p22: "inp (dblock s p) \<in> allInput s"
      by(auto simp add: Inv2a_innermost_def)
    from inv
    have "allInput s \<subseteq> Inputs"
      by(auto simp add: HInv_def HInv1_def)
    with p22 NotAnInput endphase2
    have outpt_nni: "outpt s' p \<noteq> NotAnInput"
      by(auto simp add: EndPhase2_def)
    show ?thesis
    proof(cases "chosen s = NotAnInput")
      case True
      with inv2c5
      have p31: "\<forall>q. outpt s q = NotAnInput"
        by auto
      with endphase2
      have p32: "\<forall>q \<in> UNIV -{p}. outpt s' q = NotAnInput"
        by(auto simp add: EndPhase2_def)
      hence some_eq: "(\<And>x. outpt s' x \<noteq> NotAnInput \<Longrightarrow> x = p)"
        by auto
      from p32 True nxt some_equality[of "\<lambda>p. outpt s' p \<noteq> NotAnInput", OF outpt_nni some_eq]
      have p33: "chosen s' = outpt s' p"
        by(auto simp add: HNext_def HNextPart_def)
      with endphase2
      have "chosen s' = inp(dblock s p) \<and> outpt s' = (outpt s)(p:=inp(dblock s p))"
        by(auto simp add: EndPhase2_def)
      with True p22
      have "if (chosen s = NotAnInput)
                        then (\<exists>ip \<in> allInput s.  chosen s' = ip
                                            \<and> outpt s' = (outpt s) (p := ip))
                        else (  outpt s' = (outpt s) (p:= chosen s)
                               \<and> chosen s' = chosen s)"
        by auto
      moreover
      from endphase2 inv2c5 nxt
      have "inpt s' = inpt s \<and> allInput s'= allInput s"
        by(auto simp add: EndPhase2_def HNext_def HNextPart_def)
      ultimately
      show ?thesis
        using srel p31
        by(auto simp add: IChoose_def s2is_def)
    next
      case False
      with nxt
      have p31: "chosen s' = chosen s"
        by(auto simp add: HNext_def HNextPart_def)
      from inv'
      have inv6: "HInv6 s'"
        by(auto simp add: HInv_def)
      have p32: "outpt s' p = chosen s"
      proof-
        from endphase2
        have "outpt s' p  = inp(dblock s p)"
          by(auto simp add: EndPhase2_def)
        moreover
        from inv6 p31
        have "outpt s' p \<in> {chosen s, NotAnInput}"
          by(auto simp add: HInv6_def)
        ultimately
        show ?thesis
          using outpt_nni
          by auto
      qed
      from srel False
      have "IChoose is is' p"
      proof(clarsimp simp add: IChoose_def s2is_def)
        from endphase2 inv2c
        have "outpt s p = NotAnInput"
          by(auto simp add: EndPhase2_def Inv2c_inner_def)
        moreover
        from endphase2 p31 p32 False
        have "outpt s' = (outpt s) (p:= chosen s) \<and> chosen s' = chosen s"
          by(auto simp add: EndPhase2_def)
        moreover
        from endphase2 nxt inv2c5
        have "inpt s' = inpt s \<and> allInput s'= allInput s"
          by(auto simp add: EndPhase2_def HNext_def HNextPart_def)
        ultimately
        show "  outpt s p = NotAnInput
              \<and> outpt s' = (outpt s)(p := chosen s) \<and> chosen s' = chosen s
              \<and> inpt s' = inpt s \<and> allInput s' = allInput s"
          by auto
      qed
      thus ?thesis
        by auto
    qed
  qed
  thus "\<exists>p. IFail is is' p \<or> IChoose is is' p"
    by auto
qed

end


subsection \<open>AddNode Phase\<close>

theory AddPhase
  imports
    Common
begin

phase AddNode
  terminating size
begin

lemma binadd_commute:
  assumes "bin_eval BinAdd x y \<noteq> UndefVal"
  shows "bin_eval BinAdd x y = bin_eval BinAdd y x"
  using assms intval_add_sym by simp

(* horrible backward proof - needs improving *)
optimization AddShiftConstantRight: "((const v) + y) \<longmapsto> y + (const v) when \<not>(is_ConstantExpr y)"
  using size_non_const
  apply (metis add_2_eq_Suc' less_Suc_eq plus_1_eq_Suc size.simps(11) size_non_add)
  unfolding le_expr_def
  apply (rule impI)
  subgoal premises 1
    apply (rule allI impI)+
    (* apply auto  -- unfolds premise eval, but not concl. *)
    subgoal premises 2 for m p va
      apply (rule BinaryExprE[OF 2])  (* go forward from v+y *)
      subgoal premises 3 for x ya
        apply (rule BinaryExpr)       (* go backward from y+v *)
        using 3 apply simp
        using 3 apply simp
        using 3 binadd_commute apply auto
        done
      done
    done
  done

optimization AddShiftConstantRight2: "((const v) + y) \<longmapsto> y + (const v) when \<not>(is_ConstantExpr y)"
  unfolding le_expr_def
   apply (auto simp: intval_add_sym)
  (* termination proof *)
  using size_non_const
  by (metis add_2_eq_Suc' lessI plus_1_eq_Suc size.simps(11) size_non_add)

(* TODO: define is_neutral and then lemmas like this:
lemma simp_neutral:
  assumes n: "is_neutral op (IntVal32 n)"
  shows "bin_eval op x (IntVal32 n) = x"
  apply (induction op)
  unfolding is_neutral.simps
  using n apply auto
*)

(* poor-mans is_neutral lemma *)
lemma is_neutral_0 [simp]:
  assumes 1: "intval_add (IntVal b x) (IntVal b 0) \<noteq> UndefVal"
  shows "intval_add (IntVal b x) (IntVal b 0) = (new_int b x)"
  using 1 by auto

optimization AddNeutral: "(e + (const (IntVal 32 0))) \<longmapsto> e"
  unfolding le_expr_def apply auto
  using is_neutral_0 eval_unused_bits_zero
  by (smt (verit) add_cancel_left_right intval_add.elims val_to_bool.simps(1))

ML_val \<open>@{term \<open>x = y\<close>}\<close>

lemma NeutralLeftSubVal:
  assumes "e1 = new_int b ival"
  shows "val[(e1 - e2) + e2] \<approx> e1"
  apply simp using assms by (cases e1; cases e2; auto)

optimization RedundantSubAdd: "((e\<^sub>1 - e\<^sub>2) + e\<^sub>2) \<longmapsto> e\<^sub>1"
  apply auto using eval_unused_bits_zero NeutralLeftSubVal
  unfolding well_formed_equal_defn
  by (smt (verit) evalDet intval_sub.elims new_int.elims)

(* a little helper lemma for using universal quantified assumptions *)
lemma allE2: "(\<forall>x y. P x y) \<Longrightarrow> (P a b \<Longrightarrow> R) \<Longrightarrow> R"
  by simp

lemma just_goal2:
  assumes 1: "(\<forall> a b. (intval_add (intval_sub a b) b \<noteq> UndefVal \<and> a \<noteq> UndefVal \<longrightarrow>
    intval_add (intval_sub a b) b = a))"
  shows "(BinaryExpr BinAdd (BinaryExpr BinSub e\<^sub>1 e\<^sub>2) e\<^sub>2) \<ge> e\<^sub>1"
  unfolding le_expr_def unfold_binary bin_eval.simps
  by (metis 1 evalDet evaltree_not_undef)

optimization RedundantSubAdd2: " e\<^sub>2 + (e\<^sub>1 - e\<^sub>2) \<longmapsto> e\<^sub>1"
  apply (metis add.commute add_less_cancel_right less_add_Suc2 plus_1_eq_Suc size_binary_const size_non_add trans_less_add2)
  by (smt (verit, del_insts) BinaryExpr BinaryExprE RedundantSubAdd(1) binadd_commute le_expr_def rewrite_preservation.simps(1))

(* Demonstration of our FOUR levels of expression rewrites:
   =======================================================
  level 1 (Java-like): "-e + y \<longmapsto> y - e"
  level 2 (expr trees): "rewrite_preservation
     (BinaryExpr BinAdd (UnaryExpr UnaryNeg e) y \<longmapsto> BinaryExpr BinSub y e) &&&
    rewrite_termination
     (BinaryExpr BinAdd (UnaryExpr UnaryNeg e) y \<longmapsto> BinaryExpr BinSub y e)
     Common.size"
  level 2b: "BinaryExpr BinAdd (UnaryExpr UnaryNeg e) y \<le> BinaryExpr BinSub y e"
  level 2c: "\<forall>m p v. ([m,p] \<turnstile> BinaryExpr BinAdd (UnaryExpr UnaryNeg e) y \<mapsto> v)
                   \<longrightarrow> ([m,p] \<turnstile> BinaryExpr BinSub y e \<mapsto> v)"
  level 3 (intval ops): "\<And>m p xa ya.
       [m,p] \<turnstile> e \<mapsto> xa \<Longrightarrow>
       [m,p] \<turnstile> y \<mapsto> ya \<Longrightarrow>
       intval_negate xa \<noteq> UndefVal \<Longrightarrow>
       intval_add (intval_negate xa) ya \<noteq> UndefVal \<Longrightarrow>
       \<exists>x. ([m,p] \<turnstile> y \<mapsto> x) \<and>
           (\<exists>y. ([m,p] \<turnstile> e \<mapsto> y) \<and>
                intval_add (intval_negate xa) ya =
                intval_sub x y)"
  level 3b: "\<forall>m p v.
       (\<exists>x ya.
           (\<exists>xa. ([m,p] \<turnstile> e \<mapsto> xa) \<and>
                 x = intval_negate xa \<and> x \<noteq> UndefVal) \<and>
                 ([m,p] \<turnstile> y \<mapsto> ya) \<and>
                 v = intval_add x ya \<and> v \<noteq> UndefVal) \<longrightarrow>
       (\<exists>x ya.
           ([m,p] \<turnstile> y \<mapsto> x) \<and>
           ([m,p] \<turnstile> e \<mapsto> ya) \<and>
            v = intval_sub x ya \<and> v \<noteq> UndefVal)"
  level 4 (Word library): "-ev + yv = yv - ev" (twice, for 32-bit and 64-bit)
*)

(* The LowLevel version, intval_*, of this helper lemma is much easier
   to prove than the bin_eval level.  And equally easy to use in AddToSub.
 *)
lemma AddToSubHelperLowLevel:
  shows "intval_add (intval_negate e) y = intval_sub y e" (is "?x = ?y")
  by (induction y; induction e; auto)

print_phases

(* -----  Starts here -----  *)

(*
 AddNode has 8 optimisations total
 Currently *6* optimisations are verified.

 -- Already verified above --

 - AddShiftRightConst
 - RedundantSubAdd
 - AddNeutral (32-bit only)

 -- Verified below --

 - RedundantAddSub
 - AddRightNegateToSub
 - AddLeftNegateToSub

 -- Left to go --
 - MergeSignExtendAdd
 - MergeZeroExtendAdd

*)

(* Value level proofs *)
lemma val_redundant_add_sub:
  assumes "a = new_int bb ival"
  assumes "val[b + a] \<noteq> UndefVal"
  shows "val[(b + a) - b] = a"
  using assms apply (cases a; cases b; auto)
  by presburger

lemma val_add_right_negate_to_sub:
  assumes "val[x + e] \<noteq> UndefVal"
  shows "val[x + (-e)] = val[x - e]"
  using assms by (cases x; cases e; auto)

(* Exp level proofs *)
lemma exp_add_left_negate_to_sub:
  "exp[-e + y] \<ge> exp[y - e]"
  apply (cases e; cases y; auto)
  using AddToSubHelperLowLevel by auto+

text \<open>Optimisations\<close>

optimization RedundantAddSub: "(b + a) - b \<longmapsto> a"
   apply auto
  by (smt (verit) evalDet intval_add.elims new_int.elims val_redundant_add_sub
      eval_unused_bits_zero)

optimization AddRightNegateToSub: "x + -e \<longmapsto> x - e"
   apply (metis Nat.add_0_right add_2_eq_Suc' add_less_mono1 add_mono_thms_linordered_field(2)
          less_SucI not_less_less_Suc_eq size_binary_const size_non_add size_pos)
   using AddToSubHelperLowLevel intval_add_sym by auto

optimization AddLeftNegateToSub: "-e + y \<longmapsto> y - e"
  apply (smt (verit, best) One_nat_def add.commute add_Suc_right is_ConstantExpr_def less_add_Suc2
         numeral_2_eq_2 plus_1_eq_Suc size.simps(1) size.simps(11) size_binary_const size_non_add)
  using exp_add_left_negate_to_sub by blast

(* ----- Ends here ----- *)

end

(* Isabelle Isar Questions:
 Why doesn't subgoal handle \forall and \<longrightarrow> ?
 Then this pattern might become just a single subgoal?
  subgoal premises p1
    apply ((rule allI)+; rule impI)
    subgoal premises p2 for m p v
*)
end