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

    Copyright (C) 2005, 2006, 2007  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>More on order relations\<close>

theory Order_ZF_1 imports ZF.Order ZF1

begin

text\<open>In \<open>Order_ZF\<close> we define some notions related to order relations
  based on the nonstrict orders ($\leq $ type). Some people however prefer to talk
  about these notions in terms of the strict order relation ($<$ type).
  This is the case for the standard Isabelle \<open>Order.thy\<close> and also for
  Metamath. In this theory file we repeat some developments from \<open>Order_ZF\<close>
  using the strict order relation as a basis.This is mostly useful for Metamath
  translation, but is also of some general interest. The names of theorems are
  copied from Metamath.\<close>

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

text\<open>In this section we introduce some definitions taken from Metamath and relate
  them to the ones used by the standard Isabelle \<open>Order.thy\<close>.
\<close>

text\<open>The next definition is the strict version of the linear order.
  What we write as \<open>R Orders A\<close> is written $R Ord A$ in Metamath.
\<close>

definition
StrictOrder (infix "Orders" 65) where
  "R Orders A \<equiv> \<forall>x y z. (x\<in>A \<and> y\<in>A \<and> z\<in>A) \<longrightarrow>
  (\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)) \<and>
  (\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R)"

text\<open>The definition of supremum for a (strict) linear order.\<close>

definition
  "Sup(B,A,R) \<equiv>
  \<Union> {x \<in> A. (\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and>
  (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> (\<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))}"

text\<open>Definition of infimum for a linear order.
  It is defined in terms of supremum.\<close>

definition
  "Infim(B,A,R) \<equiv> Sup(B,A,converse(R))"

text\<open>If relation $R$ orders a set $A$, (in Metamath sense) then $R$
  is irreflexive, transitive and linear therefore is a total order on $A$
  (in Isabelle sense).\<close>

lemma orders_imp_tot_ord: assumes A1: "R Orders A"
  shows
  "irrefl(A,R)"
  "trans[A](R)"
  "part_ord(A,R)"
  "linear(A,R)"
  "tot_ord(A,R)"
proof -
  from A1 have I:
    "\<forall>x y z. (x\<in>A \<and> y\<in>A \<and> z\<in>A) \<longrightarrow>
    (\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)) \<and>
    (\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R)"
    unfolding StrictOrder_def by simp
  then have "\<forall>x\<in>A. \<langle>x,x\<rangle> \<notin> R" by blast
  then show "irrefl(A,R)" using irrefl_def by simp
  moreover
  from I have
    "\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. \<langle>x,y\<rangle> \<in> R \<longrightarrow> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R"
    by blast
  then show "trans[A](R)" unfolding trans_on_def by blast
  ultimately show "part_ord(A,R)" using part_ord_def
    by simp
  moreover
  from I have
    "\<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle> \<in> R \<or> x=y \<or> \<langle>y,x\<rangle> \<in> R"
    by blast
  then show "linear(A,R)" unfolding linear_def by blast
  ultimately show "tot_ord(A,R)" using tot_ord_def
    by simp
qed

text\<open>A converse of \<open>orders_imp_tot_ord\<close>. Together with that
  theorem this shows that Metamath's notion of an order relation is equivalent to
  Isabelles \<open>tot_ord\<close> predicate.\<close>

lemma tot_ord_imp_orders: assumes A1: "tot_ord(A,R)"
  shows "R Orders A"
proof -
  from A1 have
    I: "linear(A,R)" and
    II: "irrefl(A,R)" and
    III: "trans[A](R)" and
    IV: "part_ord(A,R)"
    using tot_ord_def part_ord_def by auto
  from IV have "asym(R \<inter> A\<times>A)"
    using part_ord_Imp_asym by simp
  then have V: "\<forall>x y. \<langle>x,y\<rangle> \<in> (R \<inter> A\<times>A) \<longrightarrow> \<not>(\<langle>y,x\<rangle> \<in> (R \<inter> A\<times>A))"
    unfolding asym_def by blast
  from I have VI: "\<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle> \<in> R \<or> x=y \<or> \<langle>y,x\<rangle> \<in> R"
    unfolding linear_def by blast
  from III have VII:
    "\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. \<langle>x,y\<rangle> \<in> R \<longrightarrow> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R"
    unfolding trans_on_def by blast
  { fix x y z
    assume T: "x\<in>A" "y\<in>A" "z\<in>A"
    have "\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)"
    proof
      assume A2: "\<langle>x,y\<rangle> \<in> R"
      with V T have  "\<not>(\<langle>y,x\<rangle> \<in> R)" by blast
      moreover from II T A2 have "x\<noteq>y" using irrefl_def
	by auto
      ultimately show "\<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)" by simp
    next assume  "\<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)"
      with VI T show "\<langle>x,y\<rangle> \<in> R" by auto
    qed
    moreover from VII T have
      "\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R"
      by blast
    ultimately have "(\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)) \<and>
      (\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R)"
      by simp
  } then have "\<forall>x y z. (x\<in>A \<and> y\<in>A \<and> z\<in>A) \<longrightarrow>
      (\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)) \<and>
      (\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R)"
    by auto
  then show "R Orders A" using StrictOrder_def by simp
qed

subsection\<open>Properties of (strict) total orders\<close>

text\<open>In this section we discuss the properties of strict order relations.
  This continues the development contained in the standard Isabelle's
  \<open>Order.thy\<close> with a view towards using the theorems
  translated from Metamath.\<close>

text\<open>A relation orders a set iff the converse relation orders a set. Going
  one way we can use the the lemma \<open>tot_od_converse\<close> from the standard
  Isabelle's \<open>Order.thy\<close>.The other way is a bit more complicated (note that
  in Isabelle for \<open>converse(converse(r)) = r\<close> one needs $r$ to consist
  of ordered pairs, which does not follow from the \<open>StrictOrder\<close>
  definition above).\<close>

lemma cnvso: shows "R Orders A \<longleftrightarrow> converse(R) Orders A"
proof
  let ?r = "converse(R)"
  assume "R Orders A"
  then have "tot_ord(A,?r)" using orders_imp_tot_ord tot_ord_converse
    by simp
  then show "?r Orders A" using tot_ord_imp_orders
    by simp
next
  let ?r = "converse(R)"
  assume "?r Orders A"
  then have A2: "\<forall>x y z. (x\<in>A \<and> y\<in>A \<and> z\<in>A) \<longrightarrow>
    (\<langle>x,y\<rangle> \<in> ?r \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> ?r)) \<and>
    (\<langle>x,y\<rangle> \<in> ?r \<and> \<langle>y,z\<rangle> \<in> ?r \<longrightarrow> \<langle>x,z\<rangle> \<in> ?r)"
    using StrictOrder_def by simp
  { fix x y z
    assume "x\<in>A \<and> y\<in>A \<and> z\<in>A"
    with A2 have
      I: "\<langle>y,x\<rangle> \<in> ?r \<longleftrightarrow> \<not>(x=y \<or> \<langle>x,y\<rangle> \<in> ?r)" and
      II: "\<langle>y,x\<rangle> \<in> ?r \<and> \<langle>z,y\<rangle> \<in> ?r \<longrightarrow> \<langle>z,x\<rangle> \<in> ?r"
      by auto
    from I have "\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)"
      by auto
    moreover from II have "\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R"
      by auto
    ultimately have "(\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)) \<and>
      (\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R)" by simp
  } then have  "\<forall>x y z. (x\<in>A \<and> y\<in>A \<and> z\<in>A) \<longrightarrow>
      (\<langle>x,y\<rangle> \<in> R \<longleftrightarrow> \<not>(x=y \<or> \<langle>y,x\<rangle> \<in> R)) \<and>
      (\<langle>x,y\<rangle> \<in> R \<and> \<langle>y,z\<rangle> \<in> R \<longrightarrow> \<langle>x,z\<rangle> \<in> R)"
    by auto
  then show "R Orders A" using StrictOrder_def by simp
qed

text\<open>Supremum is unique, if it exists.\<close>

lemma supeu: assumes A1: "R Orders A" and A2: "x\<in>A" and
  A3: "\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R" and A4: "\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R  \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R)"
   shows
  "\<exists>!x. x\<in>A\<and>(\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
proof
  from A2 A3 A4 show
    "\<exists> x. x\<in>A\<and>(\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
    by auto
next fix x\<^sub>1 x\<^sub>2
  assume A5:
    "x\<^sub>1 \<in> A \<and> (\<forall>y\<in>B. \<langle>x\<^sub>1,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<^sub>1\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
    "x\<^sub>2 \<in> A \<and> (\<forall>y\<in>B. \<langle>x\<^sub>2,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<^sub>2\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
  from A1 have "linear(A,R)" using orders_imp_tot_ord tot_ord_def
    by simp
  then have "\<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle> \<in> R \<or> x=y \<or> \<langle>y,x\<rangle> \<in> R"
    unfolding linear_def by blast
  with A5 have "\<langle>x\<^sub>1,x\<^sub>2\<rangle> \<in> R \<or> x\<^sub>1=x\<^sub>2 \<or> \<langle>x\<^sub>2,x\<^sub>1\<rangle> \<in> R" by blast
  moreover
  { assume "\<langle>x\<^sub>1,x\<^sub>2\<rangle> \<in> R"
    with A5 obtain z where "z\<in>B" and "\<langle>x\<^sub>1,z\<rangle> \<in> R" by auto
    with A5 have False by auto }
  moreover
  { assume "\<langle>x\<^sub>2,x\<^sub>1\<rangle> \<in> R"
    with A5 obtain z where "z\<in>B" and "\<langle>x\<^sub>2,z\<rangle> \<in> R" by auto
    with A5 have False by auto }
  ultimately  show "x\<^sub>1 = x\<^sub>2" by auto
qed

text\<open>Supremum has expected properties if it exists.\<close>

lemma sup_props: assumes A1: "R Orders A" and
  A2: "\<exists>x\<in>A. (\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
  shows
  "Sup(B,A,R) \<in> A"
  "\<forall>y\<in>B. \<langle>Sup(B,A,R),y\<rangle> \<notin> R"
  "\<forall>y\<in>A. \<langle>y,Sup(B,A,R)\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R )"
proof -
  let ?S = "{x\<in>A. (\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R ) ) }"
  from A2 obtain x where
    "x\<in>A" and "(\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R)" and "\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R)"
    by auto
  with A1 have I:
    "\<exists>!x. x\<in>A\<and>(\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
    using supeu by simp
  then have "( \<Union>?S ) \<in> A" by (rule ZF1_1_L9)
  then show "Sup(B,A,R) \<in> A" using Sup_def by simp
  from I have II:
    "(\<forall>y\<in>B. \<langle>\<Union>?S ,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,\<Union>?S\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
    by (rule ZF1_1_L9)
  hence "\<forall>y\<in>B. \<langle>\<Union>?S,y\<rangle> \<notin> R" by blast
  moreover have III: "(\<Union>?S) = Sup(B,A,R)" using Sup_def by simp
  ultimately show "\<forall>y\<in>B. \<langle>Sup(B,A,R),y\<rangle> \<notin> R" by simp
  from II have IV: "\<forall>y\<in>A. \<langle>y,\<Union>?S\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R)"
    by blast
  { fix y assume A3: "y\<in>A" and "\<langle>y,Sup(B,A,R)\<rangle> \<in> R"
    with III have "\<langle>y,\<Union>?S\<rangle> \<in> R" by simp
    with IV A3 have "\<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R" by blast
  } thus  "\<forall>y\<in>A. \<langle>y,Sup(B,A,R)\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R )"
    by simp
qed

text\<open>Elements greater or equal than any element of $B$ are
  greater or equal than supremum of $B$.\<close>

lemma supnub: assumes A1: "R Orders A" and A2:
  "\<exists>x\<in>A. (\<forall>y\<in>B. \<langle>x,y\<rangle> \<notin> R) \<and> (\<forall>y\<in>A. \<langle>y,x\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R))"
  and A3: "c \<in> A" and A4: "\<forall>z\<in>B. \<langle>c,z\<rangle> \<notin> R"
  shows "\<langle>c, Sup(B,A,R)\<rangle> \<notin> R"
