section "Small-Step Semantics of Commands"

theory Small_Step imports "~~/src/HOL/IMP/Star" "./Big_Step" begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |

OrL:      "(l OR r, s) \<rightarrow> (l,s)" |
OrR:      "(l OR r, s) \<rightarrow> (r,s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection\<open>Executability\<close>

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection\<open>Proof infrastructure\<close>

subsubsection\<open>Induction rules\<close>

text\<open>The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form \<open>a \<rightarrow> b \<Longrightarrow> \<dots>\<close> where \<open>a\<close> and \<open>b\<close> are
not already pairs \<open>(DUMMY,DUMMY)\<close>. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
\<open>\<rightarrow>\<close> into pairs:\<close>
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection\<open>Proof automation\<close>

declare small_step.intros[simp,intro]

text\<open>Rule inversion:\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"
inductive_cases OrE[elim!]: "(l OR r, s) \<rightarrow> t"

text\<open>A simple property:\<close>
(*
Orによって成り立たなくなる
lemma deterministic:
  "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule: small_step.induct)
apply blast+
done *)

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text\<open>The following proof corresponds to one on the board where one would
show chains of \<open>\<rightarrow>\<close> and \<open>\<rightarrow>*\<close> steps.\<close>

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
(*  1. \<And>l s1 s2 r.
       (l, s1) \<Rightarrow> s2 \<Longrightarrow> (l, s1) \<rightarrow>* (SKIP, s2) \<Longrightarrow> (l OR r, s1) \<rightarrow>* (SKIP, s2)　*)
  fix l s1 s2 r
  assume "(l, s1) \<Rightarrow> s2"
  assume "(l, s1) \<rightarrow>* (SKIP, s2)"
  then show "(l OR r, s1) \<rightarrow>* (SKIP, s2)" by (meson small_step.OrL star.simps)
next
(*  2. \<And>r s1 s2 l.
       (r, s1) \<Rightarrow> s2 \<Longrightarrow> (r, s1) \<rightarrow>* (SKIP, s2) \<Longrightarrow> (l OR r, s1) \<rightarrow>* (SKIP, s2) *)
  fix l s1 s2 r
  assume "(r, s1) \<Rightarrow> s2"
  assume "(r, s1) \<rightarrow>* (SKIP, s2)"
  then show "(l OR r, s1) \<rightarrow>* (SKIP, s2)" by (meson small_step.OrR star.simps)
qed

text\<open>Each case of the induction can be proved automatically:\<close>
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
next
  case (OrL l s1 s2 r)
  then show ?case by (simp add: big_step.OrL big_to_small)
next
  case (OrR r s1 s2 l)
  then show ?case by (simp add: big_step.OrR big_to_small)
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction cs "(SKIP,t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text \<open>
  Finally, the equivalence theorem:
\<close>
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(\<exists>cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis SkipE finalD final_def)

text\<open>Now we can show that \<open>\<Rightarrow>\<close> yields a final state iff \<open>\<rightarrow>\<close>
terminates:\<close>

lemma big_iff_small_termination:
  "(\<exists>t. cs \<Rightarrow> t) \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text\<open>This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since \<open>\<rightarrow>\<close> is determininistic, there is no difference
between may and must terminate.\<close>

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "64-Bit Machine Word Setup"

theory Word_Setup_64
imports Word_Enum
begin

text \<open>This theory defines standard platform-specific word size and alignment.\<close>

type_synonym machine_word_len = 64
type_synonym machine_word = "machine_word_len word"

definition word_bits :: nat
where
  "word_bits = LENGTH(machine_word_len)"

text \<open>The following two are numerals so they can be used as nats and words.\<close>
definition word_size_bits :: "'a :: numeral"
where
  "word_size_bits = 3"

definition word_size :: "'a :: numeral"
where
  "word_size = 8"

lemma word_bits_conv[code]:
  "word_bits = 64"
  unfolding word_bits_def by simp

lemma word_size_word_size_bits:
  "(word_size::nat) = 2 ^ word_size_bits"
  unfolding word_size_def word_size_bits_def by simp

lemma word_bits_word_size_conv:
  "word_bits = word_size * 8"
  unfolding word_bits_def word_size_def by simp

end


