(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005, 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. 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.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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>Rings - introduction\<close>

theory Ring_ZF imports AbelianGroup_ZF

begin

text\<open>This theory file covers basic facts about rings.\<close>

subsection\<open>Definition and basic properties\<close>

text\<open>In this section we define what is a ring and list the basic properties
  of rings.\<close>

text\<open>We say that three sets $(R,A,M)$ form a ring if $(R,A)$ is an abelian
  group, $(R,M)$ is a monoid and $A$ is distributive with respect to $M$ on
  $R$. $A$ represents the additive operation on $R$.
  As such it is a subset of $(R\times R)\times R$ (recall that in ZF set theory
  functions are sets).
  Similarly $M$ represents the multiplicative operation on $R$ and is also
  a subset of $(R\times R)\times R$.
  We  don't require the multiplicative operation to be commutative in the
  definition of a ring.\<close>

definition
  "IsAring(R,A,M) \<equiv> IsAgroup(R,A) \<and> (A {is commutative on} R) \<and>
  IsAmonoid(R,M) \<and> IsDistributive(R,A,M)"

text\<open>We also define the notion of having no zero divisors. In
  standard notation the ring has no zero divisors if for all $a,b \in R$ we have
  $a\cdot b = 0$ implies $a = 0$ or $b = 0$.
\<close>

definition
  "HasNoZeroDivs(R,A,M) \<equiv> (\<forall>a\<in>R. \<forall>b\<in>R.
  M`\<langle> a,b\<rangle> = TheNeutralElement(R,A) \<longrightarrow>
  a = TheNeutralElement(R,A) \<or> b = TheNeutralElement(R,A))"

text\<open>Next we define a locale that will be used when considering rings.\<close>

locale ring0 =

  fixes R and A and M

  assumes ringAssum: "IsAring(R,A,M)"

  fixes ringa (infixl "\<ra>" 90)
  defines ringa_def [simp]: "a\<ra>b \<equiv> A`\<langle> a,b\<rangle>"

  fixes ringminus ("\<rm> _" 89)
  defines ringminus_def [simp]: "(\<rm>a) \<equiv> GroupInv(R,A)`(a)"

  fixes ringsub (infixl "\<rs>" 90)
  defines ringsub_def [simp]: "a\<rs>b \<equiv> a\<ra>(\<rm>b)"

  fixes ringm (infixl "\<cdot>" 95)
  defines ringm_def [simp]: "a\<cdot>b \<equiv> M`\<langle> a,b\<rangle>"

  fixes ringzero ("\<zero>")
  defines ringzero_def [simp]: "\<zero> \<equiv> TheNeutralElement(R,A)"

  fixes ringone ("\<one>")
  defines ringone_def [simp]: "\<one> \<equiv> TheNeutralElement(R,M)"

  fixes ringtwo ("\<two>")
  defines ringtwo_def [simp]: "\<two> \<equiv> \<one>\<ra>\<one>"

  fixes ringsq ("_\<^sup>2" [96] 97)
  defines ringsq_def [simp]: "a\<^sup>2 \<equiv> a\<cdot>a"

text\<open>In the \<open>ring0\<close> context we can use theorems proven in some
  other contexts.\<close>

lemma (in ring0) Ring_ZF_1_L1: shows
  "monoid0(R,M)"
  "group0(R,A)"
  "A {is commutative on} R"
  using ringAssum IsAring_def group0_def monoid0_def by auto

text\<open>The theorems proven in in \<open>group0\<close> context (locale) are valid
  in the \<open>ring0\<close> context when applied to the additive group of the ring. \<close>

sublocale ring0 < add_group: group0 R A ringzero ringa ringminus
  using Ring_ZF_1_L1(2) unfolding ringa_def ringminus_def ringzero_def by auto

text\<open>The theorem proven in the \<open>monoid0\<close> context are valid in the \<open>ring0\<close> context
  when applied to the multiplicative monoid of the ring.  \<close>

sublocale ring0 < mult_monoid: monoid0 R M ringm
  using Ring_ZF_1_L1(1) unfolding ringm_def by auto

text\<open>The additive operation in a ring is distributive with respect to the
  multiplicative operation.\<close>

lemma (in ring0) ring_oper_distr: assumes A1: "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows
  "a\<cdot>(b\<ra>c) = a\<cdot>b \<ra> a\<cdot>c"
  "(b\<ra>c)\<cdot>a = b\<cdot>a \<ra> c\<cdot>a"
  using ringAssum assms IsAring_def IsDistributive_def by auto

text\<open>Zero and one of the ring are elements of the ring. The negative of zero
  is zero.\<close>

lemma (in ring0) Ring_ZF_1_L2:
  shows "\<zero>\<in>R"  "\<one>\<in>R"   "(\<rm>\<zero>) = \<zero>"
  using add_group.group0_2_L2 mult_monoid.unit_is_neutral
    add_group.group_inv_of_one by auto

text\<open>The next lemma lists some properties of a ring that require one element
  of a ring.\<close>

lemma (in ring0) Ring_ZF_1_L3: assumes "a\<in>R"
  shows
  "(\<rm>a) \<in> R"
  "(\<rm>(\<rm>a)) = a"
  "a\<ra>\<zero> = a"
  "\<zero>\<ra>a = a"
  "a\<cdot>\<one> = a"
  "\<one>\<cdot>a = a"
  "a\<rs>a = \<zero>"
  "a\<rs>\<zero> = a"
  "\<two>\<cdot>a = a\<ra>a"
  "(\<rm>a)\<ra>a = \<zero>"
  using assms add_group.inverse_in_group add_group.group_inv_of_inv
    add_group.group0_2_L6 add_group.group0_2_L2 mult_monoid.unit_is_neutral
    Ring_ZF_1_L2 ring_oper_distr
  by auto

text\<open>Properties that require two elements of a ring.\<close>

lemma (in ring0) Ring_ZF_1_L4: assumes A1: "a\<in>R" "b\<in>R"
  shows
  "a\<ra>b \<in> R"
  "a\<rs>b \<in> R"
  "a\<cdot>b \<in> R"
  "a\<ra>b = b\<ra>a"
  using assms Ring_ZF_1_L1(3) Ring_ZF_1_L3
    add_group.monoid.group0_1_L1
    mult_monoid.group0_1_L1
    unfolding IsCommutative_def
  by auto

text\<open>Cancellation of an element on both sides of equality.
  This is a property of groups, written in the (additive) notation
  we use for the additive operation in rings.
\<close>

lemma (in ring0) ring_cancel_add:
  assumes A1: "a\<in>R" "b\<in>R" and A2: "a \<ra> b = a"
  shows "b = \<zero>"
  using assms add_group.group0_2_L7 by simp

text\<open>Any element of a ring multiplied by zero is zero.\<close>

lemma (in ring0) Ring_ZF_1_L6:
  assumes A1: "x\<in>R" shows "\<zero>\<cdot>x = \<zero>"   "x\<cdot>\<zero> = \<zero>"
proof -
  let ?a = "x\<cdot>\<one>"
  let ?b = "x\<cdot>\<zero>"
  let ?c = "\<one>\<cdot>x"
  let ?d = "\<zero>\<cdot>x"
  from A1 have
    "?a \<ra> ?b = x\<cdot>(\<one> \<ra> \<zero>)"   "?c \<ra> ?d = (\<one> \<ra> \<zero>)\<cdot>x"
    using Ring_ZF_1_L2 ring_oper_distr by auto
  moreover have "x\<cdot>(\<one> \<ra> \<zero>) = ?a" "(\<one> \<ra> \<zero>)\<cdot>x = ?c"
    using Ring_ZF_1_L2 Ring_ZF_1_L3 by auto
  ultimately have "?a \<ra> ?b = ?a" and T1: "?c \<ra> ?d = ?c"
    by auto
  moreover from A1 have
    "?a \<in> R"  "?b \<in> R" and T2: "?c \<in> R"  "?d \<in> R"
    using Ring_ZF_1_L2 Ring_ZF_1_L4 by auto
  ultimately have "?b = \<zero>" using ring_cancel_add
    by blast
  moreover from T2 T1 have "?d = \<zero>" using ring_cancel_add
    by blast
  ultimately show "x\<cdot>\<zero> = \<zero>"  "\<zero>\<cdot>x = \<zero>" by auto
qed

text\<open>Negative can be pulled out of a product.\<close>

lemma (in ring0) Ring_ZF_1_L7:
  assumes A1: "a\<in>R"  "b\<in>R"
  shows
  "(\<rm>a)\<cdot>b = \<rm>(a\<cdot>b)"
  "a\<cdot>(\<rm>b) = \<rm>(a\<cdot>b)"
  "(\<rm>a)\<cdot>b = a\<cdot>(\<rm>b)"
proof -
  from A1 have I:
    "a\<cdot>b \<in> R" "(\<rm>a) \<in> R" "((\<rm>a)\<cdot>b) \<in> R"
    "(\<rm>b) \<in> R" "a\<cdot>(\<rm>b) \<in> R"
    using Ring_ZF_1_L3 Ring_ZF_1_L4 by auto
  moreover have "(\<rm>a)\<cdot>b \<ra> a\<cdot>b = \<zero>"
    and II: "a\<cdot>(\<rm>b) \<ra> a\<cdot>b = \<zero>"
  proof -
    from A1 I have
      "(\<rm>a)\<cdot>b \<ra> a\<cdot>b = ((\<rm>a)\<ra> a)\<cdot>b"
      "a\<cdot>(\<rm>b) \<ra> a\<cdot>b= a\<cdot>((\<rm>b)\<ra>b)"
      using ring_oper_distr by auto
    moreover from A1 have
      "((\<rm>a)\<ra> a)\<cdot>b = \<zero>"
      "a\<cdot>((\<rm>b)\<ra>b) = \<zero>"
      using add_group.group0_2_L6 Ring_ZF_1_L6
      by auto
    ultimately show
      "(\<rm>a)\<cdot>b \<ra> a\<cdot>b = \<zero>"
      "a\<cdot>(\<rm>b) \<ra> a\<cdot>b = \<zero>"
      by auto
  qed
  ultimately show "(\<rm>a)\<cdot>b = \<rm>(a\<cdot>b)"
    using add_group.group0_2_L9 by simp
  moreover from I II show "a\<cdot>(\<rm>b) = \<rm>(a\<cdot>b)"
    using add_group.group0_2_L9 by simp
  ultimately show "(\<rm>a)\<cdot>b = a\<cdot>(\<rm>b)" by simp
qed

text\<open>Minus times minus is plus.\<close>

lemma (in ring0) Ring_ZF_1_L7A: assumes "a\<in>R"  "b\<in>R"
  shows "(\<rm>a)\<cdot>(\<rm>b) = a\<cdot>b"
  using assms Ring_ZF_1_L3 Ring_ZF_1_L7 Ring_ZF_1_L4
  by simp

text\<open>Subtraction is distributive with respect to multiplication.\<close>

lemma (in ring0) Ring_ZF_1_L8: assumes "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows
  "a\<cdot>(b\<rs>c) = a\<cdot>b \<rs> a\<cdot>c"
  "(b\<rs>c)\<cdot>a = b\<cdot>a \<rs> c\<cdot>a"
  using assms Ring_ZF_1_L3 ring_oper_distr Ring_ZF_1_L7 Ring_ZF_1_L4
  by auto

text\<open>Other basic properties involving two elements of a ring.\<close>

lemma (in ring0) Ring_ZF_1_L9: assumes "a\<in>R"  "b\<in>R"
  shows
  "(\<rm>b)\<rs>a = (\<rm>a)\<rs>b"
  "(\<rm>(a\<ra>b)) = (\<rm>a)\<rs>b"
  "(\<rm>(a\<rs>b)) = ((\<rm>a)\<ra>b)"
  "a\<rs>(\<rm>b) = a\<ra>b"
  using assms Ring_ZF_1_L1(3) add_group.group0_4_L4 add_group.group_inv_of_inv
  by auto

text\<open>If the difference of two element is zero, then those elements
  are equal.\<close>

lemma (in ring0) Ring_ZF_1_L9A:
  assumes A1: "a\<in>R"  "b\<in>R" and A2: "a\<rs>b = \<zero>"
  shows "a=b" using add_group.group0_2_L11A assms by auto

text\<open>Other basic properties involving three elements of a ring.\<close>

lemma (in ring0) Ring_ZF_1_L10:
  assumes "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows
  "a\<ra>(b\<ra>c) = a\<ra>b\<ra>c"
  (*"a\<ra>(b\<rs>c) = a\<ra>b\<rs>c"*)
  "a\<rs>(b\<ra>c) = a\<rs>b\<rs>c"
  "a\<rs>(b\<rs>c) = a\<rs>b\<ra>c"
  using assms Ring_ZF_1_L1(3) add_group.group_oper_assoc
    add_group.group0_4_L4A by auto

text\<open>Another property with three elements.\<close>

lemma (in ring0) Ring_ZF_1_L10A:
  assumes A1: "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows "a\<ra>(b\<rs>c) = a\<ra>b\<rs>c"
  using assms Ring_ZF_1_L3 Ring_ZF_1_L10 by simp

text\<open>Associativity of addition and multiplication.\<close>

lemma (in ring0) Ring_ZF_1_L11:
  assumes "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows
  "a\<ra>b\<ra>c = a\<ra>(b\<ra>c)"
  "a\<cdot>b\<cdot>c = a\<cdot>(b\<cdot>c)"
  using assms add_group.group_oper_assoc mult_monoid.sum_associative
  by auto

text\<open>An interpretation of what it means that a ring has
  no zero divisors.\<close>

lemma (in ring0) Ring_ZF_1_L12:
  assumes "HasNoZeroDivs(R,A,M)"
  and "a\<in>R"  "a\<noteq>\<zero>"  "b\<in>R"  "b\<noteq>\<zero>"
  shows "a\<cdot>b\<noteq>\<zero>"
  using assms HasNoZeroDivs_def by auto

text\<open>In rings with no zero divisors we can cancel nonzero factors.\<close>

lemma (in ring0) Ring_ZF_1_L12A:
  assumes A1: "HasNoZeroDivs(R,A,M)" and A2: "a\<in>R"  "b\<in>R"  "c\<in>R"
  and A3: "a\<cdot>c = b\<cdot>c" and A4: "c\<noteq>\<zero>"
  shows "a=b"
proof -
  from A2 have T: "a\<cdot>c \<in> R"  "a\<rs>b \<in> R"
    using Ring_ZF_1_L4 by auto
  with A1 A2 A3 have "a\<rs>b = \<zero> \<or> c=\<zero>"
    using Ring_ZF_1_L3 Ring_ZF_1_L8 HasNoZeroDivs_def
    by simp
  with A2 A4 have "a\<in>R"  "b\<in>R"  "a\<rs>b = \<zero>"
    by auto
  then show "a=b" by (rule Ring_ZF_1_L9A)
qed

text\<open>In rings with no zero divisors if two elements are different,
  then after multiplying by a nonzero element they are still different.\<close>

lemma (in ring0) Ring_ZF_1_L12B:
  assumes A1: "HasNoZeroDivs(R,A,M)"
  "a\<in>R"   "b\<in>R"   "c\<in>R"   "a\<noteq>b"   "c\<noteq>\<zero>"
  shows  "a\<cdot>c \<noteq> b\<cdot>c"
  using A1 Ring_ZF_1_L12A by auto (* A1 has to be here *)

text\<open>In rings with no zero divisors multiplying a nonzero element
  by a nonone element changes the value.\<close>

lemma (in ring0) Ring_ZF_1_L12C:
  assumes A1: "HasNoZeroDivs(R,A,M)" and
  A2: "a\<in>R"  "b\<in>R" and A3: "\<zero>\<noteq>a"  "\<one>\<noteq>b"
  shows "a \<noteq> a\<cdot>b"
proof -
  { assume "a = a\<cdot>b"
    with A1 A2 have "a = \<zero> \<or> b\<rs>\<one> = \<zero>"
      using Ring_ZF_1_L3 Ring_ZF_1_L2 Ring_ZF_1_L8
	Ring_ZF_1_L3 Ring_ZF_1_L2 Ring_ZF_1_L4 HasNoZeroDivs_def
      by simp
    with A2 A3 have False
      using Ring_ZF_1_L2 Ring_ZF_1_L9A by auto
  } then show "a \<noteq> a\<cdot>b" by auto
qed

text\<open>If a square is nonzero, then the element is nonzero.\<close>

lemma (in ring0) Ring_ZF_1_L13:
  assumes "a\<in>R"  and "a\<^sup>2 \<noteq> \<zero>"
  shows "a\<noteq>\<zero>"
  using assms Ring_ZF_1_L2 Ring_ZF_1_L6 by auto

text\<open>Square of an element and its opposite are the same.\<close>

lemma (in ring0) Ring_ZF_1_L14:
  assumes "a\<in>R" shows "(\<rm>a)\<^sup>2 = ((a)\<^sup>2)"
  using assms Ring_ZF_1_L7A by simp

text\<open>Adding zero to a set that is closed under addition results
  in a set that is also closed under addition. This is a property of groups.\<close>

lemma (in ring0) Ring_ZF_1_L15:
  assumes "H \<subseteq> R" and "H {is closed under} A"
  shows "(H \<union> {\<zero>}) {is closed under} A"
  using assms add_group.group0_2_L17 by simp

text\<open>Adding zero to a set that is closed under multiplication results
  in a set that is also closed under multiplication.\<close>

lemma (in ring0) Ring_ZF_1_L16:
  assumes A1: "H \<subseteq> R" and A2: "H {is closed under} M"
  shows "(H \<union> {\<zero>}) {is closed under} M"
  using assms Ring_ZF_1_L2 Ring_ZF_1_L6 IsOpClosed_def
  by auto

text\<open>The ring is trivial iff $0=1$.\<close>

lemma (in ring0) Ring_ZF_1_L17: shows "R = {\<zero>} \<longleftrightarrow> \<zero>=\<one>"
proof
  assume "R = {\<zero>}"
  then show "\<zero>=\<one>" using Ring_ZF_1_L2
    by blast
next assume A1: "\<zero> = \<one>"
  then have "R \<subseteq> {\<zero>}"
    using Ring_ZF_1_L3 Ring_ZF_1_L6 by auto
  moreover have "{\<zero>} \<subseteq> R" using Ring_ZF_1_L2 by auto
  ultimately show "R = {\<zero>}" by auto
qed

text\<open>The sets $\{m\cdot x. x\in R\}$ and  $\{-m\cdot x. x\in R\}$
  are the same.\<close>

lemma (in ring0) Ring_ZF_1_L18: assumes A1: "m\<in>R"
  shows "{m\<cdot>x. x\<in>R} = {(\<rm>m)\<cdot>x. x\<in>R}"
proof
  { fix a assume "a \<in> {m\<cdot>x. x\<in>R}"
    then obtain x where "x\<in>R" and "a = m\<cdot>x"
      by auto
    with A1 have "(\<rm>x) \<in> R"  and "a = (\<rm>m)\<cdot>(\<rm>x)"
      using Ring_ZF_1_L3 Ring_ZF_1_L7A by auto
    then have "a \<in> {(\<rm>m)\<cdot>x. x\<in>R}"
      by auto
  } then show "{m\<cdot>x. x\<in>R} \<subseteq> {(\<rm>m)\<cdot>x. x\<in>R}"
    by auto
next
  { fix a assume "a \<in> {(\<rm>m)\<cdot>x. x\<in>R}"
    then obtain x where "x\<in>R" and "a = (\<rm>m)\<cdot>x"
      by auto
    with A1 have "(\<rm>x) \<in> R" and "a = m\<cdot>(\<rm>x)"
      using Ring_ZF_1_L3 Ring_ZF_1_L7 by auto
    then have "a \<in> {m\<cdot>x. x\<in>R}" by auto
  } then show "{(\<rm>m)\<cdot>x. x\<in>R} \<subseteq> {m\<cdot>x. x\<in>R}"
    by auto
qed

subsection\<open>Rearrangement lemmas\<close>

text\<open>In happens quite often that we want to show a fact like
  $(a+b)c+d = (ac+d-e)+(bc+e)$in rings.
  This is trivial in romantic math and probably there is a way to make
  it trivial in formalized math. However, I don't know any other way than to
  tediously prove each such rearrangement when it is needed. This section
  collects facts of this type.\<close>

text\<open>Rearrangements with two elements of a ring.\<close>

lemma (in ring0) Ring_ZF_2_L1: assumes "a\<in>R" "b\<in>R"
  shows "a\<ra>b\<cdot>a = (b\<ra>\<one>)\<cdot>a"
  using assms Ring_ZF_1_L2 ring_oper_distr Ring_ZF_1_L3 Ring_ZF_1_L4
  by simp

text\<open>Rearrangements with two elements and cancelling.\<close>

lemma (in ring0) Ring_ZF_2_L1A: assumes "a\<in>R" "b\<in>R"
  shows
  "a\<rs>b\<ra>b = a"
  "a\<ra>b\<rs>a = b"
  "(\<rm>a)\<ra>b\<ra>a = b"
  "(\<rm>a)\<ra>(b\<ra>a) = b"
  "a\<ra>(b\<rs>a) = b"
  using assms add_group.inv_cancel_two add_group.group0_4_L6A
    Ring_ZF_1_L1(3) by auto

text\<open>In commutative rings $a-(b+1)c = (a-d-c)+(d-bc)$.\<close>

lemma (in ring0) Ring_ZF_2_L2:
  assumes "a\<in>R"  "b\<in>R"  "c\<in>R"  "d\<in>R"
  shows "a\<rs>(b\<ra>\<one>)\<cdot>c = (a\<rs>d\<rs>c)\<ra>(d\<rs>b\<cdot>c)"
proof -
  let ?B = "b\<cdot>c"
  from ringAssum assms have
    "A {is commutative on} R" and "a\<in>R" "?B \<in> R" "c\<in>R" "d\<in>R"
    unfolding IsAring_def using Ring_ZF_1_L4 by auto
  then have
    "a\<ra>(\<rm>?B\<ra>c) = a\<ra>(\<rm>d)\<ra>(\<rm>c)\<ra>(d\<ra>(\<rm>?B))"
    by (rule add_group.group0_4_L8)
  with assms show ?thesis
    using Ring_ZF_1_L2 ring_oper_distr Ring_ZF_1_L3 by auto
qed

text\<open>Rerrangement about adding linear functions.\<close>

lemma (in ring0) Ring_ZF_2_L3:
  assumes A1: "a\<in>R"  "b\<in>R"  "c\<in>R"  "d\<in>R"  "x\<in>R"
  shows "(a\<cdot>x \<ra> b) \<ra> (c\<cdot>x \<ra> d) = (a\<ra>c)\<cdot>x \<ra> (b\<ra>d)"
proof -
  from A1 have
    "A {is commutative on} R"
    "a\<cdot>x \<in> R"  "b\<in>R"  "c\<cdot>x \<in> R"  "d\<in>R"
    using Ring_ZF_1_L1 Ring_ZF_1_L4 by auto
  then have "A`\<langle>A`\<langle> a\<cdot>x,b\<rangle>,A`\<langle> c\<cdot>x,d\<rangle>\<rangle> = A`\<langle>A`\<langle> a\<cdot>x,c\<cdot>x\<rangle>,A`\<langle> b,d\<rangle>\<rangle>"
    using add_group.group0_4_L8(3) by auto
  with A1 show
    "(a\<cdot>x \<ra> b) \<ra> (c\<cdot>x \<ra> d) = (a\<ra>c)\<cdot>x \<ra> (b\<ra>d)"
    using ring_oper_distr by simp
qed

text\<open>Rearrangement with three elements\<close>

lemma (in ring0) Ring_ZF_2_L4:
  assumes "M {is commutative on} R"
  and "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows "a\<cdot>(b\<cdot>c) = a\<cdot>c\<cdot>b"
  using assms IsCommutative_def Ring_ZF_1_L11
  by simp

text\<open>Some other rearrangements with three elements.\<close>

lemma (in ring0) ring_rearr_3_elemA:
  assumes A1: "M {is commutative on} R" and
  A2: "a\<in>R"  "b\<in>R"  "c\<in>R"
  shows
  "a\<cdot>(a\<cdot>c) \<rs> b\<cdot>(\<rm>b\<cdot>c) = (a\<cdot>a \<ra> b\<cdot>b)\<cdot>c"
  "a\<cdot>(\<rm>b\<cdot>c) \<ra> b\<cdot>(a\<cdot>c) = \<zero>"
proof -
  from A2 have T:
    "b\<cdot>c \<in> R"  "a\<cdot>a \<in> R"  "b\<cdot>b \<in> R"
    "b\<cdot>(b\<cdot>c) \<in> R"  "a\<cdot>(b\<cdot>c) \<in> R"
    using  Ring_ZF_1_L4 by auto
  with A2 show
    "a\<cdot>(a\<cdot>c) \<rs> b\<cdot>(\<rm>b\<cdot>c) = (a\<cdot>a \<ra> b\<cdot>b)\<cdot>c"
    using Ring_ZF_1_L7 Ring_ZF_1_L3 Ring_ZF_1_L11
      ring_oper_distr by simp
  from A2 T have
    "a\<cdot>(\<rm>b\<cdot>c) \<ra> b\<cdot>(a\<cdot>c) = (\<rm>a\<cdot>(b\<cdot>c)) \<ra> b\<cdot>a\<cdot>c"
    using Ring_ZF_1_L7 Ring_ZF_1_L11 by simp
  also from A1 A2 T have "\<dots> = \<zero>"
    using IsCommutative_def Ring_ZF_1_L11 Ring_ZF_1_L3
    by simp
  finally show "a\<cdot>(\<rm>b\<cdot>c) \<ra> b\<cdot>(a\<cdot>c) = \<zero>"
    by simp
qed

text\<open>Some rearrangements with four elements. Properties of abelian groups.\<close>

lemma (in ring0) Ring_ZF_2_L5:
  assumes "a\<in>R"  "b\<in>R"  "c\<in>R"  "d\<in>R"
  shows
  "a \<rs> b \<rs> c \<rs> d = a \<rs> d \<rs> b \<rs> c"
  "a \<ra> b \<ra> c \<rs> d = a \<rs> d \<ra> b \<ra> c"
  "a \<ra> b \<rs> c \<rs> d = a \<rs> c \<ra> (b \<rs> d)"
  "a \<ra> b \<ra> c \<ra> d = a \<ra> c \<ra> (b \<ra> d)"
  using assms Ring_ZF_1_L1(3) add_group.rearr_ab_gr_4_elemB
    add_group.rearr_ab_gr_4_elemA by auto

text\<open>Two big rearranegements with six elements, useful for
  proving properties of complex addition and multiplication.\<close>

lemma (in ring0) Ring_ZF_2_L6:
  assumes A1: "a\<in>R"  "b\<in>R"  "c\<in>R"  "d\<in>R"  "e\<in>R"  "f\<in>R"
  shows
  "a\<cdot>(c\<cdot>e \<rs> d\<cdot>f) \<rs> b\<cdot>(c\<cdot>f \<ra> d\<cdot>e) =
  (a\<cdot>c \<rs> b\<cdot>d)\<cdot>e \<rs> (a\<cdot>d \<ra> b\<cdot>c)\<cdot>f"
  "a\<cdot>(c\<cdot>f \<ra> d\<cdot>e) \<ra> b\<cdot>(c\<cdot>e \<rs> d\<cdot>f) =
  (a\<cdot>c \<rs> b\<cdot>d)\<cdot>f \<ra> (a\<cdot>d \<ra> b\<cdot>c)\<cdot>e"
  "a\<cdot>(c\<ra>e) \<rs> b\<cdot>(d\<ra>f) = a\<cdot>c \<rs> b\<cdot>d \<ra> (a\<cdot>e \<rs> b\<cdot>f)"
  "a\<cdot>(d\<ra>f) \<ra> b\<cdot>(c\<ra>e) = a\<cdot>d \<ra> b\<cdot>c \<ra> (a\<cdot>f \<ra> b\<cdot>e)"
proof -
  from A1 have T:
    "c\<cdot>e \<in> R"  "d\<cdot>f \<in> R"  "c\<cdot>f \<in> R"  "d\<cdot>e \<in> R"
    "a\<cdot>c \<in> R"  "b\<cdot>d \<in> R"  "a\<cdot>d \<in> R"  "b\<cdot>c \<in> R"
    "b\<cdot>f \<in> R"  "a\<cdot>e \<in> R"  "b\<cdot>e \<in> R"  "a\<cdot>f \<in> R"
    "a\<cdot>c\<cdot>e \<in> R"  "a\<cdot>d\<cdot>f \<in> R"
    "b\<cdot>c\<cdot>f \<in> R"  "b\<cdot>d\<cdot>e \<in> R"
    "b\<cdot>c\<cdot>e \<in> R"  "b\<cdot>d\<cdot>f \<in> R"
    "a\<cdot>c\<cdot>f \<in> R"  "a\<cdot>d\<cdot>e \<in> R"
    "a\<cdot>c\<cdot>e \<rs> a\<cdot>d\<cdot>f \<in> R"
    "a\<cdot>c\<cdot>e \<rs> b\<cdot>d\<cdot>e \<in> R"
    "a\<cdot>c\<cdot>f \<ra> a\<cdot>d\<cdot>e \<in> R"
    "a\<cdot>c\<cdot>f \<rs> b\<cdot>d\<cdot>f \<in> R"
    "a\<cdot>c \<ra> a\<cdot>e \<in> R"
    "a\<cdot>d \<ra> a\<cdot>f \<in> R"
    using Ring_ZF_1_L4 by auto
  with A1 show "a\<cdot>(c\<cdot>e \<rs> d\<cdot>f) \<rs> b\<cdot>(c\<cdot>f \<ra> d\<cdot>e) =
    (a\<cdot>c \<rs> b\<cdot>d)\<cdot>e \<rs> (a\<cdot>d \<ra> b\<cdot>c)\<cdot>f"
    using Ring_ZF_1_L8 ring_oper_distr Ring_ZF_1_L11
      Ring_ZF_1_L10 Ring_ZF_2_L5 by simp
  from A1 T show
    "a\<cdot>(c\<cdot>f \<ra> d\<cdot>e) \<ra> b\<cdot>(c\<cdot>e \<rs> d\<cdot>f) =
    (a\<cdot>c \<rs> b\<cdot>d)\<cdot>f \<ra> (a\<cdot>d \<ra> b\<cdot>c)\<cdot>e"
    using Ring_ZF_1_L8 ring_oper_distr Ring_ZF_1_L11
    Ring_ZF_1_L10A Ring_ZF_2_L5 Ring_ZF_1_L10
    by simp
  from A1 T show
    "a\<cdot>(c\<ra>e) \<rs> b\<cdot>(d\<ra>f) = a\<cdot>c \<rs> b\<cdot>d \<ra> (a\<cdot>e \<rs> b\<cdot>f)"
    "a\<cdot>(d\<ra>f) \<ra> b\<cdot>(c\<ra>e) = a\<cdot>d \<ra> b\<cdot>c \<ra> (a\<cdot>f \<ra> b\<cdot>e)"
    using ring_oper_distr Ring_ZF_1_L10 Ring_ZF_2_L5
    by auto
qed

end


header {* Exception-Aware Relational Framework *}
theory Run
imports "~~/src/HOL/Imperative_HOL/Imperative_HOL"
begin

  text {*
    With Imperative HOL comes a relational framework.
    However, this can only be used if exception freeness is already assumed.
    This results in some proof duplication, because exception freeness and
    correctness need to be shown separately.

    In this theory, we develop a relational framework that is aware of
    exceptions, and makes it possible to show correctness and exception
    freeness in one run.
    *}

  text {*
    There are two types of states:
    \begin{enumerate}
      \item A normal (Some) state contains the current heap.
      \item An exception state is None
    \end{enumerate}
    The two states exactly correspond to the option monad in Imperative HOL.
    *}

type_synonym state = "Heap.heap option"

primrec is_exn where
  "is_exn (Some _) = False" |
  "is_exn None = True"

primrec the_state where
  "the_state (Some h) = h"

-- "The exception-aware, relational semantics"

inductive run :: "'a Heap \<Rightarrow> state \<Rightarrow> state \<Rightarrow> 'a \<Rightarrow> bool" where
  push_exn: "is_exn \<sigma> \<Longrightarrow> run c \<sigma> \<sigma> r " |
  new_exn:  "\<lbrakk>\<not> is_exn \<sigma>; execute c (the_state \<sigma>) = None\<rbrakk>
    \<Longrightarrow> run c \<sigma> None r" |
  regular:  "\<lbrakk>\<not> is_exn \<sigma>; execute c (the_state \<sigma>) = Some (r, h')\<rbrakk>
    \<Longrightarrow> run c \<sigma> (Some h') r"

subsubsection "Link with @{text effect} and @{text success}"

lemma run_effectE:
  assumes "run c \<sigma> \<sigma>' r"
  assumes "\<not>is_exn \<sigma>'"
  obtains h h' where
    "\<sigma>=Some h" "\<sigma>' = Some h'"
    "effect c h h' r"
  using assms
  unfolding effect_def
  apply (cases \<sigma>)
  by (auto simp add: run.simps)

lemma run_effectI:
  assumes  "run c (Some h) (Some h') r"
  shows  "effect c h h' r"
  using run_effectE[OF assms] by auto

lemma effect_run:
  assumes "effect c h h' r"
  shows "run c (Some h) (Some h') r"
  using assms
  unfolding effect_def
  by (auto intro: run.intros)

lemma success_run:
  assumes "success f h"
  obtains h' r where "run f (Some h) (Some h') r"
proof -
  case goal1
  from assms(1) obtain r h'
    where "Heap_Monad.execute f h = Some (r, h')"
    unfolding success_def by auto
  from goal1[OF regular[of "Some h", simplified, OF this]]
  show ?thesis .
qed

text {* run always yields a result *}
lemma run_complete:
  obtains \<sigma>' r where "run c \<sigma> \<sigma>' r"
  apply (cases "is_exn \<sigma>")
  apply (auto intro: run.intros)
  apply (cases "execute c (the_state \<sigma>)")
  by (auto intro: run.intros)

lemma run_detE:
  assumes "run c \<sigma> \<sigma>' r" "run c \<sigma> \<tau> s"
          "\<not>is_exn \<sigma>"
  obtains "is_exn \<sigma>'" "\<sigma>' = \<tau>" | "\<not> is_exn \<sigma>'" "\<sigma>' = \<tau>" "r = s"
  using assms
  by (auto simp add: run.simps)

lemma run_detI:
  assumes "run c (Some h) (Some h') r" "run c (Some h) \<sigma> s"
  shows "\<sigma> = Some h' \<and> r = s"
  using assms
  by (auto simp add: run.simps)

subsubsection {* Elimination Rules for Basic Combinators *}

named_theorems run_elims "elemination rules for run"

lemma runE[run_elims]:
  assumes "run (f \<guillemotright>= g) \<sigma> \<sigma>'' r"
  obtains \<sigma>' r' where
    "run f \<sigma> \<sigma>' r'"
    "run (g r') \<sigma>' \<sigma>'' r"
using assms
apply (cases "is_exn \<sigma>")
apply (simp add: run.simps)
apply (cases "execute f (the_state \<sigma>)")
apply (simp add: run.simps bind_def)
by (auto simp add: bind_def run.simps)

lemma runE'[run_elims]:
  assumes "run (f >> g) \<sigma> \<sigma>'' res"
  obtains \<sigma>t rt where
    "run f \<sigma> \<sigma>t rt"
    "run g \<sigma>t \<sigma>'' res"
  using assms
  by (rule_tac runE)

lemma run_return[run_elims]:
  assumes "run (return x) \<sigma> \<sigma>' r"
  obtains "r = x" "\<sigma>' = \<sigma>" "\<not> is_exn \<sigma>" | "\<sigma> = None"
  using assms  apply (cases \<sigma>) apply (simp add: run.simps)
  by (auto simp add: run.simps execute_simps)

lemma run_raise_iff: "run (raise s) \<sigma> \<sigma>' r \<longleftrightarrow> (\<sigma>'=None)"
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

lemma run_raise[run_elims]:
  assumes "run (raise s) \<sigma> \<sigma>' r"
  obtains "\<sigma>' = None"
  using assms by (simp add: run_raise_iff)

lemma run_raiseI:
  "run (raise s) \<sigma> None r" by (simp add: run_raise_iff)

lemma run_if[run_elims]:
  assumes "run (if c then t else e) h h' r"
  obtains "c" "run t h h' r"
        | "\<not>c" "run e h h' r"
  using assms
  by (auto split: split_if_asm)

lemma run_case_option[run_elims]:
  assumes "run (case x of None \<Rightarrow> n | Some y \<Rightarrow> s y) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "x = None" "run n \<sigma> \<sigma>' r"
        | y where "x = Some y" "run (s y) \<sigma> \<sigma>' r"
  using assms
  by (cases x) simp_all

lemma run_heap[run_elims]:
  assumes "run (Heap_Monad.heap f) \<sigma> \<sigma>' res"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (f (the_state \<sigma>)))"
  and "res = (fst (f (the_state \<sigma>)))"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)

  apply (simp only: execute_simps)
  apply hypsubst_thin
