(*  Title:      CoW/Reverse_Symmetry.thy
    Author:     Martin Raška, Charles University
*)

theory Reverse_Symmetry
  imports Main
begin

chapter "Reverse symmetry"

text \<open>This theory deals with a mechanism which produces new facts on lists from already known facts
by the reverse symmetry of lists, induced by the mapping @{term rev}.
It constructs the rule attribute ``reversed'' which produces the symmetrical fact using so-called
reversal rules, which are rewriting rules that may be applied to obtain the symmetrical fact.
An example of such a reversal rule is the already existing @{thm rev_append[symmetric, no_vars]}.
Some additional reversal rules are given in this theory.

The symmetrical fact 'A[reversed]' is constructed from the fact 'A' in the following manner:
  1. each schematic variable @{term "xs::'a list"} of type @{typ "'a list"}
is instantiated by @{term "rev xs"};
  2. constant Nil is substituted by @{term "rev Nil"};
  3. each quantification of @{typ "'a list"} type variable @{term "\<And>(xs::'a list). P xs"}
is substituted by (logically equivalent) quantification @{term "\<And>xs. P (rev xs)"},
similarly for $\forall$, $\exists$ and $\exists!$ quantifiers; each bounded quantification of @{typ "'a list"} type
variable @{term "\<forall>(xs::'a list) \<in> A. P xs"} is substituted by (logically equivalent)
quantification @{term "\<forall>xs\<in>rev ` A. P (rev xs)"}, similarly for bounded $\exists$ quantifier;
  4. simultaneous rewrites according to a the current list of reversal rules are performed;
  5. final correctional rewrites related to reversion of @{const "Cons"} are performed.

List of reversal rules is maintained by declaration attribute ``reversal\_rule'' with standard
``add'' and ``del'' options.

See examples at the end of the file.
\<close>

section \<open>Quantifications and maps\<close>

lemma all_surj_conv: assumes "surj f" shows "(\<And>x. PROP P (f x)) \<equiv> (\<And>y. PROP P y)"
proof
  fix y assume "\<And>x. PROP P (f x)"
  then have "PROP P (f (inv f y))".
  then show "PROP P y" unfolding surj_f_inv_f[OF assms].
qed

lemma All_surj_conv: assumes "surj f" shows "(\<forall>x. P (f x)) \<longleftrightarrow> (\<forall>y. P y)"
proof (intro iffI allI)
  fix y assume "\<forall>x. P (f x)"
  then have "P (f (inv f y))"..
  then show "P y" unfolding surj_f_inv_f[OF assms].
qed simp

lemma Ex_surj_conv: assumes "surj f" shows "(\<exists>x. P (f x)) \<longleftrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then obtain x where "P (f x)"..
  then show "\<exists>x. P x"..
next
  assume "\<exists>y. P y"
  then obtain y where "P y"..
  then have "P (f (inv f y))" unfolding surj_f_inv_f[OF assms].
  then show "\<exists>x. P (f x)"..
qed

lemma Ex1_bij_conv: assumes "bij f" shows "(\<exists>!x. P (f x)) \<longleftrightarrow> (\<exists>!y. P y)"
proof
  have imp: "\<exists>!y. Q y" if bij: "bij g" and ex1: "\<exists>!x. Q (g x)" for g Q
  proof -
    from ex1E[OF ex1, rule_format]
    obtain x where ex: "Q (g x)" and uniq: "\<And>x'. Q (g x') \<Longrightarrow> x' = x" by blast
    {
      fix y assume "Q y"
      then have "Q (g (inv g y))" unfolding surj_f_inv_f[OF bij_is_surj[OF bij]].
      from uniq[OF this] have "x = inv g y"..
      then have "y = g x" unfolding bij_inv_eq_iff[OF bij]..
    }
    with ex show "\<exists>!y. Q y"..
  qed
  show "\<exists>!x. P (f x) \<Longrightarrow> \<exists>!y. P y" using imp[OF assms].
  assume "\<exists>!y. P y"
  then have "\<exists>!y. P (f (inv f y))" unfolding surj_f_inv_f[OF bij_is_surj[OF assms]].
  from imp[OF bij_imp_bij_inv[OF assms] this]
  show "\<exists>!x. P (f x)".
qed

lemma Ball_inj_conv: assumes "inj f" shows "(\<forall>y\<in>f ` A. P (inv f y)) \<longleftrightarrow> (\<forall>x\<in>A. P x)"
  using ball_simps(9)[of f A "\<lambda>y. P (inv f y)"] unfolding inv_f_f[OF assms].

lemma Bex_inj_conv: assumes "inj f" shows "(\<exists>y\<in>f ` A. P (inv f y)) \<longleftrightarrow> (\<exists>x\<in>A. P x)"
  using bex_simps(7)[of f A "\<lambda>y. P (inv f y)"] unfolding inv_f_f[OF assms].

subsection \<open>Quantifications and reverse\<close>

lemma rev_involution: "rev \<circ> rev = id"
  by auto

lemma rev_bij: "bij rev"
  using o_bij[OF rev_involution rev_involution].

lemma rev_inv: "inv rev = rev"
  using inv_unique_comp[OF rev_involution rev_involution].

lemmas all_rev_conv = all_surj_conv[OF bij_is_surj[OF rev_bij]]
   and All_rev_conv = All_surj_conv[OF bij_is_surj[OF rev_bij]]
   and Ex_rev_conv = Ex_surj_conv[OF bij_is_surj[OF rev_bij]]
   and Ex1_rev_conv = Ex1_bij_conv[OF rev_bij]
   and Ball_rev_conv = Ball_inj_conv[OF bij_is_inj[OF rev_bij], unfolded rev_inv]
   and Bex_rev_conv = Bex_inj_conv[OF bij_is_inj[OF rev_bij], unfolded rev_inv]

section \<open>Attributes\<close>

context
begin

subsection \<open>Definitons of reverse wrapers\<close>

private definition rev_Nil_wrap :: "'a list"
  where "rev_Nil_wrap = rev Nil"

private definition all_rev_wrap :: "('a list \<Rightarrow> prop) \<Rightarrow> prop"
  where "all_rev_wrap P \<equiv> (\<And>x. PROP P (rev x))"

private definition All_rev_wrap :: "('a list \<Rightarrow> bool) \<Rightarrow> bool"
  where "All_rev_wrap P = (\<forall>x. P (rev x))"

private definition Ex_rev_wrap :: "('a list \<Rightarrow> bool) \<Rightarrow> bool"
  where "Ex_rev_wrap P = (\<exists>x. P (rev x))"

private definition Ex1_rev_wrap :: "('a list \<Rightarrow> bool) \<Rightarrow> bool"
  where "Ex1_rev_wrap P = (\<exists>!x. P (rev x))"

private definition Ball_rev_wrap :: "'a list set \<Rightarrow> ('a list \<Rightarrow> bool) \<Rightarrow> bool"
  where "Ball_rev_wrap A P = (\<forall>x \<in> rev ` A. P (rev x))"

private definition Bex_rev_wrap :: "'a list set \<Rightarrow> ('a list \<Rightarrow> bool) \<Rightarrow> bool"
  where "Bex_rev_wrap A P = (\<exists>x \<in> rev ` A. P (rev x))"

subsection \<open>Initial reversal rules\<close>

private lemma rev_Nil: "rev Nil = Nil"
  by simp

private lemmas init_rev_wrap =
  eq_reflection[OF trans[OF rev_Nil[symmetric] rev_Nil_wrap_def[symmetric]]]
  transitive[OF all_rev_conv[symmetric] all_rev_wrap_def[symmetric], of P P for P]
  eq_reflection[OF trans[OF All_rev_conv[symmetric] All_rev_wrap_def[symmetric], of P P for P]]
  eq_reflection[OF trans[OF Ex_rev_conv[symmetric] Ex_rev_wrap_def[symmetric], of P P for P]] (* Ex_rev_wrapI *)
  eq_reflection[OF trans[OF Ex1_rev_conv[symmetric] Ex1_rev_wrap_def[symmetric], of P P for P]]
  eq_reflection[OF trans[OF Ball_rev_conv[symmetric] Ball_rev_wrap_def[symmetric], of P P for P]]
  eq_reflection[OF trans[OF Bex_rev_conv[symmetric] Bex_rev_wrap_def[symmetric], of P P for P]]

private lemma all_rev_unwrap: "all_rev_wrap (\<lambda>x. PROP P x) \<equiv> (\<And>x. PROP P (rev x))"
  using all_rev_wrap_def.

private lemma All_rev_unwrap: "All_rev_wrap (\<lambda>x. P x) = (\<forall>x. P (rev x))"
  using All_rev_wrap_def.

private lemma Ex_rev_unwrap: "Ex_rev_wrap (\<lambda>x. P x) = (\<exists>x. P (rev x))"
  using Ex_rev_wrap_def.

private lemma Ex1_rev_unwrap: "Ex1_rev_wrap (\<lambda>x. P x) = (\<exists>!x. P (rev x))"
  using Ex1_rev_wrap_def.

private lemma Ball_rev_unwrap: "Ball_rev_wrap A (\<lambda>x. P x) = (\<forall>x \<in> rev ` A. P (rev x))"
  using Ball_rev_wrap_def.

private lemma Bex_rev_unwrap: "Bex_rev_wrap A (\<lambda>x. P x) = (\<exists>x \<in> rev ` A. P (rev x))"
  using Bex_rev_wrap_def.

private lemmas init_rev_unwrap =
  eq_reflection[OF rev_Nil_wrap_def]
  all_rev_unwrap
  eq_reflection[OF All_rev_unwrap]
  eq_reflection[OF Ex_rev_unwrap]
  eq_reflection[OF Ex1_rev_unwrap]
  eq_reflection[OF Ball_rev_unwrap]
  eq_reflection[OF Bex_rev_unwrap]

subsection \<open>Cons reversion\<close>

definition snocs :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "snocs xs ys  = xs @ ys"

lemma Cons_rev: "a # rev u = rev (snocs u [a])"
  unfolding snocs_def by simp

lemma snocs_snocs: "snocs (snocs xs (y # ys)) zs = snocs xs (y # snocs ys zs)"
  unfolding snocs_def by simp

subsection \<open>Final corrections\<close>

lemma snocs_Nil: "snocs [] xs = xs"
  unfolding snocs_def by simp

lemma snocs_is_append: "snocs xs ys = xs @ ys"
  unfolding snocs_def..

private lemmas final_correct1 =
  snocs_Nil

private lemmas final_correct2 =
  snocs_is_append

subsection \<open>Declaration attribute \<open>reversal_rule\<close>\<close>

ML \<open>
structure Reversal_Rules =
  Named_Thms(
    val name = @{binding "reversal_rule"}
    val description = "Rules performing reverse-symmetry transformation on theorems on lists"
  )
\<close>

attribute_setup reversal_rule =
  \<open>Attrib.add_del
    (Thm.declaration_attribute Reversal_Rules.add_thm)
    (Thm.declaration_attribute Reversal_Rules.del_thm)\<close>
  "maintaining a list of reversal rules"

subsection \<open>Rule attribute \<open>reversed\<close>\<close>

ML \<open>
val eq_refl = @{thm eq_reflection}

fun pure_eq_of th =
  case Thm.prop_of th of
    Const (\<^const_name>\<open>Pure.eq\<close>, _) $ _ $ _
      => SOME (th)
  | Const (\<^const_name>\<open>Trueprop\<close>, _) $ (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ _ $ _ )
      => SOME (th RS eq_refl)
  | _ => NONE

val init_rev_wrap = @{thms init_rev_wrap}
val init_unwrap = @{thms init_rev_unwrap}
val final_correct1 = map_filter pure_eq_of @{thms final_correct1}
val final_correct2 = map_filter pure_eq_of @{thms final_correct2}

fun reverse ths context th =
  let
    val ctxt = Context.proof_of context
    val rules = map_filter pure_eq_of (ths @ Reversal_Rules.get ctxt)
    val vars = Term.add_vars (Thm.full_prop_of th) []
    fun add_inst_vars [] inst_vars = inst_vars
      | add_inst_vars ( ((v, i), T) :: vars ) inst_vars =
          case T of
            Type(\<^type_name>\<open>list\<close>, _) =>
              add_inst_vars vars (
                (
                  ((v, i), T),
                  Thm.cterm_of ctxt
                    ( Const(\<^const_name>\<open>rev\<close>, Type(\<^type_name>\<open>fun\<close>, [T, T])) $ Var((v, i), T) )
                ) :: inst_vars
              )
          | _ => add_inst_vars vars inst_vars
  in
    th
    |> Drule.instantiate_normalize
       ([], add_inst_vars vars [])
    |> Simplifier.rewrite_rule ctxt init_rev_wrap
    |> Simplifier.rewrite_rule ctxt init_unwrap
    |> Simplifier.rewrite_rule ctxt rules
    |> Simplifier.rewrite_rule ctxt final_correct1
    |> Simplifier.rewrite_rule ctxt final_correct2
  end

val reversed = Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Attrib.thms) []
  >> (fn ths => Thm.rule_attribute [] (reverse ths))
\<close>

attribute_setup reversed =
  \<open>reversed\<close>
  "Transforms the theorem on lists to reverse-symmetric version"

end

section \<open>Declaration of basic reversal rules\<close>

lemma hd_last_Nil: "hd [] = last []"
  unfolding hd_def last_def by simp

lemma last_rev_hd: "last(rev xs) = hd xs"
  by (induct xs, simp add: hd_last_Nil, simp)

lemma hd_rev_last: "hd(rev xs) = last xs"
  by (induct xs, simp add: hd_last_Nil, simp)

lemma tl_rev: "tl (rev xs) = rev (butlast xs)"
  unfolding rev_swap[symmetric] butlast_rev[of "rev xs", symmetric] rev_rev_ident..

lemma if_rev: "(if P then rev u else rev v) = rev (if P then u else v)"
  by simp

lemma rev_in_conv: "rev u \<in> A \<longleftrightarrow> u \<in> rev ` A"
  using image_iff by fastforce