proof -
  from A1 A2 have
    "\<forall>y\<in>A. \<langle>y,Sup(B,A,R)\<rangle> \<in> R \<longrightarrow> ( \<exists>z\<in>B. \<langle>y,z\<rangle> \<in> R )"
    by (rule sup_props)
  with A3 A4 show "\<langle>c, Sup(B,A,R)\<rangle> \<notin> R" by auto
qed

end


(*  Title:      Doc/Corec/Corec.thy
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Andreas Lochbihler, ETH Zuerich
    Author:     Andrei Popescu, Middlesex University
    Author:     Dmitriy Traytel, ETH Zuerich

Tutorial for nonprimitively corecursive definitions.
*)

theory Corec
imports Main Datatypes.Setup "HOL-Library.BNF_Corec"
  "HOL-Library.FSet"
begin

section \<open>Introduction
  \label{sec:introduction}\<close>

text \<open>
Isabelle's (co)datatype package \<^cite>\<open>"isabelle-datatypes"\<close> offers a convenient
syntax for introducing codatatypes. For example, the type of (infinite) streams
can be defined as follows (cf. \<^file>\<open>~~/src/HOL/Library/Stream.thy\<close>):
\<close>

    codatatype 'a stream =
      SCons (shd: 'a) (stl: "'a stream")

text \<open>
\noindent
The (co)datatype package also provides two commands, \keyw{primcorec} and
\keyw{prim\-corec\-ur\-sive}, for defining primitively corecursive functions.

This tutorial presents a definitional package for functions beyond
primitive corecursion. It describes @{command corec} and related commands:\
@{command corecursive}, @{command friend_of_corec}, and @{command coinduction_upto}.
It also covers the @{method corec_unique} proof method.
The package is not part of \<^theory>\<open>Main\<close>; it is located in
\<^file>\<open>~~/src/HOL/Library/BNF_Corec.thy\<close>.

The @{command corec} command generalizes \keyw{primcorec} in three main
respects. First, it allows multiple constructors around corecursive calls, where
\keyw{primcorec} expects exactly one. For example:
\<close>

    corec oneTwos :: "nat stream" where
      "oneTwos = SCons 1 (SCons 2 oneTwos)"

text \<open>
Second, @{command corec} allows other functions than constructors to appear in
the corecursive call context (i.e., around any self-calls on the right-hand side
of the equation). The requirement on these functions is that they must be
\emph{friendly}. Intuitively, a function is friendly if it needs to destruct
at most one constructor of input to produce one constructor of output.
We can register functions as friendly using the @{command friend_of_corec}
command, or by passing the \<open>friend\<close> option to @{command corec}. The
friendliness check relies on an internal syntactic check in combination with
a parametricity subgoal, which must be discharged manually (typically using
@{method transfer_prover} or @{method transfer_prover_eq}).

Third, @{command corec} allows self-calls that are not guarded by a constructor,
as long as these calls occur in a friendly context (a context consisting
exclusively of friendly functions) and can be shown to be terminating
(well founded). The mixture of recursive and corecursive calls in a single
function can be quite useful in practice.

Internally, the package synthesizes corecursors that take into account the
possible call contexts. The corecursor is accompanined by a corresponding,
equally general coinduction principle. The corecursor and the coinduction
principle grow in expressiveness as we interact with it. In process algebra
terminology, corecursion and coinduction take place \emph{up to} friendly
contexts.

The package fully adheres to the LCF philosophy \<^cite>\<open>mgordon79\<close>: The
characteristic theorems associated with the specified corecursive functions are
derived rather than introduced axiomatically.
(Exceptionally, most of the internal proof obligations are omitted if the
\<open>quick_and_dirty\<close> option is enabled.)
The package is described in a pair of scientific papers
\<^cite>\<open>"blanchette-et-al-2015-fouco" and "blanchette-et-al-201x-amico"\<close>. Some
of the text and examples below originate from there.

This tutorial is organized as follows:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item Section \ref{sec:introductory-examples}, ``Introductory Examples,''
describes how to specify corecursive functions and to reason about them.

\item Section \ref{sec:command-syntax}, ``Command Syntax,'' describes the syntax
of the commands offered by the package.

\item Section \ref{sec:generated-theorems}, ``Generated Theorems,'' lists the
theorems produced by the package's commands.

\item Section \ref{sec:proof-methods}, ``Proof Methods,'' briefly describes the
@{method corec_unique} and @{method transfer_prover_eq} proof methods.

\item Section \ref{sec:attribute}, ``Attribute,'' briefly describes the
@{attribute friend_of_corec_simps} attribute, which can be used to strengthen
the tactics underlying the @{command friend_of_corec} and @{command corec}
\<open>(friend)\<close> commands.

\item Section \ref{sec:known-bugs-and-limitations}, ``Known Bugs and
Limitations,'' concludes with known open issues.
\end{itemize}

Although it is more powerful than \keyw{primcorec} in many respects,
@{command corec} suffers from a number of limitations. Most notably, it does
not support mutually corecursive codatatypes, and it is less efficient than
\keyw{primcorec} because it needs to dynamically synthesize corecursors and
corresponding coinduction principles to accommodate the friends.

\newbox\boxA
\setbox\boxA=\hbox{\texttt{NOSPAM}}

\newcommand\authoremaili{\texttt{jasmin.blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
gmail.\allowbreak com}}

Comments and bug reports concerning either the package or this tutorial should
be directed to the first author at \authoremaili{} or to the
\texttt{cl-isabelle-users} mailing list.
\<close>

section \<open>Introductory Examples
  \label{sec:introductory-examples}\<close>

text \<open>
The package is illustrated through concrete examples featuring different flavors
of corecursion. More examples can be found in the directory
\<^dir>\<open>~~/src/HOL/Corec_Examples\<close>.
\<close>

subsection \<open>Simple Corecursion
  \label{ssec:simple-corecursion}\<close>

text \<open>
The case studies by Rutten~\<^cite>\<open>rutten05\<close> and Hinze~\<^cite>\<open>hinze10\<close> on stream
calculi serve as our starting point. The following definition of pointwise sum
can be performed with either \keyw{primcorec} or @{command corec}:
\<close>

    primcorec ssum :: "('a :: plus) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
      "ssum xs ys = SCons (shd xs + shd ys) (ssum (stl xs) (stl ys))"

text \<open>
\noindent
Pointwise sum meets the friendliness criterion. We register it as a friend using
the @{command friend_of_corec} command. The command requires us to give a
specification of \<^const>\<open>ssum\<close> where a constructor (\<^const>\<open>SCons\<close>) occurs at
the outermost position on the right-hand side. Here, we can simply reuse the
\keyw{primcorec} specification above:
\<close>

    friend_of_corec ssum :: "('a :: plus) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
      "ssum xs ys = SCons (shd xs + shd ys) (ssum (stl xs) (stl ys))"
       apply (rule ssum.code)
      by transfer_prover

text \<open>
\noindent
The command emits two subgoals. The first subgoal corresponds to the equation we
specified and is trivial to discharge. The second subgoal is a parametricity
property that captures the the requirement that the function may destruct at
most one constructor of input to produce one constructor of output. This subgoal
can usually be discharged using the \<open>transfer_prover\<close> or
@{method transfer_prover_eq} proof method (Section~\ref{ssec:transfer-prover-eq}).
The latter replaces equality relations by their relator terms according to the
@{thm [source] relator_eq} theorem collection before it invokes
@{method transfer_prover}.

After registering \<^const>\<open>ssum\<close> as a friend, we can use it in the corecursive
call context, either inside or outside the constructor guard:
\<close>

    corec fibA :: "nat stream" where
      "fibA = SCons 0 (ssum (SCons 1 fibA) fibA)"

text \<open>\blankline\<close>

    corec fibB :: "nat stream" where
      "fibB = ssum (SCons 0 (SCons 1 fibB)) (SCons 0 fibB)"

text \<open>
Using the \<open>friend\<close> option, we can simultaneously define a function and
register it as a friend:
\<close>

    corec (friend)
      sprod :: "('a :: {plus,times}) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
    where
      "sprod xs ys =
       SCons (shd xs * shd ys) (ssum (sprod xs (stl ys)) (sprod (stl xs) ys))"

text \<open>\blankline\<close>

    corec (friend) sexp :: "nat stream \<Rightarrow> nat stream" where
      "sexp xs = SCons (2 ^^ shd xs) (sprod (stl xs) (sexp xs))"

text \<open>
\noindent
The parametricity subgoal is given to \<open>transfer_prover_eq\<close>
(Section~\ref{ssec:transfer-prover-eq}).

The \<^const>\<open>sprod\<close> and \<^const>\<open>sexp\<close> functions provide shuffle product and
exponentiation on streams. We can use them to define the stream of factorial
numbers in two different ways:
\<close>

    corec factA :: "nat stream" where
      "factA = (let zs = SCons 1 factA in sprod zs zs)"

text \<open>\blankline\<close>

    corec factB :: "nat stream" where
      "factB = sexp (SCons 0 factB)"

text \<open>
The arguments of friendly functions can be of complex types involving the
target codatatype. The following example defines the supremum of a finite set of
streams by primitive corecursion and registers it as friendly:
\<close>

    corec (friend) sfsup :: "nat stream fset \<Rightarrow> nat stream" where
      "sfsup X = SCons (Sup (fset (fimage shd X))) (sfsup (fimage stl X))"

text \<open>
\noindent
In general, the arguments may be any bounded natural functor (BNF)
\<^cite>\<open>"isabelle-datatypes"\<close>, with the restriction that the target codatatype
(\<^typ>\<open>nat stream\<close>) may occur only in a \emph{live} position of the BNF. For
this reason, the following function, on unbounded sets, cannot be registered as
a friend:
\<close>

    primcorec ssup :: "nat stream set \<Rightarrow> nat stream" where
      "ssup X = SCons (Sup (image shd X)) (ssup (image stl X))"

subsection \<open>Nested Corecursion
  \label{ssec:nested-corecursion}\<close>

text \<open>
The package generally supports arbitrary codatatypes with multiple constructors
and nesting through other type constructors (BNFs). Consider the following type
of finitely branching Rose trees of potentially infinite depth:
\<close>

    codatatype 'a tree =
      Node (lab: 'a) (sub: "'a tree list")

text \<open>
We first define the pointwise sum of two trees analogously to \<^const>\<open>ssum\<close>:
\<close>

    corec (friend) tsum :: "('a :: plus) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
      "tsum t u =
       Node (lab t + lab u) (map (\<lambda>(t', u'). tsum t' u') (zip (sub t) (sub u)))"

text \<open>
\noindent
Here, \<^const>\<open>map\<close> is the standard map function on lists, and \<^const>\<open>zip\<close>
converts two parallel lists into a list of pairs. The \<^const>\<open>tsum\<close> function is
primitively corecursive. Instead of @{command corec} \<open>(friend)\<close>, we could
also have used \keyw{primcorec} and @{command friend_of_corec}, as we did for
\<^const>\<open>ssum\<close>.

Once \<^const>\<open>tsum\<close> is registered as friendly, we can use it in the corecursive
call context of another function:
\<close>

    corec (friend) ttimes :: "('a :: {plus,times}) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
      "ttimes t u = Node (lab t * lab u)
         (map (\<lambda>(t', u'). tsum (ttimes t u') (ttimes t' u)) (zip (sub t) (sub u)))"

text \<open>
All the syntactic convenience provided by \keyw{primcorec} is also supported by
@{command corec}, @{command corecursive}, and @{command friend_of_corec}. In
particular, nesting through the function type can be expressed using
\<open>\<lambda>\<close>-abstractions and function applications rather than through composition
(\<^term>\<open>(\<circ>)\<close>, the map function for \<open>\<Rightarrow>\<close>). For example:
\<close>

    codatatype 'a language =
      Lang (\<oo>: bool) (\<dd>: "'a \<Rightarrow> 'a language")

text \<open>\blankline\<close>

    corec (friend) Plus :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Plus r s = Lang (\<oo> r \<or> \<oo> s) (\<lambda>a. Plus (\<dd> r a) (\<dd> s a))"

text \<open>\blankline\<close>

    corec (friend) Times :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Times r s = Lang (\<oo> r \<and> \<oo> s)
         (\<lambda>a. if \<oo> r then Plus (Times (\<dd> r a) s) (\<dd> s a) else Times (\<dd> r a) s)"

text \<open>\blankline\<close>

    corec (friend) Star :: "'a language \<Rightarrow> 'a language" where
      "Star r = Lang True (\<lambda>a. Times (\<dd> r a) (Star r))"

text \<open>\blankline\<close>

    corec (friend) Inter :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Inter r s = Lang (\<oo> r \<and> \<oo> s) (\<lambda>a. Inter (\<dd> r a) (\<dd> s a))"

text \<open>\blankline\<close>

    corec (friend) PLUS :: "'a language list \<Rightarrow> 'a language" where
      "PLUS xs = Lang (\<exists>x \<in> set xs. \<oo> x) (\<lambda>a. PLUS (map (\<lambda>r. \<dd> r a) xs))"

subsection \<open>Mixed Recursion--Corecursion
  \label{ssec:mixed-recursion-corecursion}\<close>

text \<open>
It is often convenient to let a corecursive function perform some finite
computation before producing a constructor. With mixed recursion--corecursion, a
finite number of unguarded recursive calls perform this calculation before
reaching a guarded corecursive call. Intuitively, the unguarded recursive call
can be unfolded to arbitrary finite depth, ultimately yielding a purely
corecursive definition. An example is the \<^term>\<open>primes\<close> function from Di
Gianantonio and Miculan \<^cite>\<open>"di-gianantonio-miculan-2003"\<close>:
\<close>

    corecursive primes :: "nat \<Rightarrow> nat \<Rightarrow> nat stream" where
      "primes m n =
       (if (m = 0 \<and> n > 1) \<or> coprime m n then
          SCons n (primes (m * n) (n + 1))
        else
          primes m (n + 1))"
      apply (relation "measure (\<lambda>(m, n).
        if n = 0 then 1 else if coprime m n then 0 else m - n mod m)")
       apply (auto simp: mod_Suc diff_less_mono2 intro: Suc_lessI elim!: not_coprimeE)
      apply (metis dvd_1_iff_1 dvd_eq_mod_eq_0 mod_0 mod_Suc mod_Suc_eq mod_mod_cancel)
      done

text \<open>
\noindent
The @{command corecursive} command is a variant of @{command corec} that allows
us to specify a termination argument for any unguarded self-call.

When called with \<open>m = 1\<close> and \<open>n = 2\<close>, the \<^const>\<open>primes\<close>
function computes the stream of prime numbers. The unguarded call in the
\<open>else\<close> branch increments \<^term>\<open>n\<close> until it is coprime to the first
argument \<^term>\<open>m\<close> (i.e., the greatest common divisor of \<^term>\<open>m\<close> and
\<^term>\<open>n\<close> is \<open>1\<close>).

For any positive integers \<^term>\<open>m\<close> and \<^term>\<open>n\<close>, the numbers \<^term>\<open>m\<close> and
\<open>m * n + 1\<close> are coprime, yielding an upper bound on the number of times
\<^term>\<open>n\<close> is increased. Hence, the function will take the \<open>else\<close> branch at
most finitely often before taking the then branch and producing one constructor.
There is a slight complication when \<open>m = 0 \<and> n > 1\<close>: Without the first
disjunct in the \<open>if\<close> condition, the function could stall. (This corner
case was overlooked in the original example
\<^cite>\<open>"di-gianantonio-miculan-2003"\<close>.)

In the following examples, termination is discharged automatically by
@{command corec} by invoking @{method lexicographic_order}:
\<close>

    corec catalan :: "nat \<Rightarrow> nat stream" where
      "catalan n =
       (if n > 0 then ssum (catalan (n - 1)) (SCons 0 (catalan (n + 1)))
        else SCons 1 (catalan 1))"

text \<open>\blankline\<close>

    corec collatz :: "nat \<Rightarrow> nat stream" where
      "collatz n = (if even n \<and> n > 0 then collatz (n div 2)
         else SCons n (collatz (3 * n + 1)))"

text \<open>
A more elaborate case study, revolving around the filter function on lazy lists,
is presented in \<^file>\<open>~~/src/HOL/Corec_Examples/LFilter.thy\<close>.
\<close>

subsection \<open>Self-Friendship
  \label{ssec:self-friendship}\<close>

text \<open>
The package allows us to simultaneously define a function and use it as its own
friend, as in the following definition of a ``skewed product'':
\<close>

    corec (friend)
      sskew :: "('a :: {plus,times}) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
    where
      "sskew xs ys =
       SCons (shd xs * shd ys) (sskew (sskew xs (stl ys)) (sskew (stl xs) ys))"

text \<open>
\noindent
Such definitions, with nested self-calls on the right-hand side, cannot be
separated into a @{command corec} part and a @{command friend_of_corec} part.
\<close>

subsection \<open>Coinduction
  \label{ssec:coinduction}\<close>

text \<open>
Once a corecursive specification has been accepted, we normally want to reason
about it. The \<open>codatatype\<close> command generates a structural coinduction
principle that matches primitively corecursive functions. For nonprimitive
specifications, our package provides the more advanced proof principle of
\emph{coinduction up to congruence}---or simply \emph{coinduction up-to}.

The structural coinduction principle for \<^typ>\<open>'a stream\<close>, called
@{thm [source] stream.coinduct}, is as follows:
%
\begin{indentblock}
@{thm stream.coinduct[no_vars]}
\end{indentblock}
%
Coinduction allows us to prove an equality \<open>l = r\<close> on streams by
providing a relation \<open>R\<close> that relates \<open>l\<close> and \<open>r\<close> (first
premise) and that constitutes a bisimulation (second premise). Streams that are
related by a bisimulation cannot be distinguished by taking observations (via
the selectors \<^const>\<open>shd\<close> and \<^const>\<open>stl\<close>); hence they must be equal.

The coinduction up-to principle after registering \<^const>\<open>sskew\<close> as friendly is
available as @{thm [source] sskew.coinduct} and as one of the components of
the theorem collection @{thm [source] stream.coinduct_upto}:
%
\begin{indentblock}
@{thm sskew.coinduct[no_vars]}
\end{indentblock}
%
This rule is almost identical to structural coinduction, except that the
corecursive application of \<^term>\<open>R\<close> is generalized to
\<^term>\<open>stream.v5.congclp R\<close>.

The \<^const>\<open>stream.v5.congclp\<close> predicate is equipped with the following
introduction rules:

\begin{indentblock}
\begin{description}

\item[@{thm [source] sskew.cong_base}\rm:] ~ \\
@{thm sskew.cong_base[no_vars]}

\item[@{thm [source] sskew.cong_refl}\rm:] ~ \\
@{thm sskew.cong_refl[no_vars]}

\item[@{thm [source] sskew.cong_sym}\rm:] ~ \\
@{thm sskew.cong_sym[no_vars]}

\item[@{thm [source] sskew.cong_trans}\rm:] ~ \\
@{thm sskew.cong_trans[no_vars]}

\item[@{thm [source] sskew.cong_SCons}\rm:] ~ \\
@{thm sskew.cong_SCons[no_vars]}

\item[@{thm [source] sskew.cong_ssum}\rm:] ~ \\
@{thm sskew.cong_ssum[no_vars]}

\item[@{thm [source] sskew.cong_sprod}\rm:] ~ \\
@{thm sskew.cong_sprod[no_vars]}

\item[@{thm [source] sskew.cong_sskew}\rm:] ~ \\
@{thm sskew.cong_sskew[no_vars]}

\end{description}
\end{indentblock}
%
The introduction rules are also available as
@{thm [source] sskew.cong_intros}.

Notice that there is no introduction rule corresponding to \<^const>\<open>sexp\<close>,
because \<^const>\<open>sexp\<close> has a more restrictive result type than \<^const>\<open>sskew\<close>
(\<^typ>\<open>nat stream\<close> vs. \<^typ>\<open>('a :: {plus,times}) stream\<close>.

The version numbers, here \<open>v5\<close>, distinguish the different congruence
closures generated for a given codatatype as more friends are registered. As
much as possible, it is recommended to avoid referring to them in proof
documents.

Since the package maintains a set of incomparable corecursors, there is also a
set of associated coinduction principles and a set of sets of introduction
rules. A technically subtle point is to make Isabelle choose the right rules in
most situations. For this purpose, the package maintains the collection
@{thm [source] stream.coinduct_upto} of coinduction principles ordered by
increasing generality, which works well with Isabelle's philosophy of applying
the first rule that matches. For example, after registering \<^const>\<open>ssum\<close> as a
friend, proving the equality \<^term>\<open>l = r\<close> on \<^typ>\<open>nat stream\<close> might
require coinduction principle for \<^term>\<open>nat stream\<close>, which is up to
\<^const>\<open>ssum\<close>.

The collection @{thm [source] stream.coinduct_upto} is guaranteed to be complete
and up to date with respect to the type instances of definitions considered so
far, but occasionally it may be necessary to take the union of two incomparable
coinduction principles. This can be done using the @{command coinduction_upto}
command. Consider the following definitions:
\<close>

    codatatype ('a, 'b) tllist =
      TNil (terminal: 'b)
    | TCons (thd: 'a) (ttl: "('a, 'b) tllist")

text \<open>\blankline\<close>

    corec (friend) square_elems :: "(nat, 'b) tllist \<Rightarrow> (nat, 'b) tllist" where
      "square_elems xs =
       (case xs of
         TNil z \<Rightarrow> TNil z
       | TCons y ys \<Rightarrow> TCons (y ^^ 2) (square_elems ys))"

text \<open>\blankline\<close>

    corec (friend) square_terminal :: "('a, int) tllist \<Rightarrow> ('a, int) tllist" where
      "square_terminal xs =
       (case xs of
         TNil z \<Rightarrow> TNil (z ^^ 2)
       | TCons y ys \<Rightarrow> TCons y (square_terminal ys))"

text \<open>
At this point, @{thm [source] tllist.coinduct_upto} contains three variants of the
coinduction principles:
%
\begin{itemize}
\item \<^typ>\<open>('a, int) tllist\<close> up to \<^const>\<open>TNil\<close>, \<^const>\<open>TCons\<close>, and
  \<^const>\<open>square_terminal\<close>;
\item \<^typ>\<open>(nat, 'b) tllist\<close> up to \<^const>\<open>TNil\<close>, \<^const>\<open>TCons\<close>, and
  \<^const>\<open>square_elems\<close>;
\item \<^typ>\<open>('a, 'b) tllist\<close> up to \<^const>\<open>TNil\<close> and \<^const>\<open>TCons\<close>.
\end{itemize}
%
The following variant is missing:
%
\begin{itemize}
\item \<^typ>\<open>(nat, int) tllist\<close> up to \<^const>\<open>TNil\<close>, \<^const>\<open>TCons\<close>,
  \<^const>\<open>square_elems\<close>, and \<^const>\<open>square_terminal\<close>.
\end{itemize}
%
To generate it without having to define a new function with @{command corec},
we can use the following command:
\<close>

    coinduction_upto nat_int_tllist: "(nat, int) tllist"

text \<open>
\noindent
This produces the theorems
%
\begin{indentblock}
@{thm [source] nat_int_tllist.coinduct_upto} \\
@{thm [source] nat_int_tllist.cong_intros}
\end{indentblock}
%
(as well as the individually named introduction rules) and extends
the dynamic collections @{thm [source] tllist.coinduct_upto} and
@{thm [source] tllist.cong_intros}.
\<close>

subsection \<open>Uniqueness Reasoning
  \label{ssec:uniqueness-reasoning}\<close>

text \<open>
It is sometimes possible to achieve better automation by using a more
specialized proof method than coinduction. Uniqueness principles maintain a good
balance between expressiveness and automation. They exploit the property that a
corecursive definition is the unique solution to a fixpoint equation.

The @{command corec}, @{command corecursive}, and @{command friend_of_corec}
commands generate a property \<open>f.unique\<close> about the function of interest
\<^term>\<open>f\<close> that can be used to prove that any function that satisfies
\<^term>\<open>f\<close>'s corecursive specification must be equal to~\<^term>\<open>f\<close>. For example:
\[@{thm ssum.unique[no_vars]}\]

The uniqueness principles are not restricted to functions defined using
@{command corec} or @{command corecursive} or registered with
@{command friend_of_corec}. Suppose \<^term>\<open>t x\<close> is an arbitrary term
depending on \<^term>\<open>x\<close>. The @{method corec_unique} proof method, provided by our
tool, transforms subgoals of the form
\[\<^term>\<open>(\<forall>x. f x = H x f) \<Longrightarrow> f x = t x\<close>\]
into
\[\<^term>\<open>\<forall>x. t x = H x t\<close>\]
The higher-order functional \<^term>\<open>H\<close> must be such that \<^term>\<open>f x = H x f\<close>
would be a valid @{command corec} specification, but without nested self-calls
or unguarded (recursive) calls. Thus, @{method corec_unique} proves uniqueness
of \<^term>\<open>t\<close> with respect to the given corecursive equation regardless of how
\<^term>\<open>t\<close> was defined. For example:
\<close>

    lemma
      fixes f :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream"
      assumes "\<forall>xs ys. f xs ys =
        SCons (shd ys * shd xs) (ssum (f xs (stl ys)) (f (stl xs) ys))"
      shows "f = sprod"
        using assms
      proof corec_unique
        show "sprod = (\<lambda>xs ys :: nat stream.
            SCons (shd ys * shd xs) (ssum (sprod xs (stl ys)) (sprod (stl xs) ys)))"
          apply (rule ext)+
          apply (subst sprod.code)
          by simp
      qed

text \<open>
The proof method relies on some theorems generated by the package. If no function
over a given codatatype has been defined using @{command corec} or
@{command corecursive} or registered as friendly using @{command friend_of_corec},
the theorems will not be available yet. In such cases, the theorems can be
explicitly generated using the command
\<close>

    coinduction_upto stream: "'a stream"

section \<open>Command Syntax
  \label{sec:command-syntax}\<close>

subsection \<open>\keyw{corec} and \keyw{corecursive}
  \label{ssec:corec-and-corecursive-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "corec"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
  @{command_def "corecursive"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
\end{matharray}

\<^rail>\<open>
  (@@{command corec} | @@{command corecursive}) target? \<newline>
    @{syntax cr_options}? fix @'where' prop
  ;
  @{syntax_def cr_options}: '(' ((@{syntax plugins} | 'friend' | 'transfer') + ',') ')'
\<close>

\medskip

\noindent
The @{command corec} and @{command corecursive} commands introduce a corecursive
function over a codatatype.

The syntactic entity \synt{target} can be used to specify a local context,
\synt{fix} denotes name with an optional type signature, and \synt{prop} denotes
a HOL proposition \<^cite>\<open>"isabelle-isar-ref"\<close>.

The optional target is optionally followed by a combination of the following
options:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item
The \<open>plugins\<close> option indicates which plugins should be enabled
(\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.

\item
The \<open>friend\<close> option indicates that the defined function should be
registered as a friend. This gives rise to additional proof obligations.

\item
The \<open>transfer\<close> option indicates that an unconditional transfer rule
should be generated and proved \<open>by transfer_prover\<close>. The
\<open>[transfer_rule]\<close> attribute is set on the generated theorem.
\end{itemize}

The @{command corec} command is an abbreviation for @{command corecursive}
with appropriate applications of @{method transfer_prover_eq}
(Section~\ref{ssec:transfer-prover-eq}) and @{method lexicographic_order} to
discharge any emerging proof obligations.
\<close>

subsection \<open>\keyw{friend_of_corec}
  \label{ssec:friend-of-corec-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "friend_of_corec"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
\end{matharray}

\<^rail>\<open>
  @@{command friend_of_corec} target? \<newline>
    @{syntax foc_options}? fix @'where' prop
  ;
  @{syntax_def foc_options}: '(' ((@{syntax plugins} | 'transfer') + ',') ')'
\<close>

\medskip

\noindent
The @{command friend_of_corec} command registers a corecursive function as
friendly.

The syntactic entity \synt{target} can be used to specify a local context,
\synt{fix} denotes name with an optional type signature, and \synt{prop} denotes
a HOL proposition \<^cite>\<open>"isabelle-isar-ref"\<close>.

The optional target is optionally followed by a combination of the following
options:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item
The \<open>plugins\<close> option indicates which plugins should be enabled
(\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.

\item
The \<open>transfer\<close> option indicates that an unconditional transfer rule
should be generated and proved \<open>by transfer_prover\<close>. The
\<open>[transfer_rule]\<close> attribute is set on the generated theorem.
\end{itemize}
\<close>

subsection \<open>\keyw{coinduction_upto}
  \label{ssec:coinduction-upto-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "coinduction_upto"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
\end{matharray}

\<^rail>\<open>
  @@{command coinduction_upto} target? name ':' type
\<close>

\medskip

\noindent
The @{command coinduction_upto} generates a coinduction up-to rule for a given
instance of a (possibly polymorphic) codatatype and notes the result with the
specified prefix.

The syntactic entity \synt{name} denotes an identifier and \synt{type} denotes a
type \<^cite>\<open>"isabelle-isar-ref"\<close>.
\<close>

section \<open>Generated Theorems
  \label{sec:generated-theorems}\<close>

text \<open>
The full list of named theorems generated by the package can be obtained by
issuing the command \keyw{print_theorems} immediately after the datatype definition.
This list excludes low-level theorems that reveal internal constructions. To
make these accessible, add the line
\<close>

    declare [[bnf_internals]]
(*<*)
    declare [[bnf_internals = false]]
(*>*)

text \<open>
In addition to the theorem listed below for each command provided by the
package, all commands update the dynamic theorem collections

\begin{indentblock}
\begin{description}

\item[\<open>t.\<close>\hthm{coinduct_upto}]

\item[\<open>t.\<close>\hthm{cong_intros}]

\end{description}
\end{indentblock}
%
for the corresponding codatatype \<open>t\<close> so that they always contain the most
powerful coinduction up-to principles derived so far.
\<close>

subsection \<open>\keyw{corec} and \keyw{corecursive}
  \label{ssec:corec-and-corecursive-theorems}\<close>

text \<open>
For a function \<^term>\<open>f\<close> over codatatype \<open>t\<close>, the @{command corec} and
@{command corecursive} commands generate the following properties (listed for
\<^const>\<open>sexp\<close>, cf. Section~\ref{ssec:simple-corecursion}):

\begin{indentblock}
\begin{description}

\item[\<open>f.\<close>\hthm{code} \<open>[code]\<close>\rm:] ~ \\
@{thm sexp.code[no_vars]} \\
The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
\<^cite>\<open>"isabelle-datatypes"\<close>.

\item[\<open>f.\<close>\hthm{coinduct} \<open>[consumes 1, case_names t, case_conclusion D\<^sub>1 \<dots>
  D\<^sub>n]\<close>\rm:] ~ \\
@{thm sexp.coinduct[no_vars]}

\item[\<open>f.\<close>\hthm{cong_intros}\rm:] ~ \\
@{thm sexp.cong_intros[no_vars]}

\item[\<open>f.\<close>\hthm{unique}\rm:] ~ \\
@{thm sexp.unique[no_vars]} \\
This property is not generated for mixed recursive--corecursive definitions.

\item[\<open>f.\<close>\hthm{inner_induct}\rm:] ~ \\
This property is only generated for mixed recursive--corecursive definitions.
For \<^const>\<open>primes\<close> (Section~\ref{ssec:mixed-recursion-corecursion}, it reads as
follows: \\[\jot]
@{thm primes.inner_induct[no_vars]}

\end{description}
\end{indentblock}

\noindent
The individual rules making up \<open>f.cong_intros\<close> are available as

\begin{indentblock}
\begin{description}

\item[\<open>f.\<close>\hthm{cong_base}]

\item[\<open>f.\<close>\hthm{cong_refl}]

\item[\<open>f.\<close>\hthm{cong_sym}]

\item[\<open>f.\<close>\hthm{cong_trans}]

\item[\<open>f.\<close>\hthm{cong_C}\<open>\<^sub>1\<close>, \ldots, \<open>f.\<close>\hthm{cong_C}\<open>\<^sub>n\<close>] ~ \\
where \<open>C\<^sub>1\<close>, \<open>\<dots>\<close>, \<open>C\<^sub>n\<close> are \<open>t\<close>'s
constructors

\item[\<open>f.\<close>\hthm{cong_f}\<open>\<^sub>1\<close>, \ldots, \<open>f.\<close>\hthm{cong_f}\<open>\<^sub>m\<close>] ~ \\
where \<open>f\<^sub>1\<close>, \<open>\<dots>\<close>, \<open>f\<^sub>m\<close> are the available
friends for \<open>t\<close>

\end{description}
\end{indentblock}
\<close>

subsection \<open>\keyw{friend_of_corec}
  \label{ssec:friend-of-corec-theorems}\<close>

text \<open>
The @{command friend_of_corec} command generates the same theorems as
@{command corec} and @{command corecursive}, except that it adds an optional
\<open>friend.\<close> component to the names to prevent potential clashes (e.g.,
\<open>f.friend.code\<close>).
\<close>

subsection \<open>\keyw{coinduction_upto}
  \label{ssec:coinduction-upto-theorems}\<close>

text \<open>
The @{command coinduction_upto} command generates the following properties
(listed for \<open>nat_int_tllist\<close>):

\begin{indentblock}
\begin{description}

\item[\begin{tabular}{@ {}l@ {}}
  \<open>t.\<close>\hthm{coinduct_upto} \<open>[consumes 1, case_names t,\<close> \\
  \phantom{\<open>t.\<close>\hthm{coinduct_upto} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
  D\<^sub>n]\<close>\rm:
\end{tabular}] ~ \\
@{thm nat_int_tllist.coinduct_upto[no_vars]}

\item[\<open>t.\<close>\hthm{cong_intros}\rm:] ~ \\
@{thm nat_int_tllist.cong_intros[no_vars]}

\end{description}
\end{indentblock}

\noindent
The individual rules making up \<open>t.cong_intros\<close> are available
separately as \<open>t.cong_base\<close>, \<open>t.cong_refl\<close>, etc.\
(Section~\ref{ssec:corec-and-corecursive-theorems}).
\<close>

section \<open>Proof Methods
  \label{sec:proof-methods}\<close>

subsection \<open>\textit{corec_unique}
  \label{ssec:corec-unique}\<close>

text \<open>
The @{method corec_unique} proof method can be used to prove the uniqueness of
a corecursive specification. See Section~\ref{ssec:uniqueness-reasoning} for
details.
\<close>

subsection \<open>\textit{transfer_prover_eq}
  \label{ssec:transfer-prover-eq}\<close>

text \<open>
The @{method transfer_prover_eq} proof method replaces the equality relation
\<^term>\<open>(=)\<close> with compound relator expressions according to
@{thm [source] relator_eq} before calling @{method transfer_prover} on the
current subgoal. It tends to work better than plain @{method transfer_prover} on
the parametricity proof obligations of @{command corecursive} and
@{command friend_of_corec}, because they often contain equality relations on
complex types, which @{method transfer_prover} cannot reason about.
\<close>

section \<open>Attribute
  \label{sec:attribute}\<close>

subsection \<open>\textit{friend_of_corec_simps}
  \label{ssec:friend-of-corec-simps}\<close>

text \<open>
The @{attribute friend_of_corec_simps} attribute declares naturality theorems
to be used by @{command friend_of_corec} and @{command corec} \<open>(friend)\<close> in
deriving the user specification from reduction to primitive corecursion.
Internally, these commands derive naturality theorems from the parametricity proof
obligations dischared by the user or the @{method transfer_prover_eq} method, but
this derivation fails if in the arguments of a higher-order constant a type variable
occurs on both sides of the function type constructor. The required naturality
theorem can then be declared with @{attribute friend_of_corec_simps}. See
\<^file>\<open>~~/src/HOL/Corec_Examples/Tests/Iterate_GPV.thy\<close> for an example.
\<close>

section \<open>Known Bugs and Limitations
  \label{sec:known-bugs-and-limitations}\<close>

text \<open>
This section lists the known bugs and limitations of the corecursion package at
the time of this writing.

\begin{enumerate}
\setlength{\itemsep}{0pt}

\item
\emph{Mutually corecursive codatatypes are not supported.}

\item
\emph{The signature of friend functions may not depend on type variables beyond
those that appear in the codatatype.}

\item
\emph{The internal tactics may fail on legal inputs.}
In some cases, this limitation can be circumvented using the
@{attribute friend_of_corec_simps} attribute
(Section~\ref{ssec:friend-of-corec-simps}).

\item
\emph{The \<open>transfer\<close> option is not implemented yet.}

\item
\emph{The constructor and destructor views offered by {\upshape\keyw{primcorec}}
are not supported by @{command corec} and @{command corecursive}.}

\item
\emph{There is no mechanism for registering custom plugins.}

\item
\emph{The package does not interact well with locales.}

\item
\emph{The undocumented \<open>corecUU_transfer\<close> theorem is not as polymorphic as
it could be.}

\item
\emph{All type variables occurring in the arguments of a friendly function must occur
as direct arguments of the type constructor of the resulting type.}

\end{enumerate}
\<close>

end


(*  Title:       OInvariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Open reachability and invariance"

theory OInvariants
imports Invariants
begin

subsection "Open reachability"

text \<open>
  By convention, the states of an open automaton are pairs. The first component is considered
  to be the global state and the second is the local state.

  A state is `open reachable' under @{term S} and @{term U} if it is the initial state, or it
  is the destination of a transition---where the global components satisfy @{term S}---from an
  open reachable state, or it is the destination of an interleaved environment step where the
  global components satisfy @{term U}.
\<close>

inductive_set oreachable
  :: "('g \<times> 'l, 'a) automaton
      \<Rightarrow> ('g \<Rightarrow> 'g \<Rightarrow> 'a \<Rightarrow> bool)
      \<Rightarrow> ('g \<Rightarrow> 'g \<Rightarrow> bool)
      \<Rightarrow> ('g \<times> 'l) set"
  for A  :: "('g \<times> 'l, 'a) automaton"
  and S  :: "'g \<Rightarrow> 'g \<Rightarrow> 'a \<Rightarrow> bool"
  and U  :: "'g \<Rightarrow> 'g \<Rightarrow> bool"
where
    oreachable_init: "s \<in> init A \<Longrightarrow> s \<in> oreachable A S U"
  | oreachable_local: "\<lbrakk> s \<in> oreachable A S U; (s, a, s') \<in> trans A; S (fst s) (fst s') a \<rbrakk>
                        \<Longrightarrow> s' \<in> oreachable A S U"
  | oreachable_other: "\<lbrakk> s \<in> oreachable A S U; U (fst s) \<sigma>' \<rbrakk>
                        \<Longrightarrow> (\<sigma>', snd s) \<in> oreachable A S U"

lemma oreachable_local' [elim]:
  assumes "(\<sigma>, p) \<in> oreachable A S U"
      and "((\<sigma>, p), a, (\<sigma>', p')) \<in> trans A"
      and "S \<sigma> \<sigma>' a"
    shows "(\<sigma>', p') \<in> oreachable A S U"
  using assms by (metis fst_conv oreachable.oreachable_local)

lemma oreachable_other' [elim]:
  assumes "(\<sigma>, p) \<in> oreachable A S U"
      and "U \<sigma> \<sigma>'"
    shows "(\<sigma>', p) \<in> oreachable A S U"
  proof -
    from \<open>U \<sigma> \<sigma>'\<close> have "U (fst (\<sigma>, p)) \<sigma>'" by simp
    with \<open>(\<sigma>, p) \<in> oreachable A S U\<close> have "(\<sigma>', snd (\<sigma>, p)) \<in> oreachable A S U"
      by (rule oreachable_other)
    thus "(\<sigma>', p) \<in> oreachable A S U" by simp
  qed

lemma oreachable_pair_induct [consumes, case_names init other local]:
  assumes "(\<sigma>, p) \<in> oreachable A S U"
      and "\<And>\<sigma> p. (\<sigma>, p) \<in> init A \<Longrightarrow> P \<sigma> p"
      and "(\<And>\<sigma> p \<sigma>'. \<lbrakk> (\<sigma>, p) \<in> oreachable A S U; P \<sigma> p; U \<sigma> \<sigma>' \<rbrakk> \<Longrightarrow> P \<sigma>' p)"
      and "(\<And>\<sigma> p \<sigma>' p' a. \<lbrakk> (\<sigma>, p) \<in> oreachable A S U; P \<sigma> p;
                            ((\<sigma>, p), a, (\<sigma>', p')) \<in> trans A; S \<sigma> \<sigma>' a \<rbrakk> \<Longrightarrow> P \<sigma>' p')"
    shows "P \<sigma> p"
  using assms (1) proof (induction "(\<sigma>, p)" arbitrary: \<sigma> p)
    fix \<sigma> p
    assume "(\<sigma>, p) \<in> init A"
    with assms(2) show "P \<sigma> p" .
  next
    fix s \<sigma>'
    assume "s \<in> oreachable A S U"
       and "U (fst s) \<sigma>'"
       and IH: "\<And>\<sigma> p. s = (\<sigma>, p) \<Longrightarrow> P \<sigma> p"
    from this(1) obtain \<sigma> p where "s = (\<sigma>, p)"
                              and "(\<sigma>, p) \<in> oreachable A S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from IH and \<open>s = (\<sigma>, p)\<close> have "P \<sigma> p" .
    moreover from \<open>U (fst s) \<sigma>'\<close> and \<open>s = (\<sigma>, p)\<close> have "U \<sigma> \<sigma>'" by simp
    ultimately have "P \<sigma>' p" by (rule assms(3))
    with \<open>s = (\<sigma>, p)\<close> show "P \<sigma>' (snd s)" by simp
  next
    fix s a \<sigma>' p'
    assume "s \<in> oreachable A S U"
       and tr: "(s, a, (\<sigma>', p')) \<in> trans A"
       and "S (fst s) (fst (\<sigma>', p')) a"
       and IH: "\<And>\<sigma> p. s = (\<sigma>, p) \<Longrightarrow> P \<sigma> p"
    from this(1) obtain \<sigma> p where "s = (\<sigma>, p)"
                              and "(\<sigma>, p) \<in> oreachable A S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from IH \<open>s = (\<sigma>, p)\<close> have "P \<sigma> p" .
    moreover from tr and \<open>s = (\<sigma>, p)\<close> have "((\<sigma>, p), a, (\<sigma>', p')) \<in> trans A" by simp
    moreover from \<open>S (fst s) (fst (\<sigma>', p')) a\<close> and \<open>s = (\<sigma>, p)\<close> have "S \<sigma> \<sigma>' a" by simp
    ultimately show "P \<sigma>' p'" by (rule assms(4))
  qed

lemma oreachable_weakenE [elim]:
  assumes "s \<in> oreachable A PS PU"
      and PSQS: "\<And>s s' a. PS s s' a \<Longrightarrow> QS s s' a"
      and PUQU: "\<And>s s'.   PU s s'   \<Longrightarrow> QU s s'"
    shows "s \<in> oreachable A QS QU"
  using assms(1)
  proof (induction)
    fix s assume "s \<in> init A"
    thus "s \<in> oreachable A QS QU" ..
  next
    fix s a s'
    assume "s \<in> oreachable A QS QU"
       and "(s, a, s') \<in> trans A"
       and "PS (fst s) (fst s') a"
    from \<open>PS (fst s) (fst s') a\<close> have "QS (fst s) (fst s') a" by (rule PSQS)
    with \<open>s \<in> oreachable A QS QU\<close> and \<open>(s, a, s') \<in> trans A\<close> show "s' \<in> oreachable A QS QU" ..
  next
    fix s g'
    assume "s \<in> oreachable A QS QU"
       and "PU (fst s) g'"
    from \<open>PU (fst s) g'\<close> have "QU (fst s) g'" by (rule PUQU)
    with \<open>s \<in> oreachable A QS QU\<close> show "(g', snd s) \<in> oreachable A QS QU" ..
  qed

definition
  act :: "('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> 'a \<Rightarrow> bool"
where
  "act I \<equiv> (\<lambda>_ _. I)"

lemma act_simp [iff]: "act I s s' a = I a"
  unfolding act_def ..

lemma reachable_in_oreachable [elim]:
    fixes s
  assumes "s \<in> reachable A I"
    shows "s \<in> oreachable A (act I) U"
  unfolding act_def using assms proof induction
    fix s
    assume "s \<in> init A"
    thus "s \<in> oreachable A (\<lambda>_ _. I) U" ..
  next
    fix s a s'
    assume "s \<in> oreachable A (\<lambda>_ _. I) U"
       and "(s, a, s') \<in> trans A"
       and "I a"
    thus "s' \<in> oreachable A (\<lambda>_ _. I) U"
      by (rule oreachable_local)
  qed

subsection "Open Invariance"

definition oinvariant
  :: "('g \<times> 'l, 'a) automaton
      \<Rightarrow> ('g \<Rightarrow> 'g \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('g \<Rightarrow> 'g \<Rightarrow> bool)
      \<Rightarrow> (('g \<times> 'l) \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<Turnstile> (1'((1_),/ (1_) \<rightarrow>')/ _)" [100, 0, 0, 9] 8)
where
  "(A \<Turnstile> (S, U \<rightarrow>) P) = (\<forall>s\<in>oreachable A S U. P s)"

lemma oinvariantI [intro]:
    fixes T TI S U P
  assumes init: "\<And>s. s \<in> init A \<Longrightarrow> P s"
      and other: "\<And>g g' l.
                  \<lbrakk> (g, l) \<in> oreachable A S U; P (g, l); U g g' \<rbrakk> \<Longrightarrow> P (g', l)"
      and local: "\<And>s a s'.
                  \<lbrakk> s \<in> oreachable A S U; P s; (s, a, s') \<in> trans A; S (fst s) (fst s') a \<rbrakk> \<Longrightarrow> P s'"
    shows "A \<Turnstile> (S, U \<rightarrow>) P"
  unfolding oinvariant_def
  proof
       fix s
    assume "s \<in> oreachable A S U"
      thus "P s"
    proof induction
      fix s assume "s \<in> init A"
      thus "P s" by (rule init)
    next
      fix s a s'
      assume "s \<in> oreachable A S U"
         and "P s"
         and "(s, a, s') \<in> trans A"
         and "S (fst s) (fst s') a"
        thus "P s'" by (rule local)
     next
       fix s g'
       assume "s \<in> oreachable A S U"
          and "P s"
          and "U (fst s) g'"
         thus "P (g', snd s)"
           by - (rule other [where g="fst s"], simp_all)
    qed
  qed

lemma oinvariant_oreachableI:
  assumes "\<And>\<sigma> s. (\<sigma>, s)\<in>oreachable A S U \<Longrightarrow> P (\<sigma>, s)"
  shows "A \<Turnstile> (S, U \<rightarrow>) P"
  using assms unfolding oinvariant_def by auto

lemma oinvariant_pairI [intro]:
  assumes init: "\<And>\<sigma> p. (\<sigma>, p) \<in> init A \<Longrightarrow> P (\<sigma>, p)"
      and local: "\<And>\<sigma> p \<sigma>' p' a.
                   \<lbrakk> (\<sigma>, p) \<in> oreachable A S U; P (\<sigma>, p); ((\<sigma>, p), a, (\<sigma>', p')) \<in> trans A;
                     S \<sigma> \<sigma>' a \<rbrakk> \<Longrightarrow> P (\<sigma>', p')"
      and other: "\<And>\<sigma> \<sigma>' p.
                  \<lbrakk> (\<sigma>, p) \<in> oreachable A S U; P (\<sigma>, p); U \<sigma> \<sigma>' \<rbrakk> \<Longrightarrow> P (\<sigma>', p)"
    shows "A \<Turnstile> (S, U \<rightarrow>) P"
  by (rule oinvariantI)
     (clarsimp | erule init | erule(3) local | erule(2) other)+

lemma oinvariantD [dest]:
  assumes "A \<Turnstile> (S, U \<rightarrow>) P"
      and "s \<in> oreachable A S U"
    shows "P s"
  using assms unfolding oinvariant_def
  by clarsimp

lemma oinvariant_initD [dest, elim]:
  assumes invP: "A \<Turnstile> (S, U \<rightarrow>) P"
      and init: "s \<in> init A"
    shows "P s"
  proof -
    from init have "s \<in> oreachable A S U" ..
    with invP show ?thesis ..
  qed

lemma oinvariant_weakenE [elim!]:
  assumes invP: "A \<Turnstile> (PS, PU \<rightarrow>) P"
      and PQ:   "\<And>s. P s \<Longrightarrow> Q s"
      and QSPS: "\<And>s s' a. QS s s' a \<Longrightarrow> PS s s' a"
      and QUPU: "\<And>s s'.   QU s s'   \<Longrightarrow> PU s s'"
    shows       "A \<Turnstile> (QS, QU \<rightarrow>) Q"
  proof
    fix s
    assume "s \<in> init A"
    with invP have "P s" ..
    thus "Q s" by (rule PQ)
  next
    fix \<sigma> p \<sigma>' p' a
    assume "(\<sigma>, p) \<in> oreachable A QS QU"
       and "((\<sigma>, p), a, (\<sigma>', p')) \<in> trans A"
       and "QS \<sigma> \<sigma>' a"
    from this(3) have "PS \<sigma> \<sigma>' a" by (rule QSPS)
    from \<open>(\<sigma>, p) \<in> oreachable A QS QU\<close> and QSPS QUPU have "(\<sigma>, p) \<in> oreachable A PS PU" ..
    hence "(\<sigma>', p') \<in> oreachable A PS PU" using \<open>((\<sigma>, p), a, (\<sigma>', p')) \<in> trans A\<close> and \<open>PS \<sigma> \<sigma>' a\<close> ..
    with invP have "P (\<sigma>', p')" ..
    thus "Q (\<sigma>', p')" by (rule PQ)
  next
    fix \<sigma> \<sigma>' p
    assume "(\<sigma>, p) \<in> oreachable A QS QU"
       and "Q (\<sigma>, p)"
       and "QU \<sigma> \<sigma>'"
    from \<open>QU \<sigma> \<sigma>'\<close> have "PU \<sigma> \<sigma>'" by (rule QUPU)
    from \<open>(\<sigma>, p) \<in> oreachable A QS QU\<close> and QSPS QUPU have "(\<sigma>, p) \<in> oreachable A PS PU" ..
    hence "(\<sigma>', p) \<in> oreachable A PS PU" using \<open>PU \<sigma> \<sigma>'\<close> ..
    with invP have "P (\<sigma>', p)" ..
    thus "Q (\<sigma>', p)" by (rule PQ)
  qed

lemma oinvariant_weakenD [dest]:
  assumes "A \<Turnstile> (S', U' \<rightarrow>) P"
      and "(\<sigma>, p) \<in> oreachable A S U"
      and weakenS: "\<And>s s' a. S s s' a \<Longrightarrow> S' s s' a"
      and weakenU: "\<And>s s'. U s s' \<Longrightarrow> U' s s'"
    shows "P (\<sigma>, p)"
  proof -
    from \<open>(\<sigma>, p) \<in> oreachable A S U\<close> have "(\<sigma>, p) \<in> oreachable A S' U'"
      by (rule oreachable_weakenE)
         (erule weakenS, erule weakenU)
    with \<open>A \<Turnstile> (S', U' \<rightarrow>) P\<close> show "P (\<sigma>, p)" ..
  qed

lemma close_open_invariant:
  assumes oinv: "A \<Turnstile> (act I, U \<rightarrow>) P"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  proof
    fix s
    assume "s \<in> init A"
    with oinv show "P s" ..
  next
    fix \<xi> p \<xi>' p' a
    assume sr: "(\<xi>, p) \<in> reachable A I"
       and step: "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    hence "(\<xi>', p') \<in> reachable A I" ..
    hence "(\<xi>', p') \<in> oreachable A (act I) U" ..
    with oinv show "P (\<xi>', p')" ..
  qed

definition local_steps :: "((('i \<Rightarrow> 's1) \<times> 'l1) \<times> 'a \<times> ('i \<Rightarrow> 's2) \<times> 'l2) set \<Rightarrow> 'i set \<Rightarrow> bool"
where "local_steps T J \<equiv>
   (\<forall>\<sigma> \<zeta> s a \<sigma>' s'. ((\<sigma>, s), a, (\<sigma>', s')) \<in> T \<and> (\<forall>j\<in>J. \<zeta> j = \<sigma> j)
   \<longrightarrow> (\<exists>\<zeta>'. (\<forall>j\<in>J. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, s), a, (\<zeta>', s')) \<in> T))"

lemma local_stepsI [intro!]:
  assumes "\<And>\<sigma> \<zeta> s a \<sigma>' \<zeta>' s'. \<lbrakk> ((\<sigma>, s), a, (\<sigma>', s')) \<in> T; \<forall>j\<in>J. \<zeta> j = \<sigma> j \<rbrakk>
                               \<Longrightarrow> (\<exists>\<zeta>'. (\<forall>j\<in>J. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, s), a, (\<zeta>', s')) \<in> T)"
    shows "local_steps T J"
  unfolding local_steps_def using assms by clarsimp

lemma local_stepsE [elim, dest]:
  assumes "local_steps T J"
      and "((\<sigma>, s), a, (\<sigma>', s')) \<in> T"
      and "\<forall>j\<in>J. \<zeta> j = \<sigma> j"
    shows "\<exists>\<zeta>'. (\<forall>j\<in>J. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, s), a, (\<zeta>', s')) \<in> T"
  using assms unfolding local_steps_def by blast

definition other_steps :: "(('i \<Rightarrow> 's) \<Rightarrow> ('i \<Rightarrow> 's) \<Rightarrow> bool) \<Rightarrow> 'i set \<Rightarrow> bool"
where "other_steps U J \<equiv> \<forall>\<sigma> \<sigma>'. U \<sigma> \<sigma>' \<longrightarrow> (\<forall>j\<in>J. \<sigma>' j = \<sigma> j)"

lemma other_stepsI [intro!]:
  assumes "\<And>\<sigma> \<sigma>' j. \<lbrakk> U \<sigma> \<sigma>'; j \<in> J \<rbrakk> \<Longrightarrow> \<sigma>' j = \<sigma> j"
    shows "other_steps U J"
  using assms unfolding other_steps_def by simp

lemma other_stepsE [elim]:
  assumes "other_steps U J"
      and "U \<sigma> \<sigma>'"
    shows "\<forall>j\<in>J. \<sigma>' j = \<sigma> j"
  using assms unfolding other_steps_def by simp

definition subreachable
where "subreachable A U J \<equiv> \<forall>I. \<forall>s \<in> oreachable A (\<lambda>s s'. I) U.
                                  (\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s) j) \<and> (\<sigma>, snd s) \<in> reachable A I)"

lemma subreachableI [intro]:
  assumes "local_steps (trans A) J"
      and "other_steps U J"
    shows "subreachable A U J"
  unfolding subreachable_def
  proof (rule, rule)
    fix I s
    assume "s \<in> oreachable A (\<lambda>s s'. I) U"
    thus "(\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s) j) \<and> (\<sigma>, snd s) \<in> reachable A I)"
    proof induction
      fix s
      assume "s \<in> init A"
      hence "(fst s, snd s) \<in> reachable A I"
        by simp (rule reachable_init)
      moreover have "\<forall>j\<in>J. (fst s) j = (fst s) j"
        by simp
      ultimately show "\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s) j) \<and> (\<sigma>, snd s) \<in> reachable A I"
        by auto
    next
      fix s a s'
      assume "\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s) j) \<and> (\<sigma>, snd s) \<in> reachable A I"
         and "(s, a, s') \<in> trans A"
         and "I a"
      then obtain \<zeta> where "\<forall>j\<in>J. \<zeta> j = (fst s) j"
                      and "(\<zeta>, snd s) \<in> reachable A I" by auto

      from \<open>(s, a, s') \<in> trans A\<close> have "((fst s, snd s), a, (fst s', snd s')) \<in> trans A"
        by simp
      with \<open>local_steps (trans A) J\<close> obtain \<zeta>' where "\<forall>j\<in>J. \<zeta>' j = (fst s') j"
                                                 and "((\<zeta>, snd s), a, (\<zeta>', snd s')) \<in> trans A"
        using \<open>\<forall>j\<in>J. \<zeta> j = (fst s) j\<close> by - (drule(2) local_stepsE, clarsimp)
      from \<open>(\<zeta>, snd s) \<in> reachable A I\<close>
       and \<open>((\<zeta>, snd s), a, (\<zeta>', snd s')) \<in> trans A\<close>
       and \<open>I a\<close>
       have "(\<zeta>', snd s') \<in> reachable A I" ..

      with \<open>\<forall>j\<in>J. \<zeta>' j = (fst s') j\<close>
        show "\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s') j) \<and> (\<sigma>, snd s') \<in> reachable A I" by auto
    next
      fix s \<sigma>'
      assume "\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s) j) \<and> (\<sigma>, snd s) \<in> reachable A I"
         and "U (fst s) \<sigma>'"
      then obtain \<sigma> where "\<forall>j\<in>J. \<sigma> j = (fst s) j"
                      and "(\<sigma>, snd s) \<in> reachable A I" by auto
      from \<open>other_steps U J\<close> and \<open>U (fst s) \<sigma>'\<close> have "\<forall>j\<in>J. \<sigma>' j = (fst s) j"
        by - (erule(1) other_stepsE)
      with \<open>\<forall>j\<in>J. \<sigma> j = (fst s) j\<close> have "\<forall>j\<in>J. \<sigma> j = \<sigma>' j"
        by clarsimp
      with \<open>(\<sigma>, snd s) \<in> reachable A I\<close>
       show "\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = fst (\<sigma>', snd s) j) \<and> (\<sigma>, snd (\<sigma>', snd s)) \<in> reachable A I"
         by auto
    qed
  qed

lemma subreachableE [elim]:
  assumes "subreachable A U J"
      and "s \<in> oreachable A (\<lambda>s s'. I) U"
    shows "\<exists>\<sigma>. (\<forall>j\<in>J. \<sigma> j = (fst s) j) \<and> (\<sigma>, snd s) \<in> reachable A I"
  using assms unfolding subreachable_def by simp

lemma subreachableE_pair [elim]:
  assumes "subreachable A U J"
      and "(\<sigma>, s) \<in> oreachable A (\<lambda>s s'. I) U"
    shows "\<exists>\<zeta>. (\<forall>j\<in>J. \<zeta> j = \<sigma> j) \<and> (\<zeta>, s) \<in> reachable A I"
  using assms unfolding subreachable_def by (metis fst_conv snd_conv)

lemma subreachable_otherE [elim]:
  assumes "subreachable A U J"
      and "(\<sigma>, l) \<in> oreachable A (\<lambda>s s'. I) U"
      and "U \<sigma> \<sigma>'"
    shows "\<exists>\<zeta>'. (\<forall>j\<in>J. \<zeta>' j = \<sigma>' j) \<and> (\<zeta>', l) \<in> reachable A I"
  proof -
    from \<open>(\<sigma>, l) \<in> oreachable A (\<lambda>s s'. I) U\<close> and \<open>U \<sigma> \<sigma>'\<close>
      have "(\<sigma>', l) \<in> oreachable A (\<lambda>s s'. I) U"
      by - (rule oreachable_other')
    with \<open>subreachable A U J\<close> show ?thesis
      by auto
  qed

lemma oinvariant_anyact:
  assumes "A \<Turnstile> (act TT, U \<rightarrow>) P"
    shows "A \<Turnstile> (S, U \<rightarrow>) P"
  using assms by rule auto

definition
  ostep_invariant
  :: "('g \<times> 'l, 'a) automaton
      \<Rightarrow> ('g \<Rightarrow> 'g \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('g \<Rightarrow> 'g \<Rightarrow> bool)
      \<Rightarrow> (('g \<times> 'l, 'a) transition \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<Turnstile>\<^sub>A (1'((1_),/ (1_) \<rightarrow>')/ _)" [100, 0, 0, 9] 8)
where
  "(A \<Turnstile>\<^sub>A (S, U \<rightarrow>) P) =
     (\<forall>s\<in>oreachable A S U. (\<forall>a s'. (s, a, s') \<in> trans A \<and> S (fst s) (fst s') a \<longrightarrow> P (s, a, s')))"

lemma ostep_invariant_def':
  "(A \<Turnstile>\<^sub>A (S, U \<rightarrow>) P) = (\<forall>s\<in>oreachable A S U.
                           (\<forall>a s'. (s, a, s') \<in> trans A \<and> S (fst s) (fst s') a \<longrightarrow> P (s, a, s')))"
  unfolding ostep_invariant_def by auto

lemma ostep_invariantI [intro]:
  assumes *: "\<And>\<sigma> s a \<sigma>' s'. \<lbrakk> (\<sigma>, s)\<in>oreachable A S U; ((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A; S \<sigma> \<sigma>' a \<rbrakk>
                             \<Longrightarrow> P ((\<sigma>, s), a, (\<sigma>', s'))"
    shows "A \<Turnstile>\<^sub>A (S, U \<rightarrow>) P"
  unfolding ostep_invariant_def
  using assms by auto

lemma ostep_invariantD [dest]:
  assumes "A \<Turnstile>\<^sub>A (S, U \<rightarrow>) P"
      and "(\<sigma>, s)\<in>oreachable A S U"
      and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A"
      and "S \<sigma> \<sigma>' a"
    shows "P ((\<sigma>, s), a, (\<sigma>', s'))"
  using assms unfolding ostep_invariant_def' by clarsimp

lemma ostep_invariantE [elim]:
  assumes "A \<Turnstile>\<^sub>A (S, U \<rightarrow>) P"
      and "(\<sigma>, s)\<in>oreachable A S U"
      and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A"
      and "S \<sigma> \<sigma>' a"
      and "P ((\<sigma>, s), a, (\<sigma>', s')) \<Longrightarrow> Q"
    shows "Q"
  using assms by auto

lemma ostep_invariant_weakenE [elim!]:
  assumes invP: "A \<Turnstile>\<^sub>A (PS, PU \<rightarrow>) P"
      and PQ:   "\<And>t. P t \<Longrightarrow> Q t"
      and QSPS: "\<And>\<sigma> \<sigma>' a. QS \<sigma> \<sigma>' a \<Longrightarrow> PS \<sigma> \<sigma>' a"
      and QUPU: "\<And>\<sigma> \<sigma>'.   QU \<sigma> \<sigma>'   \<Longrightarrow> PU \<sigma> \<sigma>'"
    shows       "A \<Turnstile>\<^sub>A (QS, QU \<rightarrow>) Q"
  proof
    fix \<sigma> s \<sigma>' s' a
    assume "(\<sigma>, s) \<in> oreachable A QS QU"
       and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A"
       and "QS \<sigma> \<sigma>' a"
    from \<open>QS \<sigma> \<sigma>' a\<close> have "PS \<sigma> \<sigma>' a" by (rule QSPS)
    from \<open>(\<sigma>, s) \<in> oreachable A QS QU\<close> have "(\<sigma>, s) \<in> oreachable A PS PU" using QSPS QUPU ..
    with invP have "P ((\<sigma>, s), a, (\<sigma>', s'))" using \<open>((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A\<close> \<open>PS \<sigma> \<sigma>' a\<close> ..
    thus "Q ((\<sigma>, s), a, (\<sigma>', s'))" by (rule PQ)
  qed

lemma ostep_invariant_weaken_with_invariantE [elim]:
  assumes pinv: "A \<Turnstile> (S, U \<rightarrow>) P"
      and qinv: "A \<Turnstile>\<^sub>A (S, U \<rightarrow>) Q"
      and wr: "\<And>\<sigma> s a \<sigma>' s'. \<lbrakk> P (\<sigma>, s); P (\<sigma>', s'); Q ((\<sigma>, s), a, (\<sigma>', s')); S \<sigma> \<sigma>' a \<rbrakk>
                              \<Longrightarrow> R ((\<sigma>, s), a, (\<sigma>', s'))"
    shows "A \<Turnstile>\<^sub>A (S, U \<rightarrow>) R"
  proof
    fix \<sigma> s a \<sigma>' s'
    assume sr: "(\<sigma>, s) \<in> oreachable A S U"
       and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A"
       and "S \<sigma> \<sigma>' a"
    hence "(\<sigma>', s') \<in> oreachable A S U" ..
    with pinv have "P (\<sigma>', s')" ..
    from pinv and sr have "P (\<sigma>, s)" ..
    from qinv sr tr \<open>S \<sigma> \<sigma>' a\<close> have "Q ((\<sigma>, s), a, (\<sigma>', s'))" ..
    with \<open>P (\<sigma>, s)\<close> and \<open>P (\<sigma>', s')\<close> show "R ((\<sigma>, s), a, (\<sigma>', s'))" using \<open>S \<sigma> \<sigma>' a\<close> by (rule wr)
  qed

lemma ostep_to_invariantI:
  assumes sinv: "A \<Turnstile>\<^sub>A (S, U \<rightarrow>) Q"
      and init: "\<And>\<sigma> s. (\<sigma>, s) \<in> init A \<Longrightarrow> P (\<sigma>, s)"
      and local: "\<And>\<sigma> s \<sigma>' s' a.
                    \<lbrakk> (\<sigma>, s) \<in> oreachable A S U;
                      P (\<sigma>, s);
                      Q ((\<sigma>, s), a, (\<sigma>', s'));
                      S \<sigma> \<sigma>' a \<rbrakk> \<Longrightarrow> P (\<sigma>', s')"
      and other: "\<And>\<sigma> \<sigma>' s. \<lbrakk> (\<sigma>, s) \<in> oreachable A S U; U \<sigma> \<sigma>'; P (\<sigma>, s) \<rbrakk> \<Longrightarrow> P (\<sigma>', s)"
    shows "A \<Turnstile> (S, U \<rightarrow>) P"
  proof
    fix \<sigma> s assume "(\<sigma>, s) \<in> init A" thus "P (\<sigma>, s)" by (rule init)
  next
    fix \<sigma> s \<sigma>' s' a
    assume "(\<sigma>, s) \<in> oreachable A S U"
       and "P (\<sigma>, s)"
       and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A"
       and "S \<sigma> \<sigma>' a"
      show "P (\<sigma>', s')"
    proof -
      from sinv and \<open>(\<sigma>, s)\<in>oreachable A S U\<close> and \<open>((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A\<close> and \<open>S \<sigma> \<sigma>' a\<close>
        have "Q ((\<sigma>, s), a, (\<sigma>', s'))" ..
      with \<open>(\<sigma>, s)\<in>oreachable A S U\<close> and \<open>P (\<sigma>, s)\<close> show "P (\<sigma>', s')"
        using \<open>S \<sigma> \<sigma>' a\<close> by (rule local)
    qed
  next
    fix \<sigma> \<sigma>' l
    assume "(\<sigma>, l) \<in> oreachable A S U"
       and "U \<sigma> \<sigma>'"
       and "P (\<sigma>, l)"
      thus "P (\<sigma>', l)" by (rule other)
  qed

lemma open_closed_step_invariant:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
      and "local_steps (trans A) J"
      and "other_steps U J"
      and localp: "\<And>\<sigma> \<zeta> a \<sigma>' \<zeta>' s s'.
                   \<lbrakk> \<forall>j\<in>J. \<sigma> j = \<zeta> j; \<forall>j\<in>J. \<sigma>' j = \<zeta>' j; P ((\<sigma>, s), a, (\<sigma>', s')) \<rbrakk>
                   \<Longrightarrow> P ((\<zeta>, s), a, (\<zeta>', s'))"
    shows "A \<Turnstile>\<^sub>A (act I, U \<rightarrow>) P"
  proof
    fix \<sigma> s a \<sigma>' s'
    assume or: "(\<sigma>, s) \<in> oreachable A (act I) U"
       and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans A"
       and "act I \<sigma> \<sigma>' a"
    from \<open>act I \<sigma> \<sigma>' a\<close> have "I a" ..
    from \<open>local_steps (trans A) J\<close> and \<open>other_steps U J\<close> have "subreachable A U J" ..
    then obtain \<zeta> where "\<forall>j\<in>J. \<zeta> j = \<sigma> j"
                    and "(\<zeta>, s) \<in> reachable A I"
      using or unfolding act_def
        by (auto dest!: subreachableE_pair)

     from \<open>local_steps (trans A) J\<close> and tr and \<open>\<forall>j\<in>J. \<zeta> j = \<sigma> j\<close>
       obtain \<zeta>' where "\<forall>j\<in>J. \<zeta>' j = \<sigma>' j"
                   and "((\<zeta>, s), a, (\<zeta>', s')) \<in> trans A"
       by auto

    from \<open>A \<TTurnstile>\<^sub>A (I \<rightarrow>) P\<close> and \<open>(\<zeta>, s) \<in> reachable A I\<close>
                          and \<open>((\<zeta>, s), a, (\<zeta>', s')) \<in> trans A\<close>
                          and \<open>I a\<close>
      have "P ((\<zeta>, s), a, (\<zeta>', s'))" ..
    with \<open>\<forall>j\<in>J. \<zeta> j = \<sigma> j\<close> and \<open>\<forall>j\<in>J. \<zeta>' j = \<sigma>' j\<close> show "P ((\<sigma>, s), a, (\<sigma>', s'))"
      by (rule localp)
  qed

lemma oinvariant_step_anyact:
  assumes "p \<Turnstile>\<^sub>A (act TT, U \<rightarrow>) P"
    shows "p \<Turnstile>\<^sub>A (S, U \<rightarrow>) P"
  using assms by rule auto

subsection "Standard assumption predicates "

text \<open>otherwith\<close>

definition otherwith :: "('s \<Rightarrow> 's \<Rightarrow> bool)
                          \<Rightarrow> 'i set
                          \<Rightarrow> (('i \<Rightarrow> 's) \<Rightarrow> 'a \<Rightarrow> bool)
                          \<Rightarrow> ('i \<Rightarrow> 's) \<Rightarrow> ('i \<Rightarrow> 's) \<Rightarrow> 'a \<Rightarrow> bool"
where "otherwith Q I P \<sigma> \<sigma>' a \<equiv> (\<forall>i. i\<notin>I \<longrightarrow> Q (\<sigma> i) (\<sigma>' i)) \<and> P \<sigma> a"

lemma otherwithI [intro]:
  assumes other: "\<And>j. j\<notin>I \<Longrightarrow> Q (\<sigma> j) (\<sigma>' j)"
      and sync:  "P \<sigma> a"
    shows "otherwith Q I P \<sigma> \<sigma>' a"
  unfolding otherwith_def using assms by simp

lemma otherwithE [elim]:
  assumes "otherwith Q I P \<sigma> \<sigma>' a"
      and "\<lbrakk> P \<sigma> a; \<forall>j. j\<notin>I \<longrightarrow> Q (\<sigma> j) (\<sigma>' j) \<rbrakk> \<Longrightarrow> R \<sigma> \<sigma>' a"
    shows "R \<sigma> \<sigma>' a"
  using assms unfolding otherwith_def by simp

lemma otherwith_actionD [dest]:
  assumes "otherwith Q I P \<sigma> \<sigma>' a"
    shows "P \<sigma> a"
  using assms by auto

lemma otherwith_syncD [dest]:
  assumes "otherwith Q I P \<sigma> \<sigma>' a"
    shows "\<forall>j. j\<notin>I \<longrightarrow> Q (\<sigma> j) (\<sigma>' j)"
  using assms by auto

lemma otherwithEI [elim]:
  assumes "otherwith P I PO \<sigma> \<sigma>' a"
      and "\<And>\<sigma> a. PO \<sigma> a \<Longrightarrow> QO \<sigma> a"
    shows "otherwith P I QO \<sigma> \<sigma>' a"
  using assms(1) unfolding otherwith_def
  by (clarsimp elim!: assms(2))

lemma all_but:
  assumes "\<And>\<xi>. S \<xi> \<xi>"
      and "\<sigma>' i = \<sigma> i"
      and "\<forall>j. j \<noteq> i \<longrightarrow> S (\<sigma> j) (\<sigma>' j)"
    shows "\<forall>j. S (\<sigma> j) (\<sigma>' j)"
  using assms by metis

lemma all_but_eq [dest]:
  assumes "\<sigma>' i = \<sigma> i"
      and "\<forall>j. j \<noteq> i \<longrightarrow> \<sigma> j = \<sigma>' j"
    shows "\<sigma> = \<sigma>'"
  using assms by - (rule ext, metis)

text \<open>other\<close>

definition other :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 'i set \<Rightarrow> ('i \<Rightarrow> 's) \<Rightarrow> ('i \<Rightarrow> 's) \<Rightarrow> bool"
where "other P I \<sigma> \<sigma>' \<equiv> \<forall>i. if i\<in>I then \<sigma>' i = \<sigma> i else P (\<sigma> i) (\<sigma>' i)"

lemma otherI [intro]:
  assumes local: "\<And>i. i\<in>I \<Longrightarrow> \<sigma>' i = \<sigma> i"
      and other: "\<And>j. j\<notin>I \<Longrightarrow> P (\<sigma> j) (\<sigma>' j)"
    shows "other P I \<sigma> \<sigma>'"
  using assms unfolding other_def by clarsimp

lemma otherE [elim]:
  assumes "other P I \<sigma> \<sigma>'"
      and "\<lbrakk> \<forall>i\<in>I. \<sigma>' i = \<sigma> i; \<forall>j. j\<notin>I \<longrightarrow> P (\<sigma> j) (\<sigma>' j) \<rbrakk> \<Longrightarrow> R \<sigma> \<sigma>'"
    shows "R \<sigma> \<sigma>'"
  using assms unfolding other_def by simp

lemma other_localD [dest]:
  "other P {i} \<sigma> \<sigma>' \<Longrightarrow> \<sigma>' i = \<sigma> i"
  by auto

lemma other_otherD [dest]:
  "other P {i} \<sigma> \<sigma>' \<Longrightarrow> \<forall>j. j\<noteq>i \<longrightarrow> P (\<sigma> j) (\<sigma>' j)"
  by auto

lemma other_bothE [elim]:
  assumes "other P {i} \<sigma> \<sigma>'"
  obtains "\<sigma>' i = \<sigma> i" and "\<forall>j. j\<noteq>i \<longrightarrow> P (\<sigma> j) (\<sigma>' j)"
  using assms by auto

lemma weaken_local [elim]:
  assumes "other P I \<sigma> \<sigma>'"
      and PQ: "\<And>\<xi> \<xi>'. P \<xi> \<xi>' \<Longrightarrow> Q \<xi> \<xi>'"
    shows "other Q I \<sigma> \<sigma>'"
  using assms unfolding other_def by auto

definition global :: "((nat \<Rightarrow> 's) \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 's) \<times> 'local \<Rightarrow> bool"
where "global P \<equiv> (\<lambda>(\<sigma>, _). P \<sigma>)"

lemma globalsimp [simp]: "global P s = P (fst s)"
  unfolding global_def by (simp split: split_split)

definition globala :: "((nat \<Rightarrow> 's, 'action) transition \<Rightarrow> bool)
                       \<Rightarrow> ((nat \<Rightarrow> 's) \<times> 'local, 'action) transition \<Rightarrow> bool"
where "globala P \<equiv> (\<lambda>((\<sigma>, _), a, (\<sigma>', _)). P (\<sigma>, a, \<sigma>'))"

lemma globalasimp [simp]: "globala P s = P (fst (fst s), fst (snd s), fst (snd (snd s)))"
  unfolding globala_def by (simp split: split_split)

end


(*
 * @TAG(OTHER_LGPL)
 *)

(*  Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HeapList.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* Paths and Lists in the Heap *}
theory HeapList
imports Simpl_Heap
begin

text {* Adapted from 'HOL/Hoare/Heap.thy'. *}

subsection "Paths in The Heap"

primrec
 Path :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref \<Rightarrow>  ref list  \<Rightarrow> bool"
where
"Path x h y [] = (x = y)" |
"Path x h y (p#ps) = (x = p \<and> x \<noteq> Null \<and> Path (h x) h y ps)"

lemma Path_Null_iff [iff]: "Path Null h y xs  = (xs = [] \<and> y = Null)"
apply(case_tac xs)
apply fastforce
apply fastforce
done

lemma Path_not_Null_iff [simp]: "p\<noteq>Null \<Longrightarrow>
  Path p h q as = (as = [] \<and> q = p  \<or>  (\<exists>ps. as = p#ps \<and> Path (h p) h q ps ))"
apply(case_tac as)
apply fastforce
apply fastforce
done

lemma Path_append [simp]:
  "\<And>p. Path p f q (as@bs)  = (\<exists>y. Path p f y as \<and> Path y f q bs)"
by(induct as, simp+)

lemma notin_Path_update[simp]:
 "\<And>p. u \<notin> set ps \<Longrightarrow> Path p (f(u := v)) q ps  = Path p f q ps "
by(induct ps, simp, simp add:eq_sym_conv)

lemma Path_upd_same [simp]:
  "Path p (f(p:=p)) q qs =
      ((p=Null \<and> q=Null \<and> qs = []) \<or> (p\<noteq>Null \<and> q=p \<and> (\<forall>x\<in>set qs. x=p)))"
by (induct qs) auto

text {* @{thm[source] Path_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> Path p (f(p:=p)) q qs = X"} from looping, because of
@{thm[source] Path_not_Null_iff} and @{thm[source]fun_upd_apply}.
 *}

lemma notin_Path_updateI [intro]:
 "\<lbrakk>Path p h q ps ; r \<notin> set ps\<rbrakk> \<Longrightarrow> Path p (h(r := y)) q ps "
by simp

lemma Path_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> Path p (f(new (set alloc) := x)) q ps  = Path p f q ps "
  by (rule notin_Path_update) fastforce

lemma Null_notin_Path [simp,intro]:
"\<And>p. Path p f q ps \<Longrightarrow> Null \<notin> set ps"
by(induct ps) auto

lemma Path_snoc:
 "\<lbrakk>Path p (f(a := q)) a as ; a\<noteq>Null\<rbrakk> \<Longrightarrow> Path p (f(a := q)) q (as @ [a])"
by simp

subsection "Lists on The Heap"

subsubsection "Relational Abstraction"

definition
 List :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list \<Rightarrow> bool" where
"List p h ps = Path p h Null ps "

lemma List_empty [simp]: "List p h [] = (p = Null)"
by(simp add:List_def)

lemma List_cons [simp]: "List p h (a#ps) = (p = a \<and> p\<noteq>Null \<and> List (h p) h ps)"
by(simp add:List_def)

lemma List_Null [simp]: "List Null h ps = (ps = [])"
by(case_tac ps, simp_all)

lemma List_not_Null [simp]: "p\<noteq>Null \<Longrightarrow>
  List p h as = (\<exists>ps. as = p#ps \<and> List (h p) h ps)"
by(case_tac as, simp_all, fast)

lemma Null_notin_List [simp,intro]: "\<And>p. List p h ps \<Longrightarrow> Null \<notin> set ps"
by (simp add : List_def)

lemma List_upd_same_lemma: "\<And>p.  p \<noteq> Null \<Longrightarrow> \<not> List p (h(p := p)) ps"
apply (induct ps)
apply  simp
apply (simp (no_asm_simp) del: fun_upd_apply)
apply (simp (no_asm_simp) only: fun_upd_apply refl if_True)
apply blast
done

lemma List_upd_same [simp]: "List p (h(p:=p)) ps = (p = Null \<and> ps = [])"
apply (cases "p=Null")
apply  simp
apply (fast dest: List_upd_same_lemma)
done

text {* @{thm[source] List_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> List p (h(p:=p)) as = X"} from looping, because of
@{thm[source] List_not_Null} and @{thm[source] fun_upd_apply}.
 *}

lemma  List_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> List p (h(new (set alloc) := x)) ps = List p h ps"
by (rule notin_List_update) fastforce

lemma List_updateI [intro]:
 "\<lbrakk>List p h ps; q \<notin> set ps\<rbrakk> \<Longrightarrow> List p (h(q := y)) ps"
by simp

lemma List_unique: "\<And>p bs. List p h as \<Longrightarrow> List p h bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List p h as \<Longrightarrow> \<exists>!as. List p h as"
by(blast intro:List_unique)

lemma List_app: "\<And>p. List p h (as@bs) = (\<exists>y. Path p h y as \<and> List y h bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List (h p) h ps \<Longrightarrow> p \<notin> set ps"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>p. List p h ps \<Longrightarrow> distinct ps"
apply(induct ps, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma heap_eq_List_eq:
  "\<And>p. \<forall>x \<in> set ps. h x = g x \<Longrightarrow> List p h ps = List p g ps"
  by (induct ps) auto

lemma heap_eq_ListI:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. h x = g x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

lemma heap_eq_ListI1:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. g x = h x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

text {* The following lemmata are usefull for the simplifier to instantiate
bound variables in the assumptions resp. conclusion, using the uniqueness
of the List predicate *}

lemma conj_impl_simp: "(P \<and> Q \<longrightarrow> K) = (P \<longrightarrow> Q \<longrightarrow> K)"
by auto

lemma  List_unique_all_impl_simp [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. List p h ps \<longrightarrow> P ps) = P ps"
by (auto dest: List_unique)

(*
lemma  List_unique_all_impl_simp1 [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. Q ps \<longrightarrow> List p h ps \<longrightarrow> P ps) = Q ps \<longrightarrow> P ps"
by (auto dest: List_unique)
*)
lemma List_unique_ex_conj_simp [simp]:
"List p h ps \<Longrightarrow> (\<exists>ps. List p h ps \<and> P ps) = P ps"
by (auto dest: List_unique)

subsection "Functional abstraction"

definition
 islist :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool" where
"islist p h = (\<exists>ps. List p h ps)"

definition
 list :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list" where
"list p h = (THE ps. List p h ps)"

lemma List_conv_islist_list: "List p h ps = (islist p h \<and> ps = list p h)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst the1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply (clarify)
apply (rule theI)
apply  assumption
by (rule List_unique)

lemma List_islist [intro]:
  "List p h ps \<Longrightarrow> islist p h"
  apply (simp add: List_conv_islist_list)
  done

lemma List_list:
  "List p h ps \<Longrightarrow> list p h = ps"
  apply (simp only: List_conv_islist_list)
  done

lemma [simp]: "p\<noteq>Null \<Longrightarrow> islist (h p) h = islist p h"
by(simp add:islist_def)

lemma [simp]: "list Null h = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk>islist (h p) h; p\<noteq>Null \<rbrakk> \<Longrightarrow> list p h = p # list (h p) h"
apply(insert List_not_Null[of _ h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist (h p) h \<Longrightarrow> p \<notin> set(list (h p) h)"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> list p (h(y := q)) = list p h"
apply(drule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> islist p (h(y := q))"
apply(frule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma list_distinct[simp]: "islist p h \<Longrightarrow> distinct (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

lemma Null_notin_list [simp,intro]: "islist p h \<Longrightarrow> Null \<notin> set (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

end