proof -
  case goal1
  from goal1(2) have "h' = snd (f a)" "res = fst (f a)" by simp_all
  from goal1(1)[OF this] show ?case .
qed

subsection {* Array Commands*}

lemma run_length[run_elims]:
  assumes "run (Array.len a) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<not>is_exn \<sigma>" "\<sigma>' = \<sigma>" "r = Array.length (the_state \<sigma>) a"
  using assms
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

lemma run_new_array[run_elims]:
  assumes "run (Array.new n x) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Array.alloc (replicate n x) (the_state \<sigma>)))"
  and "r = fst (Array.alloc (replicate n x) (the_state \<sigma>))"
  and "Array.get (the_state \<sigma>') r = replicate n x"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)
  apply (simp add: Array.get_alloc)
  apply hypsubst_thin
proof -
  case goal1
  from goal1(2) have "h' = snd (Array.alloc (replicate n x) a)"
    "r = fst (Array.alloc (replicate n x) a)" by (auto simp add: execute_simps)
  from goal1(1)[OF this] show ?case .
qed

lemma run_upd[run_elims]:
  assumes "run (Array.upd i x a) \<sigma> \<sigma>' res"
          "\<not>is_exn \<sigma>"
  obtains "\<not> i < Array.length (the_state \<sigma>) a"
          "\<sigma>' = None"
  |
          "i < Array.length (the_state \<sigma>) a"
          "\<sigma>' = Some (Array.update a i x (the_state \<sigma>))"
          "res = a"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (cases "i < Array.length (the_state \<sigma>) a")
  apply (auto simp add: run.simps)
  apply (simp_all only: execute_simps)
  prefer 3
  apply auto[2]
  apply hypsubst_thin