(*****************************************************************************
 * HOL-TestGen --- theorem-prover based test case generation
 *                 http://www.brucker.ch/projects/hol-testgen/
 *
 * Monads.thy --- a base testing theory for sequential computations.
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2005-2012 ETH Zurich, Switzerland
 *               2009-2017 Univ. Paris-Sud, France
 *               2009-2015 Achim D. Brucker, Germany
 *               2015-2017 The University of Sheffield, UK
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

section \<open>Basic Monad Theory for Sequential Computations\<close>
theory
  Monads
  imports
    Main
begin

subsection\<open>General Framework for Monad-based Sequence-Test\<close>
text\<open>
  As such, Higher-order Logic as a purely functional specification formalism has no built-in
  mechanism for state and state-transitions. Forms of testing involving state require therefore
  explicit mechanisms for their treatment inside the logic; a well-known technique to model
  states inside purely functional languages are \emph{monads} made popular by Wadler and Moggi
  and extensively used in Haskell. \HOL is powerful enough to represent the most important
  standard monads; however, it is not possible to represent monads as such due to well-known
  limitations of the Hindley-Milner type-system.

  Here is a variant for state-exception monads, that models precisely transition functions with
  preconditions. Next, we declare the state-backtrack-monad. In all of them, our concept of
  i/o-stepping functions can be formulated; these are functions mapping input to a given monad.
  Later on, we will build the usual concepts of:
  \begin{enumerate}
    \item deterministic i/o automata,
    \item non-deterministic i/o automata, and
    \item labelled transition systems (LTS)
  \end{enumerate}
\<close>

subsubsection\<open>State Exception Monads\<close>
type_synonym ('o, '\<sigma>) MON\<^sub>S\<^sub>E = "'\<sigma> \<rightharpoonup> ('o \<times> '\<sigma>)"

definition bind_SE :: "('o,'\<sigma>)MON\<^sub>S\<^sub>E \<Rightarrow> ('o \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E) \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E"
where     "bind_SE f g = (\<lambda>\<sigma>. case f \<sigma> of None \<Rightarrow> None
                                        | Some (out, \<sigma>') \<Rightarrow> g out \<sigma>')"

notation bind_SE ("bind\<^sub>S\<^sub>E")
syntax
          "_bind_SE" :: "[pttrn,('o,'\<sigma>)MON\<^sub>S\<^sub>E,('o','\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E"
                                                                          ("(2 _ \<leftarrow> _; _)" [5,8,8]8)
translations
          "x \<leftarrow> f; g" \<rightleftharpoons> "CONST bind_SE f (% x . g)"

definition unit_SE :: "'o \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>E"   ("(return _)" 8)
where     "unit_SE e = (\<lambda>\<sigma>. Some(e,\<sigma>))"
notation   unit_SE ("unit\<^sub>S\<^sub>E")

definition fail\<^sub>S\<^sub>E :: "('o, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "fail\<^sub>S\<^sub>E = (\<lambda>\<sigma>. None)"
notation   fail\<^sub>S\<^sub>E ("fail\<^sub>S\<^sub>E")

definition assert_SE :: "('\<sigma> \<Rightarrow> bool) \<Rightarrow> (bool, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "assert_SE P = (\<lambda>\<sigma>. if P \<sigma> then Some(True,\<sigma>) else None)"
notation   assert_SE ("assert\<^sub>S\<^sub>E")

definition assume_SE :: "('\<sigma> \<Rightarrow> bool) \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "assume_SE P = (\<lambda>\<sigma>. if \<exists>\<sigma> . P \<sigma> then Some((), SOME \<sigma> . P \<sigma>) else None)"
notation   assume_SE ("assume\<^sub>S\<^sub>E")

definition if_SE :: "['\<sigma> \<Rightarrow> bool, ('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E, ('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "if_SE c E F = (\<lambda>\<sigma>. if c \<sigma> then E \<sigma> else F \<sigma>)"
notation   if_SE   ("if\<^sub>S\<^sub>E")

text\<open>
  The standard monad theorems about unit and associativity:
\<close>

lemma bind_left_unit : "(x \<leftarrow> return a; k) = k"
  apply (simp add: unit_SE_def bind_SE_def)
  done

lemma bind_right_unit: "(x \<leftarrow> m; return x) = m"
  apply (simp add:  unit_SE_def bind_SE_def)
  apply (rule ext)
  subgoal for "\<sigma>"
    apply (case_tac "m \<sigma>")
     apply ( simp_all)
    done
  done

lemma bind_assoc: "(y \<leftarrow> (x \<leftarrow> m; k); h) = (x \<leftarrow> m; (y \<leftarrow> k; h))"
  apply (simp add: unit_SE_def bind_SE_def)
  apply (rule ext)
  subgoal for "\<sigma>"
    apply (case_tac "m \<sigma>", simp_all)
    subgoal for a
      apply (case_tac "a", simp_all)
      done
    done
  done

text\<open>
  In order to express test-sequences also on the object-level and to make our theory amenable to
  formal reasoning over test-sequences, we represent them as lists of input and generalize the
  bind-operator of the state-exception monad accordingly. The approach is straightforward, but
  comes with a price: we have to encapsulate all input and output data into one type. Assume that
  we have a typed interface to a module with the operations $op_1$, $op_2$, \ldots, $op_n$ with
  the inputs $\iota_1$, $\iota_2$, \ldots, $\iota_n$ (outputs are treated analogously). Then we
  can encode for this interface the general input - type:
  \begin{displaymath}
    \texttt{datatype}\ \texttt{in}\ =\ op_1\ ::\ \iota_1\ |\ ...\ |\ \iota_n
  \end{displaymath}
  Obviously, we loose some type-safety in this approach; we have to express that in traces only
  \emph{corresponding} input and output belonging to the same operation will occur; this form
  of side-conditions have to be expressed inside \HOL. From the user perspective, this will not
  make much difference, since junk-data resulting from too weak typing can be ruled out by adopted
  front-ends.
\<close>

text\<open>
  In order to express test-sequences also on the object-level and to make our theory amenable to
  formal reasoning over test-sequences, we represent them as lists of input and generalize the
  bind-operator of the state-exception monad accordingly. Thus, the notion of test-sequence
  is mapped to the notion of a \emph{computation}, a semantic notion; at times we will use
  reifications of computations, \ie{} a data-type in order to make computation amenable to
  case-splitting and meta-theoretic reasoning. To this end,  we have to encapsulate all input
  and output data into one type. Assume that we have a typed interface to a module with
  the operations $op_1$, $op_2$, \ldots, $op_n$ with the inputs  $\iota_1$, $\iota_2$, \ldots,
  $\iota_n$ (outputs are treated analogously).
   Then we can encode for this interface the general input - type:
  \begin{displaymath}
  \texttt{datatype}\ \texttt{in}\ =\ op_1\ ::\ \iota_1\ |\ ...\ |\ \iota_n
  \end{displaymath}
  Obviously, we loose some type-safety in this approach; we have to express
  that in traces only \emph{corresponding} input and output belonging to the
  same operation will occur; this form of side-conditions have to be expressed
  inside \HOL. From the user perspective, this will not make much difference,
  since junk-data resulting from too weak typing can be ruled out by adopted
  front-ends.\<close>

text\<open>Note that the subsequent notion of a test-sequence allows the io stepping
function (and the special case of a program under test) to stop execution
\emph{within} the sequence; such premature terminations are characterized by an
output list which is shorter than the input list. Note that our primary
notion of multiple execution ignores failure and reports failure
steps only by missing results ...\<close>

fun    mbind :: "'\<iota> list  \<Rightarrow>  ('\<iota> \<Rightarrow> ('o,'\<sigma>) MON\<^sub>S\<^sub>E) \<Rightarrow> ('o list,'\<sigma>) MON\<^sub>S\<^sub>E"
  where "mbind [] iostep \<sigma> = Some([], \<sigma>)" |
    "mbind (a#H) iostep \<sigma> =
                (case iostep a \<sigma> of
                     None   \<Rightarrow> Some([], \<sigma>)
                  |  Some (out, \<sigma>') \<Rightarrow> (case mbind H iostep \<sigma>' of
                                          None    \<Rightarrow> Some([out],\<sigma>')
                                        | Some(outs,\<sigma>'') \<Rightarrow> Some(out#outs,\<sigma>'')))"

text\<open>As mentioned, this definition is fail-safe; in case of an exception,
the current state is maintained, no result is reported.
An alternative is the fail-strict variant \<open>mbind'\<close> defined below.\<close>

lemma mbind_unit [simp]: "mbind [] f = (return [])"
  by(rule ext, simp add: unit_SE_def)

lemma mbind_nofailure [simp]: "mbind S f \<sigma> \<noteq> None"
  apply (rule_tac x=\<sigma> in spec)
  apply (induct S)
  using mbind.simps(1) apply force
  apply(simp add:unit_SE_def)
  apply(safe)[1]
  subgoal for a S x
    apply (case_tac "f a x")
     apply(simp)
    apply(safe)[1]
    subgoal for aa b
      apply (erule_tac x="b" in allE)
      apply (erule exE)+
      apply (simp)
      done
    done
  done

text\<open>The fail-strict version of \<open>mbind'\<close> looks as follows:\<close>
fun    mbind' :: "'\<iota> list  \<Rightarrow>  ('\<iota> \<Rightarrow> ('o,'\<sigma>) MON\<^sub>S\<^sub>E) \<Rightarrow> ('o list,'\<sigma>) MON\<^sub>S\<^sub>E"
where "mbind' [] iostep \<sigma> = Some([], \<sigma>)" |
      "mbind' (a#H) iostep \<sigma> =
                (case iostep a \<sigma> of
                     None   \<Rightarrow> None
                  |  Some (out, \<sigma>') \<Rightarrow> (case mbind H iostep \<sigma>' of
                                          None    \<Rightarrow> None   \<comment> \<open>fail-strict\<close>
                                        | Some(outs,\<sigma>'') \<Rightarrow> Some(out#outs,\<sigma>'')))"

text\<open>
  mbind' as failure strict operator can be seen as a foldr on bind---if the types would
  match \ldots
\<close>

definition try_SE :: "('o,'\<sigma>) MON\<^sub>S\<^sub>E \<Rightarrow> ('o option,'\<sigma>) MON\<^sub>S\<^sub>E"
where     "try_SE ioprog = (\<lambda>\<sigma>. case ioprog \<sigma> of
                                      None \<Rightarrow> Some(None, \<sigma>)
                                    | Some(outs, \<sigma>') \<Rightarrow> Some(Some outs, \<sigma>'))"
text\<open>In contrast @{term mbind} as a failure safe operator can roughly be seen
       as a @{term foldr} on bind - try:
       \<open>m1 ; try m2 ; try m3; ...\<close>. Note, that the rough equivalence only holds for
       certain predicates in the sequence - length equivalence modulo None,
       for example. However, if a conditional is added, the equivalence
       can be made precise:\<close>

lemma mbind_try:
  "(x \<leftarrow> mbind (a#S) F; M x) =
   (a' \<leftarrow> try_SE(F a);
      if a' = None
      then (M [])
      else (x \<leftarrow> mbind S F; M (the a' # x)))"
  apply (rule ext)
  apply (simp add: bind_SE_def try_SE_def)
  subgoal for x
    apply (case_tac "F a x")
     apply(simp)
    apply (safe)[1]
    apply (simp add: bind_SE_def try_SE_def)
    subgoal for aa b
      apply (case_tac "mbind S F b")
       apply (auto)
      done
    done
  done

text\<open>On this basis, a symbolic evaluation scheme can be established
  that reduces @{term mbind}-code to @{term try_SE}-code and If-cascades.\<close>

definition alt_SE    :: "[('o, '\<sigma>)MON\<^sub>S\<^sub>E, ('o, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>E"   (infixl "\<sqinter>\<^sub>S\<^sub>E" 10)
where     "(f \<sqinter>\<^sub>S\<^sub>E g) = (\<lambda> \<sigma>. case f \<sigma> of None \<Rightarrow> g \<sigma>
                                      | Some H \<Rightarrow> Some H)"

definition malt_SE   :: "('o, '\<sigma>)MON\<^sub>S\<^sub>E list \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "malt_SE S = foldr alt_SE S fail\<^sub>S\<^sub>E"
notation   malt_SE ("\<Sqinter>\<^sub>S\<^sub>E")

lemma malt_SE_mt [simp]: "\<Sqinter>\<^sub>S\<^sub>E [] = fail\<^sub>S\<^sub>E"
  by(simp add: malt_SE_def)

lemma malt_SE_cons [simp]: "\<Sqinter>\<^sub>S\<^sub>E (a # S) = (a \<sqinter>\<^sub>S\<^sub>E (\<Sqinter>\<^sub>S\<^sub>E S))"
  by(simp add: malt_SE_def)

subsubsection\<open>State-Backtrack Monads\<close>
text\<open>This subsection is still rudimentary and as such an interesting
  formal analogue to the previous monad definitions. It is doubtful that it is
  interesting for testing and as a computational structure at all.
  Clearly more relevant is ``sequence'' instead of ``set,'' which would
  rephrase Isabelle's internal tactic concept.
\<close>

type_synonym ('o, '\<sigma>) MON\<^sub>S\<^sub>B = "'\<sigma> \<Rightarrow> ('o \<times> '\<sigma>) set"

definition bind_SB :: "('o, '\<sigma>)MON\<^sub>S\<^sub>B \<Rightarrow> ('o \<Rightarrow>  ('o', '\<sigma>)MON\<^sub>S\<^sub>B) \<Rightarrow> ('o', '\<sigma>)MON\<^sub>S\<^sub>B"
where     "bind_SB f g \<sigma> = \<Union> ((\<lambda>(out, \<sigma>). (g out \<sigma>)) ` (f \<sigma>))"
notation   bind_SB ("bind\<^sub>S\<^sub>B")

definition unit_SB   :: "'o \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>B" ("(returns _)" 8)
where     "unit_SB e = (\<lambda>\<sigma>. {(e,\<sigma>)})"
notation   unit_SB ("unit\<^sub>S\<^sub>B")

syntax "_bind_SB" :: "[pttrn,('o,'\<sigma>)MON\<^sub>S\<^sub>B,('o','\<sigma>)MON\<^sub>S\<^sub>B] \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>B"
                                                                         ("(2 _ := _; _)" [5,8,8]8)
translations
          "x := f; g" \<rightleftharpoons> "CONST bind_SB f (% x . g)"

lemma bind_left_unit_SB : "(x := returns a; m) = m"
  apply (rule ext)
  apply (simp add: unit_SB_def bind_SB_def)
  done

lemma bind_right_unit_SB: "(x := m; returns x) = m"
  apply (rule ext)
  apply (simp add: unit_SB_def bind_SB_def)
done

lemma bind_assoc_SB: "(y := (x := m; k); h) = (x := m; (y := k; h))"
  apply (rule ext)
  apply (simp add: unit_SB_def bind_SB_def split_def)
done

subsubsection\<open>State Backtrack Exception Monad\<close>
text\<open>
  The following combination of the previous two Monad-Constructions allows for the semantic
  foundation of a simple generic assertion language in the style of Schirmer's Simpl-Language or
  Rustan Leino's Boogie-PL language. The key is to use the exceptional element None for violations
  of the assert-statement.
\<close>
type_synonym  ('o, '\<sigma>) MON\<^sub>S\<^sub>B\<^sub>E = "'\<sigma> \<Rightarrow> (('o \<times> '\<sigma>) set) option"

definition bind_SBE :: "('o,'\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E \<Rightarrow> ('o \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E) \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E"
where     "bind_SBE f g = (\<lambda>\<sigma>. case f \<sigma> of None \<Rightarrow> None
                                         | Some S \<Rightarrow> (let S' = (\<lambda>(out, \<sigma>'). g out \<sigma>') ` S
                                                      in  if None \<in> S' then None
                                                          else Some(\<Union> (the ` S'))))"

syntax "_bind_SBE" :: "[pttrn,('o,'\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E,('o','\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E] \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E"
                                                                         ("(2 _ :\<equiv> _; _)" [5,8,8]8)
translations
          "x :\<equiv> f; g" \<rightleftharpoons> "CONST bind_SBE f (% x . g)"

definition unit_SBE   :: "'o \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E"   ("(returning _)" 8)
where     "unit_SBE e = (\<lambda>\<sigma>. Some({(e,\<sigma>)}))"

definition assert_SBE   :: "('\<sigma> \<Rightarrow> bool) \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E"
where     "assert_SBE e = (\<lambda>\<sigma>. if e \<sigma> then Some({((),\<sigma>)})
                                      else None)"
notation   assert_SBE ("assert\<^sub>S\<^sub>B\<^sub>E")

definition assume_SBE :: "('\<sigma> \<Rightarrow> bool) \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E"
where     "assume_SBE e = (\<lambda>\<sigma>. if e \<sigma> then Some({((),\<sigma>)})
                                      else Some {})"
notation   assume_SBE ("assume\<^sub>S\<^sub>B\<^sub>E")

definition havoc_SBE :: " (unit, '\<sigma>)MON\<^sub>S\<^sub>B\<^sub>E"
where     "havoc_SBE = (\<lambda>\<sigma>.  Some({x. True}))"
notation   havoc_SBE ("havoc\<^sub>S\<^sub>B\<^sub>E")

lemma bind_left_unit_SBE : "(x :\<equiv> returning a; m) = m"
  apply (rule ext)
  apply (simp add: unit_SBE_def bind_SBE_def)
  done

lemma bind_right_unit_SBE: "(x :\<equiv> m; returning x) = m"
  apply (rule ext)
  apply (simp add: unit_SBE_def bind_SBE_def)
  subgoal for x
    apply (case_tac "m x")
     apply (simp_all add:Let_def)
    apply (rule HOL.ccontr)
    apply (simp add: Set.image_iff)
    done
  done

lemmas aux = trans[OF HOL.neq_commute,OF Option.not_None_eq]

lemma bind_assoc_SBE: "(y :\<equiv> (x :\<equiv> m; k); h) = (x :\<equiv> m; (y :\<equiv> k; h))"
proof (rule ext, simp add: unit_SBE_def bind_SBE_def, rename_tac x,
    case_tac "m x", simp_all add: Let_def Set.image_iff, safe,goal_cases)
  case (1 x a aa b ab ba a b)
  then show ?case  by(rule_tac x="(a, b)" in bexI, simp_all)
next
  case (2 x a aa b ab ba)
  then show ?case
    apply (rule_tac x="(aa, b)" in bexI, simp_all add:split_def)
    apply (erule_tac x="(aa,b)" in ballE)
     apply (auto simp: aux image_def split_def intro!: rev_bexI)
    done
next
  case (3 x a a b)
  then show ?case  by(rule_tac x="(a, b)" in bexI, simp_all)
next
  case (4 x a aa b)
  then show ?case
    apply (erule_tac Q="None = X" for X in contrapos_pp)
    apply (erule_tac x="(aa,b)" and P="\<lambda> x. None \<noteq> case_prod (\<lambda>out. k) x" in ballE)
     apply (auto simp: aux image_def split_def intro!: rev_bexI)
    done
next
  case (5 x a aa b ab ba a b)
  then show ?case  apply simp apply ((erule_tac x="(ab,ba)" in ballE)+)
       apply (simp_all add: aux, (erule exE)+, simp add:split_def)
    apply (erule rev_bexI, case_tac "None\<in>(\<lambda>p. h(snd p))`y",auto simp:split_def)
    done

next
  case (6 x a aa b a b)
  then show ?case    apply simp apply ((erule_tac x="(a,b)" in ballE)+)
       apply (simp_all add: aux, (erule exE)+, simp add:split_def)
    apply (erule rev_bexI, case_tac "None\<in>(\<lambda>p. h(snd p))`y",auto simp:split_def)
    done
qed

subsection\<open>Valid Test Sequences in the State Exception Monad\<close>
text\<open>
  This is still an unstructured merge of executable monad concepts and specification oriented
  high-level properties initiating test procedures.
\<close>

definition valid_SE :: "'\<sigma> \<Rightarrow> (bool,'\<sigma>) MON\<^sub>S\<^sub>E \<Rightarrow> bool" (infix "\<Turnstile>" 15)
where "(\<sigma> \<Turnstile> m) = (m \<sigma> \<noteq> None \<and> fst(the (m \<sigma>)))"
text\<open>
  This notation consideres failures as valid---a definition inspired by I/O conformance.
  Note that it is not possible to define this concept once and for all in a Hindley-Milner
  type-system. For the moment, we present it only for the state-exception monad, although for
  the same definition, this notion is applicable to other monads as well.
\<close>

lemma syntax_test :
  "\<sigma> \<Turnstile> (os \<leftarrow> (mbind \<iota>s ioprog); return(length \<iota>s = length os))"
oops

lemma valid_true[simp]: "(\<sigma> \<Turnstile> (s \<leftarrow> return x ; return (P s))) = P x"
  by(simp add: valid_SE_def unit_SE_def bind_SE_def)

text\<open>Recall mbind\_unit for the base case.\<close>

lemma valid_failure: "ioprog a \<sigma> = None \<Longrightarrow>
                                   (\<sigma> \<Turnstile> (s \<leftarrow> mbind (a#S) ioprog ; M s)) =
                                   (\<sigma> \<Turnstile> (M []))"
  by(simp add: valid_SE_def unit_SE_def bind_SE_def)

lemma valid_failure': "A \<sigma> = None \<Longrightarrow> \<not>(\<sigma> \<Turnstile> ((s \<leftarrow> A ; M s)))"
  by(simp add: valid_SE_def unit_SE_def bind_SE_def)

lemma valid_successElem: (* atomic boolean Monad "Query Functions" *)
                         "M \<sigma> = Some(f \<sigma>,\<sigma>) \<Longrightarrow>  (\<sigma> \<Turnstile> M) = f \<sigma>"
  by(simp add: valid_SE_def unit_SE_def bind_SE_def )

lemma valid_success:  "ioprog a \<sigma> = Some(b,\<sigma>') \<Longrightarrow>
                                  (\<sigma>  \<Turnstile> (s \<leftarrow> mbind (a#S) ioprog ; M s)) =
                                  (\<sigma>' \<Turnstile> (s \<leftarrow> mbind S ioprog ; M (b#s)))"
  apply (simp add: valid_SE_def unit_SE_def bind_SE_def )
  apply (cases "mbind S ioprog \<sigma>'", auto)
  done

lemma valid_success'': "ioprog a \<sigma> = Some(b,\<sigma>') \<Longrightarrow>
                                    (\<sigma>  \<Turnstile> (s \<leftarrow> mbind (a#S) ioprog ; return (P s))) =
                                    (\<sigma>' \<Turnstile> (s \<leftarrow> mbind S ioprog ; return (P (b#s))))"
  apply (simp add: valid_SE_def unit_SE_def bind_SE_def )
  apply (cases "mbind S ioprog \<sigma>'")
   apply (simp_all)
  apply (auto)
  done

lemma valid_success':  "A \<sigma> = Some(b,\<sigma>') \<Longrightarrow> (\<sigma> \<Turnstile> ((s \<leftarrow> A ; M s))) = (\<sigma>' \<Turnstile> (M b))"
by(simp add: valid_SE_def unit_SE_def bind_SE_def )

lemma valid_both: "(\<sigma> \<Turnstile> (s \<leftarrow> mbind (a#S) ioprog ; return (P s))) =
                         (case ioprog a \<sigma> of
                               None \<Rightarrow> (\<sigma>  \<Turnstile> (return (P [])))
                             | Some(b,\<sigma>') \<Rightarrow> (\<sigma>'  \<Turnstile> (s \<leftarrow> mbind S ioprog ; return (P (b#s)))))"
  apply (case_tac "ioprog a \<sigma>")
   apply (simp_all add: valid_failure valid_success'' split: prod.splits)
  done

lemma valid_propagate_1 [simp]: "(\<sigma> \<Turnstile> (return P)) = (P)"
  by(auto simp: valid_SE_def unit_SE_def)

lemma valid_propagate_2: "\<sigma> \<Turnstile> ((s \<leftarrow> A ; M s)) \<Longrightarrow>  \<exists> v \<sigma>'. the(A \<sigma>) = (v,\<sigma>') \<and> \<sigma>' \<Turnstile> (M v)"
  apply (auto simp: valid_SE_def unit_SE_def bind_SE_def)
  apply (cases "A \<sigma>")
   apply (simp_all)
  apply (drule_tac x="A \<sigma>" and f=the in arg_cong)
  apply (simp)
  apply (rename_tac a b aa )
  apply (rule_tac x="fst aa" in exI)
  apply (rule_tac x="snd aa" in exI)
  by (auto)

lemma valid_propagate_2': "\<sigma> \<Turnstile> ((s \<leftarrow> A ; M s)) \<Longrightarrow>  \<exists> a. (A \<sigma>) = Some a \<and> (snd a) \<Turnstile> (M (fst a))"
  apply (auto simp: valid_SE_def unit_SE_def bind_SE_def)
  apply (cases "A \<sigma>")
   apply (simp_all)
  apply (simp_all split: prod.splits)
  apply (drule_tac x="A \<sigma>" and f=the in arg_cong)
  apply (simp)
  apply (rename_tac a b aa x1 x2)
  apply (rule_tac x="fst aa" in exI)
  apply (rule_tac x="snd aa" in exI)
  apply (auto)
  done

lemma valid_propagate_2'': "\<sigma> \<Turnstile> ((s \<leftarrow> A ; M s)) \<Longrightarrow> \<exists> v \<sigma>'. A \<sigma> = Some(v,\<sigma>') \<and> \<sigma>' \<Turnstile> (M v)"
  apply (auto simp: valid_SE_def unit_SE_def bind_SE_def)
  apply (cases "A \<sigma>")
   apply (simp_all)
  apply (drule_tac x="A \<sigma>" and f=the in arg_cong)
  apply (simp)
  apply (rename_tac a b aa )
  apply (rule_tac x="fst aa" in exI)
  apply (rule_tac x="snd aa" in exI)
  apply (auto)
  done

lemma valid_propoagate_3[simp]: "(\<sigma>\<^sub>0 \<Turnstile> (\<lambda>\<sigma>. Some (f \<sigma>, \<sigma>))) = (f \<sigma>\<^sub>0)"
  by(simp add: valid_SE_def )

lemma valid_propoagate_3'[simp]: "\<not>(\<sigma>\<^sub>0 \<Turnstile> (\<lambda>\<sigma>. None))"
  by(simp add: valid_SE_def )

lemma assert_disch1 :" P \<sigma> \<Longrightarrow> (\<sigma> \<Turnstile> (x \<leftarrow> assert\<^sub>S\<^sub>E P; M x)) = (\<sigma> \<Turnstile> (M True))"
  by(auto simp: bind_SE_def assert_SE_def valid_SE_def)

lemma assert_disch2 :" \<not> P \<sigma> \<Longrightarrow> \<not> (\<sigma> \<Turnstile> (x \<leftarrow> assert\<^sub>S\<^sub>E P ; M s))"
  by(auto simp: bind_SE_def assert_SE_def valid_SE_def)

lemma assert_disch3 :" \<not> P \<sigma> \<Longrightarrow> \<not> (\<sigma> \<Turnstile> (assert\<^sub>S\<^sub>E P))"
  by(auto simp: bind_SE_def assert_SE_def valid_SE_def)

lemma assert_D : "(\<sigma> \<Turnstile> (x \<leftarrow> assert\<^sub>S\<^sub>E P; M x)) \<Longrightarrow> P \<sigma> \<and> (\<sigma> \<Turnstile> (M True))"
  by(auto simp: bind_SE_def assert_SE_def valid_SE_def split: HOL.if_split_asm)

lemma assume_D : "(\<sigma> \<Turnstile> (x \<leftarrow> assume\<^sub>S\<^sub>E P; M x)) \<Longrightarrow> \<exists> \<sigma>. (P \<sigma> \<and>  \<sigma> \<Turnstile> (M ()))"
  apply (auto simp: bind_SE_def assume_SE_def valid_SE_def split: HOL.if_split_asm)
  apply (rule_tac x="Eps P" in exI)
  apply (auto)[1]
  subgoal for x a b
    apply (rule_tac x="True" in exI, rule_tac x="b" in exI)
    apply (subst Hilbert_Choice.someI)
     apply (assumption)
    apply (simp)
    done
  apply (subst Hilbert_Choice.someI,assumption)
  apply (simp)
  done

text\<open>
  These two rule prove that the SE Monad in connection with the notion of valid sequence is
  actually sufficient for a representation of a Boogie-like language. The SBE monad with explicit
  sets of states---to be shown below---is strictly speaking not necessary (and will therefore
  be discontinued in the development).
\<close>

lemma if_SE_D1 : "P \<sigma> \<Longrightarrow> (\<sigma> \<Turnstile> if\<^sub>S\<^sub>E P B\<^sub>1 B\<^sub>2) = (\<sigma> \<Turnstile> B\<^sub>1)"
  by(auto simp: if_SE_def valid_SE_def)

lemma if_SE_D2 : "\<not> P \<sigma> \<Longrightarrow> (\<sigma> \<Turnstile> if\<^sub>S\<^sub>E P B\<^sub>1 B\<^sub>2) = (\<sigma> \<Turnstile> B\<^sub>2)"
  by(auto simp: if_SE_def valid_SE_def)

lemma if_SE_split_asm : " (\<sigma> \<Turnstile> if\<^sub>S\<^sub>E P B\<^sub>1 B\<^sub>2) = ((P \<sigma> \<and> (\<sigma> \<Turnstile> B\<^sub>1)) \<or> (\<not> P \<sigma> \<and> (\<sigma> \<Turnstile> B\<^sub>2)))"
  by(cases "P \<sigma>",auto simp: if_SE_D1 if_SE_D2)

lemma if_SE_split : " (\<sigma> \<Turnstile> if\<^sub>S\<^sub>E P B\<^sub>1 B\<^sub>2) = ((P \<sigma> \<longrightarrow> (\<sigma> \<Turnstile> B\<^sub>1)) \<and> (\<not> P \<sigma> \<longrightarrow> (\<sigma> \<Turnstile> B\<^sub>2)))"
  by(cases "P \<sigma>", auto simp: if_SE_D1 if_SE_D2)


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory SPRViewSingle
imports
  KBPsAlg
  SPRView
  List_local
  ODList
  Trie
  "~~/src/HOL/Library/Mapping"
begin
(*>*)

subsection{*Perfect Recall for a Single Agent*}

text{*

\label{sec:kbps-spr-single-agent}

We capture our expectations of a single-agent scenario in the
following locale:

*}

locale FiniteSingleAgentEnvironment =
  FiniteEnvironment jkbp envInit envAction envTrans envVal envObs
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "('s :: {finite, linorder}) list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
+ fixes agent :: "'a"
  assumes envSingleAgent: "a = agent"

text{*

As per the clock semantics of \S\ref{sec:kbps-theory-clock-view}, we
assume that the set of states is finite and linearly ordered. We give
the sole agent the name @{text "agent"}.

Our simulation is quite similar to the one for the clock semantics of
\S\ref{sec:kbps-theory-clock-view}: it records the set of worlds that
the agent considers possible relative to a trace and the SPR view. The
key difference is that it is path-sensitive:

*}

context FiniteSingleAgentEnvironment
begin

definition spr_abs :: "'s Trace \<Rightarrow> 's set" where
  "spr_abs t \<equiv>
    tLast ` { t' \<in> SPR.jkbpC . spr_jview agent t' = spr_jview agent t }"

type_synonym (in -) 's spr_simWorlds = "'s set \<times> 's"

definition spr_sim :: "'s Trace \<Rightarrow> 's spr_simWorlds" where
  "spr_sim \<equiv> \<lambda>t. (spr_abs t, tLast t)"
(*<*)

lemma spr_absI[elim]:
  "\<lbrakk> t' \<in> SPR.jkbpC; spr_jview a t' = spr_jview a t; v = tLast t' \<rbrakk>
    \<Longrightarrow> v \<in> spr_abs t"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by blast

lemma spr_abs_tLastD[simp]:
  "v \<in> spr_abs t \<Longrightarrow> envObs a v = envObs a (tLast t)"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by auto

lemma spr_abs_conv:
  "v \<in> spr_abs t
    \<longleftrightarrow> (\<exists>t'. t' \<in> SPR.jkbpC \<and> spr_jview a t' = spr_jview a t \<and> v = tLast t')"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by blast

lemma spr_abs_eq[dest]:
  "spr_jview a t = spr_jview a t' \<Longrightarrow> spr_abs t = spr_abs t'"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by auto

lemma spr_abs_refl[intro, simp]:
  "t \<in> SPR.jkbpC \<Longrightarrow> tLast t \<in> spr_abs t"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by auto

lemma spr_sim_simps[simp]:
  "fst (spr_sim t) = spr_abs t"
  unfolding spr_sim_def by simp

(*>*)
text{*

The Kripke structure for this simulation relates worlds for @{term
"agent"} if the sets of states it considers possible coincide, and the
observation of the final states of the trace is the same. Propositions
are evaluated at the final state.

*}

definition spr_simRels :: "'a \<Rightarrow> 's spr_simWorlds Relation" where
  "spr_simRels \<equiv> \<lambda>a. { ((U, u), (V, v)) |U u V v.
                         U = V \<and> {u, v} \<subseteq> U \<and> envObs a u = envObs a v }"

definition spr_simVal :: "'s spr_simWorlds \<Rightarrow> 'p \<Rightarrow> bool" where
  "spr_simVal \<equiv> envVal \<circ> snd"

abbreviation spr_simMC :: "('a, 'p, 's spr_simWorlds) KripkeStructure" where
  "spr_simMC \<equiv> mkKripke (spr_sim ` SPR.jkbpC) spr_simRels spr_simVal"
(*<*)

lemma spr_simVal[iff]:
  "spr_simVal (spr_sim t) = envVal (tLast t)"
  unfolding spr_sim_def spr_simVal_def by simp

lemma spr_sim_r:
  "sim_r SPR.MC spr_simMC spr_sim"
proof
  fix a t v'
  assume t: "t \<in> worlds SPR.MC"
     and tv': "(spr_sim t, v') \<in> relations spr_simMC a"
  from tv' obtain s
    where vv': "v' = (spr_abs t, s)"
      and st: "s \<in> spr_abs t"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by auto
  from st obtain v
    where "v \<in> SPR.jkbpC"
      and "spr_jview a v = spr_jview a t"
      and "tLast v = s"
    by (auto(*<*)iff: spr_abs_conv(*>*))
  with t vv'
  have "(t, v) \<in> relations SPR.MC a"
   and "spr_sim v = v'"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by auto
  thus "\<exists>v. (t, v) \<in> relations SPR.MC a \<and> spr_sim v = v'" by blast
qed

(*>*)
text{*

Demonstrating that this is a simulation
(\S\ref{sec:kripke-theory-simulations}) is straightforward.

*}

lemma spr_sim: "sim SPR.MC spr_simMC spr_sim"
(*<*)
proof
  show "sim_f SPR.MC spr_simMC spr_sim"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by (rule) auto
next
  show "sim_r SPR.MC spr_simMC spr_sim"
    by (rule spr_sim_r)
qed auto

(*>*)
text{**}
end (* context FiniteSingleAgentEnvironment *)

sublocale FiniteSingleAgentEnvironment
        < SPRsingle!: SimIncrEnvironment jkbp envInit envAction envTrans envVal
                                       spr_jview envObs spr_jviewInit spr_jviewIncr
                                       spr_sim spr_simRels spr_simVal
(*<*)
  by default (rule spr_sim)
(*>*)

(* **************************************** *)

subsubsection{* Representations *}

text{*

\label{sec:kbps-theory-spr-single-rep}

As in \S\ref{sec:kbps-theory-clock-view-algops}, we quotient @{typ "'s
spr_simWorlds"} by @{term "spr_simRels"}. Because there is only a
single agent, an element of this quotient corresponding to a cononical
trace @{term "t"} is isomorphic to the set of states that are possible
given the sequence of observations made by @{term "agent"} on @{term
"t"}. Therefore we have a very simple representation:

*}

context FiniteSingleAgentEnvironment
begin

type_synonym (in -) 's spr_simWorldsRep = "'s odlist"

text{*

It is very easy to map these representations back to simulated
equivalence classes:

*}

definition
  spr_simAbs :: "'s spr_simWorldsRep \<Rightarrow> 's spr_simWorlds set"
where
  "spr_simAbs \<equiv> \<lambda>ss. { (toSet ss, s) |s. s \<in> toSet ss }"

text{*

This time our representation is unconditionally canonical:

*}

lemma spr_simAbs_inj: "inj spr_simAbs"
(*<*)
  apply (rule injI)
  unfolding spr_simAbs_def
  apply (subgoal_tac "toSet x = toSet y")
  apply auto
  using toSet_inj
  apply (erule injD)
  done

lemma spr_sim_rep_abs[simp]:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "toSet ec = spr_abs t"
proof
  show "toSet ec \<subseteq> spr_abs t"
  proof
    fix x assume x: "x \<in> toSet ec"
    hence "(toSet ec, x) \<in> spr_simAbs ec"
      unfolding spr_simAbs_def by simp
    with ec have "(toSet ec, x) \<in> SPRsingle.sim_equiv_class a t"
      by simp
    with x envSingleAgent[where a=a] show "x \<in> spr_abs t"
      unfolding spr_sim_def spr_abs_def by auto
  qed
next
  show "spr_abs t \<subseteq> toSet ec"
  proof
    fix x assume x: "x \<in> spr_abs t"
    with ec envSingleAgent[where a=a] show "x \<in> toSet ec"
      unfolding spr_simAbs_def spr_sim_def spr_abs_def by auto
  qed
qed

lemma spr_sim_rep_abs_syn[simp]:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  shows "set (toList ec) = spr_abs t"
  using spr_sim_rep_abs[OF ec] unfolding toSet_def by simp

lemma spr_simAbs_list:
  "spr_simAbs ` fromList ` X = (\<lambda>ss. { (ss, s) |s. s \<in> ss }) ` set ` X"
  unfolding spr_simAbs_def Set.image_def by auto

(*>*)
text{*

We again make use of the following Kripke structure, where the worlds
are the final states of the subset of the temporal slice that @{term
"agent"} believes possible:

*}

definition spr_repRels :: "'a \<Rightarrow> ('s \<times> 's) set" where
  "spr_repRels \<equiv> \<lambda>a. { (s, s'). envObs a s' = envObs a s }"

abbreviation spr_repMC :: "'s set \<Rightarrow> ('a, 'p, 's) KripkeStructure" where
  "spr_repMC \<equiv> \<lambda>X. mkKripke X spr_repRels envVal"

text{*

Similarly we show that this Kripke structure is adequate by
introducing an intermediate structure and connecting them all with a
tower of simulations:

*}

abbreviation spr_jkbpCSt :: "'s Trace \<Rightarrow> 's spr_simWorlds set" where
  "spr_jkbpCSt t \<equiv> SPRsingle.sim_equiv_class agent t"

abbreviation
  spr_simMCt :: "'s Trace \<Rightarrow> ('a, 'p, 's spr_simWorlds) KripkeStructure"
where
  "spr_simMCt t \<equiv> mkKripke (spr_jkbpCSt t) spr_simRels spr_simVal"

definition spr_repSim :: "'s spr_simWorlds \<Rightarrow> 's" where
  "spr_repSim \<equiv> snd"
(*<*)

lemma spr_repMC_kripke[intro, simp]: "kripke (spr_repMC X)"
  by (rule kripkeI) simp

lemma spr_repMC_S5n[intro, simp]: "S5n (spr_repMC X)"
  unfolding spr_repRels_def
  by (intro S5nI equivI refl_onI symI transI) auto

lemma jkbpCSt_jkbpCS_subset:
  "SPRsingle.sim_equiv_class agent t \<subseteq> spr_sim ` SPR.jkbpC"
  by auto

lemma spr_simRep_sim_simps[simp]:
  "spr_repSim ` spr_sim ` T = tLast ` T"
  "spr_repSim (spr_sim t) = tLast t"
  unfolding spr_repSim_def spr_sim_def Set.image_def by auto

(*>*)
text{**}

lemma spr_repSim:
  assumes tC: "t \<in> SPR.jkbpC"
  shows "sim (spr_simMCt t)
             ((spr_repMC \<circ> fst) (spr_sim t))
             spr_repSim"
(*<*) (is "sim ?M ?M' ?f")
proof
  show "sim_range ?M ?M' ?f"
  proof
    show "worlds ?M' = ?f ` worlds ?M"
      unfolding spr_sim_def spr_repSim_def spr_abs_def Set.image_def
      by auto
  next
    fix a
    show "relations ?M' a \<subseteq> worlds ?M' \<times> worlds ?M'"
      unfolding spr_sim_def spr_repSim_def by simp
  qed
next
  show "sim_val ?M ?M' ?f"
    unfolding spr_sim_def spr_simVal_def spr_repSim_def by auto
next
  from tC
  show "sim_f ?M ?M' ?f"
    unfolding spr_sim_def spr_simVal_def spr_repSim_def
    apply -
    apply rule
    apply (cut_tac a=a in envSingleAgent)
    apply (auto iff: spr_sim_def spr_repRels_def)
    apply (rule spr_tLast)
    apply auto
    done
next
  show "sim_r ?M ?M' ?f"
    unfolding spr_sim_def spr_simVal_def spr_repSim_def
    apply -
    apply rule
    apply (cut_tac a=a in envSingleAgent)
    unfolding spr_abs_def spr_sim_def spr_repRels_def spr_simRels_def Set.image_def
    apply auto
    done
qed

(*>*)
text{*

As before, the following sections discharge the requirements of the
@{text "Algorithm"} locale of Figure~\ref{fig:kbps-alg-alg-locale}.

*}

(* **************************************** *)

subsubsection{* Initial states *}

text{*

The initial states of the automaton for @{term "agent"} is simply the
partition of @{term "envInit"} under @{term "agent"}'s observation.

*}

definition (in -)
  spr_simInit :: "('s :: linorder) list \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                     \<Rightarrow> 'a \<Rightarrow> 'obs \<Rightarrow> 's spr_simWorldsRep"
where
  "spr_simInit envInit envObs \<equiv> \<lambda>a iobs.
    ODList.fromList [ s. s \<leftarrow> envInit, envObs a s = iobs ]"
(*<*)

abbreviation
  spr_simInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 's spr_simWorldsRep"
where
  "spr_simInit \<equiv> SPRViewSingle.spr_simInit envInit envObs"

(*>*)
text{**}

lemma spr_simInit:
  assumes "iobs \<in> envObs a ` set envInit"
  shows "spr_simAbs (spr_simInit a iobs)
       = spr_sim ` { t' \<in> SPR.jkbpC. spr_jview a t' = spr_jviewInit a iobs }"
(*<*)
  using assms
  unfolding spr_simInit_def
  using envSingleAgent[where a=a]
  unfolding spr_simAbs_def spr_sim_def [abs_def] spr_abs_def
  apply (auto iff: spr_jview_def SPR.jviewInit)
   apply (rule_tac x="tInit s" in image_eqI)
    apply (auto iff: spr_jview_def)[1]
    apply (rule_tac x="tInit xa" in image_eqI)
    apply auto[1]
   apply simp
   apply simp
  apply (rule_tac x="tInit xa" in image_eqI)
  apply auto
  done
(*>*)

(* **************************************** *)

subsubsection{* Simulated observations *}

text{*

As the agent makes the same observation on the entire equivalence
class, we arbitrarily choose the first element of the representation:

*}

definition (in -)
  spr_simObs :: "('a \<Rightarrow> 's \<Rightarrow> 'obs)
               \<Rightarrow> 'a \<Rightarrow> ('s :: linorder) spr_simWorldsRep \<Rightarrow> 'obs"
where
  "spr_simObs envObs \<equiv> \<lambda>a. envObs a \<circ> ODList.hd"
(*<*)

abbreviation
  spr_simObs :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 'obs"
where
  "spr_simObs \<equiv> SPRViewSingle.spr_simObs envObs"

(*>*)
text{**}

lemma spr_simObs:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "spr_simObs a ec = envObs a (tLast t)"
(*<*)
proof -
  have A: "\<forall>s \<in> set (toList ec). envObs a s = envObs a (tLast t)"
    using spr_sim_rep_abs[OF ec] by (simp add: toSet_def)
  from tC ec have B: "tLast t \<in> set (toList ec)"
    using envSingleAgent[where a=a] by simp
  show ?thesis
    unfolding spr_simObs_def
    by (simp add: list_choose_hd[OF A B] ODList.hd_def)
qed
(*>*)

(* **************************************** *)

subsubsection{* Evaluation *}

text{*

\label{sec:kbps-spr-single-agent-eval}

As the single-agent case is much simpler than the multi-agent ones, we
define an evaluation function specialised to its representation.

Intuitively @{term "eval"} yields the subset of @{term "X"} where the
formula holds, where @{term "X"} is taken to be a representation of a
canonical equivalence class for @{term "agent"}.

*}

fun (in -)
  eval :: "(('s :: linorder) \<Rightarrow> 'p \<Rightarrow> bool)
        \<Rightarrow> 's odlist \<Rightarrow> ('a, 'p) Kform \<Rightarrow> 's odlist"
where
  "eval val X (Kprop p)      = ODList.filter (\<lambda>s. val s p) X"
| "eval val X (Knot \<phi>)       = ODList.difference X (eval val X \<phi>)"
| "eval val X (Kand \<phi> \<psi>)     = ODList.intersect (eval val X \<phi>) (eval val X \<psi>)"
| "eval val X (Kknows a \<phi>)   = (if eval val X \<phi> = X then X else ODList.empty)"
| "eval val X (Kcknows as \<phi>) =
                     (if as = [] \<or> eval val X \<phi> = X then X else ODList.empty)"

text{*

In general this is less efficient than the tableau approach of
\citet[Proposition~3.2.1]{FHMV:1995}, which labels all states with all
formulas. However it is often the case that the set of relevant worlds
is much smaller than the set of all system states.

Showing that this corresponds with the standard models relation is
routine.

*}
(*<*)

lemma eval_ec_subseteq:
  shows "toSet (eval envVal ec \<phi>) \<subseteq> toSet ec"
  by (induct \<phi>) auto

lemma eval_models_aux:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  assumes s: "s \<in> toSet ec"
  shows "s \<in> toSet (eval envVal ec \<phi>) \<longleftrightarrow> spr_repMC (toSet ec), s \<Turnstile> \<phi>"
using s
proof(induct \<phi> arbitrary: s)
  case (Kknows a \<phi> s) with ec envSingleAgent[where a=a] show ?case
    unfolding spr_repRels_def
    by (auto simp: inj_eq[OF toSet_inj, symmetric] dest: subsetD[OF eval_ec_subseteq])
next
  case (Kcknows as \<phi> s)
  from ec show ?case
  proof(cases as)
    case Nil with Kcknows show ?thesis by clarsimp
  next
    case (Cons x xs)
    hence "set as = {agent}"
      by (induct as) (auto simp: envSingleAgent)
    moreover
    have "(spr_repRels agent \<inter> toSet ec \<times> toSet ec)\<^sup>+ = (spr_repRels agent \<inter> toSet ec \<times> toSet ec)"
      by (rule trancl_id) (simp add: spr_repRels_def trans_def)
    moreover note Kcknows ec
    ultimately show ?thesis
      unfolding spr_repRels_def
      by (auto simp: inj_eq[OF toSet_inj, symmetric] dest: subsetD[OF eval_ec_subseteq])
  qed
qed simp_all

lemma eval_all_or_nothing:
  assumes subj_phi: "subjective agent \<phi>"
  shows "toSet (eval envVal ec \<phi>) = {} \<or> toSet (eval envVal ec \<phi>) = toSet ec"
  using subj_phi by (induct \<phi> rule: subjective.induct) auto
(*>*)

lemma eval_models:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  assumes subj: "subjective agent \<phi>"
  assumes s: "s \<in> toSet ec"
  shows "toSet (eval envVal ec \<phi>) \<noteq> {} \<longleftrightarrow> spr_repMC (toSet ec), s \<Turnstile> \<phi>"
(*<*)
  using eval_models_aux[OF ec s, symmetric] eval_all_or_nothing[OF subj] s
  by auto
(*>*)

(* **************************************** *)

subsubsection{* Simulated actions *}

text{*

The actions enabled on a canonical equivalence class are those for
which @{term "eval"} yields a non-empty set of states:

*}

definition (in -)
  spr_simAction :: "('a, 'p, 'aAct) KBP \<Rightarrow> (('s :: linorder) \<Rightarrow> 'p \<Rightarrow> bool)
                     \<Rightarrow> 'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 'aAct list"
where
  "spr_simAction kbp envVal \<equiv> \<lambda>a X.
    [ action gc. gc \<leftarrow> kbp, eval envVal X (guard gc) \<noteq> ODList.empty ]"
(*<*)

abbreviation
  spr_simAction :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 'aAct list"
where
  "spr_simAction \<equiv> SPRViewSingle.spr_simAction (jkbp agent) envVal"

(*>*)
text{*

The key lemma relates the agent's behaviour on an equivalence class to
that on its representation:

*}

lemma spr_simAction_jAction:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  shows "set (spr_simAction agent ec)
       = set (jAction (spr_repMC (toSet ec)) (tLast t) agent)"
(*<*)
proof -
  have "\<And>P. (set (jkbp agent) \<inter> {gc. P gc})
      = { gc \<in> set (jkbp agent). P gc }"
    by blast
  then
  show ?thesis
    unfolding spr_simAction_def jAction_def
    apply clarsimp
    apply (rule SUP_cong)
     apply simp_all
     apply (rule Collect_cong)
     apply rule
      apply clarsimp
      apply (subst eval_models[OF ec, symmetric])
        apply (simp_all add: toSet_eq_iff)
       using subj tC ec
       apply (fastforce+)[2]
    apply clarsimp
    apply (subst (asm) eval_models[OF ec, symmetric])
    using subj tC ec
    apply fastforce+
    done (* FIXME improve *)
qed

lemma spr_submodel_aux:
  assumes tC: "t \<in> SPR.jkbpC"
      and s: "s \<in> worlds (spr_simMCt t)"
  shows "gen_model SPRsingle.MCS s = gen_model (spr_simMCt t) s"
proof(rule gen_model_subset[where T="SPRsingle.sim_equiv_class agent t"])
  fix a
  let ?X = "SPRsingle.sim_equiv_class agent t"
  show "relations SPRsingle.MCS a \<inter> ?X \<times> ?X
      = relations (spr_simMCt t) a \<inter> ?X \<times> ?X"
    by (simp add: Int_ac Int_absorb1
                  relation_mono[OF jkbpCSt_jkbpCS_subset jkbpCSt_jkbpCS_subset])
next
  let ?X = "SPRsingle.sim_equiv_class agent t"
  from s show "(\<Union>a. relations (spr_simMCt t) a)\<^sup>* `` {s} \<subseteq> ?X"
    apply (clarsimp simp del: mkKripke_simps)
    apply (erule kripke_rels_trc_worlds)
    apply auto
    done
next
  let ?Y = "{ t' \<in> SPR.jkbpC . spr_jview agent t' = spr_jview agent t }"
  let ?X = "spr_sim ` ?Y"
  from s obtain t'
    where st': "s = spr_sim t'"
      and t'C: "t' \<in> SPR.jkbpC"
      and t'O: "spr_jview agent t = spr_jview agent t'"
    by fastforce
  { fix t''
    assume tt': "(t', t'') \<in> (\<Union>a. relations SPR.MC a)\<^sup>*"
    from t'C tt' have t''C: "t'' \<in> SPR.jkbpC"
      by - (erule kripke_rels_trc_worlds, simp_all)
    from tt' t'O have t''O: "spr_jview agent t = spr_jview agent t''"
      apply induct
      unfolding SPR.mkM_def
      apply auto
      apply (cut_tac a=x in envSingleAgent)
      apply simp
      done
    from t''C t''O have "t'' \<in> ?Y" by simp }
  hence "(\<Union>a. relations SPR.MC a)\<^sup>* `` {t'} \<subseteq> ?Y"
    by clarsimp
  hence "spr_sim ` ((\<Union>a. relations SPR.MC a)\<^sup>* `` {t'}) \<subseteq> ?X"
    by (rule image_mono)
  with st' t'C
  show "(\<Union>a. relations SPRsingle.MCS a)\<^sup>* `` {s} \<subseteq> ?X"
    using sim_trc_commute[OF SPR.mkM_kripke spr_sim, where t=t'] by simp
qed (insert s, auto)

(*>*)
text{*

The @{text "Algorithm"} locale requires the following lemma, which is
a straightforward chaining of the above simulations.

*}

lemma spr_simAction:
  assumes tC: "t \<in> SPR.jkbpC"
      and ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "set (spr_simAction a ec) = set (jAction SPR.MC t a)"
(*<*)
proof -
  from ec
  have ec': "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
    by (simp only: envSingleAgent[where a=a])
  have "set (spr_simAction a ec) = set (spr_simAction agent ec)"
    by (simp only: envSingleAgent[where a=a])
  also from tC ec' have "... = set (jAction (spr_repMC (toSet ec)) (tLast t) agent)"
    by (rule spr_simAction_jAction)
  also from tC ec' have "... = set (jAction (spr_simMCt t) (spr_sim t) agent)"
    by (simp add: simulation_jAction_eq[OF _ spr_repSim])
  also from tC have "... = set (jAction SPRsingle.MCS (spr_sim t) agent)"
    using gen_model_jAction_eq[OF spr_submodel_aux[OF tC, where s="spr_sim t"], where w'="spr_sim t"]
          gen_model_world_refl[where w="spr_sim t" and M="spr_simMCt t"]
    by simp
  also from tC have "... = set (jAction SPR.MC t agent)"
    by (simp add: simulation_jAction_eq[OF _ spr_sim])
  finally show ?thesis by (simp only: envSingleAgent[where a=a])
qed
(*>*)

(* **************************************** *)

subsubsection{* Simulated transitions *}

text{*

It is straightforward to determine the possible successor states of a
given canonical equivalence class @{term "X"}:

*}

definition (in -)
  spr_trans :: "('a, 'p, 'aAct) KBP
              \<Rightarrow> ('s \<Rightarrow> 'eAct list)
              \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
              \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
              \<Rightarrow> 'a \<Rightarrow> ('s :: linorder) spr_simWorldsRep \<Rightarrow> 's list"
where
  "spr_trans kbp envAction envTrans val \<equiv> \<lambda>a X.
    [ envTrans eact (\<lambda>a'. aact) s .
       s \<leftarrow> toList X, eact \<leftarrow> envAction s, aact \<leftarrow> spr_simAction kbp val a X ]"
(*<*)

abbreviation
  spr_trans :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 's list"
where
  "spr_trans \<equiv> SPRViewSingle.spr_trans (jkbp agent) envAction envTrans envVal"

(*>*)
text{*

Using this function we can determine the set of possible successor
equivalence classes from @{term "X"}:

*}

abbreviation (in -) envObs_rel :: "('s \<Rightarrow> 'obs) \<Rightarrow> 's \<times> 's \<Rightarrow> bool" where
  "envObs_rel envObs \<equiv> \<lambda>(s, s'). envObs s' = envObs s"

definition (in -)
  spr_simTrans :: "('a, 'p, 'aAct) KBP
                 \<Rightarrow> (('s::linorder) \<Rightarrow> 'eAct list)
                 \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
                 \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
                 \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                 \<Rightarrow> 'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 's spr_simWorldsRep list"
where
  "spr_simTrans kbp envAction envTrans val envObs \<equiv> \<lambda>a X.
    map ODList.fromList (partition (envObs_rel (envObs a))
                                   (spr_trans kbp envAction envTrans val a X))"
(*<*)

abbreviation
  spr_simTrans :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 's spr_simWorldsRep list"
where
  "spr_simTrans \<equiv> SPRViewSingle.spr_simTrans (jkbp agent) envAction envTrans envVal envObs"

lemma envObs_rel_equiv:
  "equiv UNIV (rel_ext (envObs_rel (envObs agent)))"
  by (intro equivI refl_onI symI transI) auto

lemma spr_trans:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  shows "set (spr_trans agent ec)
       = { s |t' s. t' \<leadsto> s \<in> SPR.jkbpC \<and> spr_jview agent t' = spr_jview agent t }" (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
  proof
    fix x assume x: "x \<in> ?lhs"
    with assms show "x \<in> ?rhs"
      unfolding spr_trans_def
      apply (clarsimp simp del: split_paired_Ex split_paired_All)
      apply (frule spr_sim_rep_abs)
      unfolding toSet_def
      apply clarsimp

      apply (simp only: spr_abs_conv[where a=agent])
      apply clarify

      apply (rule_tac x="t'" in exI)
      apply simp
      apply (rule_tac n="Suc (tLength t')" in SPR.jkbpCn_jkbpC_inc)
      apply (auto iff: Let_def simp del: split_paired_Ex split_paired_All)

      apply (rule_tac x=xa in exI)
      apply (rule_tac x="\<lambda>a'. aact" in exI)
      apply auto
      apply (subst envSingleAgent)
      apply (simp add: spr_simAction[where a=agent])
      apply (subst SPR.jkbpC_jkbpCn_jAction_eq[symmetric])
      apply auto
      apply (subst S5n_jAction_eq[where w'=t])
      apply simp_all
      unfolding SPR.mkM_def
      apply simp
      done
  qed
next
  show "?rhs \<subseteq> ?lhs"
  proof
    fix s assume s: "s \<in> ?rhs"
    then obtain t'
      where t'sC: "t' \<leadsto> s \<in> SPR.jkbpC"
        and tt': "spr_jview agent t' = spr_jview agent t"
      by blast
    from t'sC have t'Cn: "t' \<in> SPR.jkbpCn (tLength t')" by blast
    from t'sC obtain eact aact
      where eact: "eact \<in> set (envAction (tLast t'))"
        and aact: "\<forall>a. aact a \<in> set (jAction (SPR.mkM (SPR.jkbpCn (tLength t'))) t' a)"
        and s: "s = envTrans eact aact (tLast t')"
      using SPR.jkbpC_tLength_inv[where t="t' \<leadsto> s" and n="Suc (tLength t')"]
      by (auto iff: Let_def)
    from tC ec s eact aact tt' t'sC
    show "s \<in> ?lhs"
      unfolding spr_trans_def
      apply (clarsimp)
      apply (rule bexI[where x="tLast t'"])
      apply (rule bexI[where x=eact])
      apply simp_all
       prefer 2
       apply (blast intro: spr_absI)
      apply (simp add: spr_simAction[where a=agent])
      apply (rule image_eqI[where x="aact agent"])
       apply (subgoal_tac "(\<lambda>a'. aact agent) = aact")
        apply simp
       apply (rule ext)
       apply (cut_tac a=a' in envSingleAgent)
       apply simp
      apply (erule allE[where x=agent])
      apply (subst SPR.jkbpC_jkbpCn_jAction_eq)
      apply auto
      apply (subst S5n_jAction_eq[where w=t and w'=t'])
        apply simp
       apply (unfold SPR.mkM_def)[1]
       apply simp
       apply (blast dest: SPR.sync[rule_format])
      apply (auto dest: SPR.sync[rule_format])
      done
  qed
qed

(*>*)
text{*

The @{text "partition"} function splits a list into equivalence
classes under the given equivalence relation.

The property asked for by the @{text "Algorithm"} locale follows from
the properties of @{text "partition"} and @{text "spr_trans"}:

*}

lemma spr_simTrans:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "spr_simAbs ` set (spr_simTrans a ec)
      = { SPRsingle.sim_equiv_class a (t' \<leadsto> s)
          |t' s. t' \<leadsto> s \<in> SPR.jkbpC \<and> spr_jview a t' = spr_jview a t}"
(*<*) (is "?lhs a = ?rhs a")
proof -
  from ec have ec': "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
    by (simp only: envSingleAgent[where a=a])
  from ec' have "?lhs agent = ?rhs agent"
    unfolding spr_simTrans_def
    apply clarsimp
    apply (simp only: spr_simAbs_list partition[OF envObs_rel_equiv subset_UNIV] spr_trans[OF tC ec'])
    apply clarsimp
    apply rule

     (* left to right *)

     apply clarsimp
     apply (erule quotientE)
     apply clarsimp
     apply (rule_tac x=t' in exI)
     apply (rule_tac x=x in exI)
     apply clarsimp
     apply rule
      apply clarsimp
      apply (rule_tac x="t'a \<leadsto> s" in image_eqI)
       apply (unfold spr_sim_def [abs_def] spr_abs_def)[1]
       apply clarsimp
       apply (auto iff: spr_jview_def)[1]
        apply (rule_tac x="t'c \<leadsto> xa" in image_eqI)
         apply simp
        apply simp
       apply (simp add: spr_jview_def)
     apply clarsimp
     apply (frule spr_jview_tStep_eq_inv)
     apply clarsimp
     apply (rule_tac x=s' in exI)
     apply (unfold spr_sim_def [abs_def] spr_abs_def)[1]
     apply clarsimp
     apply (auto iff: spr_jview_def)[1]
      apply (rule_tac x="t'b \<leadsto> xa" in image_eqI)
       apply simp
       apply simp

     (* right to left *)

     apply clarsimp
     apply (rule_tac x="spr_abs (t' \<leadsto> s)" in image_eqI)
      apply rule
       apply clarsimp
       apply (frule spr_jview_tStep_eq_inv)
       apply clarsimp
       apply (unfold spr_sim_def [abs_def])[1]
       apply clarsimp
       apply rule
        apply (erule spr_abs_eq)
       apply (erule spr_absI[where a=agent]) back
        apply simp
       apply simp
      apply clarsimp
      apply (simp only: spr_abs_conv[where a=agent])
      apply clarsimp
      apply (frule spr_jview_tStep_eq_inv)
      apply clarsimp
      apply (rule_tac x="t'' \<leadsto> s'" in image_eqI)
       apply (unfold spr_sim_def [abs_def])[1]
       apply clarsimp
       apply blast
      apply blast
     apply (rule_tac x=s in quotientI2)
      apply auto[1]
     apply rule
      apply clarsimp
      apply rule
       apply blast
      apply (cut_tac v=x and t="t' \<leadsto> s" in spr_abs_conv[where a=agent])
      apply clarsimp
      apply (frule spr_jview_tStep_eq_inv)
      apply clarsimp
      apply (rule_tac x=t'' in exI)
      apply (simp add: Let_def spr_jview_def)
     apply clarsimp
     apply (erule spr_absI[where a=agent]) back back
     apply (auto iff: spr_jview_def)
     done
   thus "?lhs a = ?rhs a" by (simp only: envSingleAgent[where a=a])
qed

(*>*)
text{**}

end (* context FiniteSingleAgentEnvironment *)

(* **************************************** *)

subsubsection{* Maps *}

text{*

\label{sec:kbps-theory-spr-single-maps}

As in \S\ref{sec:kbps-theory-clock-view-maps}, we use a pair of tries
and an association list to handle the automata representation. Recall
that the keys of these tries are lists of system states.

*}

type_synonym ('s, 'obs) spr_trans_trie = "('s, ('obs, 's odlist) mapping) trie"
type_synonym ('s, 'aAct) spr_acts_trie = "('s, ('s, 'aAct) trie) trie"
(*<*)

definition
  trans_MapOps_lookup :: "('s::linorder, 'obs) spr_trans_trie
                        \<Rightarrow> 's odlist \<times> 'obs \<rightharpoonup> 's odlist"
where
  "trans_MapOps_lookup \<equiv> \<lambda>m k.
     Option.bind (trie_odlist_lookup m (fst k)) (\<lambda>m'. Mapping.lookup m' (snd k))"

definition
  trans_MapOps_update :: "'s odlist \<times> 'obs \<Rightarrow> ('s :: linorder) odlist
                        \<Rightarrow> ('s, ('obs, 's odlist) mapping) trie
                        \<Rightarrow> ('s, ('obs, 's odlist) mapping) trie"
where
  "trans_MapOps_update \<equiv> \<lambda>k v m.
     trie_odlist_update_with (fst k) m Mapping.empty
      (\<lambda>m. Mapping.update (snd k) v m)"

definition
  trans_MapOps :: "(('s :: linorder, ('obs, 's odlist) mapping) trie, 's odlist \<times> 'obs, 's odlist) MapOps"
where
  "trans_MapOps \<equiv>
     \<lparr> MapOps.empty = trie_empty,
       lookup = trans_MapOps_lookup,
       update = trans_MapOps_update \<rparr>"

lemma (in FiniteSingleAgentEnvironment) trans_MapOps[intro, simp]:
  "MapOps (\<lambda>k. (spr_simAbs (fst k), snd k)) (SPRsingle.jkbpSEC \<times> UNIV) trans_MapOps"
proof
  fix k show "MapOps.lookup trans_MapOps (MapOps.empty trans_MapOps) k = None"
    unfolding trans_MapOps_def trans_MapOps_lookup_def trie_odlist_lookup_def
    by (auto split: split_split)
next
  fix e k k' M
  assume k: "(spr_simAbs (fst k), snd k) \<in> SPRsingle.jkbpSEC \<times> (UNIV :: 'z set)"
     and k': "(spr_simAbs (fst k'), snd k') \<in> SPRsingle.jkbpSEC \<times> (UNIV :: 'z set)"
  show "MapOps.lookup trans_MapOps (MapOps.update trans_MapOps k e M) k'
         = (if (spr_simAbs (fst k'), snd k') = (spr_simAbs (fst k), snd k)
             then Some e else MapOps.lookup trans_MapOps M k')"
  proof(cases "(spr_simAbs (fst k'), snd k') = (spr_simAbs (fst k), snd k)")
    case True hence "k = k'"
      using injD[OF spr_simAbs_inj] k k' by (auto iff: prod_eqI)
    thus ?thesis
      unfolding trans_MapOps_def trans_MapOps_lookup_def trans_MapOps_update_def trie_odlist_lookup_def trie_odlist_update_with_def
      by (simp add: trie_lookup_trie_update_with lookup_update split: option.split split_split)
  next
    case False thus ?thesis
      unfolding trans_MapOps_def trans_MapOps_lookup_def trans_MapOps_update_def trie_odlist_lookup_def trie_odlist_update_with_def
      by (auto simp: lookup_empty lookup_update_neq trie_lookup_trie_update_with split: option.split split_split)
  qed
qed

(*>*)

subsubsection{* Locale instantiation *}

text{*

The above is sufficient to instantiate the @{term "Algorithm"} locale.

*}

sublocale FiniteSingleAgentEnvironment
        < SPRsingle!: Algorithm
            jkbp envInit envAction envTrans envVal
            spr_jview envObs spr_jviewInit spr_jviewIncr
            spr_sim spr_simRels spr_simVal
            spr_simAbs spr_simObs spr_simInit spr_simTrans spr_simAction
            trie_odlist_MapOps trans_MapOps
(*<*)
  apply (unfold_locales)

  using spr_simInit
  apply auto[1]

  using spr_simObs
  apply auto[1]

  using spr_simAction
  apply blast

  using spr_simTrans
  apply blast

  apply (rule trie_odlist_MapOps[OF subset_inj_on[OF spr_simAbs_inj subset_UNIV]])
  apply (rule trans_MapOps)

  done

definition
  mkSPRSingleAuto :: "('a, 'p, 'aAct) KBP
                    \<Rightarrow> ('s :: linorder) list
                    \<Rightarrow> ('s \<Rightarrow> 'eAct list)
                    \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
                    \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
                    \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                    \<Rightarrow> 'a \<Rightarrow> ('obs, 'aAct, 's odlist) Protocol"
where
  "mkSPRSingleAuto \<equiv> \<lambda>kbp envInit envAction envTrans envVal envObs.
    mkAlgAuto trie_odlist_MapOps
              trans_MapOps
              (spr_simObs envObs)
              (spr_simInit envInit envObs)
              (spr_simTrans kbp envAction envTrans envVal envObs)
              (spr_simAction kbp envVal)
              (\<lambda>a. map (spr_simInit envInit envObs a \<circ> envObs a) envInit)"

lemma (in FiniteSingleAgentEnvironment) mkSPRSingleAuto_implements:
  "SPR.implements (mkSPRSingleAuto (jkbp agent) envInit envAction envTrans envVal envObs)"
  using SPRsingle.k_mkAlgAuto_implements
  unfolding mkSPRSingleAuto_def mkAlgAuto_def alg_dfs_def SPRsingle.KBP.k_ins_def SPRsingle.KBP.k_empt_def SPRsingle.k_frontier_def SPRsingle.KBP.k_memb_def SPRsingle.KBP.transUpdate_def SPRsingle.KBP.actsUpdate_def
  apply simp
  done

(*

We actually run this unfolding of the algorithm. The lemma is keeping
us honest.

*)

type_synonym (in -)
  ('aAct, 'obs, 's) SPRSingleAutoDFS = "(('s, 'aAct list) trie, (('s, ('obs, 's odlist) mapping) trie)) AlgState"

definition
  SPRSingleAutoDFS :: "('a, 'p, 'aAct) KBP
                     \<Rightarrow> ('s :: linorder) list
                     \<Rightarrow> ('s \<Rightarrow> 'eAct list)
                     \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
                     \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
                     \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                     \<Rightarrow> 'a \<Rightarrow> ('aAct, 'obs, 's) SPRSingleAutoDFS"
where
  "SPRSingleAutoDFS \<equiv> \<lambda>kbp envInit envAction envTrans envVal envObs. \<lambda>a.
    alg_dfs trie_odlist_MapOps
            trans_MapOps
            (spr_simObs envObs a)
            (spr_simTrans kbp envAction envTrans envVal envObs a)
            (spr_simAction kbp envVal a)
            (map (spr_simInit envInit envObs a \<circ> envObs a) envInit)"

lemma (in FiniteSingleAgentEnvironment)
  "mkSPRSingleAuto kbp envInit envAction envTrans envVal envObs
 = (\<lambda>a. alg_mk_auto trie_odlist_MapOps trans_MapOps (spr_simInit a) (SPRSingleAutoDFS kbp envInit envAction envTrans envVal envObs a))"
  unfolding mkSPRSingleAuto_def SPRSingleAutoDFS_def mkAlgAuto_def alg_mk_auto_def by (simp add: Let_def)

(*>*)
text{*

We use this theory to synthesise a solution to the robot of
\S\ref{sec:kbps-robot-intro} in \S\ref{sec:kbps-theory-robot}.

*}
(*<*)

end
(*>*)


section \<open> Collections \<close>

theory utp_collection
  imports utp_lift_pretty utp_pred
begin

subsection \<open> Partial Lens Definedness \<close>

definition src_pred :: "('a \<Longrightarrow> 's) \<Rightarrow> 's upred" ("\<^bold>S'(_')") where
[upred_defs]: "src_pred x = (&\<^bold>v \<in>\<^sub>u \<guillemotleft>\<S>\<^bsub>x\<^esub>\<guillemotright>)"

lemma wb_lens_src_true [simp]: "wb_lens x \<Longrightarrow> \<^bold>S(x) = true"
  by (rel_simp, simp add: wb_lens.source_UNIV)

subsection \<open> Indexed Lenses \<close>

definition ind_lens :: "('i \<Rightarrow> ('a \<Longrightarrow> 's)) \<Rightarrow> ('i, 's) uexpr \<Rightarrow> ('a \<Longrightarrow> 's)" where
[lens_defs]: "ind_lens f x = \<lparr> lens_get = (\<lambda> s. get\<^bsub>f (\<lbrakk>x\<rbrakk>\<^sub>e s)\<^esub> s), lens_put = (\<lambda> s v. put\<^bsub>f (\<lbrakk>x\<rbrakk>\<^sub>e s)\<^esub> s v) \<rparr>"

lemma ind_lens_mwb [simp]: "\<lbrakk> \<And> i. mwb_lens (F i); \<And> i. unrest (F i) x \<rbrakk> \<Longrightarrow> mwb_lens (ind_lens F x)"
  by (unfold_locales, auto simp add: lens_defs lens_indep.lens_put_irr2 unrest_uexpr.rep_eq)

lemma ind_lens_vwb [simp]: "\<lbrakk> \<And> i. vwb_lens (F i); \<And> i. unrest (F i) x \<rbrakk> \<Longrightarrow> vwb_lens (ind_lens F x)"
  by (unfold_locales, auto simp add: lens_defs lens_indep.lens_put_irr2 unrest_uexpr.rep_eq)

lemma src_ind_lens: "\<lbrakk> \<And> i. unrest (f i) e \<rbrakk> \<Longrightarrow> \<S>\<^bsub>ind_lens f e\<^esub> = {s. s \<in> \<S>\<^bsub>f (\<lbrakk>e\<rbrakk>\<^sub>e s)\<^esub>}"
  apply (auto simp add: lens_defs lens_source_def unrest unrest_uexpr.rep_eq)
  apply (blast)
  apply metis
  done

(*
lemma "\<^bold>S(src_pred (ind_lens x = U(&x \<in> \<S>\<^bsub>x\<^esub>)"
*)

subsection \<open> Overloaded Collection Lens \<close>

consts collection_lens :: "'k \<Rightarrow> ('a \<Longrightarrow> 's)"

definition [lens_defs]: "fun_collection_lens = fun_lens"
definition [lens_defs]: "pfun_collection_lens = pfun_lens"
definition [lens_defs]: "ffun_collection_lens = ffun_lens"
definition [lens_defs]: "list_collection_lens = list_lens"

lemma vwb_fun_collection_lens [simp]: "vwb_lens (fun_collection_lens k)"
  by (simp add: fun_collection_lens_def fun_vwb_lens)

lemma mwb_pfun_collection_lens [simp]: "mwb_lens (pfun_collection_lens k)"
  by (simp add: pfun_collection_lens_def)

lemma mwb_ffun_collection_lens [simp]: "mwb_lens (ffun_collection_lens k)"
  by (simp add: ffun_collection_lens_def)

lemma mwb_list_collection_lens [simp]: "mwb_lens (list_collection_lens i)"
  by (simp add: list_collection_lens_def list_mwb_lens)

lemma source_list_collection_lens: "\<S>\<^bsub>list_collection_lens i\<^esub> = {xs. i < length xs}"
  by (simp add: list_collection_lens_def source_list_lens)

adhoc_overloading
  collection_lens fun_collection_lens and
  collection_lens pfun_collection_lens and
  collection_lens ffun_collection_lens and
  collection_lens list_collection_lens

subsection \<open> Syntax for Collection Lens \<close>

abbreviation "ind_lens_poly f x i \<equiv> ind_lens (\<lambda> k. f k ;\<^sub>L x) i"

utp_lift_notation ind_lens_poly (0 1)

syntax
  "_svid_collection" :: "svid \<Rightarrow> logic \<Rightarrow> svid" ("_[_]" [999, 0] 999)

translations
  "_svid_collection x i" == "CONST ind_lens_poly CONST collection_lens x i"

lemma src_list_collection_lens [simp]:
  "\<lbrakk> vwb_lens x; x \<sharp> i \<rbrakk> \<Longrightarrow> \<^bold>S(ind_lens_poly list_collection_lens x i) = U(i < length(&x))"
  apply (simp add: upred_defs src_ind_lens unrest source_list_collection_lens source_lens_comp)
  apply (transfer, auto simp add: fun_eq_iff lens_defs wb_lens.source_UNIV)
  done

end


theory Lambda
imports
  "../Nominal2"
begin

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  binds x in l ("Lam [_]. _" [100, 100] 100)

nominal_datatype sem =
  L e::"env" x::"name" l::"lam" binds x "bn e" in l
| N "neu"
and neu =
  V "name"
| A "neu" "sem"
and env =
  ENil
| ECons "env" "name" "sem"
binder
  bn
where
  "bn ENil = []"
| "bn (ECons env x v) = (atom x) # (bn env)"

thm sem_neu_env.supp

lemma test1:
  shows "supp p \<sharp>* (fv_bn env) \<Longrightarrow> (p \<bullet> env) = permute_bn p env"
apply(induct env rule: sem_neu_env.inducts(3))
apply(rule TrueI)+
apply(auto simp add: sem_neu_env.perm_bn_simps sem_neu_env.supp)
apply(drule meta_mp)
apply(drule fresh_star_supp_conv)
apply(subst (asm) supp_finite_atom_set)
apply(simp add: finite_supp)
apply(simp add: fresh_star_Un)
apply(rule fresh_star_supp_conv)
apply(subst supp_finite_atom_set)
apply(simp)
apply(simp)
apply(simp)
apply(rule perm_supp_eq)
apply(drule fresh_star_supp_conv)
apply(subst (asm) supp_finite_atom_set)
apply(simp add: finite_supp)
apply(simp add: fresh_star_Un)
apply(rule fresh_star_supp_conv)
apply(simp)
done

thm alpha_sem_raw_alpha_neu_raw_alpha_env_raw_alpha_bn_raw.inducts(4)[no_vars]

lemma alpha_bn_inducts_raw[consumes 1]:
  "\<lbrakk>alpha_bn_raw x7 x8;
  P4 ENil_raw ENil_raw;
 \<And>env_raw env_rawa sem_raw sem_rawa name namea.
    \<lbrakk>alpha_bn_raw env_raw env_rawa; P4 env_raw env_rawa; alpha_sem_raw sem_raw sem_rawa\<rbrakk>
    \<Longrightarrow> P4 (ECons_raw env_raw name sem_raw) (ECons_raw env_rawa namea sem_rawa)\<rbrakk>
\<Longrightarrow> P4 x7 x8"
apply(induct rule: alpha_sem_raw_alpha_neu_raw_alpha_env_raw_alpha_bn_raw.inducts(4))
apply(rule TrueI)+
apply(auto)
done

lemmas alpha_bn_inducts[consumes 1] = alpha_bn_inducts_raw[quot_lifted]

lemma test2:
  shows "alpha_bn env1 env2 \<Longrightarrow> p \<bullet> (bn env1) = q \<bullet> (bn env2) \<Longrightarrow> permute_bn p env1 = permute_bn q env2"
apply(induct rule: alpha_bn_inducts)
apply(auto simp add: sem_neu_env.perm_bn_simps sem_neu_env.bn_defs)
apply(simp add: atom_eqvt)
done

lemma fresh_star_Union:
  assumes "as \<subseteq> bs" "bs \<sharp>* x"
  shows "as \<sharp>* x"
using assms by (auto simp add: fresh_star_def)

nominal_function  (invariant "\<lambda>x y. case x of Inl (x1, y1) \<Rightarrow>
  supp y \<subseteq> (supp y1 - set (bn x1)) \<union> (fv_bn x1) | Inr (x2, y2) \<Rightarrow> supp y \<subseteq> supp x2 \<union> supp y2")
  evals :: "env \<Rightarrow> lam \<Rightarrow> sem" and
  evals_aux :: "sem \<Rightarrow> sem \<Rightarrow> sem"
where
  "evals ENil (Var x) = N (V x)"
| "evals (ECons tail y v) (Var x) = (if x = y then v else evals tail (Var x))"
| "atom x \<sharp> env \<Longrightarrow> evals env (Lam [x]. t) = L env x t"
| "evals env (App t1 t2) = evals_aux (evals env t1) (evals env t2)"
| "set (atom x # bn env) \<sharp>* (fv_bn env, t') \<Longrightarrow> evals_aux (L env x t) t' = evals (ECons env x t') t"
| "evals_aux (N n) t' = N (A n t')"
apply(simp add: eqvt_def  evals_evals_aux_graph_def)
apply(perm_simp)
apply(simp)
apply(erule evals_evals_aux_graph.induct)
apply(simp add: sem_neu_env.supp lam.supp sem_neu_env.bn_defs)
apply(simp add: sem_neu_env.supp lam.supp sem_neu_env.bn_defs)
apply(rule conjI)
apply(rule impI)
apply(blast)
apply(rule impI)
apply(simp add: supp_at_base)
apply(blast)
apply(simp add: sem_neu_env.supp lam.supp sem_neu_env.bn_defs)
apply(blast)
apply(simp add: sem_neu_env.supp lam.supp sem_neu_env.bn_defs)
apply(blast)
apply(simp add: sem_neu_env.supp lam.supp sem_neu_env.bn_defs)
apply(blast)
apply(simp add: sem_neu_env.supp lam.supp sem_neu_env.bn_defs)
--"completeness"
apply(case_tac x)
apply(simp)
apply(case_tac a)
apply(simp)
apply(case_tac aa rule: sem_neu_env.exhaust(3))
apply(simp add: sem_neu_env.fresh)
apply(case_tac b rule: lam.exhaust)
apply(metis)+
apply(case_tac aa rule: sem_neu_env.exhaust(3))
apply(rule_tac y="b" and c="env" in lam.strong_exhaust)
apply(metis)+
apply(simp add: fresh_star_def)
apply(simp)
apply(rule_tac y="b" and c="ECons env name sem" in lam.strong_exhaust)
apply(metis)+
apply(simp add: fresh_star_def)
apply(simp)
apply(case_tac b)
apply(simp)
apply(rule_tac y="a" and c="(a, ba)" in sem_neu_env.strong_exhaust(1))
apply(simp)
apply(rotate_tac 4)
apply(drule_tac x="name" in meta_spec)
apply(drule_tac x="env" in meta_spec)
apply(drule_tac x="ba" in meta_spec)
apply(drule_tac x="lam" in meta_spec)
apply(simp add:  sem_neu_env.alpha_refl)
apply(rotate_tac 9)
apply(drule_tac meta_mp)
apply(simp (no_asm_use) add: fresh_star_def sem_neu_env.fresh fresh_Pair)
apply(simp)
apply(subst fresh_finite_atom_set)
defer
apply(simp)
apply(subst fresh_finite_atom_set)
defer
apply(simp)
apply(metis)+
--"compatibility"
apply(all_trivials)
apply(simp)
apply(simp)
defer
apply(simp)
apply(simp)
apply (simp add: meta_eq_to_obj_eq[OF evals_def, symmetric, unfolded fun_eq_iff])
apply (subgoal_tac "eqvt_at (\<lambda>(a, b). evals a b) (ECons env x t'a, t)")
apply (subgoal_tac "eqvt_at (\<lambda>(a, b). evals a b) (ECons enva xa t'a, ta)")
apply (thin_tac "eqvt_at evals_evals_aux_sumC (Inl (ECons env x t'a, t))")
apply (thin_tac "eqvt_at evals_evals_aux_sumC (Inl (ECons enva xa t'a, ta))")
apply(erule conjE)+
defer
apply (simp_all add: eqvt_at_def evals_def)[3]
defer
defer
apply(simp add: sem_neu_env.alpha_refl)
apply(erule conjE)+
apply(erule_tac c="(env, enva)" in Abs_lst1_fcb2)
apply(simp add: Abs_fresh_iff)
apply(simp add: fresh_star_def)
apply(perm_simp)
apply(simp add: fresh_star_Pair perm_supp_eq)
apply(perm_simp)
apply(simp add: fresh_star_Pair perm_supp_eq)
apply(simp add: sem_neu_env.bn_defs sem_neu_env.supp)
using at_set_avoiding3
apply -
apply(drule_tac x="set (atom x # bn env)" in meta_spec)
apply(drule_tac x="(fv_bn env, fv_bn enva, env, enva, x, xa, t, ta, t'a)" in meta_spec)
apply(drule_tac x="[atom x # bn env]lst. t" in meta_spec)
apply(simp (no_asm_use) add: finite_supp Abs_fresh_star_iff)
apply(drule meta_mp)
apply(simp add: supp_Pair finite_supp supp_finite_atom_set)
apply(drule meta_mp)
apply(simp add: fresh_star_def)
apply(erule exE)
apply(erule conjE)+
apply(rule trans)
apply(rule sym)
apply(rule_tac p="p" in perm_supp_eq)
apply(simp)
apply(perm_simp)
apply(simp add: fresh_star_Un fresh_star_insert)
apply(rule conjI)
apply(simp (no_asm_use) add: fresh_star_def fresh_Pair)
apply(simp add: fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(rule conjI)
apply(simp (no_asm_use) add: fresh_star_def fresh_Pair)
apply(simp add: fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(rule conjI)
apply(simp (no_asm_use) add: fresh_star_def fresh_Pair)
apply(simp add: fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(simp (no_asm_use) add: fresh_star_def fresh_Pair)
apply(simp add: fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(simp add: eqvt_at_def perm_supp_eq)
apply(subst (3) perm_supp_eq)
apply(simp)
apply(simp add: fresh_star_def fresh_Pair)
apply(auto)[1]
apply(rotate_tac 6)
apply(drule sym)
apply(simp)
apply(rotate_tac 11)
apply(drule trans)
apply(rule sym)
apply(rule_tac p="p" in supp_perm_eq)
apply(assumption)
apply(rotate_tac 11)
apply(rule sym)
apply(simp add: atom_eqvt)
apply(simp (no_asm_use) add: Abs_eq_iff2 alphas)
apply(erule conjE | erule exE)+
apply(rule trans)
apply(rule sym)
apply(rule_tac p="pa" in perm_supp_eq)
apply(erule fresh_star_Union)
apply(simp (no_asm_use) add: fresh_star_insert fresh_star_Un)
apply(rule conjI)
apply(perm_simp)
apply(simp add: fresh_star_insert fresh_star_Un)
apply(simp add: fresh_Pair)
apply(simp add: fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(rule conjI)
apply(perm_simp)
apply(simp add: fresh_star_insert fresh_star_Un)
apply(simp add: fresh_Pair)
apply(simp add: fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(rule conjI)
apply(perm_simp)
defer
apply(perm_simp)
apply(simp add: fresh_star_insert fresh_star_Un)
apply(simp add: fresh_star_Pair)
apply(simp add: fresh_star_def fresh_def)
apply(simp add: supp_finite_atom_set)
apply(blast)
apply(simp)
apply(perm_simp)
apply(subst (3) perm_supp_eq)
apply(erule fresh_star_Union)
apply(simp add: fresh_star_insert fresh_star_Un)
apply(simp add: fresh_star_def fresh_Pair)
apply(subgoal_tac "pa \<bullet> enva = p \<bullet> env")
apply(simp)
defer
apply(simp (no_asm_use) add: fresh_star_insert fresh_star_Un)
apply(simp (no_asm_use) add: fresh_star_def)
apply(rule ballI)
apply(subgoal_tac "a \<notin> supp ta - insert (atom xa) (set (bn enva)) \<union> (fv_bn enva \<union> supp t'a)")
apply(simp only: fresh_def)
apply(blast)
apply(simp (no_asm_use))
apply(rule conjI)
apply(blast)
apply(simp add: fresh_Pair)
apply(simp add: fresh_star_def fresh_def)
apply(simp add: supp_finite_atom_set)
apply(subst test1)
apply(erule fresh_star_Union)
apply(simp add: fresh_star_insert fresh_star_Un)
apply(simp add: fresh_star_def fresh_Pair)
apply(subst test1)
apply(simp)
apply(simp add: fresh_star_insert fresh_star_Un)
apply(simp add: fresh_star_def fresh_Pair)
apply(rule sym)
apply(erule test2)
apply(perm_simp)
apply(simp)
done

text {* can probably not proved by a trivial size argument *}
termination (* apply(lexicographic_order) *)
sorry

lemma [eqvt]:
  shows "(p \<bullet> evals env t) = evals (p \<bullet> env) (p \<bullet> t)"
  and "(p \<bullet> evals_aux v s) = evals_aux (p \<bullet> v) (p \<bullet> s)"
sorry

(* fixme: should be a provided lemma *)
lemma fv_bn_finite:
  shows "finite (fv_bn env)"
apply(induct env rule: sem_neu_env.inducts(3))
apply(auto simp add: sem_neu_env.supp finite_supp)
done

lemma test:
  fixes env::"env"
  shows "supp (evals env t) \<subseteq> (supp t - set (bn env)) \<union> (fv_bn env)"
  and "supp (evals_aux s v) \<subseteq> (supp s) \<union> (supp v)"
apply(induct env t and s v rule: evals_evals_aux.induct)
apply(simp add: sem_neu_env.supp lam.supp supp_Nil sem_neu_env.bn_defs)
apply(simp add: sem_neu_env.supp lam.supp supp_Nil supp_Cons sem_neu_env.bn_defs)
apply(rule conjI)
apply(auto)[1]
apply(rule impI)
apply(simp)
apply(simp add: supp_at_base)
apply(blast)
apply(simp)
apply(subst sem_neu_env.supp)
apply(simp add: sem_neu_env.supp lam.supp)
apply(auto)[1]
apply(simp add: lam.supp sem_neu_env.supp)
apply(blast)
apply(simp add: sem_neu_env.supp sem_neu_env.bn_defs)
apply(blast)
apply(simp add: sem_neu_env.supp)
done

nominal_function
  reify :: "sem \<Rightarrow> lam" and
  reifyn :: "neu \<Rightarrow> lam"
where
  "atom x \<sharp> (env, y, t) \<Longrightarrow> reify (L env y t) = Lam [x]. (reify (evals (ECons env y (N (V x))) t))"
| "reify (N n) = reifyn n"
| "reifyn (V x) = Var x"
| "reifyn (A n d) = App (reifyn n) (reify d)"
apply(subgoal_tac "\<And>p x y. reify_reifyn_graph x y \<Longrightarrow> reify_reifyn_graph (p \<bullet> x) (p \<bullet> y)")
apply(simp add: eqvt_def)
apply(simp add: permute_fun_def)
apply(rule allI)
apply(rule ext)
apply(rule ext)
apply(rule iffI)
apply(drule_tac x="p" in meta_spec)
apply(drule_tac x="- p \<bullet> x" in meta_spec)
apply(drule_tac x="- p \<bullet> xa" in meta_spec)
apply(simp add: permute_bool_def)
apply(simp add: permute_bool_def)
apply(erule reify_reifyn_graph.induct)
apply(perm_simp)
apply(rule reify_reifyn_graph.intros)
apply(rule_tac p="-p" in permute_boolE)
apply(perm_simp add: permute_minus_cancel)
apply(simp)
apply(simp)
apply(perm_simp)
apply(rule reify_reifyn_graph.intros)
apply(simp)
apply(perm_simp)
apply(rule reify_reifyn_graph.intros)
apply(perm_simp)
apply(rule reify_reifyn_graph.intros)
apply(simp)
apply(simp)
apply(rule TrueI)
--"completeness"
apply(case_tac x)
apply(simp)
apply(case_tac a rule: sem_neu_env.exhaust(1))
apply(subgoal_tac "\<exists>x::name. atom x \<sharp> (env, name, lam)")
apply(metis)
apply(rule obtain_fresh)
apply(blast)
apply(blast)
apply(case_tac b rule: sem_neu_env.exhaust(2))
apply(simp)
apply(simp)
apply(metis)
--"compatibility"
apply(all_trivials)
defer
apply(simp)
apply(simp)
apply(simp)
apply(erule conjE)
apply (simp add: meta_eq_to_obj_eq[OF reify_def, symmetric, unfolded fun_eq_iff])
apply (subgoal_tac "eqvt_at (\<lambda>t. reify t) (evals (ECons env y (N (V x))) t)")
apply (subgoal_tac "eqvt_at (\<lambda>t. reify t) (evals (ECons enva ya (N (V xa))) ta)")
apply (thin_tac "eqvt_at reify_reifyn_sumC (Inl (evals (ECons env y (N (V x))) t))")
apply (thin_tac "eqvt_at reify_reifyn_sumC (Inl (evals (ECons enva ya (N (V xa))) ta))")
defer
apply (simp_all add: eqvt_at_def reify_def)[2]
apply(subgoal_tac "\<exists>c::name. atom c \<sharp> (x, xa, env, enva, y, ya, t, ta)")
prefer 2
apply(rule obtain_fresh)
apply(blast)
apply(erule exE)
apply(rule trans)
apply(rule sym)
apply(rule_tac a="x" and b="c" in flip_fresh_fresh)
apply(simp add: Abs_fresh_iff)
apply(simp add: Abs_fresh_iff fresh_Pair)
apply(auto)[1]
apply(rule fresh_eqvt_at)
back
apply(assumption)
apply(simp add: finite_supp)
apply(rule_tac S="supp (env, y, x, t)" in supports_fresh)
apply(simp add: supports_def fresh_def[symmetric])
apply(perm_simp)
apply(simp add: swap_fresh_fresh fresh_Pair)
apply(simp add: finite_supp)
apply(simp add: fresh_def[symmetric])
apply(simp add: eqvt_at_def)
apply(simp add: eqvt_at_def[symmetric])
apply(perm_simp)
apply(simp add: flip_fresh_fresh)
apply(rule sym)
apply(rule trans)
apply(rule sym)
apply(rule_tac a="xa" and b="c" in flip_fresh_fresh)
apply(simp add: Abs_fresh_iff)
apply(simp add: Abs_fresh_iff fresh_Pair)
apply(auto)[1]
apply(rule fresh_eqvt_at)
back
apply(assumption)
apply(simp add: finite_supp)
apply(rule_tac S="supp (enva, ya, xa, ta)" in supports_fresh)
apply(simp add: supports_def fresh_def[symmetric])
apply(perm_simp)
apply(simp add: swap_fresh_fresh fresh_Pair)
apply(simp add: finite_supp)
apply(simp add: fresh_def[symmetric])
apply(simp add: eqvt_at_def)
apply(simp add: eqvt_at_def[symmetric])
apply(perm_simp)
apply(simp add: flip_fresh_fresh)
apply(simp (no_asm) add: Abs1_eq_iff)
(* HERE *)
thm at_set_avoiding3
using at_set_avoiding3
apply -
apply(drule_tac x="set (atom y # bn env)" in meta_spec)
apply(drule_tac x="(env, enva)" in meta_spec)
apply(drule_tac x="[atom y # bn env]lst. t" in meta_spec)
apply(simp (no_asm_use) add: finite_supp)
apply(drule meta_mp)
apply(rule Abs_fresh_star)
apply(auto)[1]
apply(erule exE)
apply(erule conjE)+
apply(drule_tac q="(x \<leftrightarrow> c)" in eqvt_at_perm)
apply(perm_simp)
apply(simp add: flip_fresh_fresh fresh_Pair)
apply(drule_tac q="(xa \<leftrightarrow> c)" in eqvt_at_perm)
apply(perm_simp)
apply(simp add: flip_fresh_fresh fresh_Pair)
apply(drule sym)
(* HERE *)
apply(rotate_tac 9)
apply(drule sym)
apply(rotate_tac 9)
apply(drule trans)
apply(rule sym)
apply(rule_tac p="p" in supp_perm_eq)
apply(assumption)
apply(simp)
apply(perm_simp)
apply(simp (no_asm_use) add: Abs_eq_iff2 alphas)
apply(erule conjE | erule exE)+
apply(clarify)
apply(rule trans)
apply(rule sym)
apply(rule_tac p="pa" in perm_supp_eq)
defer
apply(rule sym)
apply(rule trans)
apply(rule sym)
apply(rule_tac p="p" in perm_supp_eq)
defer
apply(simp add: atom_eqvt)
apply(drule_tac q="(x \<leftrightarrow> c)" in eqvt_at_perm)
apply(perm_simp)
apply(simp add: flip_fresh_fresh fresh_Pair)

apply(rule sym)
apply(erule_tac Abs_lst1_fcb2')
apply(rule fresh_eqvt_at)
back
apply(drule_tac q="(c \<leftrightarrow> x)" in eqvt_at_perm)
apply(perm_simp)
apply(simp add: flip_fresh_fresh)
apply(simp add: finite_supp)
apply(rule supports_fresh)
apply(rule_tac S="supp (enva, ya, xa, ta)" in supports_fresh)
apply(simp add: supports_def fresh_def[symmetric])
apply(perm_simp)
apply(simp add: swap_fresh_fresh fresh_Pair)
apply(simp add: finite_supp)
apply(simp add: fresh_def[symmetric])
apply(simp add: eqvt_at_def)
apply(simp add: eqvt_at_def[symmetric])
apply(perm_simp)
apply(rule fresh_eqvt_at)
back
apply(drule_tac q="(c \<leftrightarrow> x)" in eqvt_at_perm)
apply(perm_simp)
apply(simp add: flip_fresh_fresh)
apply(assumption)
apply(simp add: finite_supp)
sorry

termination sorry

definition
  eval :: "lam \<Rightarrow> sem"
where
  "eval t = evals ENil t"

definition
  normalize :: "lam \<Rightarrow> lam"
where
  "normalize t = reify (eval t)"

end