lemma in_lists_rev: "u \<in> lists A \<Longrightarrow> rev u \<in> lists A"
  by auto

lemma rev_in_lists: "rev u \<in> lists A \<Longrightarrow> u \<in> lists A"
  by auto

lemma rev_lists_conv: "rev ` lists A = lists A"
proof (intro equalityI subsetI)
  fix x
  show "x \<in> rev ` lists A \<Longrightarrow> x \<in> lists A"
    unfolding rev_in_conv[symmetric] using rev_in_lists.
  show "x \<in> lists A \<Longrightarrow> x \<in> rev ` lists A"
    unfolding rev_in_conv[symmetric] using in_lists_rev.
qed

lemma coset_rev: "List.coset (rev xs) = List.coset xs"
 by simp

lemmas [reversal_rule] =
  Cons_rev
  snocs_snocs
  rev_append[symmetric]
  last_rev_hd hd_rev_last
  tl_rev butlast_rev
  rev_is_rev_conv
  length_rev
  take_rev
  drop_rev
  rotate_rev
  if_rev
  rev_in_conv
  rev_lists_conv
  set_rev
  coset_rev

section \<open>Examples\<close>

context
begin

subsection \<open>Cons and append\<close>

private lemma example_Cons_append:
  assumes "xs = [a, b]" and "ys = [b, a, b]"
  shows "xs @ xs @ xs = a # b # a # ys"
using assms by simp

thm
  example_Cons_append
  example_Cons_append[reversed]
  example_Cons_append[reversed, reversed]

thm
  not_Cons_self
  not_Cons_self[reversed]

thm
  neq_Nil_conv
  neq_Nil_conv[reversed]

subsection \<open>Induction rules\<close>

thm
  list_nonempty_induct
  list_nonempty_induct[reversed] (* needs work *)
  list_nonempty_induct[reversed, where P="\<lambda>x. P (rev x)" for P, unfolded rev_rev_ident]

thm
  list_induct2
  list_induct2[reversed] (* needs work *)
  list_induct2[reversed, where P="\<lambda>x y. P (rev x) (rev y)" for P, unfolded rev_rev_ident]

subsection \<open>hd, tl, last, butlast\<close>

thm
  hd_append
  hd_append[reversed]
  last_append

thm
  length_tl
  length_tl[reversed]
  length_butlast

thm
  hd_Cons_tl
  hd_Cons_tl[reversed]
  append_butlast_last_id
  append_butlast_last_id[reversed]

subsection \<open>set\<close>

thm
  hd_in_set
  hd_in_set[reversed]
  last_in_set

thm
  set_ConsD
  set_ConsD[reversed]

thm
  split_list_first
  split_list_first[reversed]

thm
  split_list_first_prop
  split_list_first_prop[reversed]
  split_list_first_prop[reversed, unfolded append_assoc append_Cons append_Nil]
  split_list_last_prop

thm
  split_list_first_propE
  split_list_first_propE[reversed]
  split_list_first_propE[reversed, unfolded append_assoc append_Cons append_Nil]
  split_list_last_propE

subsection \<open>rotate\<close>

private lemma rotate1_hd_tl': "xs \<noteq> [] \<Longrightarrow> rotate 1 xs = tl xs @ [hd xs]"
  by (cases xs) simp_all

thm
  rotate1_hd_tl'
  rotate1_hd_tl'[reversed]

end

end


theory ComputationConGlob imports "ComputationCon"
begin
section \<open>Auxiliary lemmas\<close>

lemma eq_list_i:
  assumes a0:"length ba = length b" and a1:"\<forall>j. j \<noteq> i \<longrightarrow> ba ! j = b ! j" and
          a3:"i < length b"
        shows " take i b @ drop (Suc i) b = take i ba @ drop (Suc i) ba"
proof-
  have "b=  take i b @ b!i # drop (Suc i) b" and "ba =  take i ba @ ba!i # drop (Suc i) ba"
    using  a0 a3 by (auto simp add: id_take_nth_drop)
  then have  "\<forall>j<i. take i b = take i ba" using a0 a1 a3
    by (metis less_imp_le_nat less_irrefl_nat nth_take_lemma)
  moreover have  "\<forall>j< length ( drop (Suc i) ba).  drop (Suc i) b!j = drop (Suc i) ba!j"
    using a0 a1 a3
    by simp
  ultimately show ?thesis using a0 a3
    by (metis append_Nil append_eq_conv_conj length_drop linorder_neqE_nat list.size(3) not_less_zero nth_equalityI)
qed

section \<open>Computation: @{text "\<Gamma>\<turnstile>(c, s) \<rightarrow>\<^sub>i\<^sub>c\<^sub>e  (c', s')"}\<close>