proof -
  case (goal1 aa h')
  from goal1(4) have "h' = Array.update a i x aa" "res = a" by auto
  from goal1(2)[OF this] show ?case .
qed

lemma run_nth[run_elims]:
  assumes "run (Array.nth a i) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<not>is_exn \<sigma>"
    "i < Array.length (the_state \<sigma>) a"
    "r = (Array.get (the_state \<sigma>) a) ! i"
    "\<sigma>' = \<sigma>"
  |
    "\<not> i < Array.length (the_state \<sigma>) a"
    "\<sigma>' = None"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (cases "i < Array.length (the_state \<sigma>) a")
  apply (auto simp add: run.simps)
  apply (simp_all only: execute_simps)
  prefer 3
  apply auto[2]
  apply hypsubst_thin
proof -
  case (goal1 aa h')
  from goal1(4) have "r = Array.get aa a ! i" "h' = aa" by auto
  from goal1(1)[OF this] show ?case .
qed

lemma run_of_list[run_elims]:
  assumes "run (Array.of_list xs) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Array.alloc xs (the_state \<sigma>)))"
          "r = fst (Array.alloc xs (the_state \<sigma>))"
          "Array.get (the_state \<sigma>') r = xs"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)
  apply (simp add: Array.get_alloc)
  apply hypsubst_thin
proof -
  case goal1
  from goal1(2) have "h' = snd (Array.alloc xs a)"
    "r = fst (Array.alloc xs a)" by (auto simp add: execute_simps)
  from goal1(1)[OF this] show ?case .
qed

lemma run_freeze[run_elims]:
  assumes "run (Array.freeze a) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = \<sigma>"
          "r = Array.get (the_state \<sigma>) a"
  using assms
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

subsection {* Reference Commands*}

lemma run_new_ref[run_elims]:
  assumes "run (ref x) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Ref.alloc x (the_state \<sigma>)))"
          "r = fst (Ref.alloc x (the_state \<sigma>))"
          "Ref.get (the_state \<sigma>') r = x"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)
  apply hypsubst_thin
proof -
  case goal1
  from goal1(2) have
    "h' = snd (Ref.alloc x a)"
    "r = fst (Ref.alloc x a)"
    by (auto simp add: execute_simps)
  from goal1(1)[OF this] show ?case .
qed

lemma "fst (Ref.alloc x h) = Ref (lim h)"
  unfolding alloc_def
  by (simp add: Let_def)

lemma run_update[run_elims]:
  assumes "run (p := x) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (Ref.set p x (the_state \<sigma>))" "r = ()"
  using assms
  unfolding Ref.update_def
  by (auto elim: run_heap)

lemma run_lookup[run_elims]:
  assumes "run (!p) \<sigma> \<sigma>' r"
          "\<not> is_exn \<sigma>"
  obtains "\<not>is_exn \<sigma>" "\<sigma>' = \<sigma>" "r = Ref.get (the_state \<sigma>) p"
  using assms
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

end


(* Author: Dmitriy Traytel *)

header {* Deciding Equivalence of $\Pi$-Extended Regular Expressions *}

(*<*)
theory Pi_Equivalence_Checking
imports Pi_Regular_Exp "~~/src/HOL/Library/While_Combinator" List_More
begin
(*>*)

lemma image2p_in_rel: "BNF_Greatest_Fixpoint.image2p f g (in_rel R) =  in_rel (map_prod f g ` R)"
  unfolding image2p_def fun_eq_iff by auto

lemma image2p_apply: "BNF_Greatest_Fixpoint.image2p f g R x y = (\<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"
  unfolding image2p_def fun_eq_iff by auto

lemma rtrancl_fold_product:
shows "{((r, s), (f a r, f a s))| r s a. a \<in> A}^* =
       {((r, s), (fold f w r, fold f w s))| r s w. w \<in> lists A}" (is "?L = ?R")
