theory Array_Map_Impl
imports
  "../Sep_Main" Imp_Map_Spec Array_Blit
  "HOL-Library.Code_Target_Numeral"
begin
  subsection "Array Map"

  type_synonym 'v array_map = "'v option array"
  definition "iam_initial_size \<equiv> 8::nat"

  definition "iam_of_list l i \<equiv> if i<length l then l!i else None"

  definition is_iam :: "(nat\<rightharpoonup>'a) \<Rightarrow> ('a::heap) array_map \<Rightarrow> assn" where
    "is_iam m a \<equiv> \<exists>\<^sub>Al. a\<mapsto>\<^sub>al * \<up>(m=iam_of_list l)"

  definition iam_new_sz :: "nat \<Rightarrow> ('v::heap) array_map Heap"
    where "iam_new_sz sz \<equiv> Array.new sz None"

  definition iam_new :: "('v::heap) array_map Heap"
    where "iam_new \<equiv> iam_new_sz iam_initial_size"

  definition iam_lookup
    :: "nat \<Rightarrow> ('v::heap) array_map \<Rightarrow> 'v option Heap"
    where "iam_lookup k a = do {
      l\<leftarrow>Array.len a;
      if k < l then Array.nth a k else return None
    }"

  definition iam_delete
    :: "nat \<Rightarrow> ('v::heap) array_map \<Rightarrow> ('v::heap) array_map Heap"
  where "iam_delete k a = do {
      l\<leftarrow>Array.len a;
      if k < l then Array.upd k None a else return a
    }"

  lemma [code]: "iam_delete k a \<equiv> upd_oo (return a) k None a"
    unfolding upd_oo_def iam_delete_def .

  definition iam_update
    :: "nat \<Rightarrow> 'v::heap \<Rightarrow> 'v array_map \<Rightarrow> 'v array_map Heap"
    where "iam_update k v a = do {
      l\<leftarrow>Array.len a;
      a\<leftarrow>if k>=l then do {
          let newsz = max (k+1) (2 * l + 3);
          array_grow a newsz None
        } else return a;

      Array.upd k (Some v) a
    }"

  lemma [code]: "iam_update k v a = upd_oo
    (do {
      l\<leftarrow>Array.len a;
      let newsz = max (k+1) (2 * l + 3);
      a\<leftarrow>array_grow a newsz None;
      Array.upd k (Some v) a
    })
    k (Some v) a"
  proof -
    have [simp]:
      "\<And>x t e. do {
        l\<leftarrow>Array.len a;
        if x l then
          t l
        else do {
          l'\<leftarrow>Array.len a;
          e l l'
        }
      }
      =
      do {
        l\<leftarrow>Array.len a;
        if x l then t l else e l l
      }"
      apply (auto
        simp: bind_def execute_len
        split: option.split
        intro!: ext
      )
      done

    show ?thesis
      unfolding upd_oo_def iam_update_def
      apply simp
      apply (rule cong[OF arg_cong, where f1=bind])
      apply simp
      apply (rule ext)
      apply auto
      done
  qed

  lemma precise_iam: "precise is_iam"
    apply rule
    by (auto simp add: is_iam_def dest: preciseD[OF snga_prec])

  lemma iam_new_abs: "iam_of_list (replicate n None) = Map.empty"
    unfolding iam_of_list_def[abs_def]
    by auto

  lemma iam_new_sz_rule: "<emp> iam_new_sz n < is_iam Map.empty >"
    unfolding iam_new_sz_def is_iam_def[abs_def]
    by (sep_auto simp: iam_new_abs)

  lemma iam_new_rule: "<emp> iam_new < is_iam Map.empty >"
    unfolding iam_new_def by (sep_auto heap: iam_new_sz_rule)

  lemma iam_lookup_rule: "< is_iam m p >
    iam_lookup k p
    <\<lambda>r. is_iam m p * \<up>(r=m k) >"
    unfolding iam_lookup_def is_iam_def
    by (sep_auto simp: iam_lookup_abs1 iam_lookup_abs2)

  lemma iam_delete_abs1: "k<length l
    \<Longrightarrow> iam_of_list (l[k := None]) = iam_of_list l |` (- {k})"
    unfolding iam_of_list_def[abs_def]
    by (auto intro!: ext simp: restrict_map_def)

  lemma iam_delete_abs2: "\<not>k<length l
    \<Longrightarrow> iam_of_list l |` (- {k}) = iam_of_list l"
    unfolding iam_of_list_def[abs_def]
    by (auto intro!: ext simp: restrict_map_def)

  lemma iam_delete_rule: "< is_iam m p >
    iam_delete k p
    <\<lambda>r. is_iam (m|`(-{k})) r>"
    unfolding is_iam_def iam_delete_def
    by (sep_auto simp: iam_delete_abs1 iam_delete_abs2)

  lemma iam_update_abs1: "iam_of_list (l@replicate n None) = iam_of_list l"
    unfolding iam_of_list_def[abs_def]
    by (auto intro!: ext simp: nth_append)

  lemma iam_update_abs2: "\<not> length l \<le> k
    \<Longrightarrow> iam_of_list (l[k := Some v]) = iam_of_list l(k \<mapsto> v)"
    unfolding iam_of_list_def[abs_def]
    by auto

  lemma iam_update_rule:
    "< is_iam m p > iam_update k v p <\<lambda>r. is_iam (m(k\<mapsto>v)) r>\<^sub>t"
    unfolding is_iam_def iam_update_def
    by (sep_auto
      decon: decon_if_split
      simp: iam_update_abs1 iam_update_abs2)

  interpretation iam: imp_map is_iam
    apply unfold_locales
    by (rule precise_iam)
  interpretation iam: imp_map_empty is_iam iam_new
    apply unfold_locales
    by (sep_auto heap: iam_new_rule)
  interpretation iam_sz: imp_map_empty is_iam "iam_new_sz sz"
    apply unfold_locales
    by (sep_auto heap: iam_new_sz_rule)

  interpretation iam: imp_map_lookup is_iam iam_lookup
    apply unfold_locales
    by (sep_auto heap: iam_lookup_rule)
  interpretation iam: imp_map_delete is_iam iam_delete
    apply unfold_locales
    by (sep_auto heap: iam_delete_rule)
  interpretation iam: imp_map_update is_iam iam_update
    apply unfold_locales
    by (sep_auto heap: iam_update_rule)

end


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

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

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

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

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

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

record globals_list =
  next_' :: "ref \<Rightarrow> ref"

record state_list = "globals_list state" +
  p_'    :: "ref"
  sl_q_'    :: "ref"
  r_'    :: "ref"

procedures Rev(p|sl_q) =
      "\<acute>sl_q :== Null;;
       WHILE \<acute>p \<noteq> Null
       DO
         \<acute>r :== \<acute>p;; \<lbrace>\<acute>p \<noteq> Null\<rbrace>\<longmapsto> \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<lbrace>\<acute>r \<noteq> Null\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>sl_q;; \<acute>sl_q :== \<acute>r
       OD"
print_theorems

lemma (in Rev_impl)
 Rev_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV \<^esub>{\<sigma>} \<acute>sl_q :== PROC Rev(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (vcg spec=modifies)
done

lemma (in Rev_impl) shows
 Rev_spec:
  "\<forall>Ps. \<Gamma>\<turnstile> \<lbrace>List \<acute>p \<acute>next Ps\<rbrace> \<acute>sl_q :== PROC Rev(\<acute>p) \<lbrace>List \<acute>sl_q \<acute>next (rev Ps)\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (hoare_rule anno =
       "\<acute>sl_q :== Null;;
       WHILE \<acute>p \<noteq> Null INV \<lbrace>\<exists>Ps' Qs'. List \<acute>p \<acute>next Ps' \<and> List \<acute>sl_q \<acute>next Qs' \<and>
                             set Ps' \<inter> set Qs' = {} \<and>
                             rev Ps' @ Qs' = rev Ps\<rbrace>
        DO
         \<acute>r :== \<acute>p;; \<lbrace>\<acute>p \<noteq> Null\<rbrace>\<longmapsto>\<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<lbrace>\<acute>r \<noteq> Null\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>sl_q;; \<acute>sl_q :== \<acute>r
       OD" in HoarePartial.annotateI)
apply vcg
apply   clarsimp
apply  fastforce
apply clarsimp
done

declare [[names_unique = false]]

record globals =
  strnext_'   :: "ref \<Rightarrow> ref"
  chr_'    :: "ref \<Rightarrow> char"

  qnext_' :: "ref \<Rightarrow> ref"
  cont_'   :: "ref \<Rightarrow> int"
record state = "globals state" +
  str_'  :: "ref"
  queue_':: "ref"
  q_'    :: "ref"
  r_'    :: "ref"

definition project_globals_str:: "globals \<Rightarrow> globals_list"
  where "project_globals_str g = \<lparr>next_' = strnext_' g\<rparr>"

definition project_str:: "state \<Rightarrow> state_list"
where
"project_str s =
  \<lparr>globals = project_globals_str (globals s),
   state_list.p_' = str_' s, sl_q_' = q_' s, state_list.r_' = r_' s\<rparr>"

definition inject_globals_str::
  "globals \<Rightarrow> globals_list \<Rightarrow> globals"
where
  "inject_globals_str G g =
   G\<lparr>strnext_' := next_' g\<rparr>"

definition "inject_str"::"state \<Rightarrow> state_list \<Rightarrow> state" where
"inject_str S s = S\<lparr>globals := inject_globals_str (globals S) (globals s),
                str_' := state_list.p_' s, q_' := sl_q_' s,
                r_' := state_list.r_' s\<rparr>"

lemma globals_inject_project_str_commutes:
  "inject_globals_str G (project_globals_str G) = G"
  by (simp add: inject_globals_str_def project_globals_str_def)

lemma inject_project_str_commutes: "inject_str S (project_str S) = S"
  by (simp add: inject_str_def project_str_def globals_inject_project_str_commutes)

lemma globals_project_inject_str_commutes:
  "project_globals_str (inject_globals_str G g) = g"
  by (simp add: inject_globals_str_def project_globals_str_def)

lemma project_inject_str_commutes: "project_str (inject_str S s) = s"
  by (simp add: inject_str_def project_str_def globals_project_inject_str_commutes)

lemma globals_inject_str_last:
  "inject_globals_str (inject_globals_str G g) g' = inject_globals_str G g'"
  by (simp add: inject_globals_str_def)

lemma inject_str_last:
  "inject_str (inject_str S s) s' = inject_str S s'"
  by (simp add: inject_str_def globals_inject_str_last)

definition
  "lift\<^sub>e = (\<lambda>\<Gamma> p. map_option (lift\<^sub>c project_str inject_str) (\<Gamma> p))"
print_locale lift_state_space
interpretation ex: lift_state_space project_str inject_str
  "xstate_map project_str" lift\<^sub>e "lift\<^sub>c project_str inject_str"
  "lift\<^sub>f project_str inject_str" "lift\<^sub>s project_str"
  "lift\<^sub>r project_str inject_str"
  apply -
  apply       (rule lift_state_space.intro)
  apply       (rule project_inject_str_commutes)
  apply      simp
  apply     simp
  apply    (simp add: lift\<^sub>e_def)
  apply   simp
  apply  simp
  apply simp
  done

interpretation ex: lift_state_space_ext project_str inject_str
  "xstate_map project_str" lift\<^sub>e "lift\<^sub>c project_str inject_str"
  "lift\<^sub>f project_str inject_str" "lift\<^sub>s project_str"
  "lift\<^sub>r project_str inject_str"

(*  project_str "inject_str" _ lift\<^sub>e *)
apply -
apply intro_locales [1]
  apply (rule lift_state_space_ext_axioms.intro)
  apply  (rule inject_project_str_commutes)
  apply (rule inject_str_last)
apply (simp_all add: lift\<^sub>e_def)
  done

(*
  apply (intro_locales)
  apply (rule lift_state_space_ext_axioms.intro)
  apply  (rule inject_project_str_commutes)
  apply (rule inject_str_last)
  done
*)

(*
declare lift_set_def [simp] project_def [simp] project_globals_def [simp]
*)
lemmas Rev_lift_spec = ex.lift_hoarep' [OF Rev_impl.Rev_spec,simplified lift\<^sub>s_def
 project_str_def project_globals_str_def,simplified, of _ "''Rev''"]
print_theorems

definition "\<N> p' p = (if p=''Rev'' then p' else '''')"

procedures RevStr(str|q) = "rename (\<N> RevStr_'proc)
                (lift\<^sub>c project_str inject_str (Rev_body.Rev_body))"

lemmas Rev_lift_spec' =
  Rev_lift_spec [of "[''Rev''\<mapsto>Rev_body.Rev_body]" ,
     simplified Rev_impl_def Rev_clique_def,simplified]
thm Rev_lift_spec'

lemma Rev_lift_spec'':
  "\<forall>Ps. lift\<^sub>e [''Rev'' \<mapsto> Rev_body.Rev_body]
       \<turnstile> \<lbrace>List \<acute>str \<acute>strnext Ps\<rbrace> Call ''Rev'' \<lbrace>List \<acute>q \<acute>strnext (rev Ps)\<rbrace>"
  by (rule Rev_lift_spec')

lemma (in RevStr_impl) \<N>_ok:
"\<forall>p bdy. (lift\<^sub>e [''Rev'' \<mapsto> Rev_body.Rev_body]) p = Some bdy \<longrightarrow>
     \<Gamma> (\<N> RevStr_'proc p) = Some (rename (\<N> RevStr_'proc) bdy)"
apply (insert RevStr_impl)
apply (auto simp add: RevStr_body_def lift\<^sub>e_def \<N>_def)
done

context RevStr_impl
begin
 thm hoare_to_hoare_rename'[OF _ Rev_lift_spec'', OF \<N>_ok,
  simplified \<N>_def, simplified ]
end

lemmas (in RevStr_impl) RevStr_spec =
  hoare_to_hoare_rename' [OF _ Rev_lift_spec'', OF \<N>_ok,
  simplified \<N>_def, simplified ]

lemma (in RevStr_impl) RevStr_spec':
"\<forall>Ps. \<Gamma>\<turnstile> \<lbrace>List \<acute>str \<acute>strnext Ps\<rbrace> \<acute>q :== PROC RevStr(\<acute>str)
          \<lbrace>List \<acute>q \<acute>strnext (rev Ps)\<rbrace>"
  by (rule RevStr_spec)

lemmas Rev_modifies' =
  Rev_impl.Rev_modifies [of "[''Rev''\<mapsto>Rev_body.Rev_body]", simplified Rev_impl_def,
   simplified]
thm Rev_modifies'

context RevStr_impl
begin
lemmas RevStr_modifies' =
  hoare_to_hoare_rename' [OF _ ex.hoare_lift_modifies' [OF Rev_modifies'],
         OF \<N>_ok, of "''Rev''", simplified \<N>_def Rev_clique_def,simplified]
end

lemma (in RevStr_impl) RevStr_modifies:
"\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV \<^esub>{\<sigma>} \<acute>str :== PROC RevStr(\<acute>str)
  {t. t may_only_modify_globals \<sigma> in [strnext]}"
apply (rule allI)
apply (rule HoarePartialProps.ConseqMGT [OF RevStr_modifies'])
apply (clarsimp simp add:
  lift\<^sub>s_def mex_def meq_def
  project_str_def inject_str_def project_globals_str_def inject_globals_str_def)
apply blast
done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* License: BSD, terms see file ./LICENSE *)

theory Addr_Type
imports "~~/src/HOL/Word/Word"
begin

type_synonym addr_bitsize = "64"
type_synonym addr = "addr_bitsize word"
definition addr_bitsize :: nat where "addr_bitsize \<equiv> 64"
definition addr_align :: nat where "addr_align \<equiv> 2"
declare addr_align_def[simp]

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

declare addr_bitsize_def[simp]

lemma addr_card:
  "addr_card = 2^addr_bitsize"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(addr_bitsize) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end


theory OpenFlow_Serialize
imports OpenFlow_Matches
        OpenFlow_Action
        Semantics_OpenFlow
        Simple_Firewall.Primitives_toString
        IP_Addresses.Lib_Word_toString
begin

definition "serialization_test_entry \<equiv> OFEntry 7 {EtherDst 0x1, IPv4Dst (PrefixMatch 0xA000201 32), IngressPort ''s1-lan'', L4Dst 0x50 0, L4Src 0x400 0x3FF, IPv4Proto 6, EtherType 0x800} [ModifyField_l2dst 0xA641F185E862, Forward ''s1-wan'']"

value "(map ((<<) (1::48 word) \<circ> (*) 8) \<circ> rev) [0..<6]"

definition "serialize_mac (m::48 word) \<equiv> (intersperse (CHR '':'') \<circ> map (hex_string_of_word 1 \<circ> (\<lambda>h. (m >> h * 8) && 0xff)) \<circ> rev) [0..<6]"
lemma "serialize_mac 0xdeadbeefcafe = ''de:ad:be:ef:ca:fe''" by eval

definition "serialize_action pids a \<equiv> (case a of
	Forward oif \<Rightarrow> ''output:'' @ pids oif |
	ModifyField_l2dst na \<Rightarrow> ''mod_dl_dst:'' @ serialize_mac na)"

definition "serialize_actions pids a \<equiv> if length a = 0 then ''drop'' else (intersperse (CHR '','') \<circ> map (serialize_action pids)) a"

lemma "serialize_actions (\<lambda>oif. ''42'') (ofe_action serialization_test_entry) =
  ''mod_dl_dst:a6:41:f1:85:e8:62,output:42''" by eval
lemma "serialize_actions anything [] = ''drop''"
  by(simp add: serialize_actions_def)

definition "prefix_to_string pfx \<equiv> ipv4_cidr_toString (pfxm_prefix pfx, pfxm_length pfx)"

primrec serialize_of_match where
"serialize_of_match pids (IngressPort p) = ''in_port='' @ pids p" |
"serialize_of_match _ (VlanId i) = ''dl_vlan='' @ dec_string_of_word0 i" |
"serialize_of_match _ (VlanPriority _) = undefined" | (* uh, äh\<dots> We don't use that anyway\<dots> *)
"serialize_of_match _ (EtherType i) = ''dl_type=0x'' @ hex_string_of_word0 i" |
"serialize_of_match _ (EtherSrc m) = ''dl_src='' @ serialize_mac m" |
"serialize_of_match _ (EtherDst m) = ''dl_dst='' @ serialize_mac m" |
"serialize_of_match _ (IPv4Proto i) = ''nw_proto='' @ dec_string_of_word0 i" |
"serialize_of_match _ (IPv4Src p) = ''nw_src='' @ prefix_to_string p" |
"serialize_of_match _ (IPv4Dst p) = ''nw_dst='' @ prefix_to_string p" |
"serialize_of_match _ (L4Src i m) = ''tp_src='' @ dec_string_of_word0 i @ (if m = max_word then [] else ''/0x'' @ hex_string_of_word 3 m)" |
"serialize_of_match _ (L4Dst i m) = ''tp_dst='' @ dec_string_of_word0 i @ (if m = max_word then [] else ''/0x'' @ hex_string_of_word 3 m)"

definition serialize_of_matches :: "(string \<Rightarrow> string) \<Rightarrow> of_match_field set \<Rightarrow> string"
  where
  "serialize_of_matches pids \<equiv> (@) ''hard_timeout=0,idle_timeout=0,'' \<circ> intersperse (CHR '','') \<circ> map (serialize_of_match pids) \<circ> sorted_list_of_set"

lemma "serialize_of_matches pids of_matches=
(List.append ''hard_timeout=0,idle_timeout=0,'')
  (intersperse (CHR '','') (map (serialize_of_match pids) (sorted_list_of_set of_matches)))"
by (simp add: serialize_of_matches_def)

export_code serialize_of_matches checking SML (*needs "HOL-Library.Code_Char"*)

lemma "serialize_of_matches (\<lambda>oif. ''42'') (ofe_fields serialization_test_entry) =
  ''hard_timeout=0,idle_timeout=0,in_port=42,dl_type=0x800,dl_dst=00:00:00:00:00:01,nw_proto=6,nw_dst=10.0.2.1/32,tp_src=1024/0x03ff,tp_dst=80/0x0000''"
by eval

definition "serialize_of_entry pids e \<equiv> (case e of (OFEntry p f a) \<Rightarrow> ''priority='' @ dec_string_of_word0 p @ '','' @ serialize_of_matches pids f @ '','' @ ''action='' @ serialize_actions pids a)"

lemma "serialize_of_entry (the \<circ> map_of [(''s1-lan'',''42''),(''s1-wan'',''1337'')]) serialization_test_entry =
  ''priority=7,hard_timeout=0,idle_timeout=0,in_port=42,dl_type=0x800,dl_dst=00:00:00:00:00:01,nw_proto=6,nw_dst=10.0.2.1/32,tp_src=1024/0x03ff,tp_dst=80/0x0000,action=mod_dl_dst:a6:41:f1:85:e8:62,output:1337''"
  by eval

end


theory Optimizing
imports Semantics_Ternary
begin

section\<open>Optimizing\<close>

subsection\<open>Removing Shadowed Rules\<close>
text\<open>Note: there is no executable code for rmshadow at the moment\<close>

text\<open>Assumes: @{term "simple_ruleset"}\<close>
fun rmshadow :: "('a, 'p) match_tac \<Rightarrow> 'a rule list \<Rightarrow> 'p set \<Rightarrow> 'a rule list" where
  "rmshadow _ [] _ = []" |
  "rmshadow \<gamma> ((Rule m a)#rs) P = (if (\<forall>p\<in>P. \<not> matches \<gamma> m a p)
    then
      rmshadow \<gamma> rs P
    else
      (Rule m a) # (rmshadow \<gamma> rs {p \<in> P. \<not> matches \<gamma> m a p}))"
(*needs a ruleset without log and empty*)

subsubsection\<open>Soundness\<close>
  lemma rmshadow_sound:
    "simple_ruleset rs \<Longrightarrow> p \<in> P \<Longrightarrow> approximating_bigstep_fun \<gamma> p (rmshadow \<gamma> rs P) = approximating_bigstep_fun \<gamma> p rs"
  proof(induction rs arbitrary: P)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    let ?fw="approximating_bigstep_fun \<gamma>" \<comment> \<open>firewall semantics\<close>
    let ?rm="rmshadow \<gamma>"
    let ?match="matches \<gamma> (get_match r) (get_action r)"
    let ?set="{p \<in> P. \<not> ?match p}"
    from Cons.IH Cons.prems have IH: "?fw p (?rm rs P) = ?fw p rs" by (simp add: simple_ruleset_def)
    from Cons.IH[of "?set"] Cons.prems have IH': "p \<in> ?set \<Longrightarrow> ?fw p (?rm rs ?set) = ?fw p rs" by (simp add: simple_ruleset_def)
    from Cons show ?case
      proof(cases "\<forall>p\<in>P. \<not> ?match p") \<comment> \<open>the if-condition of rmshadow\<close>
      case True
        from True have 1: "?rm (r#rs) P = ?rm rs P"
          apply(cases r)
          apply(rename_tac m a)
          apply(clarify)
          apply(simp)
          done
        from True Cons.prems have "?fw p (r # rs) = ?fw p rs"
          apply(cases r)
          apply(rename_tac m a)
          apply(simp add: fun_eq_iff)
          apply(clarify)
          apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
          apply(simp)
          done
        from this IH have "?fw p (?rm rs P) = ?fw p (r#rs) " by simp
        thus "?fw p (?rm (r#rs) P) = ?fw p (r#rs) " using 1 by simp
      next
      case False \<comment> \<open>else\<close>
        have "?fw p (r # (?rm rs ?set)) = ?fw p (r # rs)"
          proof(cases "p \<in> ?set")
            case True
              from True IH' show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
                apply(cases r)
                apply(rename_tac m a)
                apply(simp add: fun_eq_iff)
                apply(clarify)
                apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
                apply(simp)
                done
            next
            case False
              from False Cons.prems have "?match p" by simp
              from Cons.prems have "get_action r = Accept \<or> get_action r = Drop" by(simp add: simple_ruleset_def)
              from this \<open>?match p\<close>show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
                apply(cases r)
                apply(rename_tac m a)
                apply(simp add: fun_eq_iff)
                apply(clarify)
                apply(rename_tac s)
                apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
                apply(simp split:action.split)
                apply fast
                done
          qed
        from False this show ?thesis
          apply(cases r)
          apply(rename_tac m a)
          apply(simp add: fun_eq_iff)
          apply(clarify)
          apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
          apply(simp)
          done
    qed
  qed

subsection\<open>Removing rules which cannot apply\<close>

fun rmMatchFalse :: "'a rule list \<Rightarrow> 'a rule list" where
  "rmMatchFalse [] = []" |
  "rmMatchFalse ((Rule (MatchNot MatchAny) _)#rs) = rmMatchFalse rs" |
  "rmMatchFalse (r#rs) = r # rmMatchFalse rs"

lemma rmMatchFalse_correct: "approximating_bigstep_fun \<gamma> p (rmMatchFalse rs) s = approximating_bigstep_fun \<gamma> p rs s"
  proof-
    { fix m::"'a match_expr" and a and rs
      assume assm: "m \<noteq> MatchNot MatchAny"
      have "rmMatchFalse (Rule m a # rs) = Rule m a # (rmMatchFalse rs)" (is ?hlp)
      proof(cases m)
        case (MatchNot mexpr) with assm show ?hlp by(cases mexpr) simp_all
        qed(simp_all)
    } note rmMatchFalse_helper=this
  show ?thesis
    proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct)
      case Empty thus ?case by(simp)
      next
      case Decision thus ?case by(metis Decision_approximating_bigstep_fun)
      next
      case (Nomatch \<gamma> p m a) thus ?case
        by(cases "m = MatchNot MatchAny") (simp_all add: rmMatchFalse_helper)
      next
      case (Match \<gamma> p m a rs)
        from Match(1) have "m \<noteq> MatchNot MatchAny" using bunch_of_lemmata_about_matches(3) by fast
        with Match rmMatchFalse_helper show ?case by(simp split:action.split)
    qed
  qed

text\<open>We can stop after a default rule (a rule which matches anything) is observed.\<close>
fun cut_off_after_match_any :: "'a rule list \<Rightarrow> 'a rule list" where
  "cut_off_after_match_any [] = []" |
  "cut_off_after_match_any (Rule m a # rs) =
    (if m = MatchAny \<and> (a = Accept \<or> a = Drop \<or> a = Reject)
     then [Rule m a] else Rule m a # cut_off_after_match_any rs)"

lemma cut_off_after_match_any:
  "approximating_bigstep_fun \<gamma> p (cut_off_after_match_any rs) s = approximating_bigstep_fun \<gamma> p rs s"
  apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
  apply(induction \<gamma> p rs s rule: approximating_bigstep_fun.induct)
    apply(simp; fail)
   apply(simp; fail)
  by(simp split: action.split action.split_asm add: bunch_of_lemmata_about_matches(2))

lemma cut_off_after_match_any_simplers: "simple_ruleset rs \<Longrightarrow> simple_ruleset (cut_off_after_match_any rs)"
  by(induction rs rule: cut_off_after_match_any.induct) (simp_all add: simple_ruleset_def)

lemma cut_off_after_match_any_preserve_matches:
  "\<forall> r \<in> set rs. P (get_match r) \<Longrightarrow> \<forall> r \<in> set (cut_off_after_match_any rs). P (get_match r)"
  apply(induction rs rule: cut_off_after_match_any.induct)
   apply(simp; fail)
  by(auto simp add: simple_ruleset_def)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005 (modified)    |
            |              September 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_continuous
imports CSP_F_domain Domain_F_cpo CSP_T.CSP_T_mono
begin

(*****************************************************************

         1. continuous failuresfun
         2. continuous failuresFun
         3. continuous [[ ]]Ffun
         4. continuous [[ ]]FFun

 *****************************************************************)

(*=============================================================*
 |                     traces fstF                             |
 *=============================================================*)

lemma continuous_traces_fstF:
   "continuous ((%M. traces P (fstF o M)))"
apply (subgoal_tac "(%M. traces P (fstF o M)) = (traces P) o ((o) fstF)")
apply (simp add: continuous_traces continuous_op_fstF compo_continuous)
apply (simp add: fun_eq_iff)
done

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

lemma continuous_failures_STOP: "continuous (failures (STOP))"
by (simp add: failures_iff continuous_Constant)

lemma continuous_failures_SKIP: "continuous (failures (SKIP))"
by (simp add: failures_iff continuous_Constant)

lemma continuous_failures_DIV: "continuous (failures (DIV))"
by (simp add: failures_iff continuous_Constant)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma continuous_failures_Act_prefix:
 "continuous (failures P) ==> continuous (failures (a -> P))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionF)
apply (rule order_antisym)

(* <= *)
apply (rule)
apply (simp add: in_failures)
apply (erule disjE, fast)
apply (elim conjE exE)
apply (simp)

(* => *)
apply (rule)
apply (simp)
apply (erule bexE)
apply (simp add: in_failures)
apply (erule disjE, simp)
apply (elim conjE exE)
apply (rule disjI2)
apply (rule_tac x="sa" in exI, simp)
apply (rule_tac x="xa" in bexI)
apply (simp_all)

by (simp add: directed_def)

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

lemma continuous_failures_Ext_pre_choice:
 "ALL a. continuous (failures (Pf a))
     ==> continuous (failures (? a:X -> (Pf a)))"
apply (simp add: continuous_iff)
apply (intro allI impI)

apply (subgoal_tac "Xa ~= {}")
apply (erule exchange_forall_orderE)
apply (drule_tac x="Xa" in spec)
apply (simp add: isLUB_UnionF)

apply (rule_tac x="LUB Xa" in exI)
apply (rule conjI)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (erule disjE, fast)
 apply (elim conjE exE)
 apply (simp)
 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB Xa = x", simp)
 apply (simp add: isLUB_LUB)

(* => *)
 apply (rule)
 apply (simp)
 apply (erule bexE)
 apply (simp add: in_failures)
 apply (erule disjE, simp)
 apply (elim conjE exE)
 apply (rule disjI2)
 apply (rule_tac x="a" in exI)
 apply (rule_tac x="sa" in exI, simp)

 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB Xa = xa", simp)
 apply (rule_tac x="x" in bexI)
 apply (simp)
 apply (simp)
 apply (simp add: isLUB_LUB)

 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (simp add: isLUB_LUB)

by (simp add: directed_def)

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

lemma continuous_failures_Ext_choice:
 "[| continuous (failures P) ; continuous (failures Q) |]
  ==> continuous (failures (P [+] Q))"
apply (subgoal_tac "mono (failures P) & mono (failures Q)")
apply (subgoal_tac "continuous (%M. traces P (fstF o M)) &
                    continuous (%M. traces Q (fstF o M))")
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (elim conjE)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (subgoal_tac "xb = x")
apply (subgoal_tac "xc = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionF)
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim conjE bexE disjE)

 (* 1 *)
  apply (simp add: directed_def)
  apply (drule_tac x="xd" in spec)
  apply (drule_tac x="xe" in spec)
  apply (simp, elim conjE exE)
  apply (rule_tac x="z" in bexI)
  apply (rule disjI1)
  apply (rule conjI)
  apply (rule memF_subsetF, simp)
  apply (simp add: mono_def)
  apply (rotate_tac -4)
  apply (rule memF_subsetF, simp)
  apply (simp add: mono_def)

 (* 2-5 *)
  apply (fast)+

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (fast)

apply (simp add: directed_def)
apply (rule LUB_unique, simp_all)+

apply (simp add: continuous_traces_fstF)
apply (simp add: continuous_mono)
done

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

lemma continuous_failures_Int_choice:
 "[| continuous (failures P) ; continuous (failures Q) |]
  ==> continuous (failures (P |~| Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionF)
apply (rule order_antisym)
 apply (rule, simp add: in_failures, fast)
 apply (rule, simp add: in_failures, fast)
apply (simp add: directed_def)
by (rule LUB_unique, simp_all)

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

lemma continuous_failures_Rep_int_choice:
 "ALL c. continuous (failures (Pf c))
  ==> continuous (failures (!! :C .. Pf))"
apply (simp add: continuous_iff)
apply (intro allI impI)

apply (subgoal_tac "X ~= {}")
apply (erule exchange_forall_orderE)
apply (drule_tac x="X" in spec)
apply (simp add: isLUB_UnionF)

apply (rule_tac x="LUB X" in exI)
apply (rule conjI)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim conjE bexE)
 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB X = x", simp)
 apply (elim bexE)
 apply (rule_tac x="xa" in bexI)
 apply (fast)
 apply (simp)
 apply (simp add: isLUB_LUB)

(* => *)
 apply (rule)
 apply (simp)
 apply (erule bexE)
 apply (simp add: in_failures)
 apply (elim conjE bexE)
 apply (rule_tac x="c" in bexI)

 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB X = xa", simp)
 apply (rule_tac x="x" in bexI)
 apply (simp)
 apply (simp)
 apply (simp add: isLUB_LUB)
 apply (simp)

 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (simp add: isLUB_LUB)

by (simp add: directed_def)

(*--------------------------------*
 |              IF                |
 *--------------------------------*)

lemma continuous_failures_IF:
 "[| continuous (failures P) ; continuous (failures Q) |]
  ==> continuous (failures (IF b THEN P ELSE Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)
apply (case_tac "b")
 apply (rule_tac x="x" in exI, simp)
 apply (simp add: failures_iff)

 apply (rule_tac x="xa" in exI, simp)
 apply (simp add: failures_iff)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

lemma continuous_failures_Parallel:
 "[| continuous (failures P) ; continuous (failures Q) |]
  ==> continuous (failures (P |[X]| Q))"
apply (subgoal_tac "mono (failures P) & mono (failures Q)")

apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="Xa" in spec, simp)
apply (drule_tac x="Xa" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "Xa ~= {}")
apply (simp add: isLUB_UnionF)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim exE bexE conjE)

 apply (simp add: directed_def)
 apply (drule_tac x="xb" in spec)
 apply (drule_tac x="xc" in spec)
 apply (simp, elim conjE exE)
 apply (rule_tac x="z" in bexI)
 apply (rule_tac x="Y" in exI)
 apply (rule_tac x="Z" in exI)
 apply (simp)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)

 apply (rule conjI)
 apply (rule memF_subsetF, simp)
 apply (simp add: mono_def)
 apply (rotate_tac -4)
 apply (rule memF_subsetF, simp)
 apply (simp add: mono_def)
 apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (fast)

apply (simp add: directed_def)
apply (simp add: LUB_unique)

by (simp add: continuous_mono)

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

lemma continuous_failures_Hiding:
 "continuous (failures P)
  ==> continuous (failures (P -- X))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="Xa" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "Xa ~= {}")
apply (simp add: isLUB_UnionF)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (fast)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (fast)

by (simp add: directed_def)

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

lemma continuous_failures_Renaming:
 "continuous (failures P)
  ==> continuous (failures (P [[r]]))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionF)
apply (rule order_antisym)
 apply (rule, simp add: in_failures, fast)
 apply (rule, simp add: in_failures, fast)
by (simp add: directed_def)

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

lemma continuous_failures_Seq_compo:
 "[| continuous (failures P) ; continuous (failures Q) |]
  ==> continuous (failures (P ;; Q))"
apply (subgoal_tac "mono (traces P) & mono (failures Q)")
apply (subgoal_tac "continuous (%M. traces P (fstF o M))")
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (subgoal_tac "xb = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionF)
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim bexE exE conjE disjE)

 (* 1 *)
  apply (fast)

 (* 2 *)
  apply (simp add: directed_def)
  apply (drule_tac x="xc" in spec)
  apply (drule_tac x="xd" in spec)
  apply (simp, elim conjE exE)
  apply (rule_tac x="z" in bexI)
  apply (rule disjI2)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

  apply (rule conjI)
  apply (rule memT_subdomT, simp)
  apply (simp add: mono_def)
  apply (subgoal_tac "fstF o xc <= fstF o z")
  apply (simp add: comp_def)

  apply (simp add: comp_def)
  apply (simp add: order_prod_def)
  apply (simp add: mono_fstF[simplified mono_def])

  apply (rotate_tac -4)
  apply (rule memF_subsetF, simp)
  apply (simp add: mono_def)
  apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (fast)

apply (simp add: directed_def)
apply (simp add: LUB_unique)+
apply (simp add: continuous_traces_fstF)
apply (simp add: continuous_mono)
apply (simp add: mono_traces)
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

lemma continuous_failures_Depth_rest:
 "continuous (failures P)
  ==> continuous (failures (P |. n))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionF)
apply (rule order_antisym)
 apply (rule, simp add: in_failures)
 apply (rule, simp add: in_failures)
by (simp add: directed_def)

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

lemma continuous_failures_variable_lm: "continuous (sndF o (%M. M p))"
apply (rule compo_continuous)
apply (simp add: continuous_prod_variable)
apply (simp add: sndF_def)
apply (rule compo_continuous)
apply (simp add: cont_Rep_domF)
apply (simp add: snd_continuous)
done

lemma continuous_failures_variable:
   "continuous (failures ($p))"
apply (simp add: failures_iff)
apply (simp add: continuous_failures_variable_lm[simplified comp_def])
done

(** [[ ]]Ff **)

lemma continuous_semFf_variable: "continuous ([[$p]]Ff)"
apply (simp add: semFf_Proc_name)
apply (simp add: continuous_prod_variable)
done

(*--------------------------------*
 |             Proc               |
 *--------------------------------*)

lemma continuous_failures: "continuous (failures P)"
apply (induct_tac P)
apply (simp add: continuous_failures_STOP)
apply (simp add: continuous_failures_SKIP)
apply (simp add: continuous_failures_DIV)
apply (simp add: continuous_failures_Act_prefix)
apply (simp add: continuous_failures_Ext_pre_choice)
apply (simp add: continuous_failures_Ext_choice)
apply (simp add: continuous_failures_Int_choice)
apply (simp add: continuous_failures_Rep_int_choice)
apply (simp add: continuous_failures_IF)
apply (simp add: continuous_failures_Parallel)
apply (simp add: continuous_failures_Hiding)
apply (simp add: continuous_failures_Renaming)
apply (simp add: continuous_failures_Seq_compo)
apply (simp add: continuous_failures_Depth_rest)
apply (simp add: continuous_failures_variable)
done

(*=============================================================*
 |                          [[P]]Ff                            |
 *=============================================================*)

lemma continuous_semFf:
  "continuous ([[Pf]]Ff)"
apply (simp add: semFf_def)
apply (simp add: continuous_domF_decompo)
apply (simp add: continuous_traces_fstF)
apply (simp add: continuous_failures)
done

(*=============================================================*
 |                         [[P]]Ffun                           |
 *=============================================================*)

lemma continuous_semFfun:
  "continuous ([[PF]]Ffun)"
apply (simp add: semFfun_def)
apply (simp add: prod_continuous)
apply (simp add: proj_fun_def comp_def)
apply (simp add: continuous_semFf)
done

end


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>LBV for the JVM \label{sec:JVM}\<close>

theory LBVJVM
imports "../DFA/Abstract_BV" TF_JVM
begin

type_synonym prog_cert = "cname \<Rightarrow> mname \<Rightarrow> ty\<^sub>i' err list"

definition check_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> bool"
where
  "check_cert P mxs mxl n cert \<equiv> check_types P mxs mxl cert \<and> size cert = n+1 \<and>
                                 (\<forall>i<n. cert!i \<noteq> Err) \<and> cert!n = OK None"

definition lbvjvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow>
             ty\<^sub>i' err list \<Rightarrow> instr list \<Rightarrow> ty\<^sub>i' err \<Rightarrow> ty\<^sub>i' err"
where
  "lbvjvm P mxs maxr T\<^sub>r et cert bs \<equiv>
  wtl_inst_list bs cert (JVM_SemiType.sup P mxs maxr) (JVM_SemiType.le P mxs maxr) Err (OK None) (exec P mxs T\<^sub>r et bs) 0"

definition wt_lbv :: "jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
             ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> instr list \<Rightarrow> bool"
where
  "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 et cert ins \<equiv>
   check_cert P mxs (1+size Ts+mxl\<^sub>0) (size ins) cert \<and>
   0 < size ins \<and>
   (let start  = Some ([],(OK (Class C))#((map OK Ts))@(replicate mxl\<^sub>0 Err));
        result = lbvjvm P mxs (1+size Ts+mxl\<^sub>0) T\<^sub>r et cert ins (OK start)
    in result \<noteq> Err)"

definition wt_jvm_prog_lbv :: "jvm_prog \<Rightarrow> prog_cert \<Rightarrow> bool"
where
  "wt_jvm_prog_lbv P cert \<equiv>
  wf_prog (\<lambda>P C (mn,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,b,et)). wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 et (cert C mn) b) P"

definition mk_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow> instr list
              \<Rightarrow> ty\<^sub>m \<Rightarrow> ty\<^sub>i' err list"
where
  "mk_cert P mxs T\<^sub>r et bs phi \<equiv> make_cert (exec P mxs T\<^sub>r et bs) (map OK phi) (OK None)"

definition prg_cert :: "jvm_prog \<Rightarrow> ty\<^sub>P \<Rightarrow> prog_cert"
where
  "prg_cert P phi C mn \<equiv> let (C,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,ins,et)) = method P C mn
                         in  mk_cert P mxs T\<^sub>r et ins (phi C mn)"

lemma check_certD [intro?]:
  "check_cert P mxs mxl n cert \<Longrightarrow> cert_ok cert n Err (OK None) (states P mxs mxl)"
  by (unfold cert_ok_def check_cert_def check_types_def) auto

lemma (in start_context) wt_lbv_wt_step:
  assumes lbv: "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
  shows "\<exists>\<tau>s \<in> list (size is) A. wt_step r Err step \<tau>s \<and> OK first \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof -
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err \<in> A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)"
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None \<in> A" by (simp add: JVM_states_unfold)
  moreover note bounded_step
  moreover from lbv have "cert_ok cert (size is) Err (OK None) A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover note exec_pres_type
  moreover
  from lbv
  have "wtl_inst_list is cert f r Err (OK None) step 0 (OK first) \<noteq> Err"
    by (simp add: wt_lbv_def lbvjvm_def step_def_exec [symmetric])
  moreover note first_in_A
  moreover from lbv have "0 < size is" by (simp add: wt_lbv_def)
  ultimately show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed
(*>*)

lemma (in start_context) wt_lbv_wt_method:
  assumes lbv: "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
  shows "\<exists>\<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from lbv have l: "is \<noteq> []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C Ts obtain \<tau>s where
    list:  "\<tau>s \<in> list (size is) A" and
    step:  "wt_step r Err step \<tau>s" and
    start: "OK first \<sqsubseteq>\<^sub>r \<tau>s!0"
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "size \<tau>s = size is" by simp
  have "size (map ok_val \<tau>s) = size is" by simp
  moreover from l have 0: "0 < size \<tau>s" by simp
  with step obtain \<tau>s0 where "\<tau>s!0 = OK \<tau>s0"
    by (unfold wt_step_def) blast
  with start 0 have "wt_start P C Ts mxl\<^sub>0 (map ok_val \<tau>s)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def Err.le_def)
  moreover {
    from list have "check_types P mxs mxl \<tau>s" by (simp add: check_types_def)
    also from step  have "\<forall>x \<in> set \<tau>s. x \<noteq> Err"
      by (auto simp add: all_set_conv_all_nth wt_step_def)
    hence [symmetric]: "map OK (map ok_val \<tau>s) = \<tau>s"
      by (auto intro!: map_idI)
    finally have "check_types P mxs mxl (map OK (map ok_val \<tau>s))" .
  }
  moreover {
    note bounded_step
    moreover from list have "set \<tau>s \<subseteq> A" by simp
    moreover from step have "wt_err_step (sup_state_opt P) step \<tau>s"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def states_def)
  }
  ultimately have "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s)"
    by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis ..
qed
(*>*)

lemma (in start_context) wt_method_wt_lbv:
  assumes wt: "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  defines [simp]: "cert \<equiv> mk_cert P mxs T\<^sub>r xt is \<tau>s"

  shows "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
(*<*)
proof -
  let ?\<tau>s  = "map OK \<tau>s"
  let ?cert = "make_cert step ?\<tau>s (OK None)"

  from wt obtain
    0:        "0 < size is" and
    size:     "size is = size ?\<tau>s" and
    ck_types: "check_types P mxs mxl ?\<tau>s" and
    wt_start: "wt_start P C Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (force simp add: wt_method_def2 check_types_def)

  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err \<in> A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)"
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None \<in> A" by (simp add: JVM_states_unfold)
  moreover from wf have "mono r step (size is) A" by (rule step_mono)
  hence "mono r step (size ?\<tau>s) A" by (simp add: size)
  moreover from exec_pres_type
  have "pres_type step (size ?\<tau>s) A" by (simp add: size)
  moreover
  from ck_types have \<tau>s_in_A: "set ?\<tau>s \<subseteq> A" by (simp add: check_types_def)
  hence "\<forall>pc. pc < size ?\<tau>s \<longrightarrow> ?\<tau>s!pc \<in> A \<and> ?\<tau>s!pc \<noteq> Err" by auto
  moreover from bounded_step
  have "bounded step (size ?\<tau>s)" by (simp add: size)
  moreover have "OK None \<noteq> Err" by simp
  moreover from bounded_step size \<tau>s_in_A app_eff
  have "wt_err_step (sup_state_opt P) step ?\<tau>s"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def states_def)
  hence "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  from 0 size have "0 < size \<tau>s" by auto
  hence "?\<tau>s!0 = OK (\<tau>s!0)" by simp
  with wt_start have "OK first \<sqsubseteq>\<^sub>r ?\<tau>s!0"
    by (clarsimp simp add: wt_start_def lesub_def Err.le_def JVM_le_Err_conv)
  moreover note first_in_A
  moreover have "OK first \<noteq> Err" by simp
  moreover note size
  ultimately
  have "wtl_inst_list is ?cert f r Err (OK None) step 0 (OK first) \<noteq> Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover from 0 size have "\<tau>s \<noteq> []" by auto
  moreover from ck_types have "check_types P mxs mxl ?cert"
    apply (auto simp add: make_cert_def check_types_def JVM_states_unfold)
    apply (subst Ok_in_err [symmetric])
    apply (drule nth_mem)
    apply auto
    done
  moreover note 0 size
  ultimately show ?thesis
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def step_def_exec [symmetric]
                  check_cert_def make_cert_def nth_append)
qed
(*>*)

theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv P Cert \<Longrightarrow> wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C mn. let (C,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C mn in
              SOME \<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"

  assume wt: "wt_jvm_prog_lbv P Cert"
  hence "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P"
    apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
    apply (erule wf_prog_lift)
    apply (auto dest!: start_context.wt_lbv_wt_method [OF start_context.intro]
                intro: someI)
    apply (erule sees_method_is_class)
    done
  thus ?thesis by (unfold wf_jvm_prog_def) blast
qed
(*>*)

theorem jvm_lbv_complete:
  assumes wt: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  shows "wt_jvm_prog_lbv P (prg_cert P \<Phi>)"
(*<*)
  using wt
  apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
  apply (erule wf_prog_lift)
  apply (auto simp add: prg_cert_def
              intro!: start_context.wt_method_wt_lbv start_context.intro)
  apply (erule sees_method_is_class)
  done
(*>*)

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Cong_Subst
  imports Weak_Early_Cong Weak_Early_Bisim_Subst Strong_Early_Bisim_Subst
begin

consts congruenceSubst :: "(pi \<times> pi) set"

definition weakCongruenceSubst (infixr "\<simeq>\<^sup>s" 65) where "P \<simeq>\<^sup>s Q \<equiv> \<forall>\<sigma>. P[<\<sigma>>] \<simeq> Q[<\<sigma>>]"

lemma unfoldE:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<simeq>\<^sup>s Q"

  shows "P[<s>] \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q[<s>]"
  and   "Q[<s>] \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P[<s>]"
proof -
  from assms show "P[<s>] \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q[<s>]" by(simp add: weakCongruenceSubst_def weakCongruence_def)
next
  from assms show "Q[<s>] \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P[<s>]" by(simp add: weakCongruenceSubst_def weakCongruence_def)
qed

lemma unfoldI:
  fixes P :: pi
  and   Q :: pi

  assumes "\<And>s. P[<s>] \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q[<s>]"
  and     "\<And>s. Q[<s>] \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P[<s>]"

  shows "P \<simeq>\<^sup>s Q"
using assms
by(simp add: weakCongruenceSubst_def weakCongruence_def)

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<simeq> Q"
using assms
apply(simp add: weakCongruenceSubst_def weakCongruence_def)
apply(erule_tac x="[]" in allE)
by auto

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   p :: "name prm"

  assumes "P \<simeq>\<^sup>s Q"

  shows "(p \<bullet> P) \<simeq>\<^sup>s (p \<bullet> Q)"
proof(simp add: weakCongruenceSubst_def, rule allI)
  fix s
  from assms have "P[<(rev p \<bullet> s)>] \<simeq> Q[<(rev p \<bullet> s)>]" by(auto simp add: weakCongruenceSubst_def)
  thus "(p \<bullet> P)[<s>] \<simeq> (p \<bullet> Q)[<s>]" by(drule_tac p=p in Weak_Early_Cong.eqvtI) (simp add: eqvts name_per_rev)
qed

lemma strongEqWeakCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<simeq>\<^sup>s Q"
using assms
by(auto intro: strongBisimWeakCong simp add: substClosed_def weakCongruenceSubst_def)

lemma congSubstBisimSubst:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<approx>\<^sup>s Q"
using assms
by(auto intro: congruenceWeakBisim simp add: substClosed_def weakCongruenceSubst_def)

lemma reflexive:
  fixes P :: pi

  shows "P \<simeq>\<^sup>s P"
proof -
  from Weak_Early_Bisim.reflexive have "\<And>P. P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P"
    by(blast intro: Weak_Early_Step_Sim.reflexive)
  thus ?thesis
    by(force simp add: weakCongruenceSubst_def weakCongruence_def)
qed

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "Q \<simeq>\<^sup>s P"
using assms by(auto simp add: weakCongruenceSubst_def weakCongruence_def)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<simeq>\<^sup>s Q"

  shows "P[<s>] \<simeq>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: weakCongruenceSubst_def)
  fix s'
  assume "\<forall>s. P[<s>] \<simeq> Q[<s>]"
  hence "P[<(s@s')>] \<simeq> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<simeq> (Q[<s>])[<s'>]"
    by simp
qed

end


theory CR
imports Lam_Funs
begin

text {* The Church-Rosser proof from Barendregt's book *}

lemma forget:
  assumes asm: "x\<sharp>L"
  shows "L[x::=P] = L"
using asm
proof (nominal_induct L avoiding: x P rule: lam.strong_induct)
  case (Var z)
  have "x\<sharp>Var z" by fact
  thus "(Var z)[x::=P] = (Var z)" by (simp add: fresh_atm)
next
  case (App M1 M2)
  have "x\<sharp>App M1 M2" by fact
  moreover
  have ih1: "x\<sharp>M1 \<Longrightarrow> M1[x::=P] = M1" by fact
  moreover
  have ih1: "x\<sharp>M2 \<Longrightarrow> M2[x::=P] = M2" by fact
  ultimately show "(App M1 M2)[x::=P] = (App M1 M2)" by simp
next
  case (Lam z M)
  have vc: "z\<sharp>x" "z\<sharp>P" by fact+
  have ih: "x\<sharp>M \<Longrightarrow>  M[x::=P] = M" by fact
  have asm: "x\<sharp>Lam [z].M" by fact
  then have "x\<sharp>M" using vc by (simp add: fresh_atm abs_fresh)
  then have "M[x::=P] = M" using ih by simp
  then show "(Lam [z].M)[x::=P] = Lam [z].M" using vc by simp
qed

lemma forget_automatic:
  assumes asm: "x\<sharp>L"
  shows "L[x::=P] = L"
  using asm
by (nominal_induct L avoiding: x P rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact:
  fixes z::"name"
  assumes asms: "z\<sharp>N" "z\<sharp>L"
  shows "z\<sharp>(N[y::=L])"
using asms
proof (nominal_induct N avoiding: z y L rule: lam.strong_induct)
  case (Var u)
  have "z\<sharp>(Var u)" "z\<sharp>L" by fact+
  thus "z\<sharp>((Var u)[y::=L])" by simp
next
  case (App N1 N2)
  have ih1: "\<lbrakk>z\<sharp>N1; z\<sharp>L\<rbrakk> \<Longrightarrow> z\<sharp>N1[y::=L]" by fact
  moreover
  have ih2: "\<lbrakk>z\<sharp>N2; z\<sharp>L\<rbrakk> \<Longrightarrow> z\<sharp>N2[y::=L]" by fact
  moreover
  have "z\<sharp>App N1 N2" "z\<sharp>L" by fact+
  ultimately show "z\<sharp>((App N1 N2)[y::=L])" by simp
next
  case (Lam u N1)
  have vc: "u\<sharp>z" "u\<sharp>y" "u\<sharp>L" by fact+
  have "z\<sharp>Lam [u].N1" by fact
  hence "z\<sharp>N1" using vc by (simp add: abs_fresh fresh_atm)
  moreover
  have ih: "\<lbrakk>z\<sharp>N1; z\<sharp>L\<rbrakk> \<Longrightarrow> z\<sharp>(N1[y::=L])" by fact
  moreover
  have  "z\<sharp>L" by fact
  ultimately show "z\<sharp>(Lam [u].N1)[y::=L]" using vc by (simp add: abs_fresh)
qed

lemma fresh_fact_automatic:
  fixes z::"name"
  assumes asms: "z\<sharp>N" "z\<sharp>L"
  shows "z\<sharp>(N[y::=L])"
  using asms
by (nominal_induct N avoiding: z y L rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact':
  fixes a::"name"
  assumes a: "a\<sharp>t2"
  shows "a\<sharp>t1[a::=t2]"
using a
by (nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma substitution_lemma:
  assumes a: "x\<noteq>y"
  and     b: "x\<sharp>L"
  shows "M[x::=N][y::=L] = M[y::=L][x::=N[y::=L]]"
using a b
proof (nominal_induct M avoiding: x y N L rule: lam.strong_induct)
  case (Var z) (* case 1: Variables*)
  have "x\<noteq>y" by fact
  have "x\<sharp>L" by fact
  show "Var z[x::=N][y::=L] = Var z[y::=L][x::=N[y::=L]]" (is "?LHS = ?RHS")
  proof -
    { (*Case 1.1*)
      assume  "z=x"
      have "(1)": "?LHS = N[y::=L]" using `z=x` by simp
      have "(2)": "?RHS = N[y::=L]" using `z=x` `x\<noteq>y` by simp
      from "(1)" "(2)" have "?LHS = ?RHS"  by simp
    }
    moreover
    { (*Case 1.2*)
      assume "z=y" and "z\<noteq>x"
      have "(1)": "?LHS = L"               using `z\<noteq>x` `z=y` by simp
      have "(2)": "?RHS = L[x::=N[y::=L]]" using `z=y` by simp
      have "(3)": "L[x::=N[y::=L]] = L"    using `x\<sharp>L` by (simp add: forget)
      from "(1)" "(2)" "(3)" have "?LHS = ?RHS" by simp
    }
    moreover
    { (*Case 1.3*)
      assume "z\<noteq>x" and "z\<noteq>y"
      have "(1)": "?LHS = Var z" using `z\<noteq>x` `z\<noteq>y` by simp
      have "(2)": "?RHS = Var z" using `z\<noteq>x` `z\<noteq>y` by simp
      from "(1)" "(2)" have "?LHS = ?RHS" by simp
    }
    ultimately show "?LHS = ?RHS" by blast
  qed
next
  case (Lam z M1) (* case 2: lambdas *)
  have ih: "\<lbrakk>x\<noteq>y; x\<sharp>L\<rbrakk> \<Longrightarrow> M1[x::=N][y::=L] = M1[y::=L][x::=N[y::=L]]" by fact
  have "x\<noteq>y" by fact
  have "x\<sharp>L" by fact
  have fs: "z\<sharp>x" "z\<sharp>y" "z\<sharp>N" "z\<sharp>L" by fact+
  hence "z\<sharp>N[y::=L]" by (simp add: fresh_fact)
  show "(Lam [z].M1)[x::=N][y::=L] = (Lam [z].M1)[y::=L][x::=N[y::=L]]" (is "?LHS=?RHS")
  proof -
    have "?LHS = Lam [z].(M1[x::=N][y::=L])" using `z\<sharp>x` `z\<sharp>y` `z\<sharp>N` `z\<sharp>L` by simp
    also from ih have "\<dots> = Lam [z].(M1[y::=L][x::=N[y::=L]])" using `x\<noteq>y` `x\<sharp>L` by simp
    also have "\<dots> = (Lam [z].(M1[y::=L]))[x::=N[y::=L]]" using `z\<sharp>x` `z\<sharp>N[y::=L]` by simp
    also have "\<dots> = ?RHS" using  `z\<sharp>y` `z\<sharp>L` by simp
    finally show "?LHS = ?RHS" .
  qed
next
  case (App M1 M2) (* case 3: applications *)
  thus "(App M1 M2)[x::=N][y::=L] = (App M1 M2)[y::=L][x::=N[y::=L]]" by simp
qed

lemma substitution_lemma_automatic:
  assumes asm: "x\<noteq>y" "x\<sharp>L"
  shows "M[x::=N][y::=L] = M[y::=L][x::=N[y::=L]]"
  using asm
by (nominal_induct M avoiding: x y N L rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

section {* Beta Reduction *}

inductive
  "Beta" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _" [80,80] 80)
where
    b1[intro]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> (App s1 t)\<longrightarrow>\<^sub>\<beta>(App s2 t)"
  | b2[intro]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> (App t s1)\<longrightarrow>\<^sub>\<beta>(App t s2)"
  | b3[intro]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> (Lam [a].s1)\<longrightarrow>\<^sub>\<beta> (Lam [a].s2)"
  | b4[intro]: "a\<sharp>s2 \<Longrightarrow> (App (Lam [a].s1) s2)\<longrightarrow>\<^sub>\<beta>(s1[a::=s2])"

equivariance Beta

nominal_inductive Beta
  by (simp_all add: abs_fresh fresh_fact')

inductive
  "Beta_star"  :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta>\<^sup>* _" [80,80] 80)
where
    bs1[intro, simp]: "M \<longrightarrow>\<^sub>\<beta>\<^sup>* M"
  | bs2[intro]: "\<lbrakk>M1\<longrightarrow>\<^sub>\<beta>\<^sup>* M2; M2 \<longrightarrow>\<^sub>\<beta> M3\<rbrakk> \<Longrightarrow> M1 \<longrightarrow>\<^sub>\<beta>\<^sup>* M3"

equivariance Beta_star

lemma beta_star_trans:
  assumes a1: "M1\<longrightarrow>\<^sub>\<beta>\<^sup>* M2"
  and     a2: "M2\<longrightarrow>\<^sub>\<beta>\<^sup>* M3"
  shows "M1 \<longrightarrow>\<^sub>\<beta>\<^sup>* M3"
using a2 a1
by (induct) (auto)

section {* One-Reduction *}

inductive
  One :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1 _" [80,80] 80)
where
    o1[intro!]:      "M\<longrightarrow>\<^sub>1M"
  | o2[simp,intro!]: "\<lbrakk>t1\<longrightarrow>\<^sub>1t2;s1\<longrightarrow>\<^sub>1s2\<rbrakk> \<Longrightarrow> (App t1 s1)\<longrightarrow>\<^sub>1(App t2 s2)"
  | o3[simp,intro!]: "s1\<longrightarrow>\<^sub>1s2 \<Longrightarrow> (Lam [a].s1)\<longrightarrow>\<^sub>1(Lam [a].s2)"
  | o4[simp,intro!]: "\<lbrakk>a\<sharp>(s1,s2); s1\<longrightarrow>\<^sub>1s2;t1\<longrightarrow>\<^sub>1t2\<rbrakk> \<Longrightarrow> (App (Lam [a].t1) s1)\<longrightarrow>\<^sub>1(t2[a::=s2])"

equivariance One

nominal_inductive One
  by (simp_all add: abs_fresh fresh_fact')

inductive
  "One_star"  :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1\<^sup>* _" [80,80] 80)
where
    os1[intro, simp]: "M \<longrightarrow>\<^sub>1\<^sup>* M"
  | os2[intro]: "\<lbrakk>M1\<longrightarrow>\<^sub>1\<^sup>* M2; M2 \<longrightarrow>\<^sub>1 M3\<rbrakk> \<Longrightarrow> M1 \<longrightarrow>\<^sub>1\<^sup>* M3"

equivariance One_star

lemma one_star_trans:
  assumes a1: "M1\<longrightarrow>\<^sub>1\<^sup>* M2"
  and     a2: "M2\<longrightarrow>\<^sub>1\<^sup>* M3"
  shows "M1\<longrightarrow>\<^sub>1\<^sup>* M3"
using a2 a1
by (induct) (auto)

lemma one_fresh_preserv:
  fixes a :: "name"
  assumes a: "t\<longrightarrow>\<^sub>1s"
  and     b: "a\<sharp>t"
  shows "a\<sharp>s"
using a b
proof (induct)
  case o1 thus ?case by simp
next
  case o2 thus ?case by simp
next
  case (o3 s1 s2 c)
  have ih: "a\<sharp>s1 \<Longrightarrow>  a\<sharp>s2" by fact
  have c: "a\<sharp>Lam [c].s1" by fact
  show ?case
  proof (cases "a=c")
    assume "a=c" thus "a\<sharp>Lam [c].s2" by (simp add: abs_fresh)
  next
    assume d: "a\<noteq>c"
    with c have "a\<sharp>s1" by (simp add: abs_fresh)
    hence "a\<sharp>s2" using ih by simp
    thus "a\<sharp>Lam [c].s2" using d by (simp add: abs_fresh)
  qed
next
  case (o4 c t1 t2 s1 s2)
  have i1: "a\<sharp>t1 \<Longrightarrow> a\<sharp>t2" by fact
  have i2: "a\<sharp>s1 \<Longrightarrow> a\<sharp>s2" by fact
  have as: "a\<sharp>App (Lam [c].s1) t1" by fact
  hence c1: "a\<sharp>Lam [c].s1" and c2: "a\<sharp>t1" by (simp add: fresh_prod)+
  from c2 i1 have c3: "a\<sharp>t2" by simp
  show "a\<sharp>s2[c::=t2]"
  proof (cases "a=c")
    assume "a=c"
    thus "a\<sharp>s2[c::=t2]" using c3 by (simp add: fresh_fact')
  next
    assume d1: "a\<noteq>c"
    from c1 d1 have "a\<sharp>s1" by (simp add: abs_fresh)
    hence "a\<sharp>s2" using i2 by simp
    thus "a\<sharp>s2[c::=t2]" using c3 by (simp add: fresh_fact)
  qed
qed

lemma one_fresh_preserv_automatic:
  fixes a :: "name"
  assumes a: "t\<longrightarrow>\<^sub>1s"
  and     b: "a\<sharp>t"
  shows "a\<sharp>s"
using a b
apply(nominal_induct avoiding: a rule: One.strong_induct)
apply(auto simp add: abs_fresh fresh_atm fresh_fact)
done

lemma subst_rename:
  assumes a: "c\<sharp>t1"
  shows "t1[a::=t2] = ([(c,a)]\<bullet>t1)[c::=t2]"
using a
by (nominal_induct t1 avoiding: a c t2 rule: lam.strong_induct)
   (auto simp add: calc_atm fresh_atm abs_fresh)

lemma one_abs:
  assumes a: "Lam [a].t\<longrightarrow>\<^sub>1t'"
  shows "\<exists>t''. t'=Lam [a].t'' \<and> t\<longrightarrow>\<^sub>1t''"
proof -
  have "a\<sharp>Lam [a].t" by (simp add: abs_fresh)
  with a have "a\<sharp>t'" by (simp add: one_fresh_preserv)
  with a show ?thesis
    by (cases rule: One.strong_cases[where a="a" and aa="a"])
       (auto simp add: lam.inject abs_fresh alpha)
qed

lemma one_app:
  assumes a: "App t1 t2 \<longrightarrow>\<^sub>1 t'"
  shows "(\<exists>s1 s2. t' = App s1 s2 \<and> t1 \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2) \<or>
         (\<exists>a s s1 s2. t1 = Lam [a].s \<and> t' = s1[a::=s2] \<and> s \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2 \<and> a\<sharp>(t2,s2))"
using a by (erule_tac One.cases) (auto simp add: lam.inject)

lemma one_red:
  assumes a: "App (Lam [a].t1) t2 \<longrightarrow>\<^sub>1 M" "a\<sharp>(t2,M)"
  shows "(\<exists>s1 s2. M = App (Lam [a].s1) s2 \<and> t1 \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2) \<or>
         (\<exists>s1 s2. M = s1[a::=s2] \<and> t1 \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2)"
using a
by (cases rule: One.strong_cases [where a="a" and aa="a"])
   (auto dest: one_abs simp add: lam.inject abs_fresh alpha fresh_prod)

text {* first case in Lemma 3.2.4*}

lemma one_subst_aux:
  assumes a: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N] \<longrightarrow>\<^sub>1 M[x::=N']"
using a
proof (nominal_induct M avoiding: x N N' rule: lam.strong_induct)
  case (Var y)
  thus "Var y[x::=N] \<longrightarrow>\<^sub>1 Var y[x::=N']" by (cases "x=y") auto
next
  case (App P Q) (* application case - third line *)
  thus "(App P Q)[x::=N] \<longrightarrow>\<^sub>1  (App P Q)[x::=N']" using o2 by simp
next
  case (Lam y P) (* abstraction case - fourth line *)
  thus "(Lam [y].P)[x::=N] \<longrightarrow>\<^sub>1 (Lam [y].P)[x::=N']" using o3 by simp
qed

lemma one_subst_aux_automatic:
  assumes a: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N] \<longrightarrow>\<^sub>1 M[x::=N']"
using a
by (nominal_induct M avoiding: x N N' rule: lam.strong_induct)
   (auto simp add: fresh_prod fresh_atm)

lemma one_subst:
  assumes a: "M\<longrightarrow>\<^sub>1M'"
  and     b: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N]\<longrightarrow>\<^sub>1M'[x::=N']"
using a b
proof (nominal_induct M M' avoiding: N N' x rule: One.strong_induct)
  case (o1 M)
  thus ?case by (simp add: one_subst_aux)
next
  case (o2 M1 M2 N1 N2)
  thus ?case by simp
next
  case (o3 a M1 M2)
  thus ?case by simp
next
  case (o4 a N1 N2 M1 M2 N N' x)
  have vc: "a\<sharp>N" "a\<sharp>N'" "a\<sharp>x" "a\<sharp>N1" "a\<sharp>N2" by fact+
  have asm: "N\<longrightarrow>\<^sub>1N'" by fact
  show ?case
  proof -
    have "(App (Lam [a].M1) N1)[x::=N] = App (Lam [a].(M1[x::=N])) (N1[x::=N])" using vc by simp
    moreover have "App (Lam [a].(M1[x::=N])) (N1[x::=N]) \<longrightarrow>\<^sub>1 M2[x::=N'][a::=N2[x::=N']]"
      using o4 asm by (simp add: fresh_fact)
    moreover have "M2[x::=N'][a::=N2[x::=N']] = M2[a::=N2][x::=N']"
      using vc by (simp add: substitution_lemma fresh_atm)
    ultimately show "(App (Lam [a].M1) N1)[x::=N] \<longrightarrow>\<^sub>1 M2[a::=N2][x::=N']" by simp
  qed
qed

lemma one_subst_automatic:
  assumes a: "M\<longrightarrow>\<^sub>1M'"
  and     b: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N]\<longrightarrow>\<^sub>1M'[x::=N']"
using a b
by (nominal_induct M M' avoiding: N N' x rule: One.strong_induct)
   (auto simp add: one_subst_aux substitution_lemma fresh_atm fresh_fact)

lemma diamond[rule_format]:
  fixes    M :: "lam"
  and      M1:: "lam"
  assumes a: "M\<longrightarrow>\<^sub>1M1"
  and     b: "M\<longrightarrow>\<^sub>1M2"
  shows "\<exists>M3. M1\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3"
  using a b
proof (nominal_induct avoiding: M1 M2 rule: One.strong_induct)
  case (o1 M) (* case 1 --- M1 = M *)
  thus "\<exists>M3. M\<longrightarrow>\<^sub>1M3 \<and>  M2\<longrightarrow>\<^sub>1M3" by blast
next
  case (o4 x Q Q' P P') (* case 2 --- a beta-reduction occurs*)
  have vc: "x\<sharp>Q" "x\<sharp>Q'" "x\<sharp>M2" by fact+
  have i1: "\<And>M2. Q \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have i2: "\<And>M2. P \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have "App (Lam [x].P) Q \<longrightarrow>\<^sub>1 M2" by fact
  hence "(\<exists>P' Q'. M2 = App (Lam [x].P') Q' \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q') \<or>
         (\<exists>P' Q'. M2 = P'[x::=Q'] \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q')" using vc by (simp add: one_red)
  moreover (* subcase 2.1 *)
  { assume "\<exists>P' Q'. M2 = App (Lam [x].P') Q' \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q'"
    then obtain P'' and Q'' where
      b1: "M2=App (Lam [x].P'') Q''" and b2: "P\<longrightarrow>\<^sub>1P''" and b3: "Q\<longrightarrow>\<^sub>1Q''" by blast
    from b2 i2 have "(\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> P''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P''' where
      c1: "P'\<longrightarrow>\<^sub>1P'''" and c2: "P''\<longrightarrow>\<^sub>1P'''" by force
    from b3 i1 have "(\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by force
    from c1 c2 d1 d2
    have "P'[x::=Q']\<longrightarrow>\<^sub>1P'''[x::=Q'''] \<and> App (Lam [x].P'') Q'' \<longrightarrow>\<^sub>1 P'''[x::=Q''']"
      using vc b3 by (auto simp add: one_subst one_fresh_preserv)
    hence "\<exists>M3. P'[x::=Q']\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  moreover (* subcase 2.2 *)
  { assume "\<exists>P' Q'. M2 = P'[x::=Q'] \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q'"
    then obtain P'' Q'' where
      b1: "M2=P''[x::=Q'']" and b2: "P\<longrightarrow>\<^sub>1P''" and  b3: "Q\<longrightarrow>\<^sub>1Q''" by blast
    from b2 i2 have "(\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> P''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P''' where
      c1: "P'\<longrightarrow>\<^sub>1P'''" and c2: "P''\<longrightarrow>\<^sub>1P'''" by blast
    from b3 i1 have "(\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by blast
    from c1 c2 d1 d2
    have "P'[x::=Q']\<longrightarrow>\<^sub>1P'''[x::=Q'''] \<and> P''[x::=Q'']\<longrightarrow>\<^sub>1P'''[x::=Q''']"
      by (force simp add: one_subst)
    hence "\<exists>M3. P'[x::=Q']\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  ultimately show "\<exists>M3. P'[x::=Q']\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" by blast
next
  case (o2 P P' Q Q') (* case 3 *)
  have i0: "P\<longrightarrow>\<^sub>1P'" by fact
  have i0': "Q\<longrightarrow>\<^sub>1Q'" by fact
  have i1: "\<And>M2. Q \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have i2: "\<And>M2. P \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  assume "App P Q \<longrightarrow>\<^sub>1 M2"
  hence "(\<exists>P'' Q''. M2 = App P'' Q'' \<and> P\<longrightarrow>\<^sub>1P'' \<and> Q\<longrightarrow>\<^sub>1Q'') \<or>
         (\<exists>x P' P'' Q'. P = Lam [x].P' \<and> M2 = P''[x::=Q'] \<and> P'\<longrightarrow>\<^sub>1 P'' \<and> Q\<longrightarrow>\<^sub>1Q' \<and> x\<sharp>(Q,Q'))"
    by (simp add: one_app[simplified])
  moreover (* subcase 3.1 *)
  { assume "\<exists>P'' Q''. M2 = App P'' Q'' \<and> P\<longrightarrow>\<^sub>1P'' \<and> Q\<longrightarrow>\<^sub>1Q''"
    then obtain P'' and Q'' where
      b1: "M2=App P'' Q''" and b2: "P\<longrightarrow>\<^sub>1P''" and b3: "Q\<longrightarrow>\<^sub>1Q''" by blast
    from b2 i2 have "(\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> P''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P''' where
      c1: "P'\<longrightarrow>\<^sub>1P'''" and c2: "P''\<longrightarrow>\<^sub>1P'''" by blast
    from b3 i1 have "\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by blast
    from c1 c2 d1 d2
    have "App P' Q'\<longrightarrow>\<^sub>1App P''' Q''' \<and> App P'' Q'' \<longrightarrow>\<^sub>1 App P''' Q'''" by blast
    hence "\<exists>M3. App P' Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  moreover (* subcase 3.2 *)
  { assume "\<exists>x P1 P'' Q''. P = Lam [x].P1 \<and> M2 = P''[x::=Q''] \<and> P1\<longrightarrow>\<^sub>1 P'' \<and> Q\<longrightarrow>\<^sub>1Q'' \<and> x\<sharp>(Q,Q'')"
    then obtain x P1 P1'' Q'' where
      b0: "P = Lam [x].P1" and b1: "M2 = P1''[x::=Q'']" and
      b2: "P1\<longrightarrow>\<^sub>1P1''" and  b3: "Q\<longrightarrow>\<^sub>1Q''" and vc: "x\<sharp>(Q,Q'')" by blast
    from b0 i0 have "\<exists>P1'. P'=Lam [x].P1' \<and> P1\<longrightarrow>\<^sub>1P1'" by (simp add: one_abs)
    then obtain P1' where g1: "P'=Lam [x].P1'" and g2: "P1\<longrightarrow>\<^sub>1P1'" by blast
    from g1 b0 b2 i2 have "(\<exists>M3. (Lam [x].P1')\<longrightarrow>\<^sub>1M3 \<and> (Lam [x].P1'')\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P1''' where
      c1: "(Lam [x].P1')\<longrightarrow>\<^sub>1P1'''" and c2: "(Lam [x].P1'')\<longrightarrow>\<^sub>1P1'''" by blast
    from c1 have "\<exists>R1. P1'''=Lam [x].R1 \<and> P1'\<longrightarrow>\<^sub>1R1" by (simp add: one_abs)
    then obtain R1 where r1: "P1'''=Lam [x].R1" and r2: "P1'\<longrightarrow>\<^sub>1R1" by blast
    from c2 have "\<exists>R2. P1'''=Lam [x].R2 \<and> P1''\<longrightarrow>\<^sub>1R2" by (simp add: one_abs)
    then obtain R2 where r3: "P1'''=Lam [x].R2" and r4: "P1''\<longrightarrow>\<^sub>1R2" by blast
    from r1 r3 have r5: "R1=R2" by (simp add: lam.inject alpha)
    from b3 i1 have "(\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by blast
    from g1 r2 d1 r4 r5 d2
    have "App P' Q'\<longrightarrow>\<^sub>1R1[x::=Q'''] \<and> P1''[x::=Q'']\<longrightarrow>\<^sub>1R1[x::=Q''']"
      using vc i0' by (simp add: one_subst one_fresh_preserv)
    hence "\<exists>M3. App P' Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  ultimately show "\<exists>M3. App P' Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" by blast
next
  case (o3 P P' x) (* case 4 *)
  have i1: "P\<longrightarrow>\<^sub>1P'" by fact
  have i2: "\<And>M2. P \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have "(Lam [x].P)\<longrightarrow>\<^sub>1 M2" by fact
  hence "\<exists>P''. M2=Lam [x].P'' \<and> P\<longrightarrow>\<^sub>1P''" by (simp add: one_abs)
  then obtain P'' where b1: "M2=Lam [x].P''" and b2: "P\<longrightarrow>\<^sub>1P''" by blast
  from i2 b1 b2 have "\<exists>M3. (Lam [x].P')\<longrightarrow>\<^sub>1M3 \<and> (Lam [x].P'')\<longrightarrow>\<^sub>1M3" by blast
  then obtain M3 where c1: "(Lam [x].P')\<longrightarrow>\<^sub>1M3" and c2: "(Lam [x].P'')\<longrightarrow>\<^sub>1M3" by blast
  from c1 have "\<exists>R1. M3=Lam [x].R1 \<and> P'\<longrightarrow>\<^sub>1R1" by (simp add: one_abs)
  then obtain R1 where r1: "M3=Lam [x].R1" and r2: "P'\<longrightarrow>\<^sub>1R1" by blast
  from c2 have "\<exists>R2. M3=Lam [x].R2 \<and> P''\<longrightarrow>\<^sub>1R2" by (simp add: one_abs)
  then obtain R2 where r3: "M3=Lam [x].R2" and r4: "P''\<longrightarrow>\<^sub>1R2" by blast
  from r1 r3 have r5: "R1=R2" by (simp add: lam.inject alpha)
  from r2 r4 have "(Lam [x].P')\<longrightarrow>\<^sub>1(Lam [x].R1) \<and> (Lam [x].P'')\<longrightarrow>\<^sub>1(Lam [x].R2)"
    by (simp add: one_subst)
  thus "\<exists>M3. (Lam [x].P')\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 r5 by blast
qed

lemma one_lam_cong:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "(Lam [a].t1)\<longrightarrow>\<^sub>\<beta>\<^sup>*(Lam [a].t2)"
  using a
proof induct
  case bs1 thus ?case by simp
next
  case (bs2 y z)
  thus ?case by (blast dest: b3)
qed

lemma one_app_congL:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "App t1 s\<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s"
  using a
proof induct
  case bs1 thus ?case by simp
next
  case bs2 thus ?case by (blast dest: b1)
qed

lemma one_app_congR:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "App s t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App s t2"
using a
proof induct
  case bs1 thus ?case by simp
next
  case bs2 thus ?case by (blast dest: b2)
qed

lemma one_app_cong:
  assumes a1: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  and     a2: "s1\<longrightarrow>\<^sub>\<beta>\<^sup>*s2"
  shows "App t1 s1\<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s2"
proof -
  have "App t1 s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s1" using a1 by (rule one_app_congL)
  moreover
  have "App t2 s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s2" using a2 by (rule one_app_congR)
  ultimately show ?thesis by (rule beta_star_trans)
qed

lemma one_beta_star:
  assumes a: "(t1\<longrightarrow>\<^sub>1t2)"
  shows "(t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2)"
  using a
proof(nominal_induct rule: One.strong_induct)
  case o1 thus ?case by simp
next
  case o2 thus ?case by (blast intro!: one_app_cong)
next
  case o3 thus ?case by (blast intro!: one_lam_cong)
next
  case (o4 a s1 s2 t1 t2)
  have vc: "a\<sharp>s1" "a\<sharp>s2" by fact+
  have a1: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2" and a2: "s1\<longrightarrow>\<^sub>\<beta>\<^sup>*s2" by fact+
  have c1: "(App (Lam [a].t2) s2) \<longrightarrow>\<^sub>\<beta> (t2 [a::= s2])" using vc by (simp add: b4)
  from a1 a2 have c2: "App (Lam [a].t1 ) s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App (Lam [a].t2 ) s2"
    by (blast intro!: one_app_cong one_lam_cong)
  show ?case using c2 c1 by (blast intro: beta_star_trans)
qed

lemma one_star_lam_cong:
  assumes a: "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  shows "(Lam  [a].t1)\<longrightarrow>\<^sub>1\<^sup>* (Lam [a].t2)"
  using a
proof induct
  case os1 thus ?case by simp
next
  case os2 thus ?case by (blast intro: one_star_trans)
qed

lemma one_star_app_congL:
  assumes a: "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  shows "App t1 s\<longrightarrow>\<^sub>1\<^sup>* App t2 s"
  using a
proof induct
  case os1 thus ?case by simp
next
  case os2 thus ?case by (blast intro: one_star_trans)
qed

lemma one_star_app_congR:
  assumes a: "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  shows "App s t1 \<longrightarrow>\<^sub>1\<^sup>* App s t2"
  using a
proof induct
  case os1 thus ?case by simp
next
  case os2 thus ?case by (blast intro: one_star_trans)
qed

lemma beta_one_star:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>t2"
  shows "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  using a
proof(induct)
  case b1 thus ?case by (blast intro!: one_star_app_congL)
next
  case b2 thus ?case by (blast intro!: one_star_app_congR)
next
  case b3 thus ?case by (blast intro!: one_star_lam_cong)
next
  case b4 thus ?case by auto
qed

lemma trans_closure:
  shows "(M1\<longrightarrow>\<^sub>1\<^sup>*M2) = (M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M2)"
proof
  assume "M1 \<longrightarrow>\<^sub>1\<^sup>* M2"
  then show "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M2"
  proof induct
    case (os1 M1) thus "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M1" by simp
  next
    case (os2 M1 M2 M3)
    have "M2\<longrightarrow>\<^sub>1M3" by fact
    then have "M2\<longrightarrow>\<^sub>\<beta>\<^sup>*M3" by (rule one_beta_star)
    moreover have "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M2" by fact
    ultimately show "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M3" by (auto intro: beta_star_trans)
  qed
next
  assume "M1 \<longrightarrow>\<^sub>\<beta>\<^sup>* M2"
  then show "M1\<longrightarrow>\<^sub>1\<^sup>*M2"
  proof induct
    case (bs1 M1) thus  "M1\<longrightarrow>\<^sub>1\<^sup>*M1" by simp
  next
    case (bs2 M1 M2 M3)
    have "M2\<longrightarrow>\<^sub>\<beta>M3" by fact
    then have "M2\<longrightarrow>\<^sub>1\<^sup>*M3" by (rule beta_one_star)
    moreover have "M1\<longrightarrow>\<^sub>1\<^sup>*M2" by fact
    ultimately show "M1\<longrightarrow>\<^sub>1\<^sup>*M3" by (auto intro: one_star_trans)
  qed
qed

lemma cr_one:
  assumes a: "t\<longrightarrow>\<^sub>1\<^sup>*t1"
  and     b: "t\<longrightarrow>\<^sub>1t2"
  shows "\<exists>t3. t1\<longrightarrow>\<^sub>1t3 \<and> t2\<longrightarrow>\<^sub>1\<^sup>*t3"
  using a b
proof (induct arbitrary: t2)
  case os1 thus ?case by force
next
  case (os2 t s1 s2 t2)
  have b: "s1 \<longrightarrow>\<^sub>1 s2" by fact
  have h: "\<And>t2. t \<longrightarrow>\<^sub>1 t2 \<Longrightarrow> (\<exists>t3. s1 \<longrightarrow>\<^sub>1 t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3)" by fact
  have c: "t \<longrightarrow>\<^sub>1 t2" by fact
  show "\<exists>t3. s2 \<longrightarrow>\<^sub>1 t3 \<and>  t2 \<longrightarrow>\<^sub>1\<^sup>* t3"
  proof -
    from c h have "\<exists>t3. s1 \<longrightarrow>\<^sub>1 t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3" by blast
    then obtain t3 where c1: "s1 \<longrightarrow>\<^sub>1 t3" and c2: "t2 \<longrightarrow>\<^sub>1\<^sup>* t3" by blast
    have "\<exists>t4. s2 \<longrightarrow>\<^sub>1 t4 \<and> t3 \<longrightarrow>\<^sub>1 t4" using b c1 by (blast intro: diamond)
    thus ?thesis using c2 by (blast intro: one_star_trans)
  qed
qed

lemma cr_one_star:
  assumes a: "t\<longrightarrow>\<^sub>1\<^sup>*t2"
      and b: "t\<longrightarrow>\<^sub>1\<^sup>*t1"
    shows "\<exists>t3. t1\<longrightarrow>\<^sub>1\<^sup>*t3\<and>t2\<longrightarrow>\<^sub>1\<^sup>*t3"
using a b
proof (induct arbitrary: t1)
  case (os1 t) then show ?case by force
next
  case (os2 t s1 s2 t1)
  have c: "t \<longrightarrow>\<^sub>1\<^sup>* s1" by fact
  have c': "t \<longrightarrow>\<^sub>1\<^sup>* t1" by fact
  have d: "s1 \<longrightarrow>\<^sub>1 s2" by fact
  have "t \<longrightarrow>\<^sub>1\<^sup>* t1 \<Longrightarrow> (\<exists>t3.  t1 \<longrightarrow>\<^sub>1\<^sup>* t3 \<and> s1 \<longrightarrow>\<^sub>1\<^sup>* t3)" by fact
  then obtain t3 where f1: "t1 \<longrightarrow>\<^sub>1\<^sup>* t3"
                   and f2: "s1 \<longrightarrow>\<^sub>1\<^sup>* t3" using c' by blast
  from cr_one d f2 have "\<exists>t4. t3\<longrightarrow>\<^sub>1t4 \<and> s2\<longrightarrow>\<^sub>1\<^sup>*t4" by blast
  then obtain t4 where g1: "t3\<longrightarrow>\<^sub>1t4"
                   and g2: "s2\<longrightarrow>\<^sub>1\<^sup>*t4" by blast
  have "t1\<longrightarrow>\<^sub>1\<^sup>*t4" using f1 g1 by (blast intro: one_star_trans)
  thus ?case using g2 by blast
qed

lemma cr_beta_star:
  assumes a1: "t\<longrightarrow>\<^sub>\<beta>\<^sup>*t1"
  and     a2: "t\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "\<exists>t3. t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t3\<and>t2\<longrightarrow>\<^sub>\<beta>\<^sup>*t3"
proof -
  from a1 have "t\<longrightarrow>\<^sub>1\<^sup>*t1" by (simp only: trans_closure)
  moreover
  from a2 have "t\<longrightarrow>\<^sub>1\<^sup>*t2" by (simp only: trans_closure)
  ultimately have "\<exists>t3. t1\<longrightarrow>\<^sub>1\<^sup>*t3 \<and> t2\<longrightarrow>\<^sub>1\<^sup>*t3" by (blast intro: cr_one_star)
  then obtain t3 where "t1\<longrightarrow>\<^sub>1\<^sup>*t3" and "t2\<longrightarrow>\<^sub>1\<^sup>*t3" by blast
  hence "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t3" and "t2\<longrightarrow>\<^sub>\<beta>\<^sup>*t3" by (simp_all only: trans_closure)
  then show "\<exists>t3. t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t3\<and>t2\<longrightarrow>\<^sub>\<beta>\<^sup>*t3" by blast
qed

end