type_synonym ('g,'l) par_state = "('g \<times> 'l list)"
type_synonym ('g,'l,'p,'f,'e) gconf = "('g \<times> 'l,'p,'f,'e)com  \<times> ((('g,'l)par_state,'f) xstate)"
type_synonym ('g,'l,'p,'f,'e) gconfs = "('g\<times>'l,'p,'f,'e) body \<times> (('g,'l,'p,'f,'e) gconf) list"
type_synonym ('s,'f) tran = "('s,'f) xstate \<times> ('s,'f) xstate"

definition toParState::"nat \<Rightarrow> ('g\<times>'l)\<times>('l list) \<Rightarrow>   ('g,'l)par_state"
  where "toParState i s \<equiv> let ((g,l),ls) = s in
             (g, (take i ls)@ (l#(drop i ls)))"

lemma toPar_li:"i \<le> length ls  \<Longrightarrow>
       (g',ls') = toParState i ((g,l),ls) \<Longrightarrow>
       ls' ! i = l"
  unfolding toParState_def
  by (auto, metis (no_types) length_take min.absorb2 nth_append_length)

lemma toPar_gi:"
       (g',ls') = toParState i ((g,l),ls) \<Longrightarrow>
       g' = g"
  unfolding toParState_def Let_def by auto

lemma toPar_ljlti:assumes a0:"i \<le> length ls" and a1:"j< i" and
       a2:"(g',ls') = toParState i ((g,l),ls)"
     shows" ls' ! j = ls!j"
proof -
  have "\<forall>as. take i as = take i ls \<or> ls' \<noteq> as"
    using a2 a0
    unfolding toParState_def by (simp add: append_eq_conv_conj min.absorb2)
  then show ?thesis
    using a2
    by (metis a1 nth_take)
qed

lemma toPar_ljgti:assumes a0:"i \<le> length ls" and a1:"j > i" and a1': "j< length ls'" and
       a2:"(g',ls') = toParState i ((g,l),ls)"
     shows" ls' ! j = ls!(j-1)"
proof-
  have ls':"ls' = take i ls @ l # drop i ls" using a2 unfolding toParState_def by auto
  then have "length ls' = length ls+1"
    by auto
  have j:"j < Suc (min (length ls) i + length ls - i)"
    using a0 a1 a1' a2 unfolding toParState_def by auto
  moreover { assume "(length ls) \<le> i + length ls - i"
    then have ?thesis using ls' a0 a1 ls'
      by (auto simp add: min.absorb2 nth_append)
  }
  moreover
  {assume "(length ls) > i + length ls - i"
    then have ?thesis using ls' a0 a1 ls'
      using diff_add_inverse min.strict_order_iff by auto
  }
  ultimately show ?thesis by auto
qed

lemma len_toParState:"length (snd (toParState i s )) = length (snd s) +1"
  unfolding toParState_def Let_def split_beta
  by simp

definition toSeqState::"nat \<Rightarrow>  ('g,'l)par_state \<Rightarrow> ('g\<times>'l)\<times>('l list)"
  where "toSeqState i s \<equiv> let (g,ls) = s in ((g,ls!i), take i ls @ drop (i+1) ls)"

lemma len_toSeqState:"i<length (snd s) \<Longrightarrow> length (snd (toSeqState i s)) = length (snd s) -1"
  unfolding toSeqState_def Let_def split_beta
  by simp

lemma i_less_toSeq:"i<length (snd (toSeqState i s)) \<Longrightarrow> i<length (snd s)"
  unfolding toSeqState_def Let_def split_beta
  by (metis Suc_eq_plus1 append_Nil2 drop_all
       less_imp_le_nat not_le_imp_less not_less_eq snd_conv take_all)

lemma Par2Seq0:"i\<le>length ls \<Longrightarrow> toSeqState i (toParState i (g,ls)) = (g,ls)"
proof (induct  rule: rev_induct)
  case Nil
  then show ?case  unfolding toSeqState_def toParState_def
    by (simp add: split_beta)
next
  case (snoc x xs)
  then show ?case unfolding toSeqState_def toParState_def Let_def
  proof(auto simp add: split_beta)
    assume "i \<le> Suc (length xs)"
    then show "(fst g,
         (take i xs @ take (i - length xs) [x] @ snd g # drop i xs @ drop (i - length xs) [x]) ! i) =
        g"
      by (metis append_assoc eq_snd_iff fst_conv length_append_singleton
          length_take min.absorb2 nth_append_length take_append)
  next
    assume a0:"i \<le> length xs \<Longrightarrow>
     (fst g, (take i xs @ snd g # drop i xs) ! i) = g \<and>
     take i xs @ drop (Suc i - min (length xs) i) (snd g # drop i xs) = xs" and
        a1:"i \<le> Suc (length xs)"
    show "take i xs @
        take (min (i - min (length xs) i) (i - length xs)) [x] @
        drop (Suc i - (min (length xs) i + min (Suc 0) (i - length xs)))
         (snd g # drop i xs @ drop (i - length xs) [x]) =
        xs @ [x]"
      using a0 a1
      by (simp add: Suc_diff_le drop_Cons' min_def not_less_eq_eq)
  qed
qed

lemma Par2Seq1:"i=length ls \<Longrightarrow> toSeqState i (toParState i (g,ls)) = (g,ls)"
  unfolding toSeqState_def toParState_def Let_def split_beta
  by auto

lemma Par2Seq:"i\<le>length ls \<Longrightarrow> toSeqState i (toParState i (g,ls)) = (g,ls)"
  using Par2Seq0 Par2Seq1
  by (metis le_neq_implies_less)

lemma len_toParState_list:"(g',ls') = toParState i ((g,l),ls) \<Longrightarrow> length ls' = length ls +1"
  unfolding toParState_def by auto

lemma len_toSeqState_list:"i<length ls \<Longrightarrow> ((g',l),ls') = toSeqState i (g,ls) \<Longrightarrow> length ls = length ls' +1"
  unfolding toSeqState_def
  by auto

lemma Seq2Par:"i<length ls \<Longrightarrow> toParState i (toSeqState i (g,ls)) = (g,ls)"
proof (induct  rule: rev_induct)
  case Nil
  then show ?case unfolding toSeqState_def toParState_def Let_def
    by auto
next
  case (snoc x xs)
  then show ?case unfolding toSeqState_def toParState_def Let_def
    apply (auto simp add: split_beta)
    by (metis butlast_snoc drop_append id_take_nth_drop snoc.prems take_butlast)
qed

(* lemma assumes a0:"i<length sl" and
       a1:"length (snd (toParState (toSeqState i (sg, sl)) i)) =
       length (snd (toParState (toSeqState i (sg', sl')) i))"
     shows "length sl = length sl'"
proof-
  have "toParState (toSeqState i (sg, sl)) i = (sg, sl)"
    using a0
    by (simp add: Seq2Par)
qed *)

(* typedef ('g,'l) global_s = "{(i,g::('g\<times>'l)\<times>('l list)).  i \<le> length (snd g)  \<and> (\<exists>g'. g' = toParState i g)}"
  unfolding toParState_def
  by auto *)

typedef ('g,'l) global_s = "{(i,g::('g\<times>'l)\<times>('l list)).  i \<le> length (snd g)  \<and> (\<exists>g'. g' = toParState i g)}"
  unfolding toParState_def
  by auto
print_theorems
term Rep_global_s
term Abs_global_s

typedef ('g,'l) global_s1 = "{(g'::('g\<times>'l list)).  (\<exists>i g. i \<le> length (snd g')  \<and> (g' = toParState i g))}"
  unfolding toParState_def
  by auto
print_theorems
term Rep_global_s
term Abs_global_s

setup_lifting type_definition_global_s

lift_definition global_s_of_local::"(nat\<times>('g\<times>'l)\<times>('l list)) \<Rightarrow> ('g,'l) global_s"
  is "\<lambda>l. (((fst l) mod (length (snd (snd l)) +1), snd l))"
  by auto

(*
definition global_s_of_local::"(nat\<times>('g\<times>'l)\<times>('l list)) \<Rightarrow> ('g,'l) global_s"
  where "global_s_of_local l \<equiv> Abs_global_s (((fst l) mod length (snd (snd l)), snd l))"
 *)
definition transfer_global_s ::"(nat\<times>('g\<times>'l)\<times>('l list)) \<Rightarrow>('g,'l) global_s \<Rightarrow> bool"
  where "transfer_global_s l g \<equiv> g = global_s_of_local l"

print_theorems

typedef ('g,'l) type_global = "{g::('g,'l)par_state. \<forall>i<length (snd g). (\<exists>g'. g = toParState i g')}"
  unfolding toParState_def Let_def split_beta
  by fastforce

print_theorems

thm Abs_type_global_inject Rep_type_global Abs_type_global_inverse Rep_type_global_inverse

term Rep_type_global
term Abs_type_global

primrec toPar_xstate::"nat \<Rightarrow> (('g\<times>'l)\<times>('l list),'f) xstate \<Rightarrow> ((('g,'l)par_state,'f) xstate)"
  where "toPar_xstate i (Normal s) = Normal (toParState i s)"
  |"toPar_xstate i (Abrupt s)  = Abrupt (toParState i s)"
  |"toPar_xstate i (Fault f)  = Fault f"
  |"toPar_xstate i Stuck  = Stuck"

primrec toSeq_xstate::"nat \<Rightarrow> ((('g,'l)par_state,'f) xstate) \<Rightarrow>  (('g\<times>'l)\<times>('l list),'f)  xstate"
  where "toSeq_xstate i (Normal s) = Normal (toSeqState i s)"
  |"toSeq_xstate i (Abrupt s) = Abrupt (toSeqState i s)"
  |"toSeq_xstate i (Fault f)  = Fault f"
  |"toSeq_xstate i Stuck = Stuck"

lemma Par_xstate_Seq_Abrupt:"i<length (snd s)  \<Longrightarrow> toPar_xstate i (toSeq_xstate i (Abrupt s)) = Abrupt s"
  apply (auto simp add: split_beta)
  by (metis Seq2Par prod.collapse)

lemma Par_xstate_Seq_Normal:"i<length (snd s)  \<Longrightarrow> toPar_xstate i (toSeq_xstate i (Normal s)) = Normal s"
  apply (auto simp add: split_beta)
  by (metis Seq2Par prod.collapse)

lemma Par_xstate_Seq_Fault:"toPar_xstate i (toSeq_xstate i (Fault f)) = Fault f"
  by auto

lemma Par_xstate_Seq_Stuck:"toPar_xstate i (toSeq_xstate i (Stuck)) = Stuck"
  by auto

lemma Par_Seq_xstate:"\<forall>nas. (s= Normal nas \<or> s = Abrupt nas)  \<longrightarrow> i< length (snd nas) \<Longrightarrow>
      toPar_xstate i (toSeq_xstate i s) = s"
  apply (cases s)
  using Par_xstate_Seq_Abrupt by auto

lemma Seq_xstate_Par_Abrupt:"i\<le>length (snd s)  \<Longrightarrow>  toSeq_xstate i (toPar_xstate i (Abrupt s))  = Abrupt s"
  apply (auto simp add: split_beta)
  by (metis Par2Seq prod.collapse)

lemma Seq_xstate_Par_Normal:"i\<le>length (snd s)  \<Longrightarrow>  toSeq_xstate i (toPar_xstate i (Normal s) )  = Normal s"
  apply (auto simp add: split_beta)
  by (metis Par2Seq prod.collapse)

lemma Seq_xstate_Par_Fault:"toSeq_xstate i (toPar_xstate i (Fault f))  = Fault f"
  by auto

lemma Seq_xstate_Par_Stuck:"toSeq_xstate i (toPar_xstate i Stuck)  = Stuck"
  by auto

lemma Seq_Par_xstate:"\<forall>nas. (s= Normal nas \<or> s = Abrupt nas)  \<longrightarrow> i\<le> length (snd nas) \<Longrightarrow>
      toSeq_xstate i (toPar_xstate i s) = s"
  using Par2Seq
  by (cases s, auto)

definition toSeqCptn:: "nat \<Rightarrow> (('g,'l,'p,'f,'e) gconf list) \<Rightarrow> ('g, 'l,  'p,'f,'e) config_gs list"
  where "toSeqCptn p cpt \<equiv>
     map (\<lambda>cfg. (fst cfg, toSeq_xstate p (snd cfg))) cpt
"

lemma toSeqCptn_simp:"toSeqCptn i (x#xs) = (fst x, toSeq_xstate i (snd x)) # (toSeqCptn i xs)"
  by (simp add: toSeqCptn_def)

lemma toSeqCptn_j:"j<length cpt \<Longrightarrow> (toSeqCptn p cpt)!j = (fst (cpt!j), toSeq_xstate p (snd (cpt!j)))"
  unfolding toSeqCptn_def by auto

definition toParCptn::"nat \<Rightarrow> ('g, 'l,  'p,'f,'e) config_gs list \<Rightarrow> (('g,'l,'p,'f,'e) gconf list)"
  where "toParCptn p cpt \<equiv>
   map (\<lambda>cfg. (fst cfg, toPar_xstate p (snd cfg))) cpt
"

lemma toParCptn_simp:"toParCptn i (x#xs) = (fst x, toPar_xstate i (snd x)) # (toParCptn i xs)"
  by (simp add: toParCptn_def)

lemma toParCptn_j:"j<length cpt \<Longrightarrow> (toParCptn p cpt)!j = (fst (cpt!j), toPar_xstate p (snd (cpt!j)))"
  unfolding toParCptn_def by auto

definition Par_pred::"nat \<Rightarrow> (('g,'l) c_state)  set  \<Rightarrow> (('g,'l) par_state set)"
  where "Par_pred i p \<equiv> (toParState i) ` p"

definition Par_rel::"nat \<Rightarrow> ((('g,'l) c_state ,'f) tran) set  \<Rightarrow> ((('g,'l) par_state,'f) tran) set"
  where "Par_rel i r \<equiv> (\<lambda>(x,y). ((toPar_xstate i x), (toPar_xstate i y))) ` r"

definition Seq_pred::"nat \<Rightarrow> (('g,'l) par_state set) \<Rightarrow> (('g,'l) c_state)  set"
  where "Seq_pred i p \<equiv> (toSeqState i) ` p"

definition Seq_rel::"nat \<Rightarrow> ((('g,'l) par_state,'f) tran) set \<Rightarrow> ((('g,'l) c_state ,'f) tran) set  "
  where "Seq_rel i r \<equiv> (\<lambda>(x,y). ((toSeq_xstate i x), (toSeq_xstate i y))) ` r"

lemma Seq_Par_pred_ID:"\<forall>s\<in>p. i\<le>length (snd s) \<Longrightarrow> Seq_pred i (Par_pred i p) = p "
  unfolding Seq_pred_def Par_pred_def apply auto
  apply (simp add: Ball_def_raw Par2Seq0)
  by (metis Par2Seq0 rev_image_eqI snd_conv)

lemma Par_Seq_pred_ID:"\<forall>s\<in>p. i<length (snd s) \<Longrightarrow> Par_pred i (Seq_pred i p) = p "
  unfolding Seq_pred_def Par_pred_def apply auto
  apply (metis Seq2Par snd_conv)
  by (metis Seq2Par image_eqI snd_conv)

lemma Seq_Par_rel_ID:"\<forall>(x,y)\<in>(r::((('a,'b) c_state ,'c) tran) set).
                      (\<forall>ns. x = Abrupt ns \<or> x = Normal ns \<longrightarrow> i\<le>length (snd ns)) \<and>
                      (\<forall>ns. y = Abrupt ns \<or> y = Normal ns \<longrightarrow> i\<le>length (snd ns)) \<Longrightarrow>
                  Seq_rel i (Par_rel i r) =r"
  unfolding Seq_rel_def Par_rel_def split_beta image_def apply auto
   apply (simp add: Seq_Par_xstate)
  by (metis Seq_Par_xstate eq_snd_iff prod.exhaust_sel swap_simp)

lemma Par_Seq_rel_ID:"\<forall>(x,y)\<in>(r::((('a,'b) par_state ,'c) tran) set).
                      (\<forall>ns. x = Abrupt ns \<or> x = Normal ns \<longrightarrow> i<length (snd ns)) \<and>
                      (\<forall>ns. y = Abrupt ns \<or> y = Normal ns \<longrightarrow> i<length (snd ns)) \<Longrightarrow>
                  Par_rel i (Seq_rel i r) =r"
  unfolding Seq_rel_def Par_rel_def split_beta image_def apply auto
   apply (simp add: Par_Seq_xstate)
  by (metis Par_Seq_xstate eq_snd_iff prod.exhaust_sel swap_simp)

lemma eq_toParSeqCptn:
   "\<forall>j<length ls. (\<forall>nas. (snd (ls!j))= Normal nas \<or> (snd (ls!j)) = Abrupt nas  \<longrightarrow> i< length (snd nas)) \<Longrightarrow>
        toParCptn i (toSeqCptn i ls) = ls"
  unfolding toParCptn_def toSeqCptn_def
  apply (rule nth_equalityI, auto)
  by (simp add: Par_Seq_xstate)

lemma eq_toSeqParCptn:
   "\<forall>j<length ls. (\<forall>nas. (snd (ls!j))= Normal nas \<or> (snd (ls!j)) = Abrupt nas  \<longrightarrow> i\<le> length (snd nas)) \<Longrightarrow>
        toSeqCptn i (toParCptn i ls) = ls"
  unfolding toParCptn_def toSeqCptn_def
  apply (rule nth_equalityI, auto)
  by (simp add: Seq_Par_xstate)

inductive
 "step_cei"::"[('g\<times>'l,'p,'f,'e) body,nat,('g, 'l, 'p,'f,'e) gconf,('g, 'l, 'p,'f,'e) gconf] \<Rightarrow> bool"
                                ("_\<turnstile>\<^sub>c\<^sub>_ (_ \<rightarrow>\<^sub>c\<^sub>e/ _)" [81,81,81,81] 100)
  for \<Gamma>::"('g\<times>'l,'p,'f,'e) body"
  where
c_stepi: "\<lbrakk>\<Gamma>\<turnstile>\<^sub>c (c,sg) \<rightarrow>\<^sub>c\<^sub>e (c',sg')\<rbrakk> \<Longrightarrow>
          \<Gamma>\<turnstile>\<^sub>c\<^sub>i (c,toPar_xstate i sg ) \<rightarrow>\<^sub>c\<^sub>e (c',toPar_xstate i sg')"

inductive_cases step_cei:
 "\<Gamma>\<turnstile>\<^sub>c\<^sub>i cfg \<rightarrow>\<^sub>c\<^sub>e cfg'"

inductive_set cptni :: "(nat\<times>('g,'l,'p,'f,'e) gconfs) set"
where
  CptnOnei: " (i,\<Gamma>, [(P,s)]) \<in> cptni"
| Cptni: "\<lbrakk>\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t); (i,\<Gamma>,(Q, t)#xs) \<in> cptni \<rbrakk> \<Longrightarrow>
             (i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni"

inductive_cases cptni_cases:
"(i,\<Gamma>, [(P,s)]) \<in> cptni"
"(i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni"

lemma step_cei_ce1: assumes a0:"\<nexists>sn. s = Normal sn \<or> s = Abrupt sn" and
              a1:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
  shows "\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
proof-
  obtain ss st where ce:"\<Gamma>\<turnstile>\<^sub>c(P,ss) \<rightarrow>\<^sub>c\<^sub>e (Q,st)" and
                  s1:"s=toPar_xstate i ss" and
                  s2:"t=toPar_xstate i st"
    by (auto intro:step_cei[OF a1])
  moreover have eq_ss_st:"ss = st" and eq_s_t:"s=t"
    using a0 ce s1 step_ce_notNormal toPar_xstate.simps(1) calculation
    by blast+
  show ?thesis
  proof (cases s)
    case (Normal x1)
    then show ?thesis using a0 by auto
  next
    case (Abrupt x2)
    then show ?thesis using a0 by auto
  next
    case (Fault x3)
    moreover have "ss = Fault x3" using calculation s1 by (cases ss, auto)
    ultimately show ?thesis
      using ce by (auto simp add: eq_s_t eq_ss_st)
  next
    case Stuck
    moreover have "ss = Stuck" using calculation s1 by (cases ss, auto)
    ultimately show ?thesis
      using ce by (auto simp add: eq_s_t eq_ss_st)
  qed
qed

lemma step_cei_ce2: assumes a0:"s = Normal sn" and a0':"i<length (snd sn)" and
              a1:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
  shows "\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
proof-
  obtain ss st where ce:"\<Gamma>\<turnstile>\<^sub>c(P,ss) \<rightarrow>\<^sub>c\<^sub>e (Q,st)" and
                  s1:"s=toPar_xstate i ss" and
                  s2:"t=toPar_xstate i st"
    by (auto intro:step_cei[OF a1])
  moreover obtain ssn where ssn:"ss=Normal ssn" using a0 s1 by (cases ss, auto)
  then have "length (snd sn) = length (snd ssn) + 1"
    using a0' s1 a0 len_toParState_list[of "fst sn" "snd sn" _ "fst (fst ssn)" "snd (fst ssn)" "snd ssn"]
    by auto
  then have len_i:"i\<le> length (snd ssn)" using a0' by auto
  show ?thesis
  proof(cases st)
    case (Normal x2)
    have "length (snd x2) = length (snd ssn)"
      using ssn  ce step_dest[OF ce[simplified ssn]]
      by (auto simp add: Normal step_dest1 elim:step_e.cases)
    then show ?thesis
      using  ce a0 s1 s2 a0' Normal Seq_xstate_Par_Normal[OF len_i ]
      apply (auto simp add: Normal a0 s1 s2 a0' ssn intro: Seq_xstate_Par_Normal)
      by (metis Par2Seq len_i prod.exhaust_sel)
  next
    case (Abrupt x2)

    then show ?thesis
      by (metis (no_types, hide_lams) Seq_xstate_Par_Abrupt Seq_xstate_Par_Normal
            ce env_c_c' len_i prod.exhaust_sel s1 s2 ssn
            step_dest stepe_Normal_elim_cases)
  next
    case (Fault x3)
    then show ?thesis
      using Seq_xstate_Par_Normal ce len_i s1 s2 ssn by fastforce
  next
    case Stuck
    then show ?thesis
      using Seq_xstate_Par_Normal ce len_i s1 s2 ssn by fastforce
  qed
qed

lemma step_cei_ce3: assumes a0:"s = Abrupt sn" and a0':"i<length (snd sn)" and
              a1:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
  shows "\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
proof-
  obtain ss st where ce:"\<Gamma>\<turnstile>\<^sub>c(P,ss) \<rightarrow>\<^sub>c\<^sub>e (Q,st)" and
                  s1:"s=toPar_xstate i ss" and
                  s2:"t=toPar_xstate i st"
    by (auto intro:step_cei[OF a1])
  moreover obtain ssn where ssn:"ss=Abrupt ssn" using a0 s1 by (cases ss, auto)
  then have "length (snd sn) = length (snd ssn) + 1"
    using a0' s1 a0 len_toParState_list[of "fst sn" "snd sn" _ "fst (fst ssn)" "snd (fst ssn)" "snd ssn"]
    by auto
  then have len_i:"i\<le> length (snd ssn)" using a0' by auto
  show ?thesis
  proof(cases st)
    case (Normal x2)
    have "length (snd x2) = length (snd ssn)"
      using Normal ce ssn step_ce_notNormal by blast
    then show ?thesis
      using  ce a0 s1 s2 a0' Normal Seq_xstate_Par_Normal[OF len_i ]
      apply (auto simp add: Normal a0 s1 s2 a0' ssn intro: Seq_xstate_Par_Normal)
      by (metis Par2Seq len_i prod.exhaust_sel)
  next
    case (Abrupt x2)
    then show ?thesis
      by (metis Seq_xstate_Par_Abrupt ce len_i s1 s2 ssn step_ce_notNormal xstate.distinct(1))
  next
    case (Fault x3)
    then show ?thesis
      using Seq_xstate_Par_Normal ce len_i s1 s2 ssn by fastforce
  next
    case Stuck
    then show ?thesis
      using Seq_xstate_Par_Normal ce len_i s1 s2 ssn by fastforce
  qed
qed

lemma step_cei_not_normal_eq:
  assumes a0:"\<forall>sn. s \<noteq> (Normal sn)" and
          a1:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
        shows "s=t"
proof-
  obtain ssj ssj1 where "s = toPar_xstate i ssj" and "t = toPar_xstate i ssj1" and
                                 "\<Gamma>\<turnstile>\<^sub>c (P,ssj) \<rightarrow>\<^sub>c\<^sub>e (Q,ssj1)"
    using a0 a1 step_cei.simps by fastforce
  moreover have "\<forall>sn. ssj \<noteq> Normal sn" using  a0 a1 calculation
    by (metis toPar_xstate.simps
         xstate.distinct(10) xstate.distinct(12) xstate.distinct(6))
  moreover have "ssj1=ssj" using step_ce_notNormal a0 a1 calculation by blast
  ultimately show ?thesis using  step_ce_notNormal step_cei.simps
    by fastforce
qed

lemma step_cei_normal_normal_same_len:
  assumes  a0:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,Normal ns) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"  and a1:"t= Normal nt \<or> t=Abrupt nt"
  shows "length (snd ns) = length (snd nt)"
proof-
  obtain ssj ssj1 where "Normal ns = toPar_xstate i ssj" and "t = toPar_xstate i ssj1" and
                                 "\<Gamma>\<turnstile>\<^sub>c (P,ssj) \<rightarrow>\<^sub>c\<^sub>e (Q,ssj1)"
    using  step_cei.simps a0 by fastforce
  moreover obtain ssjn ssj1n where "ssj = Normal ssjn" and "ssj1 = Normal ssj1n \<or> ssj1 = Abrupt ssj1n"
    using calculation a1 apply auto
     apply (metis old.prod.exhaust toPar_xstate.simps(2) toPar_xstate.simps(3) toPar_xstate.simps(4)
                 xstate.distinct(3) xstate.distinct(6) xstate.exhaust xstate.simps(5))
    by (metis step_ce_notNormal surj_pair toPar_xstate.simps(3) toPar_xstate.simps(4) toSeq_xstate.simps(2)
              toSeq_xstate.simps(4) xstate.distinct(7) xstate.exhaust xstate.simps(5))
  moreover  have "length (snd ssjn) = length (snd ssj1n)"
    using calculation ce_eq_length by blast
  moreover have "ns = (toParState i ssjn)" and "nt =  (toParState i ssj1n)"
    using \<open>ssj = Normal ssjn\<close>   calculation a1 by auto
  ultimately show ?thesis
    by (metis \<open>length (snd ssjn) = length (snd ssj1n)\<close> eq_snd_iff len_toParState_list)
qed

lemma step_ce_to_step_cei1:
  assumes a0:"\<nexists>sn. s = Normal sn \<or> s = Abrupt sn" and
          a1:"\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P, s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
  using c_stepi[OF a1] using a0  Seq_xstate_Par_Fault Seq_xstate_Par_Stuck
  apply (cases s; cases t, auto)
  using a1 step_ce_notNormal by force+

lemma step_ce_to_step_cei2:
  assumes a0:"s = Normal sn" and a0':"i<length (snd sn)"  and a0'':"t= Normal tn \<or> t=Abrupt tn" and
          a2:"length (snd sn) = length (snd tn)" and
          a1:"\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P, s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
 using c_stepi[OF a1, of i] using a0 a0' a1
  by (metis Par_xstate_Seq_Abrupt Par_xstate_Seq_Normal a0'' a2)

lemma step_ce_to_step_cei3:
  assumes a0:"s = Normal sn" and a0':"i<length (snd sn)"  and a0'':"\<forall>tn. t\<noteq>Normal tn \<and> t\<noteq>Abrupt tn" and
          a1:"\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P, s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
 using c_stepi[OF a1, of i] using a0 a0' a1
  by (metis Par_xstate_Seq_Normal a0'' toPar_xstate.simps(3) toPar_xstate.simps(4)
       toSeq_xstate.simps(3) toSeq_xstate.simps(4) xstate.exhaust)

lemma step_ce_to_step_cei4:
  assumes a0:"s = Abrupt sn" and a0':"i<length (snd sn)" and
          a2:"s=t" and
          a1:"\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P, s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
using c_stepi[OF a1, of i] using a0 a0' a1 a2
  by (metis Par_xstate_Seq_Abrupt)

lemma same_local_sublist_toSeq_State1:
  assumes a0:"\<forall>nas nasa. (s= Normal nas \<or> s = Abrupt nas) \<and> (sa= Normal nasa \<or> sa = Abrupt nasa) \<longrightarrow>
           (\<forall>j\<noteq>i. (snd nas)!j = (snd nasa)!j) \<and> length (snd nas) = length (snd nasa)" and
a1:"sa = Normal na \<or>  sa = Abrupt na" and
a2:"s = Normal ns \<or>  s = Abrupt ns" and
a3:"\<forall>nas. (s= Normal nas \<or> s = Abrupt nas)  \<longrightarrow> i<length (snd nas)"
  shows  " (toSeq_xstate i s = Normal nsx \<or> toSeq_xstate i s = Abrupt nsx) \<and>
           (toSeq_xstate i sa = Normal nsx' \<or> toSeq_xstate i sa = Abrupt nsx') \<longrightarrow>
           snd nsx = snd nsx'"
proof-
  { assume "(toSeq_xstate i s = Normal nsx \<or> toSeq_xstate i s = Abrupt nsx) \<and>
           (toSeq_xstate i sa = Normal nsx' \<or> toSeq_xstate i sa = Abrupt nsx')"
    have  a0:"(\<forall>j. j\<noteq>i\<longrightarrow> snd na!j =  snd ns!j)" and a3:"length (snd na) = length (snd ns)" and a5:"i<length (snd ns)"
      using a0 a1 a2 a3 by fastforce+
    have ?thesis  using a1 a2
      apply (auto) unfolding toSeqState_def Let_def split_beta
      by (auto intro:eq_list_i[OF  a3 a0 a5])
  } thus ?thesis by auto
qed

lemma same_local_sublist_toSeq_State:
  assumes a0:"\<forall>nas nasa. (s= Normal nas \<or> s = Abrupt nas) \<and> (sa= Normal nasa \<or> sa = Abrupt nasa) \<longrightarrow>
           (\<forall>j\<noteq>i. (snd nas)!j = (snd nasa)!j) \<and> length (snd nas) = length (snd nasa)" and
a3:"\<forall>nas. (s= Normal nas \<or> s = Abrupt nas)  \<longrightarrow> i<length (snd nas)"
  shows  " (toSeq_xstate i s = Normal nsx \<or> toSeq_xstate i s = Abrupt nsx) \<and>
           (toSeq_xstate i sa = Normal nsx' \<or> toSeq_xstate i sa = Abrupt nsx') \<longrightarrow>
           snd nsx = snd nsx'"
proof-
  { assume "(toSeq_xstate i s = Normal nsx \<or> toSeq_xstate i s = Abrupt nsx) \<and>
           (toSeq_xstate i sa = Normal nsx' \<or> toSeq_xstate i sa = Abrupt nsx')"
    then obtain na ns where nas:"(s= Normal ns \<or> s = Abrupt ns) \<and> (sa= Normal na \<or> sa = Abrupt na)"
      by (cases s; cases sa; auto)
    then have  a0:"(\<forall>j. j\<noteq>i\<longrightarrow> snd na!j =  snd ns!j)" and a3:"length (snd na) = length (snd ns)" and a5:"i<length (snd ns)"
      using a0  a3 by fastforce+
    have ?thesis  using nas
      apply (auto) unfolding toSeqState_def Let_def split_beta
      by (auto intro:eq_list_i[OF  a3 a0 a5])
  } thus ?thesis by auto
qed

lemma step_cei_i1:
  assumes a0:"\<forall>nas nasa. (s= Normal nas \<or> s = Abrupt nas) \<and> (t= Normal nasa \<or> t = Abrupt nasa) \<longrightarrow>
           (\<forall>j\<noteq>i. (snd nas)!j = (snd nasa)!j) \<and> length (snd nas) = length (snd nasa)" and
          a1:"\<forall>nas. (s= Normal nas \<or> s = Abrupt nas)  \<longrightarrow> i<length (snd nas)" and
          a2:"\<Gamma>\<turnstile>\<^sub>c (c, toSeq (toSeq_xstate i s)) \<rightarrow> (c', toSeq (toSeq_xstate i t))"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(c,s) \<rightarrow>\<^sub>c\<^sub>e (c',t)"
proof-
  have a1': "\<forall>nas. (t= Normal nas \<or> t = Abrupt nas)  \<longrightarrow> i<length (snd nas)"
  proof-
    {fix nas
      assume "(t= Normal nas \<or> t = Abrupt nas)"
      moreover obtain ns where "s = Normal ns \<or> s = Abrupt ns"
        using a2  apply (cases s, auto )
        using SmallStepCon.step_Fault_prop step_Stuck_prop calculation by fastforce+
      ultimately have ?thesis using a0 a1 by auto
    } then show ?thesis by auto
  qed
  have "\<forall>ns ns'.
       (toSeq_xstate i s = Normal ns \<or> toSeq_xstate i s = Abrupt ns) \<and>
       (toSeq_xstate i t = Normal ns' \<or> toSeq_xstate i t = Abrupt ns') \<longrightarrow>
       snd ns = snd ns'" using same_local_sublist_toSeq_State[OF a0 a1] by fastforce
  then have  c:"\<Gamma>\<turnstile>\<^sub>c (c, toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (c', toSeq_xstate i t)"
    using c_step[OF a2]  by auto
  show ?thesis using c_stepi[OF c] a1 a1' apply (cases s; cases t, auto simp add: )
    by (metis (mono_tags, hide_lams) Seq2Par a0 snd_conv)+
qed

lemma step_cei_i2:
  assumes a0:"\<forall>nas nasa. (s= Normal nas \<or> s = Abrupt nas) \<and> (t= Normal nasa \<or> t = Abrupt nasa) \<longrightarrow>
              length (snd nas) = length (snd nasa)" and
          a1:"\<forall>nas. (s= Normal nas \<or> s = Abrupt nas)  \<longrightarrow> i<length (snd nas)" and
          a2:"\<Gamma>\<turnstile>\<^sub>c (c, toSeq_xstate i s) \<rightarrow>\<^sub>e (c, toSeq_xstate i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(c,s) \<rightarrow>\<^sub>c\<^sub>e (c,t)"
proof-
  have "\<forall>nas. (t= Normal nas \<or> t = Abrupt nas)  \<longrightarrow> i<length (snd nas)"
    apply (cases s; cases t, auto)
    using a0 a1 stepe_elim_cases[of \<Gamma> c "toSeq_xstate i s" "toSeq_xstate i t",OF a2] by auto
  moreover have  a3:"\<Gamma>\<turnstile>\<^sub>c (c, toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (c, toSeq_xstate i t)" using e_step[OF a2] by auto
  ultimately show ?thesis using c_stepi[OF a3] apply (cases s; cases t, auto) using a1
    by (metis Seq2Par snd_conv)+
qed

lemma sublist:"j<(length c)-1 \<Longrightarrow> \<exists>c' c''. c = c'@([c!j,c!(j+1)]@c'')"
proof (induct j arbitrary: c)
  case 0
  then show ?case
    by (metis One_nat_def Suc_less_eq add.left_neutral append.assoc append_Cons append_Nil
               id_take_nth_drop less_Suc_eq take_Suc_conv_app_nth zero_less_diff)
next
  case (Suc j)
  then have "j<length c - 1 -1"
    by simp
  then show ?case using Suc
    by (metis Suc_eq_plus1 Suc_lessD append.assoc append_Cons append_Nil
             id_take_nth_drop less_diff_conv take_Suc_conv_app_nth)
qed

lemma cptni_dest:"(i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,(Q,t)#xs)\<in> cptni"
by (auto dest: cptni_cases)

lemma cptni_dest_pair:"(i,\<Gamma>,x#x1#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,x1#xs)\<in> cptni"
proof -
  assume "(i,\<Gamma>,x#x1#xs) \<in> cptni"
  thus ?thesis using cptni_dest prod.collapse by metis
qed

lemma cptni_dest1:"(i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,(P,s)#[(Q,t)])\<in> cptni"
proof -
  assume a1: "(i,\<Gamma>, (P, s) # (Q, t) # xs) \<in> cptni"
  have "(i,\<Gamma>, [(Q, t)]) \<in> cptni"
    by (meson cptni.CptnOnei)
  thus ?thesis
    using a1 cptni.Cptni cptni_cases(2) by blast
qed

lemma cptni_dest1_pair:"(i,\<Gamma>,x#x1#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,x#[x1])\<in> cptni"
proof -
  assume "(i,\<Gamma>,x#x1#xs) \<in> cptni"
  thus ?thesis using cptni_dest1 prod.collapse by metis
qed

lemma cptni_append_is_cptni [rule_format]:
 "\<forall>b a. (i,\<Gamma>,b#c1)\<in>cptni \<longrightarrow>  (i,\<Gamma>,a#c2)\<in>cptni \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> (i,\<Gamma>,b#c1@c2)\<in>cptni"
apply(induct c1)
 apply simp
apply clarify
apply(erule cptni.cases,simp_all)
  by (simp add: cptni.Cptni)
(* apply (simp add: cptn.CptnEnv)
by (simp add: cptn.CptnComp) *)

lemma cptni_dest_2:
  "(i,\<Gamma>,a#xs@ys) \<in> cptni  \<Longrightarrow> (i,\<Gamma>,a#xs)\<in> cptni"
proof (induct "xs" arbitrary: a)
  case Nil thus ?case using cptni.simps by fastforce
next
  case (Cons x xs')
  then have "(i,\<Gamma>,a#[x])\<in>cptni" by (simp add: cptni_dest1_pair)
  also have "(i,\<Gamma>, x # xs') \<in> cptni"
    using Cons.hyps Cons.prems cptni_dest_pair by fastforce
  ultimately show ?case using cptni_append_is_cptni [of i \<Gamma> a "[x]" x xs']
    by force
qed

lemma tl_in_cptni: "\<lbrakk> (i,g,a#xs) \<in>cptni; xs\<noteq>[] \<rbrakk> \<Longrightarrow> (i,g,xs)\<in>cptni"
  by (force elim: cptni.cases)

lemma sublist_in_cptni:"(i,\<Gamma>, ys@ xs) \<in> cptni \<Longrightarrow> xs\<noteq> [] \<Longrightarrow> (i,\<Gamma>, xs) \<in> cptni"
proof(induct ys)
  case Nil
  then show ?case by auto
next
  case (Cons a ys)
  then have "(i,\<Gamma>, a # (ys @ xs)) \<in> cptni" by auto
  then show ?case using cptni_cases
    by (metis Cons.hyps Cons.prems(2) Nil_is_append_conv tl_in_cptni)
qed

lemma cptni_step_cei:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1"
  shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i (c!j) \<rightarrow>\<^sub>c\<^sub>e (c!(j+1))"
proof-
 obtain c' c'' where "c = c'@([c!j,c!(j+1)]@c'')" using sublist[OF a1] by auto
  then have "(i,\<Gamma>,c!j#(c!(j+1))#c'') \<in>cptni" using a0 sublist_in_cptni
    by (metis append_Cons append_Nil list.distinct(1))
  then obtain pj sj pj1 sj1
    where cptni:"(i,\<Gamma>,(pj,sj)#(pj1,sj1)#c'') \<in>cptni" and
          cj:"c!j = (pj,sj)" and cj1:"c!(j+1) =(pj1,sj1)"
    by (metis prod.exhaust_sel)
  then show ?thesis using cptni_cases(2)[OF cptni] by auto
qed

lemma step_cei_notNormal:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1" and a2:"\<forall>sn. snd (c!j) \<noteq> Normal sn"
  shows "snd (c!j) = snd (c!(j+1))"
using step_cei_not_normal_eq cptni_step_cei[OF a0 a1] using a2
     by (metis eq_snd_iff)

lemma all_not_normal:"(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>  j<(length c) \<Longrightarrow> (\<nexists>na. snd (c!j) =Normal na)  \<Longrightarrow>
       j'< (length c) \<Longrightarrow> j' > j \<Longrightarrow>  \<nexists>na. snd (c!j') =Normal na"
proof (induct "j'-j" arbitrary: j)
  case 0
  then show ?case by auto
next
  case (Suc x)
  {assume "x = 0"
    then have ?case using Suc step_cei_notNormal[OF Suc(3)]
      by (metis (no_types, lifting) One_nat_def add_diff_inverse_nat
        dual_order.strict_trans less_diff_conv less_not_refl)
  }
  moreover { assume "x\<noteq>0"
    moreover have "\<nexists>na. snd (c ! (j+1)) = Normal na"
      by (metis (no_types, lifting) Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(4)
        Suc.prems(5) diff_Suc_1 lessE not_less_eq step_cei_notNormal)
    ultimately have ?case using Suc
      by (metis (no_types, lifting) Suc_diff_Suc Suc_eq_plus1 Suc_lessI add_diff_cancel_left'
               less_trans_Suc plus_1_eq_Suc)
  }
  ultimately show ?case by auto
qed

lemma cptni_not_normal_all_eq:
     "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>  j<(length c) \<Longrightarrow> (\<nexists>na. snd (c!j) =Normal na)  \<Longrightarrow>
       j'< (length c) \<Longrightarrow> j' \<ge> j \<Longrightarrow> snd (c!j) = snd (c!j')"
proof (induct "j'-j" arbitrary: j)
  case 0
  then show ?case by auto
next
  case (Suc x)
  {assume "x = 0"
    then have ?case using Suc step_cei_notNormal[OF Suc(3)]
      by (metis One_nat_def le_add_diff_inverse less_diff_conv)
  }
  moreover { assume "x\<noteq>0"
    moreover have "snd (c!j) = snd (c ! (j+1))"
      by (metis (no_types, lifting) Suc.hyps(2) Suc.prems(1) Suc.prems(2) Suc.prems(3)
              Suc.prems(4) Suc.prems(5)
               Suc_lessI add.right_neutral add_Suc_right add_diff_cancel_left' le_add_diff_inverse2
                 less_diff_conv not_add_less1 plus_1_eq_Suc step_cei_notNormal)
    ultimately have ?case using Suc
      by auto
  }
  ultimately show ?case by auto
qed

lemma cptni_normal_normal_same_length:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1" and a2:"snd (c!j) =Normal na" and
       a3:"snd (c!(j+1)) =Normal nb \<or> snd (c!(j+1)) = Abrupt nb"
     shows "length (snd na) = length (snd nb)"
  using cptni_step_cei[OF a0 a1] a2 a3 step_cei_normal_normal_same_len
  by (metis prod.exhaust_sel)

lemma cptni_i_normal_len:
    "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>  length c > 1 \<Longrightarrow> j<length c \<Longrightarrow> j'<length c \<Longrightarrow> j'\<ge>j \<Longrightarrow>
      snd(c!j) = Normal ni  \<Longrightarrow>
      snd(c!j') = Abrupt nj \<or> snd(c!j') = Normal nj \<Longrightarrow>
      length (snd (nj)) = length (snd (ni))"
proof (induct "j'-j" arbitrary: j ni)
  case 0
  then show ?case by auto
next
  case (Suc x)
  {assume "x = 0"
    then have ?case using Suc step_cei_notNormal[OF Suc(3)]
   cptni_normal_normal_same_length[OF  Suc(3)]
      by (metis (no_types, lifting) One_nat_def le_add_diff_inverse less_diff_conv less_imp_le_nat)
  }
  moreover { assume "x\<noteq>0"
    then have "j<(length c)-1" using Suc
      by linarith
    have x:"x=j' - (j+1)"
        by (metis (no_types) Suc.hyps(2) diff_Suc_1 diff_diff_add)
    moreover have j1_len:"j+1 < length c"
      using \<open>j < length c - 1\<close> less_diff_conv by blast
    moreover have  j_j':"j+1 \<le> j'"
      using \<open>x \<noteq> 0\<close> calculation(1) by auto
    have ?case
    proof(cases "snd (c!(j+1))")
      case (Normal x1)
      then show  ?thesis using Suc  x j1_len j_j'
        by (metis (mono_tags, lifting) \<open>j < length c - 1\<close> cptni_normal_normal_same_length)
    next
      case (Abrupt x2)
      then show ?thesis using cptni_not_normal_all_eq[OF Suc(3) j1_len _ Suc(6) j_j']
        by (metis Suc.prems(1) Suc.prems(6) Suc.prems(7) \<open>j < length c - 1\<close>
                 cptni_normal_normal_same_length xstate.distinct(1))
    next
      case (Fault x3)
      then show ?thesis
        by (metis Suc.prems(1) Suc.prems(4) Suc.prems(6) Suc.prems(7) \<open>j < length c - 1\<close> cptni_normal_normal_same_length
                  cptni_not_normal_all_eq j1_len j_j' xstate.distinct(3))
    next
      case Stuck
      then show ?thesis
        by (metis Suc.prems(1) Suc.prems(4) Suc.prems(6) Suc.prems(7) \<open>j < length c - 1\<close>
           cptni_normal_normal_same_length
             cptni_not_normal_all_eq j1_len j_j' xstate.distinct(5))
    qed
  }
  ultimately show ?case by auto
qed

lemma cptni_i_normal_abrupt_len:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and
          a1:"length c > 1" and a2:"j<length c" and a3:"j'<length c" and
          a4:"j'\<ge>j" and a5:"snd(c!j) = Normal ni \<or> snd(c!j) = Abrupt ni" and
      a6:"snd(c!j') = Abrupt nj \<or> snd(c!j') = Normal nj"
    shows "length (snd (nj)) = length (snd (ni))"
  using a5
proof
  assume a5:"snd (c ! j) = Normal ni "
  then show ?thesis using a0 a1 a2 a3 a4 a6 cptni_i_normal_len by blast
next
  assume a5:"snd (c ! j) = Abrupt ni"
  then show ?thesis using a0 a1 a2 a3 a4 a6
    by (metis cptni_not_normal_all_eq xstate.distinct(1) xstate.inject(2))
qed

lemma cptni_i_normal_abrupt_eq_len:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and
          a1:"length c > 1" and a2:"j<length c" and a3:"j'<length c" and
          a4:"j'\<ge>j" and
          a5:"\<forall>ni. snd(c!j) = Normal ni \<or> snd(c!j) = Abrupt ni \<longrightarrow>
                                  length (snd ni) = x"
  shows "\<forall>ni. snd(c!j') = Normal ni \<or> snd(c!j') = Abrupt ni \<longrightarrow>
                                  length (snd ni) = x"
proof-
  {fix ni
    assume a00:" snd(c!j') = Normal ni \<or> snd(c!j') = Abrupt ni"
    {assume "\<nexists>ni. snd(c!j) = Normal ni \<or> snd (c!j) = Abrupt ni"
      then have "length (snd ni) = x"
        by (metis a0 a00 a2 a3 a4 cptni_not_normal_all_eq)
    }
    moreover {assume "\<exists>ni. snd(c!j) = Normal ni \<or> snd (c!j) = Abrupt ni"
      then obtain ni' where "snd(c!j) = Normal ni' \<or> snd (c!j) = Abrupt ni'" by auto
      moreover have "length (snd ni') = x" using calculation
        by (simp add: a5)
      ultimately have "length (snd ni) = x" using a0 a1 a2 a3 a4
        using a00 cptni_i_normal_abrupt_len by blast
    }
    ultimately have "length (snd ni) = x" by auto
  }
  thus ?thesis by auto
qed

lemma cptni_i_normal_abrupt_eq_len1:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and
          a1:"length c > 1" and a2:"j<length c" and a3:"j'<length c" and
          a4:"j'\<ge>j" and
          a5:"\<forall>ni. snd(c!j) = Normal ni \<or> snd(c!j) = Abrupt ni \<longrightarrow>
                                  length (snd ni) = x"
  shows "\<forall>ni. snd(c!j') = Normal ni \<or> snd(c!j') = Abrupt ni \<longrightarrow>
                                  length (snd ni) = x"
proof-
  {fix ni
    assume a00:" snd(c!j') = Normal ni \<or> snd(c!j') = Abrupt ni"
    {assume "\<nexists>ni. snd(c!j) = Normal ni \<or> snd (c!j) = Abrupt ni"
      then have "length (snd ni) = x"
        by (metis a0 a00 a2 a3 a4 cptni_not_normal_all_eq)
    }
    moreover {assume "\<exists>ni. snd(c!j) = Normal ni \<or> snd (c!j) = Abrupt ni"
      then obtain ni' where "snd(c!j) = Normal ni' \<or> snd (c!j) = Abrupt ni'" by auto
      moreover have "length (snd ni') = x" using calculation
        by (simp add: a5)
      ultimately have "length (snd ni) = x" using a0 a1 a2 a3 a4
        using a00 cptni_i_normal_abrupt_len by blast
    }
    ultimately have "length (snd ni) = x" by auto
  }
  thus ?thesis by auto
qed

lemma length_locs_less_i':assumes a0:"(i,\<Gamma>,c) \<in> cptni" and
       a1:"length c > 0" and
       a2:"(\<forall>nas. (snd (c!0))= Normal nas \<or> (snd (c!0)) = Abrupt nas  \<longrightarrow> i< length (snd nas))"
     shows "\<forall>j<length c. (\<forall>nas. (snd (c!j))= Normal nas \<or> (snd (c!j)) = Abrupt nas  \<longrightarrow>
            i< length (snd nas))"
proof (cases "length c = 1")
  assume "length c = 1"
  then show ?thesis using a0 a1 a2 by auto
next
  assume "length c\<noteq>1"
  then have l0:"length c>1" using a1 by linarith
  { fix j nas
    assume a00:"j<length c"
    assume a01:" (snd (c!j))= Normal nas \<or> (snd (c!j)) = Abrupt nas "
    then have "i< length (snd nas)"
    proof(cases "snd (c!0)")
      case (Normal x1)
      then show ?thesis using  cptni_i_normal_abrupt_len[OF a0 l0 _ a00] a0 a1 a2
        by (metis a01 not_less0 not_less_iff_gr_or_eq order.order_iff_strict)
    next
      case (Abrupt x2)
      then show ?thesis using  cptni_i_normal_abrupt_len[OF a0 l0 _ a00] a0 a1 a2
        by (metis a01 not_less not_less0)
    next
      case (Fault x3)
      then show ?thesis
        by (metis a0 a00 a01 a1 a2 cptni_not_normal_all_eq not_less not_less0 xstate.distinct(3))
    next
      case Stuck
      then show ?thesis
        by (metis a0 a00 a01 a1 a2 cptni_not_normal_all_eq not_less not_less0 xstate.distinct(5))
    qed
  } thus ?thesis by auto
qed

lemma cptni_length_locs_less_i:
     assumes a0:"(i,\<Gamma>,c) \<in> cptni" and
       a1:"(\<forall>nas. (snd (c!0))= Normal nas \<or> (snd (c!0)) = Abrupt nas  \<longrightarrow> i< length (snd nas))"
     shows "\<forall>j<length c. (\<forall>nas. (snd (c!j))= Normal nas \<or> (snd (c!j)) = Abrupt nas  \<longrightarrow>
            i< length (snd nas))"
proof(cases "length c")
  case 0
  then show ?thesis by auto
next
  case (Suc nat)
  then show ?thesis using length_locs_less_i'[OF a0 _ a1] by auto
qed

lemma cptni_cptn_not_abrupt_normal:
 "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>
  \<forall>sn. snd(c!0) \<noteq> Normal sn \<and> snd(c!0) \<noteq>Abrupt sn  \<Longrightarrow>
 (\<Gamma>, toSeqCptn i c) \<in> cptn"
proof (induct rule:cptni.induct)
  case (CptnOnei i \<Gamma> P s)
  then show ?case unfolding toSeqCptn_def using cptn.intros by auto
next
  case (Cptni \<Gamma> i P s Q t xs)
  then have "\<forall>sn. s\<noteq>Normal sn \<and> s \<noteq>Abrupt sn"
    by simp
  then  have "\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
    using step_cei_ce1[OF _ Cptni(1)] by blast
  moreover have " (\<Gamma>, toSeqCptn i ((Q, t) # xs)) \<in> cptn" using Cptni
    by (metis nth_Cons_0 snd_conv step_cei_not_normal_eq)
  ultimately show ?case using toSeqCptn_simp
    by (simp add: toSeqCptn_simp cptn.Cptn)
qed

lemma cptni_cptn_Abrupt:
 "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>
  snd(c!0) = Abrupt sn   \<Longrightarrow> i< length (snd sn) \<Longrightarrow>
 (\<Gamma>, toSeqCptn i c) \<in> cptn"
proof (induct arbitrary: sn rule:cptni.induct)
  case (CptnOnei i \<Gamma> P s)
  then show ?case unfolding toSeqCptn_def using cptn.intros by auto
next
  case (Cptni \<Gamma> i P s Q t xs)
  then have s:"s=Abrupt sn " and "s=t"
    apply simp
    using Cptni.hyps(1) Cptni.prems(1) step_cei_not_normal_eq by fastforce
  then  have "\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
    using   step_cei_ce3[OF s _ Cptni(1)]
    using Cptni.prems(2) by linarith
  moreover have " (\<Gamma>, toSeqCptn i ((Q, t) # xs)) \<in> cptn" using Cptni
    by (simp add: \<open>s = t\<close>)
  ultimately show ?case using toSeqCptn_simp
    by (simp add: toSeqCptn_simp cptn.Cptn)
qed

lemma cptni_cptn_normal:
 "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>
  snd(c!0) = Normal sn   \<Longrightarrow> i< length (snd sn) \<Longrightarrow>
 (\<Gamma>, toSeqCptn i c) \<in> cptn"
proof (induct arbitrary: sn rule:cptni.induct)
  case (CptnOnei i \<Gamma> P s)
  then show ?case unfolding toSeqCptn_def using cptn.intros by auto
next
  case (Cptni \<Gamma> i P s Q t xs)
  then have s:"s=Normal sn "
    by simp
  then  have "\<Gamma>\<turnstile>\<^sub>c(P,toSeq_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeq_xstate i t)"
    using   step_cei_ce2[OF s _ Cptni(1)]
    using Cptni.prems(2) by linarith
  moreover have " (\<Gamma>, toSeqCptn i ((Q, t) # xs)) \<in> cptn"
  proof(cases t)
    case (Normal x1)
    then show ?thesis
      using Cptni.hyps(1) Cptni.hyps(3) Cptni.prems(2) s
            step_cei_normal_normal_same_len by fastforce
  next
    case (Abrupt x2)
    then show ?thesis
      by (metis Cptni.hyps(1) Cptni.hyps(2) Cptni.prems(2) cptni_cptn_Abrupt
          nth_Cons_0 s snd_conv step_cei_normal_normal_same_len)
  next
    case (Fault x3)
    then show ?thesis
      using Cptni.hyps(2) cptni_cptn_not_abrupt_normal by force
  next
    case Stuck
    then show ?thesis  using Cptni.hyps(2) cptni_cptn_not_abrupt_normal by force
  qed
  ultimately show ?case using toSeqCptn_simp
    by (simp add: toSeqCptn_simp cptn.Cptn)
qed

lemma cptni_cptn:
 "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>
  \<forall>sn. snd(c!0) = Normal sn \<or> snd(c!0) = Abrupt sn \<longrightarrow>  i< length (snd sn) \<Longrightarrow>
 (\<Gamma>, toSeqCptn i c) \<in> cptn"
  apply (cases "snd (c!0)") using cptni_cptn_normal cptni_cptn_Abrupt cptni_cptn_not_abrupt_normal
  by fastforce+

lemma cptn_cptni_not_abrupt_normal:
 "(\<Gamma>,c) \<in> cptn \<Longrightarrow>
  \<forall>sn. snd(c!0) \<noteq> Normal sn \<and> snd(c!0) \<noteq>Abrupt sn  \<Longrightarrow>
 (i, \<Gamma>, toParCptn i c) \<in> cptni"
proof (induct rule:cptn.induct)
  case (CptnOne \<Gamma> P s)
  then show ?case unfolding toParCptn_def using cptni.intros by auto
next
  case (Cptn \<Gamma> P s Q t xs)
  then have "\<forall>sn. s\<noteq>Normal sn \<and> s \<noteq>Abrupt sn"
    by simp
  then  have "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,toPar_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toPar_xstate i t)"
    using Cptn(1) by (simp add: c_stepi)
  moreover have " (i,\<Gamma>, toParCptn i ((Q, t) # xs)) \<in> cptni" using Cptni
    by (metis Cptn.hyps(1) Cptn.hyps(3) \<open>\<forall>sn. s \<noteq> Normal sn \<and> s \<noteq> Abrupt sn\<close>
          nth_Cons_0 snd_conv step_ce_notNormal)
  ultimately show ?case using toParCptn_simp
    by (simp add: toParCptn_simp cptni.Cptni)
qed

lemma cptn_cptni_Abrupt:
 "(\<Gamma>,c) \<in> cptn \<Longrightarrow>
  snd(c!0) = Abrupt sn   \<Longrightarrow> i\<le> length (snd sn) \<Longrightarrow>
 (i,\<Gamma>, toParCptn i c) \<in> cptni"
proof (induct arbitrary: sn rule:cptn.induct)
  case (CptnOne \<Gamma> P s)
  then show ?case unfolding toParCptn_def using cptni.intros by auto
next
  case (Cptn \<Gamma> P s Q t xs)
  then have s:"s=Abrupt sn " and "s=t"
    apply simp
    using Cptn.hyps(1) Cptn.prems(1)
    using step_ce_notNormal by force
  then  have "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,toPar_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toPar_xstate i t)"
    using  Cptni(1) Cptn.hyps(1) c_stepi by blast
  moreover have " (i,\<Gamma>, toParCptn i ((Q, t) # xs)) \<in> cptni" using Cptni
    using Cptn.hyps(3) Cptn.prems(2) \<open>s = t\<close> s by fastforce
  ultimately show ?case using toParCptn_simp
    by (simp add: toParCptn_simp cptni.Cptni)
qed

lemma cptn_cptni_normal:
 "(\<Gamma>,c) \<in> cptn \<Longrightarrow>
  snd(c!0) = Normal sn   \<Longrightarrow> i\<le> length (snd sn) \<Longrightarrow>
 (i,\<Gamma>, toParCptn i c) \<in> cptni"
proof (induct arbitrary: sn rule:cptn.induct)
  case (CptnOne \<Gamma> P s)
  then show ?case  unfolding toParCptn_def using cptni.intros by auto
next
  case (Cptn \<Gamma> P s Q t xs)
  then have s:"s=Normal sn "
    by simp
  then  have "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,toPar_xstate i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toPar_xstate i t)"
    using Cptn(1) c_stepi by blast
  moreover have " (i,\<Gamma>, toParCptn i ((Q, t) # xs)) \<in> cptni"
  proof(cases t)
    case (Normal x1)
    then show ?thesis
      using Cptn.hyps(1) Cptn.hyps(3) Cptn.prems(2) s
            step_cei_normal_normal_same_len
      by (simp add: ce_eq_length)
  next
    case (Abrupt x2)
    then show ?thesis
      by (metis Cptn.hyps(1) Cptn.hyps(2) Cptn.prems(2)
               ce_eq_length cptn_cptni_Abrupt nth_Cons_0 s snd_conv)
  next
    case (Fault x3)
    then show ?thesis
      using Cptn.hyps(2) cptn_cptni_not_abrupt_normal by fastforce
  next
    case Stuck
    then show ?thesis  using Cptn.hyps(2) cptn_cptni_not_abrupt_normal by force
  qed
  ultimately show ?case using toParCptn_simp
    by (simp add: toParCptn_simp cptni.Cptni)
qed

lemma cptn_cptni:
 "(\<Gamma>,c) \<in> cptn \<Longrightarrow>
  \<forall>sn. snd(c!0) = Normal sn \<or> snd(c!0) = Abrupt sn \<longrightarrow>  i\<le> length (snd sn) \<Longrightarrow>
 (i,\<Gamma>, toParCptn i c) \<in> cptni"
  apply (cases "snd (c!0)") using cptn_cptni_normal cptn_cptni_Abrupt cptn_cptni_not_abrupt_normal
  by fastforce+

lemma cptn_length_locs_less_i:
     assumes a0:"(\<Gamma>,c) \<in> cptn" and
       a1:"\<forall>nas. (snd (c!0))= Normal nas \<or> (snd (c!0)) = Abrupt nas  \<longrightarrow> i\<le> length (snd nas)"
     shows "\<forall>j<length c. (\<forall>nas. (snd (c!j))= Normal nas \<or> (snd (c!j)) = Abrupt nas  \<longrightarrow>
            i\<le> length (snd nas))"
proof(cases "length c")
  case 0
  then show ?thesis by auto
next
  case (Suc nat)
  then have len:"length c>0" by auto
  have  cptni:"(i,\<Gamma>, toParCptn i c) \<in> cptni" using cptn_cptni[OF a0 a1] by auto
  then have "\<forall>nas. (snd (toParCptn i c!0))= Normal nas \<or> (snd (toParCptn i c!0)) = Abrupt nas  \<longrightarrow>
             i< length (snd nas)"
    using a1 len unfolding toParCptn_def apply (cases "snd (c ! 0)", auto)
    unfolding toParState_def Let_def split_beta
    by auto
  then have "\<forall>j<length (toParCptn i c).
                (\<forall>nas. (snd ((toParCptn i c)!j))= Normal nas \<or>
                         (snd ((toParCptn i c)!j)) = Abrupt nas  \<longrightarrow>
                          i<length (snd nas))" using cptni_length_locs_less_i[OF cptni]
    by fastforce
  then show ?thesis using len unfolding toParCptn_def
    apply (auto)
     apply (metis Suc_eq_plus1 len_toParState not_less not_less_eq prod.exhaust_sel snd_conv toPar_xstate.simps(1))
    by (metis Suc_eq_plus1 len_toParState not_less not_less_eq prod.exhaust_sel snd_conv toPar_xstate.simps(2))
qed

(* definition toParPred:: "(((('g, 'l, 'p,'f,'e) config_gs) list) \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ((('g,'l,'p,'f,'e) gconf list) \<Rightarrow> bool)"
  where "toParPred Q i \<equiv> (\<lambda>x. Q (toSeqCptn i x) )"

lemma "(\<Gamma>,c) \<in> cptn \<Longrightarrow> P c \<Longrightarrow> \<forall>sn. snd(c!0) = Normal sn \<or> snd(c!0) = Abrupt sn \<longrightarrow>  i\<le> length (snd sn) \<Longrightarrow>
       (\<lambda>x. P (toSeqCptn i x)) (toParCptn i c)" *)

definition final_glob:: "('g,'l,'p,'f,'e) config_gs \<Rightarrow> bool" where
  "final_glob cfg \<equiv>   (fst cfg=Skip \<or> ((fst cfg=Throw) \<and> (\<exists>s. snd cfg=Normal s)))"

lemma final_eq:"final_glob cfg = SmallStepCon.final (fst cfg, toSeq (snd cfg))"
  unfolding final_def final_glob_def SmallStepCon.final_def
  by (cases "snd cfg",auto)

definition cpi1 :: "nat \<Rightarrow> ('g\<times>'l,'p,'f,'e) body \<Rightarrow> ('g\<times>'l,'p,'f,'e)com  \<Rightarrow>
                  (('g,'l)par_state,'f) xstate \<Rightarrow> (nat \<times>('g,'l,'p,'f,'e) gconfs) set" where
  "cpi1 i \<Gamma> P s \<equiv> {(i1,\<Gamma>1,l). l!0=(P,s) \<and> (i,\<Gamma>,l) \<in> cptni \<and> \<Gamma>1=\<Gamma>}"

lemma cpi1_sub:
  assumes a0: "(i,\<Gamma>,(x#l0)@l1) \<in> cpi1 i \<Gamma> P s"
  shows "(i,\<Gamma>,(x#l0)) \<in> cpi1 i \<Gamma> P s"
proof -
  show ?thesis using a0 unfolding cpi1_def
    using cptni_dest_2 by fastforce
qed

definition wf_state:: "nat \<Rightarrow> (('g,'l)par_state,'f) xstate \<Rightarrow> bool"
  where "wf_state i s \<equiv> \<forall>ns. s=Normal ns \<or> s = Abrupt ns \<longrightarrow> i = length (snd ns)"

definition cpi :: "nat \<Rightarrow> nat \<Rightarrow> ('g\<times>'l,'p,'f,'e) body \<Rightarrow> ('g\<times>'l,'p,'f,'e)com  \<Rightarrow>
                  (('g,'l)par_state,'f) xstate \<Rightarrow> (('g,'l,'p,'f,'e) gconfs) set" where
  "cpi len i \<Gamma> P s \<equiv> {(\<Gamma>1,l). l!0=(P,s) \<and> (i,\<Gamma>,l) \<in> cptni \<and> \<Gamma>1=\<Gamma> \<and> wf_state len s}"

lemma cpi_sub:
  assumes a0: "(\<Gamma>,(x#l0)@l1) \<in> cpi len i \<Gamma> P s"
  shows "(\<Gamma>,(x#l0)) \<in> cpi len i \<Gamma> P s"
proof -
  show ?thesis using a0 unfolding cpi_def
    using cptni_dest_2 by fastforce
qed

end


theory Induction_Demo_My
  imports Main
begin

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev [] ys = ys" |
  "itrev (x # xs) ys = itrev xs (x # ys)"

(* arbitrary ys tells us to have ys arbitrary in the IH and inductive conclusion *)
lemma "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
   apply auto
  done


(* Author: Florian Haftmann, TU Muenchen *)

section {* Lists with elements distinct as canonical example for datatype invariants *}

theory Dlist
imports Main
begin

subsection {* The type of distinct lists *}

typedef 'a dlist = "{xs::'a list. distinct xs}"
  morphisms list_of_dlist Abs_dlist
proof
  show "[] \<in> {xs. distinct xs}" by simp
qed

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
  by (simp add: list_of_dlist_inject)

lemma dlist_eqI:
  "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

text {* Formal, totalized constructor for @{typ "'a dlist"}: *}

definition Dlist :: "'a list \<Rightarrow> 'a dlist" where
  "Dlist xs = Abs_dlist (remdups xs)"

lemma distinct_list_of_dlist [simp, intro]:
  "distinct (list_of_dlist dxs)"
  using list_of_dlist [of dxs] by simp

lemma list_of_dlist_Dlist [simp]:
  "list_of_dlist (Dlist xs) = remdups xs"
  by (simp add: Dlist_def Abs_dlist_inverse)

lemma remdups_list_of_dlist [simp]:
  "remdups (list_of_dlist dxs) = list_of_dlist dxs"
  by simp

lemma Dlist_list_of_dlist [simp, code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (simp add: Dlist_def list_of_dlist_inverse distinct_remdups_id)

text {* Fundamental operations: *}

definition empty :: "'a dlist" where
  "empty = Dlist []"

definition insert :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "insert x dxs = Dlist (List.insert x (list_of_dlist dxs))"

definition remove :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "remove x dxs = Dlist (remove1 x (list_of_dlist dxs))"

definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist" where
  "map f dxs = Dlist (remdups (List.map f (list_of_dlist dxs)))"

definition filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "filter P dxs = Dlist (List.filter P (list_of_dlist dxs))"

text {* Derived operations: *}

definition null :: "'a dlist \<Rightarrow> bool" where
  "null dxs = List.null (list_of_dlist dxs)"

definition member :: "'a dlist \<Rightarrow> 'a \<Rightarrow> bool" where
  "member dxs = List.member (list_of_dlist dxs)"

definition length :: "'a dlist \<Rightarrow> nat" where
  "length dxs = List.length (list_of_dlist dxs)"

definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "fold f dxs = List.fold f (list_of_dlist dxs)"

definition foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "foldr f dxs = List.foldr f (list_of_dlist dxs)"

subsection {* Executable version obeying invariant *}

lemma list_of_dlist_empty [simp, code abstract]:
  "list_of_dlist empty = []"
  by (simp add: empty_def)

lemma list_of_dlist_insert [simp, code abstract]:
  "list_of_dlist (insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (simp add: insert_def)

lemma list_of_dlist_remove [simp, code abstract]:
  "list_of_dlist (remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (simp add: remove_def)

lemma list_of_dlist_map [simp, code abstract]:
  "list_of_dlist (map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by (simp add: map_def)

lemma list_of_dlist_filter [simp, code abstract]:
  "list_of_dlist (filter P dxs) = List.filter P (list_of_dlist dxs)"
  by (simp add: filter_def)

text {* Explicit executable conversion *}

definition dlist_of_list [simp]:
  "dlist_of_list = Dlist"

lemma [code abstract]:
  "list_of_dlist (dlist_of_list xs) = remdups xs"
  by simp

text {* Equality *}

instantiation dlist :: (equal) equal
begin

definition "HOL.equal dxs dys \<longleftrightarrow> HOL.equal (list_of_dlist dxs) (list_of_dlist dys)"

instance proof
qed (simp add: equal_dlist_def equal list_of_dlist_inject)

end

declare equal_dlist_def [code]

lemma [code nbe]:
  "HOL.equal (dxs :: 'a::equal dlist) dxs \<longleftrightarrow> True"
  by (fact equal_refl)

subsection {* Induction principle and case distinction *}

lemma dlist_induct [case_names empty insert, induct type: dlist]:
  assumes empty: "P empty"
  assumes insrt: "\<And>x dxs. \<not> member dxs x \<Longrightarrow> P dxs \<Longrightarrow> P (insert x dxs)"
  shows "P dxs"
proof (cases dxs)
  case (Abs_dlist xs)
  then have "distinct xs" and dxs: "dxs = Dlist xs" by (simp_all add: Dlist_def distinct_remdups_id)
  from `distinct xs` have "P (Dlist xs)"
  proof (induct xs)
    case Nil from empty show ?case by (simp add: empty_def)
  next
    case (Cons x xs)
    then have "\<not> member (Dlist xs) x" and "P (Dlist xs)"
      by (simp_all add: member_def List.member_def)
    with insrt have "P (insert x (Dlist xs))" .
    with Cons show ?case by (simp add: insert_def distinct_remdups_id)
  qed
  with dxs show "P dxs" by simp
qed

lemma dlist_case [cases type: dlist]:
  obtains (empty) "dxs = empty"
    | (insert) x dys where "\<not> member dys x" and "dxs = insert x dys"
proof (cases dxs)
  case (Abs_dlist xs)
  then have dxs: "dxs = Dlist xs" and distinct: "distinct xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  show thesis
  proof (cases xs)
    case Nil with dxs
    have "dxs = empty" by (simp add: empty_def)
    with empty show ?thesis .
  next
    case (Cons x xs)
    with dxs distinct have "\<not> member (Dlist xs) x"
      and "dxs = insert x (Dlist xs)"
      by (simp_all add: member_def List.member_def insert_def distinct_remdups_id)
    with insert show ?thesis .
  qed
qed

subsection {* Functorial structure *}

functor map: map
  by (simp_all add: List.map.id remdups_map_remdups fun_eq_iff dlist_eq_iff)

subsection {* Quickcheck generators *}

quickcheck_generator dlist predicate: distinct constructors: empty, insert

hide_const (open) member fold foldr empty insert remove map filter null member length fold

end


theory Unfold_stream_id
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec unfold_stream :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b Stream" where
  "unfold_stream g1 g2 a = SCons (g1 a) (unfold_stream g1 g2 (g2 a))"

fun shead :: "'a Stream \<Rightarrow> 'a" where
  "shead xs = shd xs"

fun stail :: "'a Stream \<Rightarrow> 'a Stream" where
  "stail xs = stl xs"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(* hipster_obs Stream Lst obsStream unfold_stream shead stail
nothing interesting found *)
theorem unfold_stream_id:
   "unfold_stream shead stail xs = xs"
   by hipster_coinduct_sledgehammer

end


theory ByteCode
  imports "../00Utils/Environment" "../00Utils/Iteration"
begin

datatype byte_code =
  BLookup nat
  | BPushCon nat
  | BPushLam nat
  | BApply
  | BReturn
  | BJump

datatype bclosure =
  BConst nat
  | BLam "bclosure list" nat

datatype byte_code_state =
  BS "bclosure list" "(bclosure list \<times> nat) list"

inductive evalb :: "byte_code list \<Rightarrow> byte_code_state \<Rightarrow> byte_code_state \<Rightarrow> bool"
    (infix "\<tturnstile> _ \<leadsto>\<^sub>b" 50) where
  evb_lookup [simp]: "lookup cd pc = Some (BLookup x) \<Longrightarrow> lookup env x = Some v \<Longrightarrow>
    cd \<tturnstile> BS vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>b BS (v # vs) ((env, pc) # sfs)"
| evb_pushcon [simp]: "lookup cd pc = Some (BPushCon k) \<Longrightarrow>
    cd \<tturnstile> BS vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>b BS (BConst k # vs) ((env, pc) # sfs)"
| evb_pushlam [simp]: "lookup cd pc = Some (BPushLam pc') \<Longrightarrow>
    cd \<tturnstile> BS vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>b BS (BLam env pc' # vs) ((env, pc) # sfs)"
| evb_apply [simp]: "lookup cd pc = Some BApply \<Longrightarrow>
    cd \<tturnstile> BS (v # BLam env' pc' # vs) ((env, Suc pc) # sfs) \<leadsto>\<^sub>b
      BS vs ((v # env', pc') # (env, pc) # sfs)"
| evb_return [simp]: "lookup cd pc = Some BReturn \<Longrightarrow>
    cd \<tturnstile> BS vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>b BS vs sfs"
| evb_jump [simp]: "lookup cd pc = Some BJump \<Longrightarrow>
    cd \<tturnstile> BS (v # BLam env' pc' # vs) ((env, Suc pc) # sfs) \<leadsto>\<^sub>b BS vs ((v # env', pc') # sfs)"

theorem determinismb: "cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>b \<Sigma>' \<Longrightarrow> cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>b \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction cd \<Sigma> \<Sigma>' rule: evalb.induct)
  case (evb_lookup cd pc x env v vs sfs)
  from evb_lookup(3, 1, 2) show ?case
    by (induction cd "BS vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalb.induct) simp_all
next
  case (evb_pushcon cd pc k vs env sfs)
  from evb_pushcon(2, 1) show ?case
    by (induction cd "BS vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalb.induct) simp_all
next
  case (evb_pushlam cd pc pc' vs env sfs)
  from evb_pushlam(2, 1) show ?case
    by (induction cd "BS vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalb.induct) simp_all
next
  case (evb_apply cd pc v env' pc' vs env sfs)
  from evb_apply(2, 1) show ?case
    by (induction cd "BS (v # BLam env' pc' # vs) ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalb.induct)
       simp_all
next
  case (evb_return cd pc vs env sfs)
  from evb_return(2, 1) show ?case
    by (induction cd "BS vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalb.induct) simp_all
next
  case (evb_jump cd pc v env' pc' vs env sfs)
  from evb_jump(2, 1) show ?case
    by (induction cd "BS (v # BLam env' pc' # vs) ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalb.induct)
       simp_all
qed

end


theory Chapter11_3_Evaluation
imports Chapter11_2_Typechecking
begin

primrec is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val Zero = True"
    | "is_val (Suc e) = is_val e"
    | "is_val (Rec et e0 es) = False"
    | "is_val (Lam t e) = True"
    | "is_val (Appl e1 e2) = False"
    | "is_val Triv = True"
    | "is_val (Pair e1 e2) = (is_val e1 & is_val e2)"
    | "is_val (ProjL e) = False"
    | "is_val (ProjR e) = False"
    | "is_val (Abort t e) = False"
    | "is_val (Case et el er) = False"
    | "is_val (InL t1 t2 e) = is_val e"
    | "is_val (InR t1 t2 e) = is_val e"

inductive eval :: "expr => expr => bool"
where eval_suc [simp]: "eval e e' ==> eval (Suc e) (Suc e')"
    | eval_rec_1 [simp]: "eval et et' ==> eval (Rec et e0 es) (Rec et' e0 es)"
    | eval_rec_2 [simp]: "eval (Rec Zero e0 es) e0"
    | eval_rec_3 [simp]: "is_val et ==>
            eval (Rec (Suc et) e0 es) (subst (Rec et e0 es) first (subst et first es))"
    | eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Appl e1 e2) (Appl e1 e2')"
    | eval_appl_3 [simp]: "is_val e2 ==> eval (Appl (Lam t2 e1) e2) (subst e2 first e1)"
    | eval_pair_1 [simp]: "eval e1 e1' ==> eval (Pair e1 e2) (Pair e1' e2)"
    | eval_pair_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Pair e1 e2) (Pair e1 e2')"
    | eval_projl_1 [simp]: "eval e e' ==> eval (ProjL e) (ProjL e')"
    | eval_projl_2 [simp]: "eval (ProjL (Pair e1 e2)) e1"
    | eval_projr_1 [simp]: "eval e e' ==> eval (ProjR e) (ProjR e')"
    | eval_projr_2 [simp]: "eval (ProjR (Pair e1 e2)) e2"
    | eval_abort [simp]: "eval e e' ==> eval (Abort t e) (Abort t e')"
    | eval_case_1 [simp]: "eval et et' ==> eval (Case et el er) (Case et' el er)"
    | eval_case_2 [simp]: "is_val e ==> eval (Case (InL t1 t2 e) el er) (subst e first el)"
    | eval_case_3 [simp]: "is_val e ==> eval (Case (InR t1 t2 e) el er) (subst e first er)"
    | eval_inl [simp]: "eval e e' ==> eval (InL t1 t2 e) (InL t1 t2 e')"
    | eval_inr [simp]: "eval e e' ==> eval (InR t1 t2 e) (InR t1 t2 e')"

lemma canonical_nat: "is_val e ==> typecheck gam e Nat ==>
          e = Zero | (EX e'. e = Suc e' & typecheck gam e' Nat)"
by (induction e, auto)

lemma canonical_nat_no_vars: "is_val e ==> typecheck gam e Nat ==> typecheck gam' e Nat"
by (induction e, auto)

lemma canonical_arrow: "is_val e ==> typecheck gam e (Arrow t1 t2) ==>
              EX e'. e = Lam t1 e' & typecheck (extend gam t1) e' t2"
by (induction e, auto)

lemma canonical_unit: "is_val e ==> typecheck gam e Unit ==> e = Triv"
by (induction e, auto)

lemma canonical_prod: "is_val e ==> typecheck gam e (Prod t1 t2) ==>
              EX e1 e2. e = Pair e1 e2 & typecheck gam e1 t1 & typecheck gam e2 t2"
by (induction e, auto)

lemma canonical_void: "is_val e ==> typecheck gam e Void ==> False"
by (induction e, auto)

lemma canonical_sum: "is_val e ==> typecheck gam e (Sum t1 t2) ==>
          (EX e'. e = InL t1 t2 e' & typecheck gam e' t1) |
          (EX e'. e = InR t1 t2 e' & typecheck gam e' t2)"
by (induction e, auto)

theorem preservation: "eval e e' ==> typecheck gam e t ==> typecheck gam e' t"
proof (induction e e' arbitrary: t rule: eval.induct)
case eval_suc
  thus ?case by fastforce
next case eval_rec_1
  thus ?case by fastforce
next case eval_rec_2
  thus ?case by fastforce
next case (eval_rec_3 et e0 es)
  from eval_rec_3 canonical_nat_no_vars have "typecheck (extend gam t) (subst et first es) t" by auto
  with eval_rec_3 show ?case by fastforce
next case eval_appl_1
  thus ?case by fastforce
next case eval_appl_2
  thus ?case by fastforce
next case eval_appl_3
  thus ?case by fastforce
next case eval_pair_1
  thus ?case by fastforce
next case eval_pair_2
  thus ?case by fastforce
next case eval_projl_1
  thus ?case by fastforce
next case eval_projl_2
  thus ?case by fastforce
next case eval_projr_1
  thus ?case by fastforce
next case eval_projr_2
  thus ?case by fastforce
next case eval_abort
  thus ?case by fastforce
next case eval_case_1
  thus ?case by fastforce
next case eval_case_2
  thus ?case by fastforce
next case eval_case_3
  thus ?case by fastforce
next case eval_inl
  thus ?case by fastforce
next case eval_inr
  thus ?case by fastforce
qed

theorem progress: "typecheck gam e t ==> gam = empty_env ==> is_val e | (EX e'. eval e e')"
proof (induction gam e t rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by (metis eval_suc is_val.simps(3))
next case tc_rec
  thus ?case by (metis eval_rec_1 eval_rec_2 eval_rec_3 is_val.simps(3) canonical_nat)
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by (metis eval_appl_1 eval_appl_2 eval_appl_3 canonical_arrow)
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by (metis eval_pair_1 eval_pair_2 is_val.simps(8))
next case tc_projl
  thus ?case by (metis eval_projl_1 eval_projl_2 canonical_prod)
next case tc_projr
  thus ?case by (metis eval_projr_1 eval_projr_2 canonical_prod)
next case tc_abort
  thus ?case by (metis eval_abort canonical_void)
next case tc_case
  thus ?case
  by (metis eval_case_1 eval_case_2 eval_case_3 is_val.simps(13) is_val.simps(14) canonical_sum)
next case tc_inl
  thus ?case by (metis eval_inl is_val.simps(13))
next case tc_inr
  thus ?case by (metis eval_inr is_val.simps(14))
qed

end


(*  Title:      HOL/MicroJava/DFA/Err.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section \<open>The Error Type\<close>

theory Err
imports Semilat
begin

datatype 'a err = Err | OK 'a

type_synonym 'a ebinop = "'a \<Rightarrow> 'a \<Rightarrow> 'a err"
type_synonym 'a esl = "'a set * 'a ord * 'a ebinop"

primrec ok_val :: "'a err \<Rightarrow> 'a" where
  "ok_val (OK x) = x"

definition lift :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)" where
"lift f e == case e of Err \<Rightarrow> Err | OK x \<Rightarrow> f x"

definition lift2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a err \<Rightarrow> 'b err \<Rightarrow> 'c err" where
"lift2 f e1 e2 ==
 case e1 of Err  \<Rightarrow> Err
          | OK x \<Rightarrow> (case e2 of Err \<Rightarrow> Err | OK y \<Rightarrow> f x y)"

definition le :: "'a ord \<Rightarrow> 'a err ord" where
"le r e1 e2 ==
        case e2 of Err \<Rightarrow> True |
                   OK y \<Rightarrow> (case e1 of Err \<Rightarrow> False | OK x \<Rightarrow> x <=_r y)"

definition sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a err \<Rightarrow> 'b err \<Rightarrow> 'c err)" where
"sup f == lift2(%x y. OK(x +_f y))"

definition err :: "'a set \<Rightarrow> 'a err set" where
"err A == insert Err {x . ? y:A. x = OK y}"

definition esl :: "'a sl \<Rightarrow> 'a esl" where
"esl == %(A,r,f). (A,r, %x y. OK(f x y))"

definition sl :: "'a esl \<Rightarrow> 'a err sl" where
"sl == %(A,r,f). (err A, le r, lift2 f)"

abbreviation
  err_semilat :: "'a esl \<Rightarrow> bool"
  where "err_semilat L == semilat(Err.sl L)"

primrec strict :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)" where
  "strict f Err    = Err"
| "strict f (OK x) = f x"

lemma strict_Some [simp]:
  "(strict f x = OK y) = (\<exists> z. x = OK z \<and> f z = OK y)"
  by (cases x, auto)

lemma not_Err_eq:
  "(x \<noteq> Err) = (\<exists>a. x = OK a)"
  by (cases x) auto

lemma not_OK_eq:
  "(\<forall>y. x \<noteq> OK y) = (x = Err)"
  by (cases x) auto

lemma unfold_lesub_err:
  "e1 <=_(le r) e2 == le r e1 e2"
  by (simp add: lesub_def)

lemma le_err_refl:
  "!x. x <=_r x \<Longrightarrow> e <=_(Err.le r) e"
apply (unfold lesub_def Err.le_def)
apply (simp split: err.split)
done

lemma le_err_trans [rule_format]:
  "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e3 \<longrightarrow> e1 <=_(le r) e3"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_trans)
done

lemma le_err_antisym [rule_format]:
  "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e1 \<longrightarrow> e1=e2"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_antisym)
done

lemma OK_le_err_OK:
  "(OK x <=_(le r) OK y) = (x <=_r y)"
  by (simp add: unfold_lesub_err le_def)

lemma order_le_err [iff]:
  "order(le r) = order r"
apply (rule iffI)
 apply (subst Semilat.order_def)
 apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
              intro: order_trans OK_le_err_OK [THEN iffD1])
apply (subst Semilat.order_def)
apply (blast intro: le_err_refl le_err_trans le_err_antisym
             dest: order_refl)
done

lemma le_Err [iff]:  "e <=_(le r) Err"
  by (simp add: unfold_lesub_err le_def)

lemma Err_le_conv [iff]:
 "Err <=_(le r) e  = (e = Err)"
  by (simp add: unfold_lesub_err le_def  split: err.split)

lemma le_OK_conv [iff]:
  "e <=_(le r) OK x  =  (? y. e = OK y & y <=_r x)"
  by (simp add: unfold_lesub_err le_def split: err.split)

lemma OK_le_conv:
 "OK x <=_(le r) e  =  (e = Err | (? y. e = OK y & x <=_r y))"
  by (simp add: unfold_lesub_err le_def split: err.split)

lemma top_Err [iff]: "top (le r) Err"
  by (simp add: top_def)

lemma OK_less_conv [rule_format, iff]:
  "OK x <_(le r) e = (e=Err | (? y. e = OK y & x <_r y))"
  by (simp add: lesssub_def lesub_def le_def split: err.split)

lemma not_Err_less [rule_format, iff]:
  "~(Err <_(le r) x)"
  by (simp add: lesssub_def lesub_def le_def split: err.split)

lemma semilat_errI [intro]:
  assumes semilat: "semilat (A, r, f)"
  shows "semilat(err A, Err.le r, lift2(%x y. OK(f x y)))"
  using semilat
  apply (simp only: semilat_Def closed_def plussub_def lesub_def
    lift2_def Err.le_def err_def)
  apply (simp split: err.split)
  done

lemma err_semilat_eslI_aux:
  assumes semilat: "semilat (A, r, f)"
  shows "err_semilat(esl(A,r,f))"
  apply (unfold sl_def esl_def)
  apply (simp add: semilat_errI[OF semilat])
  done

lemma err_semilat_eslI [intro, simp]:
 "\<And>L. semilat L \<Longrightarrow> err_semilat(esl L)"
by(simp add: err_semilat_eslI_aux split_tupled_all)

lemma acc_err [simp, intro!]:  "acc r \<Longrightarrow> acc(le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: err.split)
apply clarify
apply (case_tac "Err : Q")
 apply blast
apply (erule_tac x = "{a . OK a : Q}" in allE)
apply (case_tac "x")
 apply fast
apply blast
done

lemma Err_in_err [iff]: "Err : err A"
  by (simp add: err_def)

lemma Ok_in_err [iff]: "(OK x : err A) = (x:A)"
  by (auto simp add: err_def)

subsection \<open>lift\<close>

lemma lift_in_errI:
  "\<lbrakk> e : err S; !x:S. e = OK x \<longrightarrow> f x : err S \<rbrakk> \<Longrightarrow> lift f e : err S"
apply (unfold lift_def)
apply (simp split: err.split)
apply blast
done

lemma Err_lift2 [simp]:
  "Err +_(lift2 f) x = Err"
  by (simp add: lift2_def plussub_def)

lemma lift2_Err [simp]:
  "x +_(lift2 f) Err = Err"
  by (simp add: lift2_def plussub_def split: err.split)

lemma OK_lift2_OK [simp]:
  "OK x +_(lift2 f) OK y = x +_f y"
  by (simp add: lift2_def plussub_def split: err.split)

subsection \<open>sup\<close>

lemma Err_sup_Err [simp]:
  "Err +_(Err.sup f) x = Err"
  by (simp add: plussub_def Err.sup_def Err.lift2_def)

lemma Err_sup_Err2 [simp]:
  "x +_(Err.sup f) Err = Err"
  by (simp add: plussub_def Err.sup_def Err.lift2_def split: err.split)

lemma Err_sup_OK [simp]:
  "OK x +_(Err.sup f) OK y = OK(x +_f y)"
  by (simp add: plussub_def Err.sup_def Err.lift2_def)

lemma Err_sup_eq_OK_conv [iff]:
  "(Err.sup f ex ey = OK z) = (? x y. ex = OK x & ey = OK y & f x y = z)"
apply (unfold Err.sup_def lift2_def plussub_def)
apply (rule iffI)
 apply (simp split: err.split_asm)
apply clarify
apply simp
done

lemma Err_sup_eq_Err [iff]:
  "(Err.sup f ex ey = Err) = (ex=Err | ey=Err)"
apply (unfold Err.sup_def lift2_def plussub_def)
apply (simp split: err.split)
done

subsection \<open>semilat (err A) (le r) f\<close>

lemma semilat_le_err_Err_plus [simp]:
  "\<lbrakk> x: err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> Err +_f x = Err"
  by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
                   Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])

lemma semilat_le_err_plus_Err [simp]:
  "\<lbrakk> x: err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> x +_f Err = Err"
  by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
                   Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])

lemma semilat_le_err_OK1:
  "\<lbrakk> x:A; y:A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
  \<Longrightarrow> x <=_r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub1 [OF Semilat.intro])
done

lemma semilat_le_err_OK2:
  "\<lbrakk> x:A; y:A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
  \<Longrightarrow> y <=_r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub2 [OF Semilat.intro])
done

lemma eq_order_le:
  "\<lbrakk> x=y; order r \<rbrakk> \<Longrightarrow> x <=_r y"
apply (unfold Semilat.order_def)
apply blast
done

lemma OK_plus_OK_eq_Err_conv [simp]:
  assumes "x:A" and "y:A" and "semilat(err A, le r, fe)"
  shows "((OK x) +_fe (OK y) = Err) = (~(? z:A. x <=_r z & y <=_r z))"
proof -
  have plus_le_conv3: "\<And>A x y z f r.
    \<lbrakk> semilat (A,r,f); x +_f y <=_r z; x:A; y:A; z:A \<rbrakk>
    \<Longrightarrow> x <=_r z \<and> y <=_r z"
    by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "(OK x) +_fe (OK y)")
   apply assumption
  apply (rename_tac z)
  apply (subgoal_tac "OK z: err A")
  apply (drule eq_order_le)
    apply (erule Semilat.orderI [OF Semilat.intro])
   apply (blast dest: plus_le_conv3)
  apply (erule subst)
  apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
  done
qed

subsection \<open>semilat (err (Union AS))\<close>

(* FIXME? *)
lemma all_bex_swap_

text \<open>
  If @{term "AS = {}"} the thm collapses to
  @{prop "order r & closed {Err} f & Err +_f Err = Err"}
  which may not hold
\<close>
lemma err_semilat_UnionI:
  "\<lbrakk> !A:AS. err_semilat(A, r, f); AS ~= {};
      !A:AS.!B:AS. A~=B \<longrightarrow> (!a:A.!b:B. ~ a <=_r b & a +_f b = Err) \<rbrakk>
  \<Longrightarrow> err_semilat (\<Union>AS, r, f)"
apply (unfold semilat_def sl_def)
apply (simp add: closed_err_Union_lift2I)
apply (rule conjI)
 apply blast
apply (simp add: err_def)
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply clarify
apply (rename_tac A ya yb B yd z C c a b)
apply (case_tac "A = B")
 apply (case_tac "A = C")
  apply simp
 apply (rotate_tac -1)
 apply simp
apply (rotate_tac -1)
apply (case_tac "B = C")
 apply simp
apply (rotate_tac -1)
apply simp
done

end