proof-
  { fix x :: "('a \<times> 'a) \<times> 'a \<times> 'a"
    obtain r s r' s' where x: "x = ((r, s), (r', s'))" by (cases x) auto
    have "((r, s), (r', s')) \<in> ?L \<Longrightarrow> ((r, s), (r', s')) \<in> ?R"
    proof(induction rule: converse_rtrancl_induct2)
      case refl show ?case by(force intro!: fold_simps(1)[symmetric])
    next
      case step thus ?case by(force intro!: fold_simps(2)[symmetric])
    qed
    with x have "x \<in> ?L \<Longrightarrow> x \<in> ?R" by simp
  } moreover
  { fix x :: "('a \<times> 'a) \<times> 'a \<times> 'a"
    obtain r s r' s' where x: "x = ((r, s), (r', s'))" by (cases x) auto
    { fix w have "\<forall>x\<in>set w. x \<in> A \<Longrightarrow> ((r, s), fold f w r, fold f w s) \<in> ?L"
      proof(induction w rule: rev_induct)
        case Nil show ?case by simp
      next
        case snoc thus ?case by (auto elim!: rtrancl_into_rtrancl)
      qed
    }
    hence "((r, s), (r', s')) \<in> ?R \<Longrightarrow> ((r, s), (r', s')) \<in> ?L" by auto
    with x have "x \<in> ?R \<Longrightarrow> x \<in> ?L" by simp
  } ultimately show ?thesis by blast
qed

lemma in_fold_lQuot: "v \<in> fold lQuot w L \<longleftrightarrow> w @ v \<in> L"
  by (induct w arbitrary: L) (simp_all add: lQuot_def)

lemma (in project) lang_eq_ext: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> (lang n r = lang n s) =
  (\<forall>w \<in> lists(\<Sigma> n). w \<in> lang n r \<longleftrightarrow> w \<in> lang n s)"
  by (auto dest!: lang_subset_lists)

lemma (in project) lang_eq_ext_Nil_fold_Deriv:
  fixes r s n
  assumes WF: "wf n r" "wf n s"
  defines "\<BB> \<equiv> {(fold lQuot w (lang n r), fold lQuot w (lang n s))| w. w\<in>lists (\<Sigma> n)}"
  shows "lang n r = lang n s \<longleftrightarrow> (\<forall>(K, L) \<in> \<BB>. [] \<in> K \<longleftrightarrow> [] \<in> L)"
  unfolding lang_eq_ext[OF WF] \<BB>_def
  by (subst (1 2) in_fold_lQuot[of "[]", simplified, symmetric]) auto

locale rexp_DA = project "set o \<sigma>" wf_atom project lookup
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes init :: "'b rexp \<Rightarrow> 's"
  fixes delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  fixes final :: "'s \<Rightarrow> bool"
  fixes wf_state :: "'s \<Rightarrow> bool"
  fixes post :: "'s \<Rightarrow> 's"
  fixes L :: "'s \<Rightarrow> 'a lang"
  fixes n :: "nat"
  assumes L_init[simp]: "wf n r \<Longrightarrow> L (init r) = lang n r"
  assumes L_delta[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> L (delta a s) = lQuot a (L s)"
  assumes final_iff_Nil[simp]: "final s \<longleftrightarrow> [] \<in> L s"
  assumes L_wf_state[dest]: "wf_state s \<Longrightarrow> L s \<subseteq> lists (set (\<sigma> n))"
  assumes init_wf_state[simp]: "wf n r \<Longrightarrow> wf_state (init r)"
  assumes delta_wf_state[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> wf_state (delta a s)"
  assumes L_post[simp]: "wf_state s \<Longrightarrow> L (post s) = L s"
  assumes wf_state_post[simp]: "wf_state s \<Longrightarrow> wf_state (post s)"
begin

lemma L_deltas[simp]: "\<lbrakk>wf_word n w; wf_state s\<rbrakk> \<Longrightarrow> L (fold delta w s) = fold lQuot w (L s)"
  by (induction w arbitrary: s) auto

definition progression (infix "\<rightarrow>" 60) where
  "R \<rightarrow> S = (\<forall>s1 s2. R s1 s2 \<longrightarrow> wf_state s1 \<and> wf_state s2 \<and> final s1 = final s2 \<and>
     (\<forall>x \<in> set (\<sigma> n). BNF_Greatest_Fixpoint.image2p post post S (post (delta x s1)) (post (delta x s2))))"

lemma SUPR_progression[intro!]: "\<forall>n. \<exists>m. X n \<rightarrow> Y m \<Longrightarrow> (SUP n. X n) \<rightarrow> (SUP n. Y n)"
  unfolding progression_def image2p_def by fastforce

definition bisimulation where
  "bisimulation R = R \<rightarrow> R"

definition bisimulation_upto where
  "bisimulation_upto R f = R \<rightarrow> f R"

declare image2pI[intro!] image2pE[elim!]
lemmas bisim_def = bisimulation_def progression_def
lemmas bisim_upto_def = bisimulation_upto_def progression_def

definition compatible where
  "compatible f = (mono f \<and> (\<forall>R S. R \<rightarrow> S \<longrightarrow> f R \<rightarrow> f S))"

lemmas compat_def = compatible_def progression_def

lemma bisimulation_upto_bisimulation:
  assumes "compatible f" "bisimulation_upto R f"
  obtains S where "bisimulation S" "R \<le> S"
proof
  { fix n from assms have "(f^^n) R \<rightarrow> (f^^Suc n) R"
     by (induct n) (auto simp: bisimulation_upto_def compatible_def) }
  then show "bisimulation (SUP n. (f^^n) R)"
    unfolding bisimulation_def by (auto simp del: funpow.simps)
  show "R \<le> (SUP n. (f^^n) R)" by (auto intro!: exI[of _ 0])
qed

lemma bisimulation_eqL: "bisimulation (\<lambda>s1 s2. wf_state s1 \<and> wf_state s2 \<and> L s1 = L s2)"
  unfolding bisim_def by (auto simp: lQuot_def)

lemma coinduction:
  assumes bisim[unfolded bisim_def]: "bisimulation R" and
    WF: "wf_state s1" "wf_state s2" and R: "R s1 s2"
  shows "L s1 = L s2"
proof (rule set_eqI)
  fix w
  from R WF show "w \<in> L s1 \<longleftrightarrow> w \<in> L s2"
  proof (induction w arbitrary: s1 s2)
    case Nil then show ?case using bisim by simp
  next
    case (Cons a w s1 s2)
    show ?case
    proof cases
      assume a: "a \<in> set (\<sigma> n)"
      with `R s1 s2` obtain s1' s2' where "R s1' s2'" "wf_state s1'" "wf_state s2'" and
        *[symmetric]: "post s1' = post (delta a s1)"  "post s2' = post (delta a s2)"
        using bisim unfolding image2p_apply by blast
      then have "w \<in> L (post (delta a s1)) \<longleftrightarrow> w \<in> L (post (delta a s2))"
        unfolding * using Cons.IH[of s1' s2'] by simp
      with a Cons.prems(2,3) show ?case by (simp add: lQuot_def)
    next
      assume "a \<notin> set (\<sigma> n)"
      thus ?case using Cons.prems bisim by force
    qed
  qed
qed

lemma coinduction_upto:
  assumes "bisimulation_upto R f" and WF: "wf_state s1" "wf_state s2" and "R s1 s2" "compatible f"
  shows "L s1 = L s2"
proof (rule bisimulation_upto_bisimulation[OF assms(5,1)])
  fix S assume "R \<le> S"
  assume "bisimulation S"
  then show "L s1 = L s2"
  proof (rule coinduction[OF _ WF])
    from `R \<le> S` `R s1 s2` show "S s1 s2" by blast
  qed
qed

fun test_invariant where
  "test_invariant (ws, _ :: ('s \<times> 's) list , _ :: 's rel) = (case ws of [] \<Rightarrow>  False | (w::'a list,p,q)#_ \<Rightarrow> final p = final q)"
fun test where "test (ws, _ :: 's rel) = (case ws of [] \<Rightarrow>  False | (p,q)#_ \<Rightarrow> final p = final q)"

fun step_invariant where "step_invariant (ws, ps, N) =
    (let
      (w, r, s) = hd ws;
      ps' = (r, s) # ps;
      succs = map (\<lambda>a.
        let r' = delta a r; s' = delta a s
        in ((a # w, r', s'), (post r', post s'))) (\<sigma> n);
      new = remdups' snd (filter (\<lambda>(_, rs). rs \<notin> N) succs);
      ws' = tl ws @ map fst new;
      N' = set (map snd new) \<union> N
    in (ws', ps', N'))"

fun step where "step (ws, N) =
    (let
      (r, s) = hd ws;
      succs = map (\<lambda>a.
        let r' = delta a r; s' = delta a s
        in ((r', s'), (post r', post s'))) (\<sigma> n);
      new = remdups' snd (filter (\<lambda>(_, rs). rs \<notin> N) succs)
    in (tl ws @ map fst new, set (map snd new) \<union> N))"

definition closure_invariant where "closure_invariant = while_option test_invariant step_invariant"
definition closure where "closure = while_option test step"

definition invariant where
  "invariant r s = (\<lambda>(ws, ps, N).
     (r, s) \<in> snd ` set ws \<union> set ps \<and>
     distinct (map snd ws @ ps) \<and>
     bij_betw (map_prod post post) (set (map snd ws @ ps)) N \<and>
     (\<forall>(w, r', s') \<in> set ws. fold delta (rev w) r = r' \<and> fold delta (rev w) s = s' \<and>
        wf_word n (rev w) \<and> wf_state r' \<and> wf_state s') \<and>
     (\<forall>(r', s') \<in> set ps. (\<exists>w. fold delta w r = r' \<and> fold delta w s = s') \<and>
       wf_state r' \<and> wf_state s' \<and> (final r' \<longleftrightarrow> final s') \<and>
       (\<forall>a\<in>set (\<sigma> n). (post (delta a r'), post (delta a s')) \<in> N)))"

lemma invariant_start:
  "\<lbrakk>wf_state r; wf_state s\<rbrakk> \<Longrightarrow> invariant r s ([([], r, s)], [], {(post r, post s)})"
  by (auto simp add: invariant_def bij_betw_def)

lemma step_invatiant_unfold: "step_invariant (w # ws, ps, N) = (ws', ps', N') \<Longrightarrow> (\<exists>xs r s.
  w = (xs, r, s) \<and> ps' = (r, s) # ps \<and>
  ws' = ws @ remdups' (map_prod post post o snd) (filter (\<lambda>(_, p). map_prod post post p \<notin> N)
   (map (\<lambda>a. (a#xs, delta a r, delta a s)) (\<sigma> n))) \<and>
  N' = set (map (\<lambda>a. (post (delta a r), post (delta a s))) (\<sigma> n)) \<union> N)"
  by (auto split: prod.splits dest!: mp_remdups'
  simp: Let_def filter_map set_n_lists image_Collect image_image comp_def)

lemma invariant: "invariant r s st \<Longrightarrow> test_invariant st \<Longrightarrow> invariant r s (step_invariant st)"
proof (unfold invariant_def, (split prod.splits)+, elim case_prodE conjE, clarify, intro allI impI conjI)
  fix ws ps N ws' ps' N'
  assume test_invariant: "test_invariant (ws, ps, N)"
  and step_invariant: "step_invariant (ws, ps, N) = (ws', ps', N')"
  and rs: "(r, s) \<in> snd ` set ws \<union> set ps"
  and distinct: "distinct (map snd ws @ ps)"
  and bij: "bij_betw (map_prod post post) (set (map snd ws @ ps)) N"
  and ws: "\<forall>(w, r', s') \<in> set ws. fold delta (rev w) r = r' \<and> fold delta (rev w) s = s' \<and>
    wf_word n (rev w) \<and> wf_state r' \<and> wf_state s'"
      (is "\<forall>(w, r', s') \<in> set ws. ?ws w r' s'")
  and ps: "\<forall>(r', s') \<in> set ps. (\<exists>w. fold delta w r = r' \<and> fold delta w s = s') \<and>
    wf_state r' \<and> wf_state s' \<and> (final r' \<longleftrightarrow> final s') \<and>
    (\<forall>a\<in>set (\<sigma> n). (post (delta a r'), post (delta a s')) \<in> N)"
      (is "\<forall>(r, s) \<in> set ps. ?ps r s N")
  from test_invariant obtain x xs where ws_Cons: "ws = x # xs" by (cases ws) auto
  obtain w r' s' where x: "x = (w, r', s')" and ps': "ps' = (r', s') # ps"
    and ws': "ws' = xs @ remdups' (map_prod post post o snd)
      (filter (\<lambda>(_, p). map_prod post post p \<notin> N)
        (map (\<lambda>a. (a # w, delta a r',  delta a s')) (\<sigma> n)))"
    and N': "N' = (set (map (\<lambda>a. (post (delta a r'), post (delta a s'))) (\<sigma> n)) - N) \<union> N"
    using step_invatiant_unfold[OF step_invariant[unfolded ws_Cons]] by blast
  hence ws'ps': "set (map snd ws' @ ps') =
     set (remdups' (map_prod post post) (filter (\<lambda>p. map_prod post post p \<notin> N)
    (map (\<lambda>a. (delta a r',  delta a s')) (\<sigma> n)))) \<union> (set (map snd ws @ ps))"
    unfolding ws' ps' ws_Cons x by (auto dest!: mp_remdups' simp: filter_map image_image image_Un o_def)
  from rs step_invariant show "(r, s) \<in> snd ` set ws' \<union> set ps'" by (blast dest: step_invariant_mono)
(*next*)
  from distinct ps' ws' ws_Cons x bij show "distinct (map snd ws' @ ps')"
    by (auto simp: bij_betw_def
      intro!: imageI[of _ _ "map_prod post post"] distinct_remdups'_strong
        map_prod_imageI[of _ _ _ post post]
      dest!: mp_remdups'
      elim: image_eqI[of _ snd, OF sym[OF snd_conv]])
(*next*)
  from ps' ws' N' ws x bij show "bij_betw (map_prod post post) (set (map snd ws' @ ps')) N'"
  unfolding ws'ps' N' by (intro bij_betw_combine[OF _ bij]) (auto simp: bij_betw_def map_prod_def)
(*next*)
  from ws x ws_Cons have wr's': "?ws w r' s'" by auto
  with ws ws_Cons show "\<forall>(w, r', s') \<in> set ws'. ?ws w r' s'" unfolding ws'
    by (auto dest!: mp_remdups' elim!: set_mp)
(*next*)
  from ps wr's' test_invariant[unfolded ws_Cons x] show "\<forall>(r', s') \<in> set ps'. ?ps r' s' N'" unfolding ps' N'
    by (fastforce simp: image_Collect)
qed

lemma step_commute: "ws \<noteq> [] \<Longrightarrow>
  (case step_invariant (ws, ps, N) of (ws', ps', N') \<Rightarrow> (map snd ws', N')) = step (map snd ws, N)"
apply (auto split: prod.splits)
   apply (auto simp only: step_invariant.simps step.simps Let_def map_apfst_remdups' filter_map list.map_comp apfst_def map_prod_def snd_conv id_def)
   apply (auto simp: filter_map comp_def map_tl hd_map)
 apply (intro image_eqI, auto)+
done

lemma closure_invariant_closure:
  "map_option (\<lambda>(ws, ps, N). (map snd ws, N)) (closure_invariant (ws, ps, N)) = closure (map snd ws, N)"
  unfolding closure_invariant_def closure_def
  by (rule trans[OF while_option_commute[of _ test _ _ "step"]])
   (auto split: list.splits simp del: step_invariant.simps step.simps list.map simp: step_commute)

lemma
  assumes result: "closure_invariant ([([], init r, init s)], [], {(post (init r), post (init s))}) =
    Some(ws, ps, N)" (is "closure_invariant ([([], ?r, ?s)], _) = _")
  and WF: "wf n r" "wf n s"
  shows closure_invariant_sound: "ws = [] \<Longrightarrow> lang n r = lang n s" and
    counterexample: "ws \<noteq> [] \<Longrightarrow> rev (fst (hd ws)) \<in> lang n r \<longleftrightarrow> rev (fst (hd ws)) \<notin> lang n s"
proof -
  from WF have wf_state: "wf_state ?r" "wf_state ?s" by simp_all
  from invariant invariant_start[OF wf_state] have invariant_ps: "invariant ?r ?s (ws, ps, N)"
    by (rule while_option_rule[OF _ result[unfolded closure_invariant_def]])
  { assume "ws = []"
    with invariant_ps have "bisimulation (in_rel (set ps))" "(?r, ?s) \<in> set ps"
      by (auto simp: bij_betw_def invariant_def bisimulation_def progression_def image2p_in_rel)
    with wf_state have "L ?r = L ?s" by (auto dest: coinduction)
    with WF show "lang n r = lang n s" by simp
  }
  { assume "ws \<noteq> []"
    then obtain w r' s' ws' where ws: "ws = (w, r', s') # ws'" by (cases ws) auto
    with invariant_ps have "r' = fold delta (rev w) (init r)" "s' = fold delta (rev w) (init s)"
      "wf_word n (rev w)" unfolding invariant_def by auto
    moreover have "\<not> test_invariant ((w, r', s') # ws', ps, N)"
      by (rule while_option_stop[OF result[unfolded ws closure_invariant_def]])
    ultimately have "rev (fst (hd ws)) \<in> L ?r \<longleftrightarrow> rev (fst (hd ws)) \<notin> L ?s"
      unfolding ws using wf_state by (simp add: in_fold_lQuot)
    with WF show "rev (fst (hd ws)) \<in> lang n r \<longleftrightarrow> rev (fst (hd ws)) \<notin> lang n s" by simp
  }
qed

lemma closure_sound:
  assumes result: "closure ([(init r, init s)], {(post (init r), post (init s))}) = Some ([], N)"
  and WF: "wf n r" "wf n s"
  shows "lang n r = lang n s"
  using trans[OF closure_invariant_closure[of "[([], init r, init s)]", simplified] result]
  by (auto dest: closure_invariant_sound[OF _ WF])

definition check_eqv where
  "check_eqv r s =
    (let r' = init r; s' = init s in (case closure ([(r', s')], {(post r', post s')}) of
       Some ([], _) \<Rightarrow> True | _ \<Rightarrow> False))"

lemma check_eqv_sound:
  assumes "check_eqv r s" and WF: "wf n r" "wf n s"
  shows "lang n r = lang n s"
  using closure_sound assms
  by (auto simp: check_eqv_def Let_def split: option.splits list.splits)

definition counterexample where
  "counterexample r s =
    (let r' = init r; s' = init s in (case closure_invariant ([([], r', s')], [], {(post r', post s')}) of
       Some((w,_,_) # _, _) \<Rightarrow> Some (rev w) | _ => None))"

lemma counterexample_sound:
  assumes result: "counterexample r s = Some w"  and WF: "wf n r" "wf n s"
  shows "w \<in> lang n r \<longleftrightarrow> w \<notin> lang n s"
  using assms unfolding counterexample_def Let_def
  by (auto dest!: counterexample[of r s] split: option.splits list.splits)

text{* Auxiliary exacutable functions: *}

definition reachable :: "'b rexp \<Rightarrow> 's set" where
  "reachable s = snd (the (rtrancl_while (\<lambda>_. True) (\<lambda>s. map (\<lambda>a. post (delta a s)) (\<sigma> n)) (init s)))"

definition automaton :: "'b rexp \<Rightarrow> (('s * 'a) * 's) set" where
  "automaton s =
    snd (the
    (let i = init s;
         start = (([i], {post i}), {});
         test_invariant = \<lambda>((ws, Z), A). ws \<noteq> [];
         step_invariant = \<lambda>((ws, Z), A).
           (let s = hd ws;
                new_edges = map (\<lambda>a. ((s, a), delta a s)) (\<sigma> n);
                new = remdups (filter (\<lambda>ss. post ss \<notin> Z) (map snd new_edges))
           in ((new @ tl ws, post ` set new \<union> Z), set new_edges \<union> A))
    in while_option test_invariant step_invariant start))"

definition match :: "'b rexp \<Rightarrow> 'a list \<Rightarrow> bool" where
  "match s w = final (fold delta w (init s))"

lemma match_correct: "\<lbrakk>wf_word n w; wf n s\<rbrakk> \<Longrightarrow> match s w \<longleftrightarrow> w \<in> lang n s"
  unfolding match_def
  by (induct w arbitrary: s) (auto simp: in_fold_lQuot lQuot_def)

end

locale rexp_DFA = rexp_DA \<sigma> wf_atom project lookup init delta final wf_state post L n
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and init :: "'b rexp \<Rightarrow> 's"
  and delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  and final :: "'s \<Rightarrow> bool"
  and wf_state :: "'s \<Rightarrow> bool"
  and post :: "'s \<Rightarrow> 's"
  and L :: "'s \<Rightarrow> 'a lang"
  and n :: nat +
assumes fin: "finite {fold delta w (init s) | w. True}"
begin

abbreviation "Reachable s \<equiv> {fold delta w (init s) | w. True}"

lemma closure_invariant_termination:
  assumes WF: "wf n r" "wf n s"
  and result: "closure_invariant ([([], init r, init s)], [], {(post (init r), post (init s))}) = None"
    (is "closure_invariant ([([], ?r, ?s)], _) = None" is "?cl = None")
  shows "False"
proof -
  let ?D =  "post ` Reachable r \<times> post ` Reachable s"
  let ?X = "\<lambda>ps. ?D - map_prod post post ` set ps"
  let ?f = "\<lambda>(ws, ps, N). card (?X ps)"
  have "\<exists>st. ?cl = Some st" unfolding closure_invariant_def
  proof (rule measure_while_option_Some[of "invariant ?r ?s" _ _ ?f], intro conjI)
    fix st assume base: "invariant ?r ?s st" and "test_invariant st"
    hence step: "invariant ?r ?s (step_invariant st)" by (rule invariant)
    obtain ws ps N where st: "st = (ws, ps, N)" by (cases st) blast
    hence "finite (?X ps)" by (blast intro: finite_cartesian_product fin)
    moreover obtain ws' ps' N' where step_invariant: "step_invariant (ws, ps, N) = (ws', ps', N')"
      by (cases "step_invariant (ws, ps, N)") blast
    moreover
    { have "map_prod post post ` set ps \<subseteq> ?D" using base[unfolded st invariant_def] by fast
      moreover
      have "map_prod post post ` set ps' \<subseteq> ?D" using step[unfolded st step_invariant invariant_def]
        by fast
      moreover
      { have "distinct (map snd ws @ ps)" "inj_on (map_prod post post) (set (map snd ws @ ps))"
          using base[unfolded st invariant_def] by (auto simp: bij_betw_def)
        hence "distinct (map (map_prod post post) (map snd ws @ ps))" unfolding distinct_map ..
        hence "map_prod post post ` set ps \<subset> map_prod post post ` set (snd (hd ws) # ps)"
          using `test_invariant st` st by (cases ws) (simp_all, blast)
        moreover have "map_prod post post ` set ps' = map_prod post post ` set (snd (hd ws) # ps)"
          using step_invariant by (auto split: prod.splits)
        ultimately have "map_prod post post ` set ps \<subset> map_prod post post ` set ps'" by simp
      }
      ultimately have "?X ps' \<subset> ?X ps" by (auto simp add: image_set simp del: set_map)
    }
    ultimately show "?f (step_invariant st) < ?f st" unfolding st step_invariant
      using psubset_card_mono[of "?X ps" "?X ps'"] by simp
  qed (auto simp add: invariant_start WF invariant)
  then show False using result by auto
qed

lemma closure_termination:
  assumes WF: "wf n r" "wf n s"
  and result: "closure ([(init r, init s)], {(post (init r), post (init s))}) = None"
  shows "False"
  using trans[OF closure_invariant_closure[of "[([], init r, init s)]", simplified] result]
  by (auto intro: closure_invariant_termination[OF WF])

lemma closure_invariant_complete:
  assumes eq: "lang n r = lang n s"
  and WF:  "wf n r" "wf n s"
  shows "\<exists>ps N. closure_invariant ([([], init r, init s)], [], {(post (init r), post (init s))}) =
    Some([], ps, N)" (is "\<exists>_ _. closure_invariant ([([], ?r, ?s)], _) = _" is "\<exists>_ _. ?cl = _")
proof (cases ?cl)
  case (Some st)
  moreover obtain ws ps N where ws_ps_N: "st = (ws, ps, N)" by (cases st) blast
  ultimately show ?thesis
  proof (cases ws)
    case (Cons wrs ws)
    with Some obtain w where "counterexample r s = Some w" unfolding counterexample_def
      by (cases wrs) (auto simp: ws_ps_N)
    with eq counterexample_sound[OF _ WF] show ?thesis by blast
  qed blast
qed (auto intro: closure_invariant_termination[OF WF])

lemma closure_complete:
  assumes "lang n r = lang n s" "wf n r" "wf n s"
  shows "\<exists>N. closure ([(init r, init s)], {(post (init r), post (init s))}) = Some ([], N)"
  using closure_invariant_complete[OF assms]
  by (subst closure_invariant_closure[of "[([], init r, init s)]", simplified, symmetric]) auto

lemma check_eqv_complete:
  assumes "lang n r = lang n s" "wf n r" "wf n s"
  shows "check_eqv r s"
  using closure_complete[OF assms] by (auto simp: check_eqv_def)

lemma counterexample_complete:
  assumes "lang n r \<noteq> lang n s" and WF: "wf n r" "wf n s"
  shows "\<exists>w. counterexample r s = Some w"
  using closure_invariant_sound[OF _ WF] closure_invariant_termination[OF WF] assms
  by (fastforce simp: counterexample_def Let_def split: option.splits list.splits)

end

locale rexp_DA_no_post = rexp_DA \<sigma> wf_atom project lookup init delta final wf_state id L n
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and init :: "'b rexp \<Rightarrow> 's"
  and delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  and final :: "'s \<Rightarrow> bool"
  and wf_state :: "'s \<Rightarrow> bool"
  and L :: "'s \<Rightarrow> 'a lang"
  and n :: nat
begin

lemma step_efficient[code]: "step (ws, N) =
  (let
    (r, s) = hd ws;
    new = remdups (filter (\<lambda>(r,s). (r,s) \<notin> N) (map (\<lambda>a. (delta a r, delta a s)) (\<sigma> n)))
  in (tl ws @ new, set new \<union> N))"
  by (force simp: Let_def map_apfst_remdups' filter_map o_def split: prod.splits)

end

locale rexp_DFA_no_post = rexp_DFA \<sigma> wf_atom project lookup init delta final wf_state id L
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and init :: "'b rexp \<Rightarrow> 's"
  and delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  and final :: "'s \<Rightarrow> bool"
  and wf_state :: "'s \<Rightarrow> bool"
  and L :: "'s \<Rightarrow> 'a lang"
begin

sublocale rexp_DA_no_post by unfold_locales

end

locale rexp_DA_sim = project "set o \<sigma>" wf_atom project lookup
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes init :: "'b rexp \<Rightarrow> 's"
  fixes sim_delta :: "'s \<Rightarrow> 's list"
  fixes final :: "'s \<Rightarrow> bool"
  fixes wf_state :: "'s \<Rightarrow> bool"
  fixes L :: "'s \<Rightarrow> 'a lang"
  fixes post :: "'s \<Rightarrow> 's"
  fixes n :: nat
  assumes L_init[simp]: "wf n r \<Longrightarrow> L (init r) = lang n r"
  assumes final_iff_Nil[simp]: "final s \<longleftrightarrow> [] \<in> L s"
  assumes L_wf_state[dest]: "wf_state s \<Longrightarrow> L s \<subseteq> lists (set (\<sigma> n))"
  assumes init_wf_state[simp]: "wf n r \<Longrightarrow> wf_state (init r)"
  assumes L_post[simp]: "wf_state s \<Longrightarrow> L (post s) = L s"
  assumes wf_state_post[simp]: "wf_state s \<Longrightarrow> wf_state (post s)"
  assumes L_sim_delta[simp]: "wf_state s \<Longrightarrow> map L (sim_delta s) = map (\<lambda>a. lQuot a (L s)) (\<sigma> n)"
  assumes sim_delta_wf_state[simp]: "wf_state s \<Longrightarrow> \<forall>s' \<in> set (sim_delta s). wf_state s'"
begin

definition "delta a s = sim_delta s ! index (\<sigma> n) a"

lemma length_sim_delta[simp]: "wf_state s \<Longrightarrow> length (sim_delta s) = length (\<sigma> n)"
  by (metis L_sim_delta length_map)

lemma L_delta[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> L (delta a s) = lQuot a (L s)"
  using L_sim_delta[of s] unfolding delta_def in_set_conv_nth
  by (subst (asm) list_eq_iff_nth_eq) auto

lemma delta_wf_state[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> wf_state (delta a s)"
  unfolding delta_def by (auto intro: bspec[OF sim_delta_wf_state nth_mem])

sublocale rexp_DA \<sigma> wf_atom project lookup init delta final wf_state post L
  by unfold_locales auto

sublocale rexp_DA_sim_no_post!: rexp_DA_no_post \<sigma> wf_atom project lookup init delta final wf_state L
  by unfold_locales auto

end

(*<*)
end
(*>*)


(*  Author:     Andreas Lochbihler *)

section {*
  Predicates modelled as FinFuns
*}

theory FinFunPred imports "~~/src/HOL/Library/FinFun_Syntax" begin

text {* Instantiate FinFun predicates just like predicates *}

type_synonym 'a pred\<^sub>f = "'a \<Rightarrow>f bool"

instantiation "finfun" :: (type, ord) ord
begin

definition le_finfun_def [code del]: "f \<le> g \<longleftrightarrow> (\<forall>x. f $ x \<le> g $ x)"

definition [code del]: "(f\<Colon>'a \<Rightarrow>f 'b) < g \<longleftrightarrow> f \<le> g \<and> \<not> f \<ge> g"

instance ..

lemma le_finfun_code [code]:
  "f \<le> g \<longleftrightarrow> finfun_All ((\<lambda>(x, y). x \<le> y) \<circ>$ ($f, g$))"
by(simp add: le_finfun_def finfun_All_All o_def)

end

instance "finfun" :: (type, preorder) preorder
  by(intro_classes)(auto simp add: less_finfun_def le_finfun_def intro: order_trans)

instance "finfun" :: (type, order) order
by(intro_classes)(auto simp add: le_finfun_def order_antisym_conv intro: finfun_ext)

instantiation "finfun" :: (type, order_bot) order_bot begin
definition "bot = finfun_const bot"
instance by(intro_classes)(simp add: bot_finfun_def le_finfun_def)
end

lemma bot_finfun_apply [simp]: "op $ bot = (\<lambda>_. bot)"
by(auto simp add: bot_finfun_def)

instantiation "finfun" :: (type, order_top) order_top begin
definition "top = finfun_const top"
instance by(intro_classes)(simp add: top_finfun_def le_finfun_def)
end

lemma top_finfun_apply [simp]: "op $ top = (\<lambda>_. top)"
by(auto simp add: top_finfun_def)

instantiation "finfun" :: (type, inf) inf begin
definition [code]: "inf f g = (\<lambda>(x, y). inf x y) \<circ>$ ($f, g$)"
instance ..
end

lemma inf_finfun_apply [simp]: "op $ (inf f g) = inf (op $ f) (op $ g)"
by(auto simp add: inf_finfun_def o_def inf_fun_def)

instantiation "finfun" :: (type, sup) sup begin
definition [code]: "sup f g = (\<lambda>(x, y). sup x y) \<circ>$ ($f, g$)"
instance ..
end

lemma sup_finfun_apply [simp]: "op $ (sup f g) = sup (op $ f) (op $ g)"
by(auto simp add: sup_finfun_def o_def sup_fun_def)

instance "finfun" :: (type, semilattice_inf) semilattice_inf
by(intro_classes)(simp_all add: inf_finfun_def le_finfun_def)

instance "finfun" :: (type, semilattice_sup) semilattice_sup
by(intro_classes)(simp_all add: sup_finfun_def le_finfun_def)

instance "finfun" :: (type, lattice) lattice ..

instance "finfun" :: (type, bounded_lattice) bounded_lattice
by(intro_classes)

instance "finfun" :: (type, distrib_lattice) distrib_lattice
by(intro_classes)(simp add: sup_finfun_def inf_finfun_def expand_finfun_eq o_def sup_inf_distrib1)

instantiation "finfun" :: (type, minus) minus begin
definition "f - g = split (op -) \<circ>$ ($f, g$)"
instance ..
end

lemma minus_finfun_apply [simp]: "op $ (f - g) = op $ f - op $ g"
by(simp add: minus_finfun_def o_def fun_diff_def)

instantiation "finfun" :: (type, uminus) uminus begin
definition "- A = uminus \<circ>$ A"
instance ..
end

lemma uminus_finfun_apply [simp]: "op $ (- g) = - op $ g"
by(simp add: uminus_finfun_def o_def fun_Compl_def)

instance "finfun" :: (type, boolean_algebra) boolean_algebra
by(intro_classes)
  (simp_all add: uminus_finfun_def inf_finfun_def expand_finfun_eq sup_fun_def inf_fun_def fun_Compl_def o_def inf_compl_bot sup_compl_top diff_eq)

text {*
  Replicate predicate operations for FinFuns
*}

abbreviation finfun_empty :: "'a pred\<^sub>f" ("{}\<^sub>f")
where "{}\<^sub>f \<equiv> bot"

abbreviation finfun_UNIV :: "'a pred\<^sub>f"
where "finfun_UNIV \<equiv> top"

definition finfun_single :: "'a \<Rightarrow> 'a pred\<^sub>f"
where [code]: "finfun_single x = finfun_empty(x $:= True)"

lemma finfun_single_apply [simp]:
  "finfun_single x $ y \<longleftrightarrow> x = y"
by(simp add: finfun_single_def finfun_upd_apply)

lemma finfun_leI [intro!]: "(!!x. A $ x \<Longrightarrow> B $ x) \<Longrightarrow> A \<le> B"
by(simp add: le_finfun_def)

lemma finfun_leD [elim]: "\<lbrakk> A \<le> B; A $ x \<rbrakk> \<Longrightarrow> B $ x"
by(simp add: le_finfun_def)

text {* Bounded quantification.
  Warning: @{text "finfun_Ball"} and @{text "finfun_Ex"} may raise an exception, they should not be used for quickcheck
*}

definition finfun_Ball_except :: "'a list \<Rightarrow> 'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Ball_except xs A P = (\<forall>a. A $ a \<longrightarrow> a \<in> set xs \<or> P a)"

lemma finfun_Ball_except_const:
  "finfun_Ball_except xs (K$ b) P \<longleftrightarrow> \<not> b \<or> set xs = UNIV \<or> Code.abort (STR ''finfun_ball_except'') (\<lambda>u. finfun_Ball_except xs (K$ b) P)"
by(auto simp add: finfun_Ball_except_def)

lemma finfun_Ball_except_const_finfun_UNIV_code [code]:
  "finfun_Ball_except xs (K$ b) P \<longleftrightarrow> \<not> b \<or> is_list_UNIV xs \<or> Code.abort (STR ''finfun_ball_except'') (\<lambda>u. finfun_Ball_except xs (K$ b) P)"
by(auto simp add: finfun_Ball_except_def is_list_UNIV_iff)

lemma finfun_Ball_except_update:
  "finfun_Ball_except xs (A(a $:= b)) P = ((a \<in> set xs \<or> (b \<longrightarrow> P a)) \<and> finfun_Ball_except (a # xs) A P)"
by(fastforce simp add: finfun_Ball_except_def finfun_upd_apply split: split_if_asm)

lemma finfun_Ball_except_update_code [code]:
  fixes a :: "'a :: card_UNIV"
  shows "finfun_Ball_except xs (finfun_update_code f a b) P = ((a \<in> set xs \<or> (b \<longrightarrow> P a)) \<and> finfun_Ball_except (a # xs) f P)"
by(simp add: finfun_Ball_except_update)

definition finfun_Ball :: "'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Ball A P = Ball {x. A $ x} P"

lemma finfun_Ball_code [code]: "finfun_Ball = finfun_Ball_except []"
by(auto intro!: ext simp add: finfun_Ball_except_def finfun_Ball_def)

definition finfun_Bex_except :: "'a list \<Rightarrow> 'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Bex_except xs A P = (\<exists>a. A $ a \<and> a \<notin> set xs \<and> P a)"

lemma finfun_Bex_except_const:
  "finfun_Bex_except xs (K$ b) P \<longleftrightarrow> b \<and> set xs \<noteq> UNIV \<and> Code.abort (STR ''finfun_Bex_except'') (\<lambda>u. finfun_Bex_except xs (K$ b) P)"
by(auto simp add: finfun_Bex_except_def)

lemma finfun_Bex_except_const_finfun_UNIV_code [code]:
  "finfun_Bex_except xs (K$ b) P \<longleftrightarrow> b \<and> \<not> is_list_UNIV xs \<and> Code.abort (STR ''finfun_Bex_except'') (\<lambda>u. finfun_Bex_except xs (K$ b) P)"
by(auto simp add: finfun_Bex_except_def is_list_UNIV_iff)

lemma finfun_Bex_except_update:
  "finfun_Bex_except xs (A(a $:= b)) P \<longleftrightarrow> (a \<notin> set xs \<and> b \<and> P a) \<or> finfun_Bex_except (a # xs) A P"
by(fastforce simp add: finfun_Bex_except_def finfun_upd_apply dest: bspec split: split_if_asm)

definition finfun_Bex :: "'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Bex A P = Bex {x. A $ x} P"

lemma finfun_Bex_code [code]: "finfun_Bex = finfun_Bex_except []"
by(auto intro!: ext simp add: finfun_Bex_except_def finfun_Bex_def)

text {* Automatically replace predicate operations by finfun predicate operations where possible *}

lemma iso_finfun_le [code_unfold]:
  "op $ A \<le> op $ B \<longleftrightarrow> A \<le> B"
by (metis le_finfun_def le_funD le_funI)

lemma iso_finfun_less [code_unfold]:
  "op $ A < op $ B \<longleftrightarrow> A < B"
by (metis iso_finfun_le less_finfun_def less_fun_def)

lemma iso_finfun_eq [code_unfold]:
  "op $ A = op $ B \<longleftrightarrow> A = B"
by(simp only: expand_finfun_eq)

lemma iso_finfun_sup [code_unfold]:
  "sup (op $ A) (op $ B) = op $ (sup A B)"
by(simp)

lemma iso_finfun_disj [code_unfold]:
  "A $ x \<or> B $ x \<longleftrightarrow> sup A B $ x"
by(simp add: sup_fun_def)

lemma iso_finfun_inf [code_unfold]:
  "inf (op $ A) (op $ B) = op $ (inf A B)"
by(simp)

lemma iso_finfun_conj [code_unfold]:
  "A $ x \<and> B $ x \<longleftrightarrow> inf A B $ x"
by(simp add: inf_fun_def)

lemma iso_finfun_empty_conv [code_unfold]:
  "(\<lambda>_. False) = op $ {}\<^sub>f"
by simp

lemma iso_finfun_UNIV_conv [code_unfold]:
  "(\<lambda>_. True) = op $ finfun_UNIV"
by simp

lemma iso_finfun_upd [code_unfold]:
  fixes A :: "'a pred\<^sub>f"
  shows "(op $ A)(x := b) = op $ (A(x $:= b))"
by(simp add: fun_eq_iff)

lemma iso_finfun_uminus [code_unfold]:
  fixes A :: "'a pred\<^sub>f"
  shows "- op $ A = op $ (- A)"
by(simp)

lemma iso_finfun_minus [code_unfold]:
  fixes A :: "'a pred\<^sub>f"
  shows "op $ A - op $ B = op $ (A - B)"
by(simp)

text {*
  Do not declare the following two theorems as @{text "[code_unfold]"},
  because this causes quickcheck to fail frequently when bounded quantification is used which raises an exception.
  For code generation, the same problems occur, but then, no randomly generated FinFun is usually around.
*}

lemma iso_finfun_Ball_Ball:
  "(\<forall>x. A $ x \<longrightarrow> P x) \<longleftrightarrow> finfun_Ball A P"
by(simp add: finfun_Ball_def)

lemma iso_finfun_Bex_Bex:
  "(\<exists>x. A $ x \<and> P x) \<longleftrightarrow> finfun_Bex A P"
by(simp add: finfun_Bex_def)

text {* Test code setup *}

notepad begin
have "inf ((\<lambda>_ :: nat. False)(1 := True, 2 := True)) ((\<lambda>_. True)(3 := False)) \<le>
      sup ((\<lambda>_. False)(1 := True, 5 := True)) (- ((\<lambda>_. True)(2 := False, 3 := False)))"
  by eval
end

declare iso_finfun_Ball_Ball[code_unfold]
notepad begin
have "(\<forall>x. ((\<lambda>_ :: nat. False)(1 := True, 2 := True)) x \<longrightarrow> x < 3)"
  by eval
end
declare iso_finfun_Ball_Ball[code_unfold del]

end


theory MuHO1_Semantics_Eval
  imports MuHO1_Semantics_Kleene
begin

context ctx
begin

section "Local Model-Checking Algorithm"

function
    lapprox_tm0 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> (name \<Rightarrow> 'a list) \<Rightarrow> tm0 \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a \<times> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<times> (name \<Rightarrow> 'a list))"
and lapprox_tm1 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> (name \<Rightarrow> 'a list) \<Rightarrow> tm1 \<Rightarrow> name  \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a \<times> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<times> (name \<Rightarrow> 'a list))"
and eval_tm0 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> (name \<Rightarrow> 'a list) \<Rightarrow> tm0 \<Rightarrow> ('a \<times> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<times> (name \<Rightarrow> 'a list))"
and eval_tm1 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> (name \<Rightarrow> 'a list) \<Rightarrow> tm1 \<Rightarrow> 'a \<Rightarrow> ('a \<times> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<times> (name \<Rightarrow> 'a list))"
  where
"lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x init 0 = (init, \<eta>1, d)" |

"lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x init (Suc n) =
    (let (val, \<eta>1', d') = lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x init n
        in eval_tm0 (\<eta>0(x := val)) \<eta>1' d' \<phi>)" |
"lapprox_tm1 \<eta>0 \<eta>1 d \<phi> x arg 0 = (\<eta>1 x arg, \<eta>1, d)" |
"lapprox_tm1 \<eta>0 \<eta>1 d \<phi> x arg (Suc n) =
    (let (_,\<eta>1'',d'') = fold (\<lambda>arg' ((_::'a), \<eta>1', d').
        (let (val''',\<eta>1''',d''') = eval_tm1 \<eta>0 \<eta>1' d' \<phi> arg'
           in (\<bottom>,
               (\<eta>1'''(x := (\<lambda>z. if z = arg' then val''' else \<eta>1' x z))),
              d'''))) (d x) (\<bottom>,\<eta>1,d)
                  in (if ((\<eta>1'' = \<eta>1) \<and> (d'' = d))
                      then (\<eta>1 x arg, \<eta>1, d)
                      else lapprox_tm1 \<eta>0 \<eta>1'' d'' \<phi> x arg n))" |
"eval_tm0 \<eta>0 \<eta>1 d (Var0 x) = ((\<eta>0 x), \<eta>1, d)" |
"eval_tm0 \<eta>0 \<eta>1 d (Func0 f) = (abs_func0 f, \<eta>1, d)" |
"eval_tm0 \<eta>0 \<eta>1 d (App \<phi> \<psi>) =
    (let (val, \<eta>1', d') = (eval_tm0 \<eta>0 \<eta>1 d \<psi>)
        in (eval_tm1 \<eta>0 \<eta>1' d' \<phi> val))" |
"eval_tm0 \<eta>0 \<eta>1 d (Mu0 x \<phi>) = lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> (card (UNIV::'a set))" |

"eval_tm1 \<eta>0 \<eta>1 d (Var1 x) arg =
    (if ListMem arg (d x)
      then (\<eta>1 x arg, \<eta>1, d)
      else (\<eta>1 x arg,
            (\<eta>1(x := (\<lambda>z. if z = arg then \<bottom> else (\<eta>1 x) z))),
           (d(x := arg # (d x)))))" |
"eval_tm1 \<eta>0 \<eta>1 d (Func1 f) arg = (abs_func1 f arg, \<eta>1, d)" |
"eval_tm1 \<eta>0 \<eta>1 d (Lam x \<phi>) arg = (eval_tm0 (\<eta>0(x := arg)) \<eta>1 d \<phi>)" |
"eval_tm1 \<eta>0 \<eta>1 d (Mu1 x \<phi>) arg =
    (let (val, \<eta>1', d') = lapprox_tm1 \<eta>0 (\<eta>1(x := \<lambda>z. \<bottom>)) (d(x := Nil))
                            \<phi> x arg (card (UNIV::('a\<Rightarrow>'a) set))
         in (val, (\<eta>1'(x := \<lambda>z. \<bottom>)), (d'(x := []))))"
  by pat_completeness auto
termination
  by size_change

(* Below is an exploration of different auxiliary lemmas and proofs that might be necessary to
   attempt a correctness proof for eval *)

(* Function that the partial functions mapping every argument not in the domain to bottom *)
fun envify :: "(name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> (name \<Rightarrow> 'a list) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a))" where
"envify \<eta>1 d = (\<lambda>x arg. (if ListMem arg (d x) then \<eta>1 x arg else \<bottom>))"

(* A proof that envify is monotonic in the variable interpretations and the domain set *)
lemma envify_mono:
  assumes "\<forall>x. set (d x) \<subseteq> set (d' x)"
    and "\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f"
  shows "\<forall>x f. envify \<eta>1 d x f \<le> envify \<eta>1' d' x f"
proof (rule allI, rule allI)
  fix x f

  show "envify \<eta>1 d x f \<le> envify \<eta>1' d' x f"
  proof (cases "ListMem f (d x)")
    case True
    then show ?thesis
      by (metis ListMem_iff assms envify.elims subsetD)
  next
    case False
    then show ?thesis
      by simp
  qed
qed

(* Proof about the property that if arguments not in the domain of a function are mapped to bottom
   before the invocation of \<open>lapprox_tm0\<close>, are still mapped to bottom after the invocation *)
lemma lapprox_tm0_not_in_dom_still_bot:
"\<And>\<eta>0 \<eta>1 d \<eta>1' d' val. \<lbrakk> \<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>;

    (\<And>\<eta>0 \<eta>1 d \<eta>1' d' val. (\<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>)
      \<Longrightarrow> eval_tm0 \<eta>0 \<eta>1 d \<phi> = (val,\<eta>1',d')
      \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1' f arg = \<bottom>))

    \<rbrakk>
    \<Longrightarrow> lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n = (val,\<eta>1',d')
    \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1' f arg = \<bottom>)"
proof (induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then have 0: "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> (Suc n) = (let (val, \<eta>1', d') = lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n
        in eval_tm0 (\<eta>0(x := val)) \<eta>1' d' \<phi>)"
    by (metis lapprox_tm0.simps(2))

  then have "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n = (val', \<eta>1'', d'')
      \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d'' f)) \<Longrightarrow> \<eta>1'' f arg = \<bottom>)" for val' \<eta>1'' d''
    using Suc.IH Suc.prems by blast

  then have 1: "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n = (val', \<eta>1'', d'')
      \<Longrightarrow>  eval_tm0 (\<eta>0(x := val')) \<eta>1'' d'' \<phi> = (val,\<eta>1',d')
      \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1' f arg = \<bottom>)" for val' \<eta>1'' d''
    by (metis Suc.prems(2))

  from 0 1 show ?case
    by (smt (verit, del_insts) Suc.prems case_prod_conv prod_cases3)
qed

(* Same property but for eval, making use of the previous proven lemma *)
lemma eval_not_in_dom_still_bot:
"\<And>\<eta>0 \<eta>1 d \<eta>1'' d' val f. \<lbrakk>\<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>;
   eval_tm0 \<eta>0 \<eta>1 d \<phi> = (val,\<eta>1'',d') \<rbrakk>
    \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1'' f arg = \<bottom>)"

"\<And>\<eta>0 \<eta>1 d \<eta>1'' d' val f arg. \<lbrakk>\<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>;
   eval_tm1 \<eta>0 \<eta>1 d \<phi>' arg = (val,\<eta>1'',d') \<rbrakk>
    \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1'' f arg = \<bottom>)"
proof (induction \<phi> and \<phi>')
  case (Var0 x)
  then show ?case
    by simp
next
  case (Func0 x)
  then show ?case
    by simp
next
  case (App x1 x2)
   then have 0: "eval_tm0 \<eta>0 \<eta>1 d (App x1 x2) = (let (val, \<eta>1', d') = (eval_tm0 \<eta>0 \<eta>1 d x2) in
                                (eval_tm1 \<eta>0 \<eta>1' d' x1 val))"
     by (metis eval_tm0.simps(3))

  have "eval_tm0 \<eta>0 \<eta>1 d x2 = (val', \<eta>1'', d'')
          \<Longrightarrow>  (\<And>f arg. \<not> (ListMem arg (d'' f)) \<Longrightarrow> \<eta>1'' f arg = \<bottom>)" for val' \<eta>1'' d''
    using App.IH(2) App.prems(1) by blast

  then have 1: "eval_tm0 \<eta>0 \<eta>1 d x2 = (val', \<eta>1'', d'')
          \<Longrightarrow> eval_tm1 \<eta>0 \<eta>1'' d'' x1 val' = (val, \<eta>1', d')
          \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1' f arg = \<bottom>)" for val' \<eta>1' \<eta>1'' d''
    by (metis App.IH(1))

  from 0 1 show ?case
    by (metis (no_types, lifting) App.prems(2) App.prems(3) case_prod_conv prod_cases3)
next
  case (Mu0 x1 x2)
  then have "eval_tm0 \<eta>0 \<eta>1 d (Mu0 x1 x2) = lapprox_tm0 \<eta>0 \<eta>1 d x2 x1 \<bottom> (card (UNIV::'a set))"
    by simp

  have "(\<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>)
            \<Longrightarrow> eval_tm0 \<eta>0 \<eta>1 d x2 = (val', \<eta>1', d')
            \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1' f arg = \<bottom>)" for \<eta>0 \<eta>1 d val' \<eta>1' d'
    using Mu0.IH Mu0.prems(1) by blast

  then have "(\<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>)
            \<Longrightarrow> lapprox_tm0 \<eta>0 \<eta>1 d x2 x1 \<bottom> (card (UNIV::'a set)) = (val,\<eta>1'',d')
            \<Longrightarrow> (\<And>f arg. \<not> (ListMem arg (d' f)) \<Longrightarrow> \<eta>1'' f arg = \<bottom>)"
    by (smt (verit, ccfv_threshold) lapprox_tm0_not_in_dom_still_bot)

  then show ?case
    using Mu0.prems(1) Mu0.prems(2) Mu0.prems(3) by simp
next
  case (Var1 x)
  show ?case
  proof (cases "ListMem arg (d x)")
    case True
    then show ?thesis
      by (smt (verit, ccfv_threshold) Pair_inject Var1.prems eval_tm1.simps(1)
          fun_upd_other fun_upd_same insert)
  next
    case False
    then show ?thesis
      by (smt (verit) Pair_inject Var1.prems eval_tm1.simps(1) fun_upd_other fun_upd_same)
  qed
next
  case (Func1 x)
  then show ?case
    by simp
next
  case (Lam x1 x2)
  then show ?case
    by (metis eval_tm1.simps(3))
next
  case (Mu1 x1 x2)
  then show ?case sorry (* Proving this case would be similar to the Mu0 case *)
qed

(* Proof that under the assumption that arguments not in the domain of a function are mapped to
   bottom, lapprox only produces domains and variable interpretations that are bigger *)
lemma lapprox_tm0_dom_mono:
  "\<And>\<eta>0 \<eta>1 d \<eta>1' d' val.

      \<lbrakk> (\<And>\<eta>0 \<eta>1 d \<eta>1' d' val. (\<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>)
      \<Longrightarrow> eval_tm0 \<eta>0 \<eta>1 d \<phi> = (val,\<eta>1',d')
      \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)) \<rbrakk>
      \<Longrightarrow>

      \<lbrakk> \<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>;
      lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n = (val,\<eta>1',d') \<rbrakk>
      \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)"
proof (induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then have 0: "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> (Suc n) =
    (let (val, \<eta>1', d') = lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n
        in eval_tm0 (\<eta>0(x := val)) \<eta>1' d' \<phi>)"
    by (metis lapprox_tm0.simps(2))

  have 1: "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n = (val', \<eta>1'', d'')
          \<Longrightarrow> eval_tm0 (\<eta>0(x := val')) \<eta>1'' d'' \<phi> = (val, \<eta>1', d')
          \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x))
            \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)" for \<eta>0 val' \<eta>1'' d''
    by (smt (verit) Suc.IH Suc.prems(1) Suc.prems(2) dual_order.trans
        eval_not_in_dom_still_bot(1) lapprox_tm0_not_in_dom_still_bot)

  with 0 have 2: "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> (Suc n) = (val, \<eta>1', d')
          \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)"
    by (smt (z3) in_mono old.prod.case prod_cases3)

  from 0 1 2 show ?case
    using Suc.prems(3) by fastforce
qed

(* Same property as above but for eval, making use of the previously proven lemma *)
lemma eval_dom_mono:
  "\<And>\<eta>0 \<eta>1 d \<eta>1' d' val.
      \<lbrakk> \<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>;
      eval_tm0 \<eta>0 \<eta>1 d \<phi> = (val,\<eta>1',d') \<rbrakk>
      \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)"

  "\<And>\<eta>0 \<eta>1 d \<eta>1' d' val arg.
      \<lbrakk> \<And>f arg. \<not> (ListMem arg (d f)) \<Longrightarrow> \<eta>1 f arg = \<bottom>;
      eval_tm1 \<eta>0 \<eta>1 d \<phi>' arg = (val,\<eta>1',d') \<rbrakk>
      \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)"
proof (induction \<phi> and \<phi>')
  case (Var0 x)
  then show ?case
    by simp
next
  case (Func0 x)
  then show ?case
    by simp
next
  case (App x1 x2)
  then have 0: "eval_tm0 \<eta>0 \<eta>1 d (App x1 x2) =
    (let (val, \<eta>1', d') = (eval_tm0 \<eta>0 \<eta>1 d x2)
        in (eval_tm1 \<eta>0 \<eta>1' d' x1 val))"
    by simp

  have "eval_tm0 \<eta>0 \<eta>1 d x2 = (val', \<eta>1'', d'')
        \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d'' x))
          \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1'' x f)" for val' \<eta>1'' d''
    using App.IH(2) App.prems(1) by blast

  then have 2: "eval_tm0 \<eta>0 \<eta>1 d x2 = (val', \<eta>1'', d'')
          \<Longrightarrow> eval_tm1 \<eta>0 \<eta>1'' d'' x1 val' = (val, \<eta>1', d')
          \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d' x))
            \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f)" for val' \<eta>1'' d''
    by (smt (verit, ccfv_SIG) App.IH(1) App.prems(1) dual_order.trans
        eval_not_in_dom_still_bot(1))

  have 3: "eval_tm1 \<eta>0 \<eta>1'' d'' x1 val' = (val, \<eta>1', d')
        \<Longrightarrow> eval_tm0 \<eta>0 \<eta>1 d (App x1 x2) = (val, \<eta>1', d')" for val' \<eta>1'' d''
    using App.prems by simp

  from 0 2 3 show ?case
    by (smt (verit) App.prems old.prod.case prod_cases3)
next
  case (Mu0 x1 x2)
  then have 0: "eval_tm0 \<eta>0 \<eta>1 d (Mu0 x1 x2)
              = lapprox_tm0 \<eta>0 \<eta>1 d x2 x1 \<bottom> (card (UNIV::'a::finite_lattice set))"
    by simp

  have "eval_tm0 \<eta>0 \<eta>1 d x2 = (val', \<eta>1'', d'')
          \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d'' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1'' x f)" for val' \<eta>1'' d''
    using Mu0.IH Mu0.prems(1) by blast

  then have 1: "lapprox_tm0 \<eta>0 \<eta>1 d x2 x1 \<bottom> n = (val', \<eta>1'', d'')
          \<Longrightarrow> (\<forall>x. set (d x) \<subseteq> set (d'' x)) \<and> (\<forall>x f. \<eta>1 x f \<le> \<eta>1'' x f)" for val' \<eta>1'' d'' n
    by (smt (verit) Mu0.IH Mu0.prems(1) lapprox_tm0_dom_mono)

  from 0 1 show ?case
    using Mu0.prems by simp
next
  case (Var1 x)
  then have 0: "eval_tm1 \<eta>0 \<eta>1 d (Var1 x) arg = (val, \<eta>1', d')"
    by simp

  have 1: "eval_tm1 \<eta>0 \<eta>1 d (Var1 x) arg = (if ListMem arg (d x)
                then (\<eta>1 x arg, \<eta>1, d)
                else (\<eta>1 x arg, (\<eta>1(x := (\<lambda>z. if z = arg then \<bottom> else (\<eta>1 x) z))), (d(x := Cons arg (d x)))))"
    by simp

  show ?case
  proof (cases "ListMem arg (d x)")
    case True
    then show ?thesis
      using 0 by simp
  next
    case False
    with 0 1 have 2: "\<forall>x. set (d x) \<subseteq> set (d' x)"
      by auto

    have 3: "\<forall>x f. \<eta>1 x f \<le> \<eta>1' x f"
    proof (rule allI, rule allI)
      fix x f
      show "\<eta>1 x f \<le> \<eta>1' x f"
      proof (cases "f = arg")
        case True
        with 1 show ?thesis
          by (smt (verit) Pair_inject Var1.prems dual_order.eq_iff fun_upd_other fun_upd_same)
      next
        case False
        with 0 1 show ?thesis
          by (smt (verit, ccfv_SIG) dual_order.eq_iff fun_upd_other fun_upd_same prod.inject)
      qed
    qed

    from 2 3 show ?thesis by simp
  qed
next
  case (Func1 x)
  then show ?case
    by simp
next
  case (Lam x1 x2)
  then show ?case
    by (metis eval_tm1.simps(3))
next
  case (Mu1 x1 x2)
  then show ?case sorry (* Case follows a similar fashion as the Mu0 case *)
  qed

lemma lapprox_tm0_stays_stable:
  assumes "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n = lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> (Suc n)"
    and "m \<ge> n"
  shows "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> m = lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> n"
  using assms
proof (induction m)
  case 0
  then have "n = 0" by simp

  have "lapprox_tm0 \<eta>0 \<eta>1 d \<phi> x \<bottom> 0 = (\<bottom>, \<eta>1, d)"
    by simp
  with \<open>n = 0\<close> show ?case
    by simp
next
  case (Suc m)
  then show ?case
    by (metis lapprox_tm0.simps(2) le_Suc_eq)
qed

(* Possible theorem statement for a verification proof of eval *)
theorem eval_eq_sem:
"\<And>\<eta>0 \<eta>1 d val \<eta>1' d'.
  \<lbrakk> eval_tm0 \<eta>0 \<eta>1 d \<phi> = (val,\<eta>1',d'); \<eta>1 = \<eta>1'; d = d' \<rbrakk>
    \<Longrightarrow> val = sem_tm0 \<eta>0 (envify \<eta>1 d) \<phi>"

"\<And>\<eta>0 \<eta>1 d val \<eta>1' d'.
  \<lbrakk> eval_tm1 \<eta>0 \<eta>1 d \<phi>' arg = (val,\<eta>1',d'); \<eta>1 = \<eta>1'; d = d' \<rbrakk>
    \<Longrightarrow> val = sem_tm1 \<eta>0 (envify \<eta>1 d) \<phi>' arg"
    sorry

end end


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

A multiple-client allocator from a single-client allocator: Merge
specification.
*)

theory Merge imports AllocBase Follows  Guar GenPrefix begin

(** Merge specification (the number of inputs is Nclients) ***)
(** Parameter A represents the type of items to Merge **)

definition
  (*spec (10)*)
  merge_increasing :: "[i, i, i] \<Rightarrow>i"  where
    "merge_increasing(A, Out, iOut) \<equiv> program guarantees
         (lift(Out) IncreasingWrt  prefix(A)/list(A)) Int
         (lift(iOut) IncreasingWrt prefix(nat)/list(nat))"

definition
  (*spec (11)*)
  merge_eq_Out :: "[i, i] \<Rightarrow>i"  where
  "merge_eq_Out(Out, iOut) \<equiv> program guarantees
         Always({s \<in> state. length(s`Out) = length(s`iOut)})"

definition
  (*spec (12)*)
  merge_bounded :: "i\<Rightarrow>i"  where
  "merge_bounded(iOut) \<equiv> program guarantees
         Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iOut). elt<Nclients})"

definition
  (*spec (13)*)
  (* Parameter A represents the type of tokens *)
  merge_follows :: "[i, i\<Rightarrow>i, i, i] \<Rightarrow>i"  where
    "merge_follows(A, In, Out, iOut) \<equiv>
     (\<Inter>n \<in> Nclients. lift(In(n)) IncreasingWrt prefix(A)/list(A))
                   guarantees
     (\<Inter>n \<in> Nclients.
        (\<lambda>s. sublist(s`Out, {k \<in> nat. k < length(s`iOut) \<and>
                      nth(k, s`iOut) = n})) Fols lift(In(n))
         Wrt prefix(A)/list(A))"

definition
  (*spec: preserves part*)
  merge_preserves :: "[i\<Rightarrow>i] \<Rightarrow>i"  where
    "merge_preserves(In) \<equiv> \<Inter>n \<in> nat. preserves(lift(In(n)))"

definition
(* environmental constraints*)
  merge_allowed_acts :: "[i, i] \<Rightarrow>i"  where
  "merge_allowed_acts(Out, iOut) \<equiv>
         {F \<in> program. AllowedActs(F) =
            cons(id(state), (\<Union>G \<in> preserves(lift(Out)) \<inter>
                                   preserves(lift(iOut)). Acts(G)))}"

definition
  merge_spec :: "[i, i \<Rightarrow>i, i, i]\<Rightarrow>i"  where
  "merge_spec(A, In, Out, iOut) \<equiv>
   merge_increasing(A, Out, iOut) \<inter> merge_eq_Out(Out, iOut) \<inter>
   merge_bounded(iOut) \<inter>  merge_follows(A, In, Out, iOut)
   \<inter> merge_allowed_acts(Out, iOut) \<inter> merge_preserves(In)"

(** State definitions.  OUTPUT variables are locals **)
locale merge =
  fixes In   \<comment> \<open>merge's INPUT histories: streams to merge\<close>
    and Out  \<comment> \<open>merge's OUTPUT history: merged items\<close>
    and iOut \<comment> \<open>merge's OUTPUT history: origins of merged items\<close>
    and A    \<comment> \<open>the type of items being merged\<close>
    and M
 assumes var_assumes [simp]:
           "(\<forall>n. In(n):var) \<and> Out \<in> var \<and> iOut \<in> var"
     and all_distinct_vars:
           "\<forall>n. all_distinct([In(n), Out, iOut])"
     and type_assumes [simp]:
           "(\<forall>n. type_of(In(n))=list(A)) \<and>
            type_of(Out)=list(A) \<and>
            type_of(iOut)=list(nat)"
     and default_val_assumes [simp]:
           "(\<forall>n. default_val(In(n))=Nil) \<and>
            default_val(Out)=Nil \<and>
            default_val(iOut)=Nil"
     and merge_spec:  "M \<in> merge_spec(A, In, Out, iOut)"

lemma (in merge) In_value_type [TC,simp]: "s \<in> state \<Longrightarrow> s`In(n) \<in> list(A)"
  unfolding state_def
apply (drule_tac a = "In (n)" in apply_type)
apply auto
done

lemma (in merge) Out_value_type [TC,simp]: "s \<in> state \<Longrightarrow> s`Out \<in> list(A)"
  unfolding state_def
apply (drule_tac a = Out in apply_type, auto)
done

lemma (in merge) iOut_value_type [TC,simp]: "s \<in> state \<Longrightarrow> s`iOut \<in> list(nat)"
  unfolding state_def
apply (drule_tac a = iOut in apply_type, auto)
done

lemma (in merge) M_in_program [intro,simp]: "M \<in> program"
apply (cut_tac merge_spec)
apply (auto dest: guarantees_type [THEN subsetD]
            simp add: merge_spec_def merge_increasing_def)
done

lemma (in merge) merge_Allowed:
     "Allowed(M) = (preserves(lift(Out)) \<inter> preserves(lift(iOut)))"
apply (insert merge_spec preserves_type [of "lift (Out)"])
apply (auto simp add: merge_spec_def merge_allowed_acts_def Allowed_def safety_prop_Acts_iff)
done

lemma (in merge) M_ok_iff:
     "G \<in> program \<Longrightarrow>
       M ok G \<longleftrightarrow> (G \<in> preserves(lift(Out)) \<and>
                   G \<in> preserves(lift(iOut)) \<and> M \<in> Allowed(G))"
apply (cut_tac merge_spec)
apply (auto simp add: merge_Allowed ok_iff_Allowed)
done

lemma (in merge) merge_Always_Out_eq_iOut:
     "\<lbrakk>G \<in> preserves(lift(Out)); G \<in> preserves(lift(iOut));
         M \<in> Allowed(G)\<rbrakk>
      \<Longrightarrow> M \<squnion> G \<in> Always({s \<in> state. length(s`Out)=length(s`iOut)})"
apply (frule preserves_type [THEN subsetD])
apply (subgoal_tac "G \<in> program")
 prefer 2 apply assumption
apply (frule M_ok_iff)
apply (cut_tac merge_spec)
apply (force dest: guaranteesD simp add: merge_spec_def merge_eq_Out_def)
done

lemma (in merge) merge_Bounded:
     "\<lbrakk>G \<in> preserves(lift(iOut)); G \<in> preserves(lift(Out));
         M \<in> Allowed(G)\<rbrakk> \<Longrightarrow>
       M \<squnion> G: Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iOut). elt<Nclients})"
apply (frule preserves_type [THEN subsetD])
apply (frule M_ok_iff)
apply (cut_tac merge_spec)
apply (force dest: guaranteesD simp add: merge_spec_def merge_bounded_def)
done

lemma (in merge) merge_bag_Follows_lemma:
"\<lbrakk>G \<in> preserves(lift(iOut));
    G: preserves(lift(Out)); M \<in> Allowed(G)\<rbrakk>
  \<Longrightarrow> M \<squnion> G \<in> Always
    ({s \<in> state. msetsum(\<lambda>i. bag_of(sublist(s`Out,
      {k \<in> nat. k < length(s`iOut) \<and> nth(k, s`iOut)=i})),
                   Nclients, A) = bag_of(s`Out)})"
apply (rule Always_Diff_Un_eq [THEN iffD1])
apply (rule_tac [2] state_AlwaysI [THEN Always_weaken])
apply (rule Always_Int_I [OF merge_Always_Out_eq_iOut merge_Bounded], auto)
apply (subst bag_of_sublist_UN_disjoint [symmetric])
apply (auto simp add: nat_into_Finite set_of_list_conv_nth  [OF iOut_value_type])
apply (subgoal_tac " (\<Union>i \<in> Nclients. {k \<in> nat. k < length (x`iOut) \<and> nth (k, x`iOut) = i}) = length (x`iOut) ")
apply (auto simp add: sublist_upt_eq_take [OF Out_value_type]
                      length_type  [OF iOut_value_type]
                      take_all [OF _ Out_value_type]
                      length_type [OF iOut_value_type])
apply (rule equalityI)
apply (blast dest: ltD, clarify)
apply (subgoal_tac "length (x ` iOut) \<in> nat")
 prefer 2 apply (simp add: length_type [OF iOut_value_type])
apply (subgoal_tac "xa \<in> nat")
apply (simp_all add: Ord_mem_iff_lt)
prefer 2 apply (blast intro: lt_trans)
apply (drule_tac x = "nth (xa, x`iOut)" and P = "\<lambda>elt. X (elt) \<longrightarrow> elt<Nclients" for X in bspec)
apply (simp add: ltI nat_into_Ord)
apply (blast dest: ltD)
done

theorem (in merge) merge_bag_Follows:
    "M \<in> (\<Inter>n \<in> Nclients. lift(In(n)) IncreasingWrt prefix(A)/list(A))
            guarantees
      (\<lambda>s. bag_of(s`Out)) Fols
      (\<lambda>s. msetsum(\<lambda>i. bag_of(s`In(i)),Nclients, A)) Wrt MultLe(A, r)/Mult(A)"
apply (cut_tac merge_spec)
apply (rule merge_bag_Follows_lemma [THEN Always_Follows1, THEN guaranteesI])
     apply (simp_all add: M_ok_iff, clarify)
apply (rule Follows_state_ofD1 [OF Follows_msetsum_UN])
   apply (simp_all add: nat_into_Finite bag_of_multiset [of _ A])
apply (simp add: INT_iff merge_spec_def merge_follows_def, clarify)
apply (cut_tac merge_spec)
apply (subgoal_tac "M ok G")
 prefer 2 apply (force intro: M_ok_iff [THEN iffD2])
apply (drule guaranteesD, assumption)
  apply (simp add: merge_spec_def merge_follows_def, blast)
apply (simp cong add: Follows_cong
            add: refl_prefix
               mono_bag_of [THEN subset_Follows_comp, THEN subsetD,
                            unfolded metacomp_def])
done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_propositional_AndImplication
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

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

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 z (nil2) = nil2"
| "models7 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models7 z xs)
        else
        models7 z xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 z (nil2) = nil2"
| "models6 z (cons2 (pair2 y22 True) x2) = models6 z x2"
| "models6 z (cons2 (pair2 y22 False) x2) =
     cons2 (z = y22) (models6 z x2)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 z (nil2) = nil2"
| "models5 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models5 z xs)
        else
        models5 z xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 z (nil2) = nil2"
| "models4 z (cons2 (pair2 y22 True) x2) =
     cons2 (z = y22) (models4 z x2)"
| "models4 z (cons2 (pair2 y22 False) x2) = models4 z x2"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models z q (nil2) = models2 q z"
| "models z q (cons2 z2 x2) = cons2 z2 (models z q x2)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     y (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x2)) y2 =
     (if (~ (or2 (models4 x2 y2))) then
        cons2 (cons2 (pair2 x2 False) (models5 x2 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun valid :: "Form => bool" where
  "valid z =
   (case models3 (Not z) (nil2) of
      nil2 => True
      | cons2 y2 z2 => False)"

theorem property0 :
  "((valid (x p q)) ==> (valid q))"
  oops

end