(*formal semantics of brainfuck*)

theory Semantics
imports Verifuck
begin

datatype 'a outp = Output "'a list"
datatype 'a inp = Input "'a list"
datatype 'a state = Error | Normal "'a tape" "'a inp" "'a outp"

fun aligned_parenthesis :: "instr list \<Rightarrow> nat \<Rightarrow> bool" where
  "aligned_parenthesis [] 0 = True" |
  "aligned_parenthesis [] _ = False" |
  "aligned_parenthesis (Loop#cs) n = aligned_parenthesis cs (Suc n)" |
  "aligned_parenthesis (Pool#_) 0 = False" |
  "aligned_parenthesis (Pool#cs) (Suc n) = aligned_parenthesis cs n" |
  "aligned_parenthesis (c#cs) n = aligned_parenthesis cs n"

inductive eval_bf :: "instr list \<Rightarrow> 'a::{zero,one,plus,minus} state \<Rightarrow> 'a state \<Rightarrow> bool"  where
init:  "s = s' \<Longrightarrow> eval_bf [] s s'" |
       "eval_bf [Right] (Normal (Tape lt c []) inp outp)       (Normal (Tape (c#lt) 0 []) inp outp)" |
       "eval_bf [Right] (Normal (Tape lt c (rt#rts)) inp outp) (Normal (Tape (c#lt) rt rts) inp outp)" |
       "eval_bf [Left]  (Normal (Tape [] c rt) inp outp)       Error"  |
       "eval_bf [Left]  (Normal (Tape (lt#lts) c rt) inp outp) (Normal (Tape lts lt (c#rt)) inp outp)" |
       "eval_bf [Incr]  (Normal (Tape lt c rt) inp outp)       (Normal (Tape lt (c + 1) rt) inp outp)" |
       "eval_bf [Decr] (Normal (Tape lt c rt) inp outp)       (Normal (Tape lt (c - 1) rt) inp outp)" |
       "eval_bf [Out] (Normal (Tape lt c rt) inp (Output outp))     (Normal (Tape lt c rt) inp (Output (c#outp)))" |
       "eval_bf [In]  (Normal (Tape lt _ rt) (Input []) outp)       (Normal (Tape lt (0 - 1) rt) (Input []) outp)" | (*really?*)
       "eval_bf [In]  (Normal (Tape lt _ rt) (Input (i#is)) outp)   (Normal (Tape lt i rt) (Input is) outp)" |
seq:  "eval_bf code s s' \<Longrightarrow> eval_bf code' s' s'' \<Longrightarrow> eval_bf (code@code') s s''" |
whileTrue:      "c \<noteq> 0 \<Longrightarrow> eval_bf code (Normal (Tape lt c rt) inp outp) (Normal (Tape lt'' c'' rt'') inp'' outp'') \<Longrightarrow>
                  eval_bf ([Loop]@code@[Pool])  (Normal (Tape lt'' c'' rt'') inp'' outp') (Normal (Tape lt' c' rt') inp' outp') \<Longrightarrow>
        eval_bf ([Loop]@code@[Pool])  (Normal (Tape lt c rt) inp outp)       (Normal (Tape lt' c' rt') inp' outp')" |

(*is this correct? what if not aligned_parenthesis ?*)
whileFalse:      "c = 0 \<Longrightarrow>  aligned_parenthesis code 0 \<Longrightarrow>
        eval_bf ([Loop]@code@[Pool])  (Normal (Tape lt c rt) inp outp)       (Normal (Tape lt c rt) inp outp)"

lemma skip_loop_forward_aligned:
  "skip_loop_forward cs rs n = Result ([], rs') \<Longrightarrow> aligned_parenthesis cs (Suc n)"
apply(induction cs arbitrary: n rs)
 apply(simp; fail)
apply(case_tac a)
       apply(simp_all)
apply(case_tac n)
 apply(simp_all)
done

inductive_cases "eval_bf [] s s'"

inductive_cases b_bf_while: "eval_bf (Loop # code @ [Pool]) s s'"
thm b_bf_while

(*inductive_cases for [] is not so good*)
lemma b_bf_init: "eval_bf [] s s' \<Longrightarrow> (s' = s \<Longrightarrow> P) \<Longrightarrow> P"
proof -
  assume "eval_bf [] s s'" and "s' = s \<Longrightarrow> P"
  have "eval_bf prog s s' \<Longrightarrow> prog = [] \<Longrightarrow> (s' = s \<Longrightarrow> P) \<Longrightarrow> P" for prog
    proof(induction prog s s' rule: eval_bf.induct)
    qed(auto intro: eval_bf.intros)
  thus ?thesis using \<open>eval_bf [] s s'\<close> and \<open>s' = s \<Longrightarrow> P\<close> by simp
qed

lemma subst1: "cmd#code' = [cmd]@code'" by (metis append_Cons append_Nil)

lemma seq': "eval_bf [cmd] s s' \<Longrightarrow> eval_bf code' s' s'' \<Longrightarrow> eval_bf (cmd#code') s s''"
apply(subst subst1)
apply(rule eval_bf.seq)
by(auto)

lemma seq_while_split: "eval_bf ([BF_LOOPSTART]@code@[BF_LOOPEND]) s si \<Longrightarrow> eval_bf (code') si s'
   \<Longrightarrow> eval_bf ([BF_LOOPSTART]@code@[BF_LOOPEND]@code') s s'"
  apply(simp)
  apply(rule eval_bf.seq[of "[BF_LOOPSTART]@code@[BF_LOOPEND]" s si "code'", simplified])
by(auto intro: eval_bf.intros)

lemma "eval_bf [] (Normal (Tape [] 0 []) inp outp) (Normal (Tape [] 0 []) inp outp)"
  by(simp add: eval_bf.intros)

(*the nat annotation is important, otherwise, 0+1=1 may not hold!*)
lemma "eval_bf [Incr, Out] (Normal (Tape [] (0::nat) []) inp (Output [])) (Normal (Tape [] 1 []) inp (Output [1]))"
  apply(rule seq')
  apply(auto intro: eval_bf.intros)
 done

lemma "run_bf [instr.Right] inp = []"
  by(simp add: run_bf_def interp_bf.simps init_table_def)

lemma eval_bf_emptyD: "eval_bf [] s s' \<Longrightarrow> s = s'"
proof-
  have "eval_bf prog s s' \<Longrightarrow> prog = [] \<Longrightarrow> s = s'" for prog
    apply(induction rule: eval_bf.induct)
    by(simp_all)
  thus "eval_bf [] s s' \<Longrightarrow> s = s'" by simp
qed

(*
(*steps left \<Rightarrow> current program \<Rightarrow> executed instructions \<Rightarrow> skip because we are in a loop? \<Rightarrow> ...*)
fun  bounded_machine :: "nat \<Rightarrow> instr list \<Rightarrow> instr list \<Rightarrow> loop_skipper \<Rightarrow>
                          ('a::{zero,one,minus,plus}, 'b) machine \<Rightarrow> ('a, 'b) machine" where
"bounded_machine 0 _ _ _ m  = m" | (*TODO: error out-of-instructions*)
"bounded_machine _ [] _ NoSkip m  = m" |
"bounded_machine (Suc n) (Incr#cs) rs NoSkip m = bounded_machine n cs (Incr#rs) NoSkip (apfst (tape_map_cur (\<lambda>x. x + 1)) m)" |
"bounded_machine (Suc n) (Decr#cs) rs NoSkip m = bounded_machine n cs (Decr#rs) NoSkip (apfst (tape_map_cur (\<lambda>x. x - 1)) m)" |
"bounded_machine (Suc n) (Left#cs) rs NoSkip m = bounded_machine n cs (Left#rs) NoSkip (apfst tape_shift_left m)" |
"bounded_machine (Suc n) (Right#cs) rs NoSkip m = bounded_machine n cs (Right#rs) NoSkip (apfst tape_shift_right m)" |
"bounded_machine (Suc n) (In#cs) rs NoSkip m = bounded_machine n cs (In#rs) NoSkip ((\<lambda>(tape, io). let (c, io') = read_io io in (tape_map_cur (\<lambda>_. c) tape, io')) m)" |
"bounded_machine (Suc n) (Out#cs) rs NoSkip m = bounded_machine n cs (Out#rs) NoSkip ((\<lambda>(tape, io). (tape, write_io (cur tape) io)) m)" |
"bounded_machine (Suc n) (Loop#cs) rs NoSkip m = bounded_machine n cs (Loop#rs) (SkipForward 0) m" | (*only if current = 0*)
"bounded_machine (Suc n) (Loop#cs) rs (SkipForward s) m = bounded_machine n cs (Loop#rs) (SkipForward (Suc s)) m" |
"bounded_machine (Suc n) (Pool#cs) rs (SkipForward 0) m = bounded_machine n cs (Pool#rs) NoSkip m" |
"bounded_machine (Suc n) (Pool#cs) rs (SkipForward (Suc s)) m = bounded_machine n cs (Loop#rs) (SkipForward s) m" |
"bounded_machine (Suc n) (c#cs) rs (SkipForward s) m = bounded_machine n cs (c#rs) (SkipForward s) m" |
"bounded_machine (Suc n) [] rs (SkipForward s) m = m" | (*no closing ]*)
"bounded_machine (Suc n) (Pool#cs) rs NoSkip m = bounded_machine n cs (Loop#rs) (SkipBackward 0) m" |
"bounded_machine (Suc n) cs (Loop#rs) (SkipBackward 0) m = bounded_machine n (Loop#cs) rs NoSkip m" |
"bounded_machine (Suc n) cs (Loop#rs) (SkipBackward (Suc s)) m = bounded_machine n (Loop#cs) rs (SkipBackward s) m" |
"bounded_machine (Suc n) cs (Pool#rs) (SkipBackward s) m = bounded_machine n (Pool#cs) rs (SkipBackward (Suc s)) m" |
"bounded_machine (Suc n) cs (c#rs) (SkipBackward s) m = bounded_machine n (c#cs) rs (SkipBackward s) m" |
"bounded_machine (Suc n) cs [] (SkipBackward s) m = m" (*no opening [*)
by pat_completeness auto

datatype loop_skipper = NoSkip | SkipForward nat | SkipBackward nat

(*TODO: error of out-of-instructions*)
(*steps left \<Rightarrow> current program \<Rightarrow> executed instructions \<Rightarrow> skip because we are in a loop? \<Rightarrow> ...*)
fun  bounded_machine :: "nat \<Rightarrow> instr list \<Rightarrow> instr list \<Rightarrow> loop_skipper \<Rightarrow>
                          ('a::{zero,one,minus,plus}, 'b) machine \<Rightarrow> ('a, 'b) machine" where
"bounded_machine 0 _ _ _ m  = m" | (*TODO: error out-of-instructions*)
"bounded_machine _ [] _ NoSkip m  = m" |
"bounded_machine (Suc n) (Incr#cs) rs NoSkip m = bounded_machine n cs (Incr#rs) NoSkip (apfst (tape_map_cur (\<lambda>x. x + 1)) m)" |
"bounded_machine (Suc n) (Decr#cs) rs NoSkip m = bounded_machine n cs (Decr#rs) NoSkip (apfst (tape_map_cur (\<lambda>x. x - 1)) m)" |
"bounded_machine (Suc n) (Left#cs) rs NoSkip m = bounded_machine n cs (Left#rs) NoSkip (apfst tape_shift_left m)" |
"bounded_machine (Suc n) (Right#cs) rs NoSkip m = bounded_machine n cs (Right#rs) NoSkip (apfst tape_shift_right m)" |
"bounded_machine (Suc n) (In#cs) rs NoSkip m = bounded_machine n cs (In#rs) NoSkip ((\<lambda>(tape, io). let (c, io') = read_io io in (tape_map_cur (\<lambda>_. c) tape, io')) m)" |
"bounded_machine (Suc n) (Out#cs) rs NoSkip m = bounded_machine n cs (Out#rs) NoSkip ((\<lambda>(tape, io). (tape, write_io (cur tape) io)) m)" |
"bounded_machine (Suc n) (Loop#cs) rs NoSkip m = bounded_machine n cs (Loop#rs) (SkipForward 0) m" | (*only if current = 0*)
"bounded_machine (Suc n) (Loop#cs) rs (SkipForward s) m = bounded_machine n cs (Loop#rs) (SkipForward (Suc s)) m" |
"bounded_machine (Suc n) (Pool#cs) rs (SkipForward 0) m = bounded_machine n cs (Pool#rs) NoSkip m" |
"bounded_machine (Suc n) (Pool#cs) rs (SkipForward (Suc s)) m = bounded_machine n cs (Loop#rs) (SkipForward s) m" |
"bounded_machine (Suc n) (c#cs) rs (SkipForward s) m = bounded_machine n cs (c#rs) (SkipForward s) m" |
"bounded_machine (Suc n) [] rs (SkipForward s) m = m" | (*no closing ]*)
"bounded_machine (Suc n) (Pool#cs) rs NoSkip m = bounded_machine n cs (Loop#rs) (SkipBackward 0) m" |
"bounded_machine (Suc n) cs (Loop#rs) (SkipBackward 0) m = bounded_machine n (Loop#cs) rs NoSkip m" |
"bounded_machine (Suc n) cs (Loop#rs) (SkipBackward (Suc s)) m = bounded_machine n (Loop#cs) rs (SkipBackward s) m" |
"bounded_machine (Suc n) cs (Pool#rs) (SkipBackward s) m = bounded_machine n (Pool#cs) rs (SkipBackward (Suc s)) m" |
"bounded_machine (Suc n) cs (c#rs) (SkipBackward s) m = bounded_machine n (c#cs) rs (SkipBackward s) m" |
"bounded_machine (Suc n) cs [] (SkipBackward s) m = m" (*no opening [*)
by pat_completeness auto

termination bounded_machine
apply(relation "measure (\<lambda>(n, cs, rs, skipper, tape, io).
      case skipper of NoSkip \<Rightarrow> n + length cs + length rs
                   |  SkipForward s \<Rightarrow> (length cs) + n + (if s = 0 then length rs else xs)
                   |  SkipBackward s \<Rightarrow> length rs + g n)")
apply(simp)
apply(simp_all)
apply(simp_all add: min_def max_def split: nat.split)
oops
*)

lemma eval_bf_tape_shift_right: "eval_bf [instr.Right] (Normal tpe inp outp) (Normal (tape_shift_right tpe) inp outp)"
  apply(cases tpe, rename_tac l c r)
  apply(case_tac r)
  apply(auto intro: eval_bf.intros)
  done

lemma eval_bf_tape_shift_left':
      "tape_shift_left' tpe = Result shifted_tape \<Longrightarrow>
        eval_bf [instr.Left] (Normal tpe inp outp) (Normal shifted_tape inp outp)"
  apply(cases tpe, rename_tac l c r)
  apply(case_tac l)
  apply(auto intro: eval_bf.intros)
  done

lemma eval_bf_intro_In_EOF:
  "eval_bf [In] (Normal (Tape lt c rt) (Input []) outp) (Normal (Tape lt EOF rt) (Input []) outp)"
  apply(subgoal_tac "EOF = -1")
   using eval_bf.intros(9) apply (metis diff_0)
  apply(simp add: EOF_def)
  done

lemma "(\<And>cs' rs' lt' c' rt' inp' outp'.
           skip_loop_forward cs (Loop # rs) 0 = Result (cs', rs') \<Longrightarrow>
           bounded_machine n cs' rs' (tpe, Buffer inp read_byte outp) = Result (Tape lt' c' rt', Buffer inp' read_byte outp') \<Longrightarrow>
           eval_bf cs' (Normal tpe (Input inp) (Output outp)) (Normal (Tape lt' c' rt') (Input inp') (Output outp'))) \<Longrightarrow>
       (case skip_loop_forward cs (Loop # rs) 0 of
            either.Error err \<Rightarrow> either.Error (err, rev rs, cs, tpe, Buffer inp read_byte outp)
          | Result (cs', rs') \<Rightarrow> bounded_machine n cs' rs' (tpe, Buffer inp read_byte outp))
        = Result (Tape lt' c' rt', Buffer inp' read_byte outp') \<Longrightarrow>
       cur tpe = 0 \<Longrightarrow>
       eval_bf (Loop # cs) (Normal tpe (Input inp) (Output outp)) (Normal (Tape lt' c' rt') (Input inp') (Output outp'))"
apply(case_tac "skip_loop_forward cs (Loop # rs) 0")
 apply(simp;fail)
apply(simp)
apply(rename_tac x2, case_tac x2)
apply(simp)
apply(frule skip_loop_forward_Result_Pool)
apply(induction cs)
 apply(simp; fail)
apply(simp)
  oops

lemma "bounded_machine limit prog rs (tpe, Buffer inp read_byte outp) = Result (Tape lt' c' rt', Buffer inp' read_byte outp')
       (*buf = Buffer inp read_byte outp *)(*\<Longrightarrow> rs = []*)
        \<Longrightarrow>
        eval_bf prog (Normal tpe (Input inp) (Output outp))  (Normal (Tape lt' c' rt') (Input inp') (Output outp'))"
  thm bounded_machine.induct
(*It won't work anyway because the case where prog starts with Pool is unprovable
  the lemma needs to use rs too!*)
  apply(induction limit prog rs "(tpe, Buffer inp read_byte outp)" arbitrary: tpe lt' c' rt' inp inp' outp' outp rule: bounded_machine.induct)
  apply(simp_all)
  apply(auto intro: eval_bf.intros)[1]
  apply(rule_tac s'="Normal (Tape (left tape) (cur tape + 1) (right tape)) (Input inp) (Output outp)" in seq')
  apply(case_tac tape)
  apply(auto intro: eval_bf.intros)[2]
  apply(rule_tac s'="Normal (Tape (left tape) (cur tape - 1) (right tape)) (Input inp) (Output outp)" in seq')
  apply(case_tac tape)
  apply(auto intro: eval_bf.intros)[2]
  apply(case_tac "tape_shift_left' tape")
  apply(auto intro: eval_bf.intros)[1]
  apply(simp)
  apply(rename_tac "shifted_tape")
  apply(rule_tac s'="Normal shifted_tape (Input inp) (Output outp)" in seq')
  apply(auto intro: eval_bf.intros eval_bf_tape_shift_left')[2]
  apply(rule_tac s'="Normal (tape_shift_right tape) (Input inp) (Output outp)" in seq')
  apply(auto simp add: eval_bf_tape_shift_right intro: eval_bf.intros)[2]

  apply(case_tac inp)
  apply(rule_tac s'="Normal (Tape (left tape) EOF (right tape)) (Input inp) (Output outp)" in seq')
  apply(case_tac tape)
  apply(auto intro: eval_bf_intro_In_EOF)[2]
  apply(rename_tac i inplist)
  apply(rule_tac s'="Normal (Tape (left tape) i (right tape)) (Input inplist) (Output outp)" in seq')
  apply(case_tac tape)
  apply(auto intro: eval_bf.intros)[2]

  apply(rule_tac s'="Normal tape (Input inp) (Output (cur tape # outp))" in seq')
  apply(case_tac tape)
  apply(auto intro: eval_bf.intros)[2]

  apply(case_tac "cur tpe = 0")
  apply(simp_all)
  apply(thin_tac "(\<And>lt' c' rt' inp' outp'.
           False \<Longrightarrow>
           _ lt' c' rt' inp' outp'\<Longrightarrow>
           _ lt' c' rt' inp' outp')")
    apply(simp split: either.split_asm)
    apply(rename_tac skipfwdres, case_tac skipfwdres, simp)
    apply(frule skip_loop_forward_Result_Pool)
    apply(frule skip_loop_forward_Reuslt_cs)
    apply(simp)
    apply(case_tac b)
     apply(frule skip_loop_forward_Reuslt)
     apply(simp; fail)
    apply(simp)
    thm seq_while_split[simplified]
    apply(rule seq_while_split[simplified])
  oops

lemma bounded_machine_eval_bf_empty:
      "(\<exists>limit. bounded_machine limit [] rs (tpe, Buffer inp read_byte outp) = Result (tpe', Buffer inp' read_byte outp'))
       \<longleftrightarrow>
       eval_bf [] (Normal tpe (Input inp) (Output outp))  (Normal tpe' (Input inp') (Output outp'))"
apply(rule iffI)
 apply(elim exE, rename_tac limit)
 apply(case_tac limit)
  apply(simp; fail)
 apply(simp)
 apply(auto intro: eval_bf.intros)[1]
apply(erule b_bf_init)
apply(simp)
apply(rule_tac x=1 in exI)
apply(simp; fail)
done

definition "initstatecomply cs tpe_init tpe_init' inp_init inp_init' outp_init outp_init' \<equiv>
  (\<exists>limit. bounded_machine limit cs [] (tpe_init, Buffer inp_init read_byte outp_init) = Result (tpe_init', Buffer inp_init' read_byte outp_init'))
   \<and> (*formerly was: \<longleftrightarrow>*)
   eval_bf cs (Normal tpe_init (Input inp_init) (Output outp_init))  (Normal tpe_init' (Input inp_init') (Output outp_init'))"

(*initstatecomply can be used in the induction to generalize and strengthen the IH*)
lemma "initstatecomply [] tpe_init tpe_init inp_init inp_init outp_init outp_init"
apply(simp add: initstatecomply_def)
apply(rule conjI)
 apply(rule_tac x=1 in exI)
 apply(simp; fail)
apply(auto intro: eval_bf.intros)[1]
done

lemma "bounded_machine n cs rs (tpe_init', Buffer inp_init' read_byte outp_init') = Result (tpe', Buffer inp' read_byte outp') \<Longrightarrow>
(\<exists>limit. bounded_machine limit (rev rs) [] (tpe_init, Buffer inp_init read_byte outp_init) =
            Result (tape, Buffer inp_init' read_byte outp_init'))"
oops

lemma bounded_machine_moreSteps:
      "bounded_machine n cs rs m = Result m' \<Longrightarrow>
          bounded_machine (n + n') cs rs m = Result m'"
apply(induction n cs rs m
        arbitrary: m'
        rule: bounded_machine.induct)
apply(simp_all split: either.split_asm if_split_asm)
apply auto
done

lemma bounded_machine_moreSteps_helper:
      "bounded_machine n cs rs m = Result m' \<Longrightarrow>
          bounded_machine (Suc (x + n)) cs rs m = Result m'"
apply(induction n cs rs m
        arbitrary: m'
        rule: bounded_machine.induct)
apply(simp_all split: either.split_asm if_split_asm)
apply auto
done

lemma bounded_machine_SucD:
      "bounded_machine n cs rs m = Result m' \<Longrightarrow>
          bounded_machine (Suc n) cs rs m = Result m'"
apply(induction n cs rs m
        arbitrary: m'
        rule: bounded_machine.induct)
apply(simp_all split: either.split_asm if_split_asm)
apply auto
done

lemma "bounded_machine n1 cs rs (tpe, Buffer inp read_byte outp) = Result (tpe', Buffer inp' read_byte outp') \<Longrightarrow>
   bounded_machine n2 (rev rs) [] (tpe_init, Buffer inp_init read_byte outp_init) = Result (tpe, Buffer inp read_byte outp) \<Longrightarrow>
  bounded_machine (n1+n2) (rev rs @ cs) [] (tpe_init, Buffer inp_init read_byte outp_init) = Result (tpe', Buffer inp' read_byte outp')"
apply(induction n1 cs rs "(tpe, Buffer inp read_byte outp)"
        arbitrary: tpe tpe' inp inp' outp outp' tpe_init inp_init outp_init n2
        rule: bounded_machine.induct)
apply(simp_all)
apply(rule bounded_machine_moreSteps_helper)
apply(simp; fail)
oops

lemma initstatecomply_revrsE: "initstatecomply (rev rs) tpe_init tpe_init' inp_init inp_init' outp_init outp_init'
   \<Longrightarrow>
   bounded_machine n cs rs (tpe_init', Buffer inp_init' read_byte outp_init') = Result (tpe', Buffer inp' read_byte outp') \<Longrightarrow>
   eval_bf cs (Normal tpe_init' (Input inp_init') (Output outp_init')) (Normal tpe' (Input inp') (Output outp'))
   \<Longrightarrow>
   eval_bf (rev rs @ cs) (Normal tpe_init (Input inp_init) (Output outp_init)) (Normal tpe' (Input inp') (Output outp'))"
apply(rule_tac s'="Normal tpe_init' (Input inp_init') (Output outp_init')" in seq)
 apply(simp_all)
apply(simp add: initstatecomply_def)
(*
apply(subgoal_tac "\<exists>limit. bounded_machine limit (rev rs) [] (tpe_init, Buffer inp_init read_byte outp_init) =
             Result (tpe_init', Buffer inp_init' read_byte outp_init')")
 apply blast
apply(simp add: initstatecomply_def[symmetric])
(*good until here*)
apply(thin_tac "initstatecomply _ _ _ _ _ _ _ ")
apply(induction n cs rs "(tpe_init', Buffer inp_init' read_byte outp_init')" rule: bounded_machine.induct)
apply(simp_all)
apply(auto dest: eval_bf_emptyD)[1]
apply(rule_tac x=1 in exI)
apply(simp)
oops*)
done

lemma "initstatecomply (rev rs) tpe_init tpe_init' inp_init inp_init' outp_init outp_init'
  \<Longrightarrow>
  bounded_machine limit prog rs (tpe_init', Buffer inp_init' read_byte outp_init') = Result (tpe', Buffer inp' read_byte outp')
    \<Longrightarrow>
    eval_bf (rev rs @ prog) (Normal tpe_init (Input inp_init) (Output outp_init))  (Normal tpe' (Input inp') (Output outp'))"
  apply(induction limit prog rs "(tpe_init', Buffer inp_init' read_byte outp_init')"
          arbitrary: tpe_init tpe_init' tpe' inp_init' inp' outp' outp_init'
          rule: bounded_machine.induct)
  apply(simp; fail)
  apply(simp)
  apply(erule initstatecomply_revrsE[where cs="[]" and n="1", simplified])
  apply(auto intro: eval_bf.intros)[2]

  apply(simp)

  apply(rule_tac n="(Suc n)" in initstatecomply_revrsE, simp, simp)
  apply(rule_tac s'="Normal (Tape (left tape) (cur tape + 1) (right tape)) (Input inp_init') (Output outp_init')" in seq')
  apply(case_tac tape)
  apply(auto intro: eval_bf.intros)[2]
  oops

lemma "bounded_machine limit prog rs (tpe, buf) = Result result
        \<Longrightarrow>
        interp_bf (prog, []) (tpe, buf) = result"
  apply(induction limit prog rs "(tpe, buf)" arbitrary:result tpe buf rule: bounded_machine.induct)
  apply(simp_all)
  apply(simp_all add: interp_bf.simps)[5]
  apply(simp add: interp_bf.simps)
  oops

lemma interp_bf_fst_emptystack: "interp_bf (i#is, []) m =
  (case i of Loop \<Rightarrow> if cur (fst m) = 0 then interp_bf (skip_loop is 1, []) m else interp_bf (is, [Loop # is]) m |
             Pool \<Rightarrow> m |
             _ \<Rightarrow> interp_bf (is, []) (next_machine i m))"
  by(simp add: interp_bf.simps split: instr.split)

lemma "interp_bf (code @ code', []) m = interp_bf (code', []) (interp_bf (code, []) m)"
  apply(induction code arbitrary: code' m)
   apply(simp add: interp_bf.simps; fail)
  apply(simp add: interp_bf_fst_emptystack)
  apply(safe)
  apply(simp split: instr.split)
  apply(safe)
  apply (simp_all add: case_prod_beta)
  (*damn you skip_loop*)
  oops

lemma "eval_bf prog (Normal (Tape [] 0 []) (Input inp) (Output []))  (Normal (Tape lt' c' rt') (Input inp') (Output outp')) \<Longrightarrow>
         interp_bf (prog, []) (Tape [] 0 [], Buffer inp read_byte []) = (Tape lt' c' rt', Buffer inp' read_byte outp')"
  apply(induction prog "(Normal (Tape [] 0 []) (Input inp) (Output []))"  "(Normal (Tape lt' c' rt') (Input inp') (Output outp'))" rule: eval_bf.induct)
  apply(simp_all add: interp_bf.simps del: next_machine.simps)[7]
  apply (simp_all add: case_prod_beta)[4]
  apply(simp add: EOF_def, fastforce)
  apply(case_tac "(read_byte inp)")
  apply fastforce
  prefer 2
  apply(simp add: interp_bf.simps; fail)
  oops

lemma "eval_bf prog (Normal (Tape [] 0 []) (Input inp) (Output outp))  (Normal (Tape lt' c' rt') (Input inp') (Output outp')) \<Longrightarrow>
          (run_bf prog inp) @ outp = outp'"
  apply(induction prog "(Normal (Tape [] 0 []) (Input inp) (Output outp))"  "(Normal (Tape lt' c' rt') (Input inp') (Output outp'))" rule: eval_bf.induct)
  apply(simp_all add: interp_bf.simps run_bf_def empty_tape_def init_table_def)
  apply (simp_all add: case_prod_beta)

  (*apply(case_tac code)
  apply(simp_all)
  apply(case_tac code')
  apply(simp_all)
  apply(auto dest: eval_bf_emptyD)[1]
  apply(frule eval_bf_emptyD)
  apply(simp)
  apply(auto)[1]

  apply(case_tac a)
  apply(simp_all)
  apply(simp_all split: instr.split_asm)

  apply(erule b_bf_init)
  apply(simp_all)
  apply(auto intro: eval_bf.intros simp add: interp_bf.simps run_bf_def empty_tape_def init_table_def init_io_def)*)

end


(*  Title:      statecharts/HA/HASem.thy

    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

header {* Semantics of Hierarchical Automata *}
theory HASem
imports HA
begin

subsection {* Definitions *}

definition
  RootExSem :: "[(('s,'e,'d)seqauto) set, 's ~=> ('s,'e,'d)seqauto set,
                 's set] => bool" where
  "RootExSem F G C == (\<exists>! S. S \<in> States (Root F G) \<and> S \<in> C)"

definition
  UniqueSucStates ::  "[(('s,'e,'d)seqauto) set, 's ~=> ('s,'e,'d)seqauto set,
                        's set] \<Rightarrow> bool" where
  "UniqueSucStates F G C  == \<forall> S \<in> (UNION F States).
                                   \<forall> A \<in> the (G S).
                                      if (S \<in> C) then
                                       \<exists>! S' . S' \<in>  States A \<and> S' \<in> C
                                     else
                                       \<forall> S \<in> States A. S \<notin> C"

definition
  IsConfSet :: "[(('s,'e,'d)seqauto) set, 's ~=> ('s,'e,'d)seqauto set,
                 's set] => bool" where
  "IsConfSet F G C ==
                C \<subseteq> (UNION F States) &
                RootExSem F G C &
                UniqueSucStates F G C"

definition
  Status :: "[('s,'e,'d)hierauto,
              's set,
              'e set,
              'd data] => bool" where
  "Status HA C E D == E \<subseteq> HAEvents HA \<and>
                      IsConfSet (SAs HA) (CompFun HA) C \<and>
                      Data.DataSpace (HAInitValue HA) = Data.DataSpace D"

subsubsection {* @{text "Status"} *}

lemma Status_EmptySet:
 "(Abs_hierauto ((@ x . True),
    {Abs_seqauto ({ @ x . True}, (@ x . True), {}, {})}, {}, empty(@ x . True \<mapsto> {})),
  {@x. True},{}, @x. True) \<in>
  {(HA,C,E,D) | HA C E D. Status HA C E D}"
apply (unfold Status_def CompFun_def SAs_def)
apply auto
apply (subst Abs_hierauto_inverse)
apply (subst hierauto_def)
apply (rule HierAuto_EmptySet)
apply (subst Abs_hierauto_inverse)
apply (subst hierauto_def)
apply (rule HierAuto_EmptySet)
apply auto
apply (unfold IsConfSet_def UniqueSucStates_def RootExSem_def)
apply auto
apply (unfold States_def)
apply auto
apply (unfold Root_def)
apply (rule someI2)
apply (rule conjI)
apply fast
apply (simp add: ran_def)
apply simp
apply (subst Abs_seqauto_inverse)
apply (subst seqauto_def)
apply (rule SeqAuto_EmptySet)
apply simp
apply (unfold HAInitValue_def)
apply auto
apply (subst Abs_hierauto_inverse)
apply (subst hierauto_def)
apply (rule HierAuto_EmptySet)
apply simp
done

definition
  "status =
    {(HA,C,E,D) |
        (HA::('s,'e,'d)hierauto)
        (C::('s set))
        (E::('e set))
        (D::'d data). Status HA C E D}"

typedef ('s,'e,'d) status =
    "status :: (('s,'e,'d)hierauto * 's set * 'e set * 'd data) set"
  unfolding status_def
  apply (rule exI)
  apply (rule Status_EmptySet)
  done

definition
  HA :: "('s,'e,'d) status  => ('s,'e,'d) hierauto" where
  "HA == fst o Rep_status"

definition
  Conf :: "('s,'e,'d) status  => 's set" where
  "Conf == fst o snd o Rep_status"

definition
  Events :: "('s,'e,'d) status  => 'e set" where
  "Events == fst o snd o snd o Rep_status"

definition
  Value :: "('s,'e,'d) status  => 'd data" where
  "Value == snd o snd o snd o Rep_status"

definition
  RootState :: "('s,'e,'d) status  => 's" where
  "RootState ST == @ S. S \<in> Conf ST \<and> S \<in> States (HARoot (HA ST))"

(* -------------------------------------------------------------- *)
(* enabled transitions                                            *)
(* -------------------------------------------------------------- *)

definition
  EnabledTrans :: "(('s,'e,'d)status * ('s,'e,'d)seqauto *
                    ('s,'e,'d)trans) set" where
  "EnabledTrans == {(ST,SA,T) .
                       SA \<in> SAs (HA ST) \<and>
                       T \<in> Delta SA \<and>
                       source T \<in> Conf ST \<and>
                       (Conf ST, Events ST, Value ST) |= (label T) }"

definition
  ET :: "('s,'e,'d) status => (('s,'e,'d) trans) set" where
  "ET ST == \<Union> SA \<in> SAs (HA ST). (EnabledTrans `` {ST}) `` {SA}"

(* -------------------------------------------------------------- *)
(* maximal non conflicting set of transitions                     *)
(* -------------------------------------------------------------- *)

definition
  MaxNonConflict :: "[('s,'e,'d)status,
                      ('s,'e,'d)trans set] => bool" where
  "MaxNonConflict ST T ==
        (T \<subseteq> ET ST) \<and>
        (\<forall> A \<in> SAs (HA ST). card (T Int Delta A) \<le> 1)  \<and>
        (\<forall> t \<in> (ET ST). (t \<in> T) =  (\<not> (\<exists> t' \<in> ET ST. HigherPriority (HA ST) (t',t))))"

(* -------------------------------------------------------------- *)
(* resolving the occurence of racing with interleaving semantic   *)
(* for one set of transitions                                     *)
(* -------------------------------------------------------------- *)

definition
 ResolveRacing :: "('s,'e,'d)trans set
                   => ('d update set)" where
 "ResolveRacing TS ==
            let
                U = PUpdate (Label TS)
            in
                SequentialRacing U"

(* -------------------------------------------------------------- *)
(* HPT is a set, there can be more than one! If there are         *)
(* nondeterministic transitions t1, t2 in one SA : SAs A, then    *)
(* they are not in conflict wt higher priority. We have to chose  *)
(* one and get different sets.                                    *)
(* -------------------------------------------------------------- *)

definition
 HPT :: "('s,'e,'d)status => (('s,'e,'d)trans set) set" where
 "HPT ST == { T. MaxNonConflict ST T}"

(* -------------------------------------------------------------- *)
(* The initials status can be defined now for a given automaton.  *)
(* -------------------------------------------------------------- *)

definition
 InitStatus :: "('s,'e,'d)hierauto => ('s,'e,'d)status" where
 "InitStatus A ==
    Abs_status (A,InitConf A,{}, HAInitValue A)"

(* -------------------------------------------------------------- *)
(* The next status for a given status can be defined now by a     *)
(* step.                                                          *)
(* -------------------------------------------------------------- *)

definition
  StepActEvent :: "('s,'e,'d)trans set => 'e set" where
  "StepActEvent TS == Union (Actevent (Label TS))"

definition
  StepStatus :: "[('s,'e,'d)status, ('s,'e,'d)trans set, 'd update]
                 => ('s,'e,'d)status" where
  "StepStatus ST TS U =
                (let
                   (A,C,E,D) = Rep_status ST;
                   C'        = StepConf A C TS;
                   E'        = StepActEvent TS;
                   D'        = U !!! D
                 in
                   Abs_status (A,C',E',D'))"

(* --------------------------------------------------------------- *)
(* The Relation StepRel defines semantic transitions on statuses   *)
(* for given hierarchical automaton.                               *)
(* --------------------------------------------------------------- *)

definition
  StepRelSem :: "('s,'e,'d)hierauto
              => (('s,'e,'d)status * ('s,'e,'d)status) set" where
  "StepRelSem A == {(ST,ST'). (HA ST) = A &
                    ((HPT ST ~= {}) -->
                       (EX TS : HPT ST.
                           EX U : ResolveRacing TS.
                                  ST' = StepStatus ST TS U)) &
                    ((HPT ST = {}) -->
                       (ST' = StepStatus ST {} DefaultUpdate))}"

(* --------------------------------------------------------------- *)
(* The Relation StepRel defines semantic transitions on statuses   *)
(* The set of all reachable stati can now be defined inductively   *)
(* as the set of statuses derived through applications of          *)
(* transitions starting from the initial status TInitStatus 0.     *)
(* --------------------------------------------------------------- *)

inductive_set
  ReachStati  :: "('s,'e,'d)hierauto => ('s,'e,'d) status set"
  for A ::  "('s,'e,'d)hierauto"
where
  Status0 : "InitStatus A \<in> ReachStati A"
| StatusStep :
     "\<lbrakk> ST \<in> ReachStati A;  TS \<in> HPT ST; U \<in> ResolveRacing TS \<rbrakk>
      \<Longrightarrow> StepStatus ST TS U \<in> ReachStati A"

subsection {* Lemmas *}

lemma Rep_status_tuple:
 "Rep_status ST = (HA ST, Conf ST, Events ST, Value ST)"
by (unfold HA_def Conf_def Events_def Value_def, simp)

lemma Rep_status_select:
 "(HA ST, Conf ST, Events ST, Value ST) \<in> status"
by (rule Rep_status_tuple [THEN subst], rule Rep_status)

lemma Status_select [simp]:
  "Status (HA ST) (Conf ST) (Events ST) (Value ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def)
apply simp
done

subsubsection {* @{text "IsConfSet"} *}

lemma IsConfSet_Status [simp]:
 "IsConfSet (SAs (HA ST)) (CompFun (HA ST)) (Conf ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply auto
done

subsubsection {* @{text "InitStatus"} *}

lemma IsConfSet_InitConf [simp]:
  "IsConfSet (SAs A) (CompFun A) (InitConf A)"
apply (unfold IsConfSet_def RootExSem_def UniqueSucStates_def, fold HARoot_def)
apply (rule conjI)
apply (fold HAStates_def, simp)
apply (rule conjI)
apply (rule_tac a="HAInitState A" in ex1I)
apply auto
apply (rename_tac S SA)
apply (case_tac "S \<in> InitConf A")
apply auto
apply (rule_tac x="InitState SA" in exI)
apply auto
apply (rule InitState_CompFun_InitConf)
apply auto
apply (rename_tac S SA T U)
apply (case_tac "U = InitState SA")
apply auto
apply (simp only:InitConf_CompFun_Ancestor HAStates_SA_mem, simp)+
done

lemma InitConf_status [simp]:
  "(A, InitConf A, {}, HAInitValue A) \<in>  status"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply auto
done

lemma Conf_InitStatus_InitConf [simp]:
 "Conf (InitStatus A) = InitConf A"
apply (unfold Conf_def InitStatus_def)
apply simp
apply (subst Abs_status_inverse)
apply auto
done

lemma HAInitValue_Value_DataSpace_Status [simp]:
  "Data.DataSpace (HAInitValue (HA ST)) = Data.DataSpace (Value ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply fast
done

lemma Value_InitStatus_HAInitValue [simp]:
 "Value (InitStatus A) = HAInitValue A"
apply (unfold Value_def InitStatus_def)
apply simp
apply (subst Abs_status_inverse)
apply auto
done

lemma HA_InitStatus [simp]:
 "HA (InitStatus A) = A"
apply (unfold InitStatus_def HA_def)
apply auto
apply (subst Abs_status_inverse)
apply auto
done

subsubsection {* @{text "Events"} *}

lemma Events_HAEvents_Status:
  "(Events ST) \<subseteq> HAEvents (HA ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply fast
done

lemma TS_EventSet:
    "TS \<subseteq>  ET ST \<Longrightarrow> \<Union> (Actevent (Label TS)) \<subseteq> HAEvents (HA ST)"
apply (unfold Actevent_def actevent_def ET_def EnabledTrans_def Action_def Label_def)
apply (cut_tac HA="HA ST" in HAEvents_SAEvents_SAs)
apply auto
apply (rename_tac Event Source Trigger Guard Action Update Target)
apply (unfold SAEvents_def)
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (erule subsetCE)
apply auto
apply (erule_tac x=SA in ballE)
apply auto
apply (erule_tac x="(Trigger, Guard, Action, Update)" in ballE)
apply auto
apply (cut_tac SA=SA in Label_Delta_subset)
apply (erule subsetCE)
apply (unfold Label_def image_def)
apply auto
done

subsubsection {* @{text "StepStatus"} *}

lemma StepStatus_empty:
   "Abs_status (HA ST, Conf ST, {}, U !!! (Value ST)) = StepStatus ST {} U";
apply (unfold StepStatus_def Let_def)
apply auto
apply (subst Rep_status_tuple)
apply auto
apply (unfold StepActEvent_def)
apply auto
done

lemma status_empty_eventset [simp]:
      "(HA ST, Conf ST, {}, U !!! (Value ST)) \<in> status";
apply (unfold status_def Status_def)
apply auto
done

lemma HA_StepStatus_emptyTS [simp]:
  "HA (StepStatus ST {} U) = HA ST";
apply (subst StepStatus_empty [THEN sym])
apply (unfold HA_def)
apply auto
apply (subst Abs_status_inverse)
apply auto
apply (subst Rep_status_tuple)
apply auto
done

subsubsection {* Enabled Transitions @{text "ET"} *}

lemma HPT_ETI:
    "TS \<in> HPT ST \<Longrightarrow> TS \<subseteq> ET ST"
by (unfold HPT_def MaxNonConflict_def, auto)

lemma finite_ET [simp]:
 "finite (ET ST)"
by (unfold ET_def Image_def EnabledTrans_def, auto)

subsubsection {* Finite Transition Set *}

lemma finite_MaxNonConflict [simp]:
 "MaxNonConflict ST TS \<Longrightarrow> finite TS"
apply (unfold MaxNonConflict_def)
apply auto
apply (subst finite_subset)
apply auto
done

lemma finite_HPT [simp]:
  "TS \<in> HPT ST \<Longrightarrow> finite TS";
by (unfold HPT_def, auto)

subsubsection {* @{text "PUpdate"} *}

lemma finite_Update:
 "finite TS \<Longrightarrow> finite ((\<lambda> F. (Rep_pupdate F) (Value ST)) ` (PUpdate (Label TS)))"
by (rule finite_imageI, auto)

lemma finite_PUpdate:
 "TS \<in> HPT S \<Longrightarrow> finite (Expr.PUpdate (Label TS))"
apply auto
done

lemma HPT_ResolveRacing_Some [simp]:
  "TS \<in> HPT S \<Longrightarrow> (SOME u. u \<in> ResolveRacing TS) \<in> ResolveRacing TS"
apply (unfold ResolveRacing_def Let_def)
apply (rule finite_SequentialRacing)
apply auto
done

subsubsection {* Higher Priority Transitions @{text "HPT"} *}

lemma finite_HPT2 [simp]:
  "finite (HPT ST)"
apply (cut_tac ST=ST in finite_ET)
apply (unfold HPT_def MaxNonConflict_def)
apply (subst Collect_subset)
apply (frule finite_Collect_subsets)
apply auto
done

lemma HPT_target_StepConf [simp]:
  "\<lbrakk> TS \<in> HPT ST; T \<in> TS \<rbrakk> \<Longrightarrow> target T \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
done

lemma HPT_target_StepConf2 [simp]:
  "\<lbrakk> TS \<in> HPT ST; (S,L,T) \<in> TS \<rbrakk> \<Longrightarrow> T \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def Target_def Source_def source_def target_def image_def)
apply auto
apply auto
done

subsubsection {* Delta Transition Set *}

lemma ET_Delta:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (unfold ET_def EnabledTrans_def)
apply simp
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (case_tac "A = SA")
apply auto
apply (cut_tac HA="HA ST" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply force
done

lemma ET_Delta_target:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (unfold ET_def EnabledTrans_def)
apply simp
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (case_tac "A = SA")
apply auto
apply (cut_tac HA="HA ST" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply force
done

lemma ET_HADelta:
   " \<lbrakk> TS \<subseteq> ET ST; t \<in> TS \<rbrakk> \<Longrightarrow> t \<in> HADelta (HA ST)"
apply (unfold HADelta_def)
apply auto
apply (unfold ET_def EnabledTrans_def Image_def)
apply auto
done

lemma HPT_HADelta:
   " \<lbrakk> TS \<in> HPT ST; t \<in> TS \<rbrakk> \<Longrightarrow> t \<in> HADelta (HA ST)"
apply (rule ET_HADelta)
apply (unfold HPT_def MaxNonConflict_def)
apply auto
done

lemma HPT_Delta:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (rule ET_Delta)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma HPT_Delta_target:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (rule ET_Delta_target)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma OneTrans_HPT_SA:
  "\<lbrakk> TS \<in> HPT ST; T \<in> TS; source T \<in> States SA;
     U \<in> TS; source U \<in> States SA; SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> T = U"
apply (unfold HPT_def MaxNonConflict_def Source_def)
apply auto
apply (erule_tac x=SA in ballE)
apply (case_tac "finite (TS \<inter> Delta SA)")
apply (frule_tac t=T in OneElement_Card)
apply fast
apply (frule_tac t=T and A=SA in ET_Delta)
apply assumption+
apply fast
apply (frule_tac t=U in OneElement_Card)
apply fast
apply (frule_tac t=U and A=SA in ET_Delta)
apply auto
done

lemma OneTrans_HPT_SA2:
  "\<lbrakk> TS \<in> HPT ST; T \<in> TS; target T \<in> States SA;
     U \<in> TS; target U \<in> States SA; SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> T = U"
apply (unfold HPT_def MaxNonConflict_def Target_def)
apply auto
apply (erule_tac x=SA in ballE)
apply (case_tac "finite (TS \<inter> Delta SA)")
apply (frule_tac t=T in OneElement_Card)
apply fast
apply (frule_tac t=T and A=SA in ET_Delta_target)
apply assumption+
apply fast
apply (frule_tac t=U in OneElement_Card)
apply fast
apply (frule_tac t=U and A=SA in ET_Delta_target)
apply auto
done

subsubsection {* Target Transition Set *}

lemma ET_Target_HAStates:
    "TS \<subseteq> ET ST \<Longrightarrow> Target TS \<subseteq> HAStates (HA ST)"
apply (unfold HAStates_def Target_def target_def ET_def EnabledTrans_def Action_def Label_def)
apply (cut_tac HA="HA ST" in Target_SAs_Delta_States)
apply auto
apply (rename_tac Source Trigger Guard Action Update Target)
apply (unfold Target_def)
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (erule subsetCE)
apply auto
apply (unfold image_def)
apply auto
apply (erule_tac x=SA in ballE)
apply auto
done

lemma HPT_Target_HAStates:
 "TS \<in> HPT ST \<Longrightarrow> Target TS \<subseteq> HAStates (HA ST)"
apply (rule HPT_ETI [THEN ET_Target_HAStates])
apply assumption
done

lemma HPT_Target_HAStates2 [simp]:
  "\<lbrakk>TS \<in> HPT ST; S \<in> Target TS\<rbrakk> \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (cut_tac HPT_Target_HAStates)
apply fast+
done

lemma OneState_HPT_Target:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Target TS;
     T \<in> Target TS; S \<in> States SA;
     T \<in> States SA; SA \<in> SAs (HA ST) \<rbrakk>
   \<Longrightarrow> S = T"
apply (unfold Target_def)
apply (auto dest: OneTrans_HPT_SA2[rotated -1])
done

subsubsection {* Source Transition Set *}

lemma ET_Source_Conf:
  "TS \<subseteq> ET ST \<Longrightarrow> (Source TS) \<subseteq> Conf ST"
apply (unfold Source_def ET_def EnabledTrans_def)
apply auto
done

lemma HPT_Source_Conf [simp]:
  "TS \<in> HPT ST \<Longrightarrow> (Source TS) \<subseteq> Conf ST"
apply (unfold HPT_def MaxNonConflict_def)
apply (rule ET_Source_Conf)
apply auto
done

lemma ET_Source_Target [simp]:
  "\<lbrakk> SA \<in> SAs (HA ST); TS \<subseteq> ET ST; States SA \<inter> Source TS = {} \<rbrakk> \<Longrightarrow> States SA \<inter> Target TS = {}"
apply (unfold ET_def EnabledTrans_def Source_def Target_def)
apply auto
apply (rename_tac Source Trigger Guard Action Update Target)
apply (erule subsetCE)
apply auto
apply (rename_tac SAA)
apply (unfold image_def source_def Int_def)
apply auto
apply (erule_tac x=Source in allE)
apply auto
apply (frule Delta_source_States)
apply (unfold source_def)
apply auto
apply (case_tac "SA=SAA")
apply auto
apply (cut_tac HA="HA ST" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SA in ballE)
apply (erule_tac x=SAA in ballE)
apply auto
apply (frule Delta_target_States)
apply (unfold target_def)
apply force
done

lemma HPT_Source_Target [simp]:
  "\<lbrakk> TS \<in> HPT ST; States SA \<inter> Source TS = {}; SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> States SA \<inter> Target TS = {}"
apply (unfold HPT_def MaxNonConflict_def)
apply auto
done

lemma ET_target_source:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> source t \<in> States A"
apply (frule ET_Delta_target)
apply auto
done

lemma ET_source_target:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> target t \<in> States A"
apply (frule ET_Delta)
apply auto
done

lemma HPT_target_source:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> source t \<in> States A"
apply (rule ET_target_source)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma HPT_source_target:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> target t \<in> States A"
apply (rule ET_source_target)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma HPT_source_target2 [simp]:
  "\<lbrakk> TS \<in>HPT ST; (s,l,t) \<in> TS; s \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow>  t \<in>States A"
apply (cut_tac ST=ST and TS=TS and t="(s,l,t)" in HPT_source_target)
apply auto
done

lemma ChiRel_ChiStar_Source_notmem:
   "\<lbrakk> TS \<in> HPT ST; (S, T) \<in> ChiRel (HA ST); S \<in> Conf ST;
      T \<notin> ChiStar (HA ST) `` Source TS \<rbrakk> \<Longrightarrow>
      S \<notin> ChiStar (HA ST) `` Source TS"
apply auto
apply (rename_tac U)
apply (simp only: Image_def)
apply auto
apply (erule_tac x=U in ballE)
apply (fast intro: ChiRel_ChiStar_trans)+
done

lemma ChiRel_ChiStar_notmem:
  "\<lbrakk> TS \<in> HPT ST; (S,T) \<in> ChiRel (HA ST);
     S \<in> ChiStar (HA ST) `` Source TS \<rbrakk> \<Longrightarrow> T \<notin> Source TS"
using [[hypsubst_thin = true]]
apply (unfold HPT_def MaxNonConflict_def HigherPriority_def restrict_def)
apply auto
apply (rename_tac U)
apply (unfold Source_def image_def)
apply auto
apply (rename_tac SSource STrigger SGuard SAction SUpdate STarget
                  TSource TTrigger TGuard TAction TUpdate TTarget)
apply (erule_tac x="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" in ballE)
apply auto
apply (erule_tac x="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" in ballE)
apply auto
apply (simp add: ET_HADelta)
apply (case_tac "SSource=S")
apply auto
apply (frule ChiStar_ChiPlus_noteq)
apply fast
apply (fast intro: ChiRel_ChiPlus_trans)
done

subsubsection {* @{text "StepActEvents"} *}

lemma StepActEvent_empty [simp]:
  "StepActEvent {} = {}";
by (unfold StepActEvent_def, auto)

lemma StepActEvent_HAEvents:
 "TS \<in> HPT ST \<Longrightarrow> StepActEvent TS \<subseteq> HAEvents (HA ST)"
apply (unfold StepActEvent_def image_def)
apply (rule HPT_ETI [THEN TS_EventSet])
apply assumption
done

subsubsection {* @{text "UniqueSucStates"} *}

lemma UniqueSucStates_Status [simp]:
  "UniqueSucStates (SAs (HA ST)) (CompFun (HA ST)) (Conf ST)";
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def IsConfSet_def)
apply auto
done

subsubsection {* @{text "RootState"} *}

lemma RootExSem_Status [simp]:
  "RootExSem (SAs (HA ST)) (CompFun (HA ST)) (Conf ST)";
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def IsConfSet_def)
apply auto
done

lemma RootState_HARootState [simp]:
  "(RootState ST) \<in> States (HARoot (HA ST))"
apply (unfold RootState_def)
apply (cut_tac ST=ST in RootExSem_Status)
apply (unfold RootExSem_def HARoot_def HAStates_def)
apply auto
apply (subst some1_equality)
apply auto
done

lemma RootState_Conf [simp]:
  "(RootState ST) \<in> (Conf ST)"
apply (unfold RootState_def)
apply (cut_tac ST=ST in RootExSem_Status)
apply (unfold RootExSem_def HARoot_def HAStates_def)
apply auto
apply (subst some1_equality)
apply auto
done

lemma RootState_notmem_Chi [simp]:
  "S \<in> HAStates (HA ST) \<Longrightarrow> (RootState ST) \<notin> Chi (HA ST) S"
by auto

lemma RootState_notmem_Range_ChiRel [simp]:
  "RootState ST \<notin> Range (ChiRel (HA ST))"
by auto

lemma RootState_Range_ChiPlus [simp]:
  "RootState ST \<notin> Range (ChiPlus (HA ST))"
by auto

lemma RootState_Range_ChiStar [simp]:
  "\<lbrakk> x \<noteq> RootState ST \<rbrakk> \<Longrightarrow> (x,RootState ST) \<notin> (ChiStar (HA ST))"
by auto

lemma RootState_notmem_ChiRel [simp]:
  "(x,RootState ST) \<notin> (ChiRel (HA ST))"
by (unfold ChiRel_def, auto)

lemma RootState_notmem_ChiRel2 [simp]:
  "\<lbrakk> S \<in> States (HARoot (HA ST))  \<rbrakk> \<Longrightarrow> (x,S) \<notin> (ChiRel (HA ST))"
by (unfold ChiRel_def, auto)

lemma RootState_Conf_StepConf [simp]:
  "\<lbrakk> RootState ST \<notin> Source TS \<rbrakk> \<Longrightarrow> RootState ST \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
apply (rename_tac S)
apply (case_tac "S=RootState ST")
apply fast
apply auto
apply (rename_tac S)
apply (case_tac "S=RootState ST")
apply fast
apply auto
done

lemma OneRootState_Conf [simp]:
  "\<lbrakk> S \<in> States (HARoot (HA ST)); S \<in> Conf ST \<rbrakk> \<Longrightarrow> S = RootState ST"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def RootExSem_def)
apply (fold HARoot_def)
apply auto
done

lemma OneRootState_Source:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Source TS; S \<in> States (HARoot (HA ST)) \<rbrakk> \<Longrightarrow> S = RootState ST"
apply (cut_tac ST=ST and TS=TS in HPT_Source_Conf, assumption)
apply (cut_tac ST=ST in OneRootState_Conf)
apply fast+
done

lemma OneState_HPT_Target_Source:
  "\<lbrakk> TS \<in> HPT ST; S \<in> States SA; SA \<in> SAs (HA ST);
     States SA \<inter> Source TS = {} \<rbrakk>
   \<Longrightarrow> S \<notin> Target TS"
apply (unfold Target_def)
apply auto
apply (unfold Source_def Image_def Int_def)
apply auto
apply (frule HPT_target_source)
apply auto
done

lemma RootState_notmem_Target [simp]:
  "\<lbrakk> TS \<in> HPT ST; S \<in> States (HARoot (HA ST)); RootState ST \<notin> Source TS \<rbrakk> \<Longrightarrow> S \<notin> Target TS"
apply auto
apply (frule OneState_HPT_Target_Source)
prefer 4
apply fast+
apply simp
apply (unfold Int_def)
apply auto
apply (frule OneRootState_Source)
apply fast+
done

subsubsection {* Configuration @{text "Conf"} *}

lemma Conf_HAStates:
 "Conf ST \<subseteq> HAStates (HA ST)"
apply (cut_tac Rep_status_select)
apply (unfold IsConfSet_def status_def Status_def HAStates_def)
apply fast
done

lemma Conf_HAStates2 [simp]:
  "S \<in> Conf ST \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (cut_tac ST="ST" in Conf_HAStates)
apply fast
done

lemma OneState_Conf [intro]:
  "\<lbrakk> S \<in> Conf ST; T \<in> Conf ST; S \<in> States SA; T \<in> States SA;
     SA \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> T = S"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def UniqueSucStates_def)
apply (case_tac "SA = HARoot (HA ST)")
apply (cut_tac ST=ST and S=S in OneRootState_Conf)
apply fast+
apply (simp only:OneRootState_Conf)
apply (erule conjE)+
apply (cut_tac HA="HA ST" in OneAncestor_HA)
apply (unfold OneAncestor_def)
apply (fold HARoot_def)
apply (erule_tac x=SA in ballE)
apply (drule ex1_implies_ex)
apply (erule exE)
apply (rename_tac U)
apply (erule_tac x=U in ballE)
apply (erule_tac x=SA in ballE)
apply (case_tac "U \<in> Conf ST")
apply simp
apply safe
apply fast+
apply simp
apply fast
done

lemma OneState_HPT_SA:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Source TS; T \<in> Source TS;
     S \<in> States SA; T \<in> States SA;
     SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> S = T"
apply (rule OneState_Conf)
apply auto
apply (frule HPT_Source_Conf, fast)+
done

lemma HPT_SAStates_Target_Source:
   "\<lbrakk>TS \<in> HPT ST; A \<in> SAs (HA ST); S \<in> States A; T \<in> States A; S \<in> Conf ST;
     T \<in> Target TS \<rbrakk> \<Longrightarrow> S \<in> Source TS"
apply (case_tac "States A \<inter> Source TS ={}")
apply (frule OneState_HPT_Target_Source)
apply fast
back
apply simp+
apply auto
apply (rename_tac U)
apply (cut_tac ST=ST in HPT_Source_Conf)
apply fast
apply (frule_tac S=S and T=U in OneState_Conf)
apply fast+
done

lemma HPT_Conf_Target_Source:
   "\<lbrakk>TS \<in> HPT ST; S \<in> Conf ST;
     S \<in> Target TS \<rbrakk> \<Longrightarrow> S \<in> Source TS"
apply (frule Conf_HAStates2)
apply (unfold HAStates_def)
apply auto
apply (simp only:HPT_SAStates_Target_Source)
done

lemma Conf_SA:
  "S \<in> Conf ST \<Longrightarrow> \<exists> A \<in> SAs (HA ST). S \<in> States A"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def)
apply fast
done

lemma HPT_Source_HAStates [simp]:
   "\<lbrakk> TS \<in> HPT ST; S \<in> Source TS \<rbrakk> \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (frule HPT_Source_Conf)
apply (rule Conf_HAStates2)
apply fast
done

lemma Conf_Ancestor:
  "\<lbrakk> S \<in> Conf ST;  A \<in> the (CompFun (HA ST) S) \<rbrakk> \<Longrightarrow> \<exists>! T \<in> States A. T \<in> Conf ST"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def UniqueSucStates_def)
apply safe
apply (erule_tac x=S in ballE)
prefer 2
apply fast
apply (erule_tac x=A in ballE)
prefer 2
apply fast
apply simp
apply (fast intro:OneState_Conf HAStates_CompFun_SAs_mem Conf_HAStates2)+
done

lemma Conf_ChiRel:
   "\<lbrakk> (S,T) \<in> ChiRel (HA ST); T \<in> Conf ST \<rbrakk> \<Longrightarrow> S \<in> Conf ST"
apply (cut_tac ST=ST in UniqueSucStates_Status)
apply (unfold UniqueSucStates_def)
apply (auto cong del: strong_SUP_cong)
apply (unfold ChiRel_def Chi_def restrict_def)
apply simp
apply safe
apply simp
apply safe
apply (rename_tac SA)
apply (unfold HAStates_def)
apply simp
apply safe
apply (rename_tac U)
apply (erule_tac x=U in ballE)
apply (erule_tac x=S in ballE)
apply (erule_tac x=SA in ballE)
apply auto
apply (case_tac "S \<in> Conf ST")
apply simp+
done

lemma Conf_ChiPlus:
   "\<lbrakk> (T,S) \<in> ChiPlus (HA ST) \<rbrakk> \<Longrightarrow>  S \<in> Conf ST \<longrightarrow> T \<in> Conf ST"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel (HA ST))" in trancl_induct)
apply (fast intro: Conf_ChiRel)+
done

lemma HPT_Conf_Target_Source_ChiPlus:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Conf ST; S \<in> ChiPlus (HA ST) `` Target TS \<rbrakk>
     \<Longrightarrow> S \<in> ChiStar (HA ST) `` Source TS"
apply auto
apply (rename_tac T)
apply (simp add: Image_def)
apply (frule HPT_Target_HAStates2)
apply fast
apply (unfold HAStates_def)
apply auto
apply (rename_tac SA)
apply (case_tac "States SA \<inter> Source TS = {}")
apply (simp only:OneState_HPT_Target_Source)
apply auto
apply (rename_tac U)
apply (erule_tac x=U in ballE)
apply auto
apply (case_tac "U=T")
apply auto
apply (frule Conf_ChiPlus)
apply simp
apply (frule HPT_Conf_Target_Source)
apply fast
back
apply fast
apply (simp add:OneState_HPT_SA)
done

lemma OneState_HPT_Target_ChiRel:
   "\<lbrakk> TS \<in> HPT ST; (U,T) \<in> ChiRel (HA ST);
      U \<in> Target TS; A \<in> SAs (HA ST); T \<in> States A;
      S \<in> States A \<rbrakk> \<Longrightarrow> S \<notin> Target TS"
using [[hypsubst_thin = true]]
apply auto
apply (unfold HigherPriority_def restrict_def HPT_def MaxNonConflict_def Target_def)
apply auto
apply (rename_tac SSource STrigger SGuard SAction SUpdate STarget
                  TSource TTrigger TGuard TAction TUpdate TTarget)
apply (cut_tac t="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" and TS=TS and ST=ST and A=A in ET_target_source)
apply assumption+
apply simp
apply assumption
apply (frule ChiRel_HAStates)
apply (unfold HAStates_def)
apply safe
apply (cut_tac t="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" and A=x and ST=ST and TS=TS in ET_target_source)
apply assumption+
apply simp
apply assumption
apply simp
apply (erule_tac x="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" in ballE)
apply simp
apply (erule_tac x="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" in ballE)
apply (simp add: ET_HADelta)
apply (cut_tac A="HA ST" and S=STarget and T=T and U=TSource in ChiRel_SA_OneAncestor)
apply fast+
apply (frule ET_Source_Conf)
apply (unfold Source_def image_def)
apply (case_tac "SSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
back
apply simp
apply (case_tac "TSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
apply simp
apply (case_tac "STarget=SSource")
apply simp
apply (fast intro:Conf_ChiRel)+
done

lemma OneState_HPT_Target_ChiPlus [rule_format]:
   "\<lbrakk> TS \<in> HPT ST; (U,T) \<in> ChiPlus (HA ST);
      S \<in> Target TS; A \<in> SAs (HA ST);
      S \<in> States A \<rbrakk> \<Longrightarrow> T \<in> States A \<longrightarrow> U \<notin> Target TS"
using [[hypsubst_thin = true]]
apply (unfold ChiPlus_def)
apply (rule_tac a="U" and b="T" and r="(ChiRel (HA ST))" in converse_trancl_induct)
apply auto
apply (simp only:OneState_HPT_Target_ChiRel)
apply (rename_tac V W)
apply (fold ChiPlus_def)
apply (unfold HPT_def MaxNonConflict_def Target_def HigherPriority_def restrict_def)
apply auto
apply (rename_tac SSource STrigger SGuard SAction SUpdate STarget
                  TSource TTrigger TGuard TAction TUpdate TTarget)
apply (cut_tac t="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" and ST=ST and TS=TS and A=A in ET_target_source)
apply assumption+
apply simp
apply assumption
apply simp
apply (frule ChiRel_HAStates)
apply (unfold HAStates_def)
apply safe
apply (cut_tac t="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" and A=x and TS=TS and ST=ST in ET_target_source)
apply assumption+
apply simp
apply assumption
apply simp
apply (erule_tac x="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" in ballE)
apply simp
apply (erule_tac x="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" in ballE)
apply (simp add: ET_HADelta)
apply (cut_tac A="HA ST" and S=TTarget and T=T and U=SSource in ChiPlus_SA_OneAncestor)
apply (fast intro: ChiRel_ChiPlus_trans2)
apply fast+
apply (frule ET_Source_Conf)
apply (unfold Source_def image_def)
apply (case_tac "SSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
apply simp
apply (case_tac "TSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
back
apply simp
apply (case_tac "TTarget=SSource")
apply simp
apply (frule_tac T=TTarget and S=SSource in Conf_ChiPlus)
apply simp
apply (frule_tac T=TSource and S=TTarget in OneState_Conf)
apply fast+
done

subsubsection {* @{text "RootExSem"} *}

lemma RootExSem_StepConf:
   "\<lbrakk> TS \<in> HPT ST \<rbrakk> \<Longrightarrow>
      RootExSem (SAs (HA ST)) (CompFun (HA ST)) (StepConf (HA ST) (Conf ST) TS)"
apply (unfold RootExSem_def)
apply (fold HARoot_def)
apply auto
apply (case_tac "RootState ST \<notin> Source TS")
apply (rule_tac x="RootState ST" in exI)
apply simp
apply simp
apply (unfold Source_def image_def)
apply simp
apply (erule bexE)
apply (rename_tac T)
apply (rule_tac x="target T" in exI)
apply simp
apply (rule HPT_source_target)
apply auto
apply (rename_tac S T)
apply (case_tac "S \<in> Conf ST")
apply (case_tac "T \<in> Conf ST")
apply (frule OneRootState_Conf)
apply auto
apply (frule OneRootState_Conf)
apply auto
apply (frule OneRootState_Conf)
apply auto
apply (case_tac "RootState ST \<in> Source TS")
apply (case_tac "T \<in> Source TS")
apply (frule HPT_Source_Conf)
apply fast
apply (unfold StepConf_def)
apply auto
apply (frule OneState_HPT_Target)
apply (frule_tac SA="HARoot (HA ST)" and TS=TS and S=T and T="RootState ST" in OneState_HPT_Target)
apply fast+
apply simp+
apply (frule trancl_Int_mem, fold ChiPlus_def, force)+
prefer 2
apply (frule OneState_HPT_Target)
apply fast+
back
apply simp+
apply (case_tac "RootState ST \<in> Source TS")
apply (case_tac "T = RootState ST")
apply auto
apply (frule trancl_Int_mem, fold ChiPlus_def, force)+
done

subsubsection {* @{text "StepConf"} *}

lemma Target_StepConf:
   "S \<in> Target TS \<Longrightarrow> S \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
done

lemma Target_ChiRel_HAInit_StepConf:
   "\<lbrakk> S \<in> Target TS; (S,T) \<in> ChiRel A;
      T \<in> HAInitStates A \<rbrakk> \<Longrightarrow> T \<in> StepConf A C TS"
apply (unfold StepConf_def)
apply auto
done

lemma StepConf_HAStates:
 "TS \<in> HPT ST \<Longrightarrow> StepConf (HA ST) (Conf ST) TS \<subseteq> HAStates (HA ST)"
apply (unfold StepConf_def)
apply auto
apply (frule tranclD2)
apply auto
done

lemma RootState_Conf_StepConf2 [simp]:
  "\<lbrakk> source T = RootState ST; T \<in> TS \<rbrakk> \<Longrightarrow> target T \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
done

lemma HPT_StepConf_HAStates [simp]:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS \<rbrakk> \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (unfold StepConf_def)
apply auto
apply (frule tranclD2)
apply auto
done

lemma StepConf_Target_HAInitStates:
  "\<lbrakk> S \<in> StepConf (HA ST) (Conf ST) TS; S \<notin> Target TS; S \<notin> Conf ST\<rbrakk> \<Longrightarrow> S \<in> HAInitStates (HA ST)"
apply (unfold StepConf_def)
apply auto
apply (frule tranclD2)
apply auto
done

lemma InitSucState_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
      S \<notin> Conf ST; S \<in> StepConf (HA ST) (Conf ST) TS \<rbrakk> \<Longrightarrow>
      InitState A \<in> StepConf (HA ST) (Conf ST) TS"
apply (frule StepConf_HAStates [THEN subsetD, THEN CompFun_HAInitStates_HAStates])
apply fast+
apply (subst (asm) StepConf_def)
apply safe
apply (unfold StepConf_def)
apply (fast intro: HAInitStates_InitState_trancl)
apply (frule trancl_Int_mem, fold ChiPlus_def)
apply (fast intro:ChiPlus_HAStates_Right [THEN HAInitStates_InitState_trancl2])
done

lemma InitSucState_Target_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> Target TS; A \<in> the (CompFun (HA ST) S)\<rbrakk> \<Longrightarrow>
      InitState A \<in> StepConf (HA ST) (Conf ST) TS"
apply (frule HPT_Target_HAStates2 [THEN CompFun_HAInitStates_HAStates])
apply fast+
apply (frule HPT_Target_HAStates2 [THEN CompFun_ChiRel])
apply (fast intro:InitState_States)+
apply (unfold StepConf_def)
apply auto
done

lemma InitSucState_Conf_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
     S \<in> Conf ST; S \<in> ChiStar (HA ST) `` (Source TS) \<rbrakk> \<Longrightarrow>
     InitState A \<in> StepConf (HA ST) (Conf ST) TS"
apply (frule Conf_HAStates2 [THEN CompFun_HAInitStates_HAStates])
apply fast
apply (subst (asm) StepConf_def)
apply safe
apply fast
apply (unfold StepConf_def)
apply (fast intro:HAInitStates_InitState_trancl)
apply (rename_tac T U V)
apply (frule trancl_Int_mem, fold ChiPlus_def, safe)
apply (subst (asm) Image_def, safe)
apply (rule_tac x=U in bexI)
apply (simp only: ChiPlus_HAStates_Right [THEN HAInitStates_InitState_trancl2])
apply fast
apply (subst (asm) Image_def, safe)
apply (rule_tac x=U in bexI)
apply (simp only: ChiPlus_HAStates_Right [THEN HAInitStates_InitState_trancl2])
apply fast
done

lemma SucState_Conf_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
     S \<in> Conf ST; States A \<inter> ChiStar (HA ST) `` (Source TS) = {} \<rbrakk> \<Longrightarrow>
     \<exists> x. x \<in> States A \<and> x \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply (cut_tac ST=ST in UniqueSucStates_Status)
apply (unfold UniqueSucStates_def)
apply (cut_tac ST=ST in Conf_HAStates2)
apply fast
apply (fold HAStates_def)
apply (erule_tac x=S in ballE)
apply (erule_tac x=A in ballE)
apply simp
apply fast+
done

lemma SucState_Conf_Source_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
     S \<in> Conf ST; States A \<inter> ChiStar (HA ST) `` (Source TS) \<noteq> {};
     S \<notin> ChiStar (HA ST) `` (Source TS)\<rbrakk> \<Longrightarrow>
     \<exists> x. x \<in> States A \<and> x \<in> StepConf (HA ST) (Conf ST) TS"
apply safe
apply (rename_tac T U)
apply (frule Conf_HAStates2 [THEN CompFun_ChiRel])
apply fast+
apply simp
apply (case_tac "U=T")
apply simp
apply (rotate_tac -5)
apply (simp only:Source_def Target_def image_def)
apply safe
apply (rename_tac Source Trigger Guard Action Update Target)
apply (erule_tac x=Target in allE)
apply simp
apply (frule HPT_source_target2)
apply fast+
apply (rule HAStates_CompFun_SAs_mem)
apply (rule Conf_HAStates2)
apply fast+
apply (frule ChiStar_ChiPlus_noteq)
apply fast
apply (case_tac "U=S")
apply (fast intro:ChiStar_Self ChiRel_ChiPlus_OneAncestor ChiPlus_ChiStar)+
done

lemma SucState_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     A \<in> the (CompFun (HA ST) S) \<rbrakk> \<Longrightarrow>
     \<exists> x. x \<in> States A \<and> x \<in> StepConf (HA ST) (Conf ST) TS"
apply (case_tac "S \<in> Target TS")
apply (fast intro: InitSucState_Target_StepConf InitState_States)
apply (case_tac "S \<in> Conf ST")
prefer 2
apply (fast intro: InitSucState_StepConf InitState_States)
apply (case_tac "S \<in> ChiStar (HA ST) `` (Source TS)")
apply (fast intro: InitSucState_Conf_StepConf InitState_States)
apply (case_tac "States A \<inter> ChiStar (HA ST) `` (Source TS) = {}")
apply (fast intro: SucState_Conf_StepConf SucState_Conf_Source_StepConf)+
done

subsubsection {* @{text "StepStatus"} *}

lemma StepStatus_expand:
   "Abs_status (HA ST, StepConf (HA ST) (Conf ST) TS,
                StepActEvent TS, U !!! (Value ST))
    = (StepStatus ST TS U)"
apply (unfold StepStatus_def Let_def)
apply (subst Rep_status_tuple)
apply auto
done

lemma UniqueSucState_Conf_Source_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U; U \<in> Conf ST \<rbrakk> \<Longrightarrow>
      U \<in> ChiStar (HA ST) `` Source TS"
apply (frule_tac ?S2.0=T in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (frule_tac ?S2.0=U in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (frule_tac S=S and T=U in Conf_ChiRel, fast)
apply (case_tac "S \<in> ChiStar (HA ST) `` Source TS")
apply (fast intro: ChiRel_ChiStar_trans)
apply (case_tac "U \<in> Source TS")
apply force
apply (unfold StepConf_def)
apply simp
apply safe
apply (fast intro: HPT_SAStates_Target_Source)+
apply (rename_tac V)
apply (case_tac "V=S")
apply (frule_tac S=S in HPT_Conf_Target_Source, fast+)
apply (fast intro: ChiStar_Image ChiRel_OneAncestor)+
apply (rename_tac V W)
apply (frule trancl_Int_mem, fold ChiPlus_def, safe)
apply (cut_tac ST=ST and S=S in HPT_Conf_Target_Source_ChiPlus)
apply fast+
apply (simp only:Image_def, safe)
apply (case_tac "(V, T) \<notin> ChiRel (HA ST)")
apply (frule_tac S=V and T=T in ChiPlus_ChiRel_Ex)
apply (fast, safe)
apply (rename_tac X)
apply (case_tac "X=S")
apply (rule_tac x=W in bexI)
prefer 4
apply (case_tac "V=S")
prefer 2
apply simp
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans2 ChiRel_OneAncestor)+
done

lemma UniqueSucState_Target_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U \<rbrakk> \<Longrightarrow>
      U \<notin> Target TS"
apply auto
apply (frule_tac ST=ST in Target_StepConf)
apply (subst (asm) (2) StepConf_def)
apply simp
apply safe
apply (cut_tac TS=TS and ST=ST and S=S and T=U in UniqueSucState_Conf_Source_StepConf)
apply fast+
apply (simp add: OneState_HPT_Target)
apply (simp only:OneState_HPT_Target_ChiRel)
apply (rename_tac V W)
apply (frule_tac U=W and S=V and T=T in ChiRel_ChiPlus_trans2)
apply (frule trancl_Int_mem, fold ChiPlus_def, force)
apply (simp only:OneState_HPT_Target_ChiPlus)
done

lemma UniqueSucState_Target_ChiRel_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U; (V,U) \<in> ChiRel (HA ST);
      U \<in> HAInitStates (HA ST) \<rbrakk>
    \<Longrightarrow> V \<notin> Target TS"
apply auto
apply (frule_tac A="HA ST" and C="Conf ST" in Target_ChiRel_HAInit_StepConf)
apply fast+
apply (subst (asm) (2) StepConf_def, safe)
apply (fast intro:UniqueSucState_Conf_Source_StepConf)
apply (simp only:OneState_HPT_Target_ChiRel)
apply (fast intro:OneHAInitState_SAStates)
apply (frule trancl_Int_mem, fold ChiPlus_def)
apply (fast intro:OneHAInitState_SAStates)
done

lemma UniqueSucState_Target_ChiPlus_StepConf [rule_format]:
  "\<lbrakk> TS \<in> HPT ST; (S,T) \<in> ChiRel (HA ST); (S,U) \<in> ChiRel (HA ST);
     V \<in> Target TS; (V,W) \<in> ChiRel (HA ST); T \<notin> ChiStar (HA ST) `` Source TS;
     (W,U) \<in> (ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST))\<^sup>+;
     T \<in> Conf ST \<rbrakk> \<Longrightarrow> (S,U) \<in> ChiRel (HA ST) \<longrightarrow> T=U"
apply (frule_tac S=S and T=T in Conf_ChiRel)
apply fast
apply (rule_tac a="W" and b="U" and r="ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST)" in trancl_induct)
apply safe
apply (rename_tac X)
apply (case_tac "W=S")
apply simp
prefer 2
apply (simp add: ChiRel_OneAncestor)
prefer 2
apply (rename_tac X Y)
apply (case_tac "X=S")
apply simp
prefer 2
apply (simp add: ChiRel_OneAncestor)
prefer 2
apply (frule_tac a=V in ChiRel_HAStates)
apply (unfold HAStates_def)
apply (simp,safe)
apply (rename_tac Y)
apply (case_tac "States Y \<inter> Source TS = {}")
apply (simp add:OneState_HPT_Target_Source)
apply (subst (asm) Int_def, safe)
apply (rename_tac Z)
apply (frule_tac S=V and T=S in Conf_ChiRel)
apply fast
apply (frule HPT_Conf_Target_Source)
prefer 2
apply fast
apply fast
apply (frule_tac S=Z and T=V in  OneState_HPT_SA)
apply fast+
apply simp
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans ChiPlus_ChiStar)
apply (simp add: Image_def)
apply (frule trancl_Int_mem, fold ChiPlus_def, simp, safe)
back
apply (frule_tac T=W and S=S in Conf_ChiPlus)
apply simp
apply (frule_tac S=V and T=W in Conf_ChiRel)
apply fast
apply (frule_tac a=V in ChiRel_HAStates)
apply (unfold HAStates_def)
apply (simp, safe)
apply (rename_tac Z)
apply (case_tac "States Z \<inter> Source TS = {}")
apply (simp add:OneState_HPT_Target_Source)
apply (subst (asm) Int_def, safe)
apply (frule_tac S=V in HPT_Conf_Target_Source)
apply fast+
apply (rename_tac P)
apply (frule_tac S=P and T=V in  OneState_HPT_SA)
apply fast+
apply (frule_tac U=V and S=W and T=S in ChiRel_ChiPlus_trans2)
apply fast+
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans ChiPlus_ChiStar)
apply (case_tac "T=S")
apply (simp add: ChiRel_OneAncestor)+
done

lemma UniqueSucStates_SAStates_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U \<rbrakk> \<Longrightarrow>
      U \<notin> StepConf (HA ST) (Conf ST) TS"
apply (subst StepConf_def)
apply (simp, safe)
apply (rule UniqueSucState_Conf_Source_StepConf)
apply fast+
apply (frule_tac U=U in UniqueSucState_Target_StepConf)
apply fast+
apply (frule_tac U=U in UniqueSucState_Target_ChiRel_StepConf)
apply fast+
apply (rename_tac V W)
apply (frule trancl_Int_mem, fold ChiPlus_def)
apply (simp, safe)
apply (frule_tac ?S2.0=T in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (frule_tac ?S2.0=U in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (subst (asm) (2) StepConf_def)
apply (simp, safe)
apply (fast intro: UniqueSucState_Target_ChiPlus_StepConf)
apply (frule_tac U=W and T=U and S=T in OneState_HPT_Target_ChiPlus)
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans2 OneHAInitState_SAStates)+
apply (frule trancl_Int_mem, fold ChiPlus_def, simp, safe)
apply (fast intro:OneHAInitState_SAStates)
done

lemma UniqueSucStates_Ancestor_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> HAStates (HA ST); SA \<in> the (CompFun (HA ST) S);
      T \<in> States SA; T \<in> StepConf (HA ST) (Conf ST) TS \<rbrakk>
    \<Longrightarrow> S \<in> StepConf (HA ST) (Conf ST) TS"
apply (rule notnotD, rule notI)
apply (subst (asm) StepConf_def)
apply (simp, safe)
apply (frule  CompFun_ChiRel, fast+)
apply (frule Conf_ChiRel, fast)
apply (frule ChiRel_ChiStar_Source_notmem, fast+)
apply (subst (asm) StepConf_def)
apply force
apply (case_tac "States SA \<inter> Source TS = {}")
apply (simp add:OneState_HPT_Target_Source)
apply (subst (asm) Int_def)
apply (simp, safe)
apply (rename_tac U)
apply (frule_tac ?S2.0=U in CompFun_ChiRel, fast+)
apply (frule Conf_ChiRel)
apply (frule HPT_Source_Conf, fast)
apply (case_tac "S \<in> ChiStar (HA ST) `` Source TS")
apply (subst (asm) StepConf_def)
apply simp
apply (frule ChiRel_ChiStar_notmem)
apply fast+
apply (case_tac "U=S")
apply (subst (asm) StepConf_def)
apply force
apply (subst (asm) StepConf_def)
apply force
apply (rename_tac U)
apply (case_tac "U=S")
apply (subst (asm) StepConf_def)
apply force
apply (frule  CompFun_ChiRel, fast+)
apply (simp add: ChiRel_OneAncestor)
apply (rename_tac U V)
apply (frule trancl_Int_mem, fold ChiPlus_def, simp, safe)
apply (frule tranclD2)
apply safe
apply (rename_tac W)
apply (case_tac "W=S")
apply simp
prefer 2
apply (frule CompFun_ChiRel, fast+)
apply (simp only: ChiRel_OneAncestor)
apply (subst (asm) StepConf_def)
apply safe
apply (simp add: Image_def)
apply (erule_tac x=U in ballE)
apply (case_tac "U=S")
apply fast
apply (simp add: rtrancl_eq_or_trancl)
apply fast
apply (simp add: Image_def)
apply (rename_tac W)
apply (erule_tac x=U in ballE)
apply (simp add: rtrancl_eq_or_trancl)
apply fast+
done

lemma UniqueSucStates_StepConf:
   "\<lbrakk> TS \<in> HPT ST \<rbrakk> \<Longrightarrow>
      UniqueSucStates (SAs (HA ST)) (CompFun (HA ST)) (StepConf (HA ST) (Conf ST) TS)"
apply (unfold UniqueSucStates_def)
apply auto
apply (simp only: SucState_StepConf)
apply (rule notnotD, rule notI)
apply (frule UniqueSucStates_SAStates_StepConf)
apply fast
prefer 2
apply fast
apply (rule HAStates_CompFun_SAs_mem)
prefer 2
apply fast
apply (simp only: HAStates_def, fast)
apply fast+
back
apply (frule UniqueSucStates_Ancestor_StepConf)
prefer 2
apply fast
apply (simp only:HAStates_def, fast)
apply fast+
done

lemma Status_Step:
  "\<lbrakk> TS \<in> HPT ST; U \<in> ResolveRacing TS \<rbrakk> \<Longrightarrow>
    (HA ST, StepConf (HA ST) (Conf ST) TS, StepActEvent TS, U !!! (Value ST)) \<in> status"
apply (unfold status_def Status_def)
apply auto
apply (frule StepActEvent_HAEvents)
apply blast
apply (unfold IsConfSet_def)
apply (rule conjI, frule StepConf_HAStates, unfold HAStates_def,assumption)
apply (rule conjI, rule RootExSem_StepConf, assumption)
apply (rule UniqueSucStates_StepConf, assumption)
done

subsection {* Meta Theorem: Preservation for Statecharts *}

(* We prove, that the well-formedness of a Statecharts is preserved by the semantics
   (theorem "IsConfSet_StepConf") *)

lemma IsConfSet_StepConf:
       "TS \<in> HPT ST \<Longrightarrow> IsConfSet (SAs (HA ST)) (CompFun (HA ST))
                                  (StepConf (HA ST) (Conf ST) TS)"
apply (unfold IsConfSet_def)
apply auto
apply (frule StepConf_HAStates)
apply (unfold HAStates_def, fast)
apply (rule RootExSem_StepConf, assumption)
apply (rule UniqueSucStates_StepConf, assumption)
done

lemma HA_StepStatus_HPT_ResolveRacing [simp]:
  "\<lbrakk> TS \<in> HPT ST; U \<in> ResolveRacing TS \<rbrakk> \<Longrightarrow>
    HA (StepStatus ST TS U) = HA ST"
apply (subst StepStatus_expand [THEN sym])
apply (subst HA_def)
apply auto
apply (subst Abs_status_inverse)
apply auto
apply (rule Status_Step)
apply auto
done

end


theory prop_16
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun last :: "Nat list => Nat" where
  "last (Nil2) = Z"
  | "last (Cons2 y (Nil2)) = y"
  | "last (Cons2 y (Cons2 x2 x3)) = last (Cons2 x2 x3)"
  (*hipster last *)
  theorem x0 :
    "(xs = (Nil2)) ==> ((last (Cons2 x xs)) = x)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Big_Step_7p8
imports Com_7p8
begin

(* concrete syntax (_,_) \<Rightarrow> _ is possible becasue we declared the transition arrow \<Rightarrow> as an
   infix symbol below with precendence 55 *)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where

Skip:       "(SKIP,s) \<Rightarrow> s" |
Assign:     "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq:        "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue:     "\<lbrakk> bval b s;   (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse:    "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:  "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
              \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
RepeatFalse: "\<lbrakk> (c, s) \<Rightarrow> t;   \<not> bval b t  \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
RepeatTrue:  "\<lbrakk> (c, s\<^sub>1) \<Rightarrow> s\<^sub>2;   bval b s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
              \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"

(* `print_theorems` is incredibly useful for seeing what certain
 * declarations bring into scope
 *)
print_theorems

declare big_step.intros [intro]

(* From the textbook:
"This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:"
*)
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct

(* The following command tells Isabelle to generate code for the predicate \<Rightarrow> and thus make the
predicate available in the `values` command, which is similar to `value`, but works on
inductive definitions and computes a set of possible results.  *)

code_pred big_step . (* The period is necessary at the end of this line *)

(* 7.2.3 Rule Inversion *)

(* Inductive definitions like above bring into scope automatically generated .induct and .cases theorems *)

(* Now we prove a bunch of rule inversions. I've decided not to use inductive_cases as in
   the official solutions and instead prove the rule inversions as they were expressed in
   the textbook.

   I must mention my indebtedness to this particular Isabelle mailing list post:
   https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2013-January/msg00118.html

*)

lemma SkipE[elim!]: "(SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
  by (erule big_step.cases, simp+)

lemma AssignE[elim!]:  "(x ::= a,s) \<Rightarrow> t \<Longrightarrow> t = s(x := aval a s)"
  by (erule big_step.cases, simp+)

lemma SeqE[elim!]: "(c1;;c2, s1) \<Rightarrow> s3 \<Longrightarrow> \<exists>s2. (c1,s1) \<Rightarrow> s2 \<and> (c2,s2) \<Rightarrow> s3"
  by (erule big_step.cases, auto)

lemma IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t \<Longrightarrow> bval b s \<and> (c1, s) \<Rightarrow> t \<or> \<not>bval b s \<and> (c2, s) \<Rightarrow> t"
  by (erule big_step.cases, simp+)

lemma WhileE[elim]:
  "(WHILE b DO c, s) \<Rightarrow> t
  \<Longrightarrow>   (bval b s \<and> (\<exists>s'. (c, s) \<Rightarrow> s' \<and> (WHILE b DO c, s') \<Rightarrow> t))
      \<or> \<not>bval b s \<and> t = s"
   by  (erule big_step.cases, auto)

lemma RepeatE[elim]:
  "(REPEAT c UNTIL b, s) \<Rightarrow> t
  \<Longrightarrow> (\<exists>s'. (c, s) \<Rightarrow> s' \<and> bval b s' \<and> (REPEAT c UNTIL b, s') \<Rightarrow> t)
    \<or> (\<not>bval b t \<and> (c, s) \<Rightarrow> t)"
  by (erule big_step.cases, auto)

inductive_cases SkipE2[elim!]: "(SKIP, s) \<Rightarrow> t"
inductive_cases AssignE2[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE2[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE2[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE2[elim]: "(WHILE b DO c, s) \<Rightarrow> t"
inductive_cases RepeatE2[elim]: "(REPEAT c UNTIL b, s) \<Rightarrow> t"

(* Lemma 7.2 *)
lemma seq_assoc_l: "(c1;; c2;; c3, s) \<Rightarrow> s' \<Longrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
  apply clarify
  apply (rule Seq, simp)
  apply (rule Seq, simp+)
  done

lemma seq_assoc_r: "(c1;; (c2;; c3), s) \<Rightarrow> s' \<Longrightarrow> (c1;; c2;; c3, s) \<Rightarrow> s'"
  apply clarify
  apply (rule Seq, rule Seq, simp+)
  done

lemma seq_assoc: "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
  by (auto simp: seq_assoc_l seq_assoc_r)

(* Section 7.2.4 *)

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c, s) \<Rightarrow> t = (c', s) \<Rightarrow> t)"

print_theorems

lemma while_if_equiv: "WHILE b DO c \<sim> IF b THEN (c;; WHILE b DO c) ELSE SKIP"
  by blast

lemma if_equiv: "IF b THEN c ELSE c \<sim> c"
  by blast

lemma repeat_if_equiv: "REPEAT c UNTIL b \<sim> c;; IF b THEN REPEAT c UNTIL b ELSE SKIP"
  using RepeatE2 by blast

(* lemma repeat_while_equiv is just for fun

   11:54 Fri 09 Mar 2018
   I was having big trouble with the induction rule again. I will try to create my own.

   16:22 Fri 09 Mar 2018

   Okay, I got this one in the end but it was difficult. I was trying to prove that

   (c ;; WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t

   which I decided to do by induction. The theorem big_step_induct_while_repeat_equiv gives
   something equivalent to what you get with "proof (induction ...")

   There is something about the necessity for the pattern match "c' = c;;WHILE b DO c" that
   completely screws up the Seq case. You end up with:

   \<And>s\<^sub>1 s\<^sub>2 s\<^sub>3 s\<^sub>2'.     (c, s\<^sub>1) \<Rightarrow> s\<^sub>2
                  \<Longrightarrow> (c = c;; WHILE b DO c \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>2)
                  \<Longrightarrow> (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3
                  \<Longrightarrow> (c, s) \<Rightarrow> s\<^sub>2' \<Longrightarrow> (WHILE b DO c, s\<^sub>2') \<Rightarrow> t
                  \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3

   The sub formula "c = c;; WHILE b DO c" is false (and can be proved so) rendering
   the whole antecedant "(c = c;; WHILE b DO c \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>2)" useless.

   I don't know if there is some small tweak that I could have pulled to make this work.
   Instead I decided to first show (by induction):

   (WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> (IF b THEN REPEAT c UNTIL b ELSE SKIP, s) \<Rightarrow> t

   and then use the  repeat_if_equiv theorem above to transitively get to our goal.

 *)

lemmas big_step_induct_while_repeat_equiv = big_step_induct[of "c;;WHILE b DO c" "s" "t"
  "\<lambda>c' s t. c' = c;; WHILE b DO c \<longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t",
    rule_format] for c b s t

lemma repeat_while_equiv: "REPEAT c UNTIL b \<sim> c ;; WHILE b DO c"
proof -
  { fix s t
    have "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> (IF b THEN REPEAT c UNTIL b ELSE SKIP, s) \<Rightarrow> t"
    by (induction "WHILE b DO c" s t rule: big_step_induct, auto)
  } note while_if_then_repeat_equiv = this
  { fix c b s t
    have "(REPEAT c UNTIL b, s) \<Rightarrow> t \<Longrightarrow> (c ;; WHILE b DO c, s) \<Rightarrow> t"
    by (induction "REPEAT c UNTIL b" s t arbitrary: b c rule: big_step_induct, auto)
  } note fwd = this
  { fix s t
    have "(c ;; IF b THEN REPEAT c UNTIL b ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" using repeat_if_equiv by blast
    moreover have "(c ;; WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> (c ;; IF b THEN REPEAT c UNTIL b ELSE SKIP, s) \<Rightarrow> t"  using while_if_then_repeat_equiv by blast
    ultimately have "(c ;; WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" by blast
  } note bwd = this
  show ?thesis using fwd bwd by blast
qed

(* Lemma 7.8 *)

lemma sim_refl: "c \<sim> c" by auto
lemma sim_sym: "c \<sim> c' \<Longrightarrow> c' \<sim> c" by auto
lemma sim_trans: "\<lbrakk> c \<sim> c'; c' \<sim> c'' \<rbrakk> \<Longrightarrow> c \<sim> c''" by auto

(* Lemma 7.9 IMP is deterministic*)
lemma imp_deterministic: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> t' \<rbrakk> \<Longrightarrow> t' = t"
  apply (induction t arbitrary: t' rule: big_step_induct)
  apply blast+
  done

end


(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section \<open>Displaying Polynomials\<close>

theory Show_Polynomials
imports
  Polynomials
  Show.Show_Instances
begin

fun shows_monom_list :: "('v :: {linorder,show})monom_list \<Rightarrow> string \<Rightarrow> string" where
  "shows_monom_list [(x,p)] = (if p = 1 then shows x else shows x +@+ shows_string ''^'' +@+ shows p)"
| "shows_monom_list ((x,p) # m) = ((if p = 1 then shows x else shows x +@+ shows_string ''^'' +@+ shows p) +@+ shows_string ''*'' +@+ shows_monom_list m)"
| "shows_monom_list [] = shows_string ''1''"

instantiation monom :: ("{linorder,show}") "show"
begin

lift_definition shows_prec_monom :: "nat \<Rightarrow> 'a monom \<Rightarrow> shows" is "\<lambda> n. shows_monom_list" .

lemma shows_prec_monom_append [show_law_simps]:
  "shows_prec d (m :: 'a monom) (r @ s) = shows_prec d m r @ s"
proof (transfer fixing: d r s)
  fix m :: "'a monom_list"
  show "shows_monom_list m (r @ s) = shows_monom_list m r @ s"
    by (induct m arbitrary: r s rule: shows_monom_list.induct, auto simp: show_law_simps)
qed

definition "shows_list (ts :: 'a monom list) = showsp_list shows_prec 0 ts"

instance by (standard, auto simp: show_law_simps shows_list_monom_def)
end

fun shows_poly :: "('v :: {show,linorder},'a :: {one,show})poly \<Rightarrow> string \<Rightarrow> string" where
  "shows_poly [] = shows_string ''0''"
| "shows_poly ((m,c) # p) = ((if c = 1 then shows m else if m = 1 then shows c else shows c +@+
     shows_string ''*'' +@+ shows m) +@+ (if p = [] then shows_string [] else shows_string '' + '' +@+ shows_poly p))"
end


section \<open>Concurrent Refinement Algebra \label{S:CRA}\<close>

text \<open>
  This theory brings together the three main operators:
  sequential composition,
  parallel composition and
  conjunction,
  as well as the iteration operators.
\<close>

theory CRA
imports
  Sequential
  Conjunction
  Parallel
begin

text \<open>
  Locale sequential-parallel brings together the sequential and parallel
  operators and relates their identities.
\<close>
locale sequential_parallel = seq_distrib + par_distrib +
  assumes nil_par_nil: "nil \<parallel> nil \<sqsubseteq> nil"
  and skip_nil: "skip \<sqsubseteq> nil"           (* 41 *)
  and skip_skip: "skip \<sqsubseteq> skip;skip"    (* 40 *)
begin

lemma nil_absorb: "nil \<parallel> nil = nil" using nil_par_nil skip_nil par_skip
by (metis inf.absorb_iff2 inf.orderE inf_par_distrib2)

lemma skip_absorb [simp]: "skip;skip = skip"
by (metis antisym seq_mono_right seq_nil_right skip_skip skip_nil)

end

text \<open>
  Locale conjunction-parallel brings together the weak conjunction and
  parallel operators and relates their identities.
  It also introduces the interchange axiom for conjunction and parallel.
\<close>

locale conjunction_parallel = conj_distrib + par_distrib +
  assumes chaos_par_top: "\<top> \<sqsubseteq> chaos \<parallel> \<top>"
  assumes chaos_par_chaos: "chaos \<sqsubseteq> chaos \<parallel> chaos"     (* 47 *)
  assumes parallel_interchange: "(c\<^sub>0 \<parallel> c\<^sub>1) \<iinter> (d\<^sub>0 \<parallel> d\<^sub>1) \<sqsubseteq> (c\<^sub>0 \<iinter> d\<^sub>0) \<parallel> (c\<^sub>1 \<iinter> d\<^sub>1)" (* 50 *)
begin

lemma chaos_skip: "chaos \<sqsubseteq> skip"  (* 46 *)
proof -
  have "chaos = (chaos \<parallel> skip) \<iinter> (skip \<parallel> chaos)" by simp
  then have "\<dots> \<sqsubseteq> (chaos \<iinter> skip) \<parallel> (skip \<iinter> chaos)" using parallel_interchange by blast
  thus ?thesis by auto
qed

lemma chaos_par_chaos_eq: "chaos = chaos \<parallel> chaos"
  by (metis antisym chaos_par_chaos chaos_skip order_refl par_mono par_skip)

lemma nonabort_par_top: "chaos \<sqsubseteq> c \<Longrightarrow> c \<parallel> \<top> = \<top>"
  by (metis chaos_par_top par_mono top.extremum_uniqueI)

lemma skip_conj_top: "skip \<iinter> \<top> = \<top>"
by (simp add: chaos_skip conjoin_top)

lemma conj_distrib2: "c \<sqsubseteq> c \<parallel> c \<Longrightarrow> c \<iinter> (d\<^sub>0 \<parallel> d\<^sub>1) \<sqsubseteq> (c \<iinter> d\<^sub>0) \<parallel> (c \<iinter> d\<^sub>1)"
proof -
  assume "c \<sqsubseteq> c \<parallel> c"
  then have "c \<iinter> (d\<^sub>0 \<parallel> d\<^sub>1) \<sqsubseteq> (c \<parallel> c) \<iinter> (d\<^sub>0 \<parallel> d\<^sub>1)" by (metis conj_mono order.refl)
  thus ?thesis by (metis parallel_interchange refine_trans)
qed

end

text \<open>
  Locale conjunction-sequential brings together the weak conjunction and
  sequential operators.
  It also introduces the interchange axiom for conjunction and sequential.
\<close>

locale conjunction_sequential = conj_distrib + seq_distrib + (* iteration + *)
  assumes chaos_seq_chaos: "chaos \<sqsubseteq> chaos;chaos"
  assumes sequential_interchange: "(c\<^sub>0;c\<^sub>1) \<iinter> (d\<^sub>0;d\<^sub>1) \<sqsubseteq> (c\<^sub>0 \<iinter> d\<^sub>0);(c\<^sub>1 \<iinter> d\<^sub>1)"  (* 51 *)
begin

lemma chaos_nil: "chaos \<sqsubseteq> nil"
  by (metis conj_chaos local.conj_commute seq_nil_left seq_nil_right
       sequential_interchange)

lemma chaos_seq_absorb: "chaos = chaos;chaos"
proof (rule antisym)
  show "chaos \<sqsubseteq> chaos;chaos" by (simp add: chaos_seq_chaos)
next
  show "chaos;chaos \<sqsubseteq> chaos" using chaos_nil
    using seq_mono_left seq_nil_left by fastforce
qed

lemma seq_bot_conj: "c;\<bottom> \<iinter> d \<sqsubseteq> (c \<iinter> d);\<bottom>"
   by (metis (no_types) conj_bot_left seq_nil_right sequential_interchange)

lemma conj_seq_bot_right [simp]: "c;\<bottom> \<iinter> c =  c;\<bottom>"
proof (rule antisym)
  show lr: "c;\<bottom> \<iinter> c \<sqsubseteq>  c;\<bottom>" by (metis seq_bot_conj conj_idem)
next
  show rl: "c;\<bottom> \<sqsubseteq> c;\<bottom> \<iinter> c"
    by (metis conj_idem conj_mono_right seq_bot_right)
qed

lemma conj_distrib3: "c \<sqsubseteq> c;c \<Longrightarrow> c \<iinter> (d\<^sub>0 ; d\<^sub>1) \<sqsubseteq> (c \<iinter> d\<^sub>0);(c \<iinter> d\<^sub>1)"
proof -
  assume "c \<sqsubseteq> c;c"
  then have "c \<iinter> (d\<^sub>0;d\<^sub>1) \<sqsubseteq> (c;c) \<iinter> (d\<^sub>0;d\<^sub>1)" by (metis conj_mono order.refl)
  thus ?thesis by (metis sequential_interchange refine_trans)
qed

(*
lemma iter_conj_distrib:
  assumes nil: "c \<sqsubseteq> nil"
    and repeat: "c \<sqsubseteq> c ; c"
  shows "c \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c \<iinter> d)\<^sup>\<omega>"
proof (unfold iter_def)
  def F \<equiv> "(\<lambda> x. c \<iinter> x)"
  def G \<equiv> "(\<lambda> x. nil \<sqinter> d;x)"
  def H \<equiv> "(\<lambda> x. nil \<sqinter> ((c \<iinter> d);x))"

  have FG: "F \<circ> G = (\<lambda> x. c \<iinter> (nil \<sqinter> d;x))"  by (metis comp_def F_def G_def)
  have HF: "H \<circ> F = (\<lambda> x. (nil \<sqinter> (c \<iinter> d);(c \<iinter> x)))" by (metis comp_def H_def F_def)

  have "F (lfp G) \<sqsubseteq> lfp H"
  proof (rule fusion_lfp_leq)
    show "mono H" by (simp add: H_def iter_step_mono)
  next
    show "dist_over_sup F" by (simp add: F_def conj_Sup_distrib)
  next
    fix x
    have "c \<iinter> (nil \<sqinter> d;x) = (c \<iinter> nil) \<sqinter> (c \<iinter> d;x)" by (metis inf_conj_distrib conj_commute)
    also have "... \<sqsubseteq> nil \<sqinter> (c \<iinter> d;x)" by (metis conjunction_sup inf_mono_left le_iff_sup nil)
    also have "... \<sqsubseteq> nil \<sqinter> (c;c \<iinter> d;x)" by (metis inf_conj_distrib inf.absorb_iff2 inf_mono_right repeat)
    also have "... \<sqsubseteq> nil \<sqinter> (c \<iinter> d);(c \<iinter> x)" by (meson inf_mono_right sequential_interchange)
    finally show "(F \<circ> G) x \<sqsubseteq> (H \<circ> F) x" by (simp add: FG HF)
  qed

  then show "c \<iinter> lfp(\<lambda>x. nil \<sqinter> d ; x) \<sqsubseteq> lfp (\<lambda>x. nil \<sqinter> (c \<iinter> d) ; x)" using F_def G_def H_def by simp
qed

lemma iter_conj_distrib1: "c\<^sup>\<omega> \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c\<^sup>\<omega> \<iinter> d)\<^sup>\<omega>"
  by (simp add: iter0 iter_conj_distrib)

lemma iter_conj_distrib2: "c\<^sup>\<omega> \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c \<iinter> d)\<^sup>\<omega>"
proof -
  have a: "c\<^sup>\<omega> \<sqsubseteq> c" by (metis iter1)
  have b: "c\<^sup>\<omega> \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c\<^sup>\<omega> \<iinter> d)\<^sup>\<omega>" by (metis iter_conj_distrib1)
  have "c\<^sup>\<omega> \<iinter> d \<sqsubseteq> c \<iinter> d" by (metis a conj_mono order.refl)
  thus ?thesis using a b by (metis refine_trans iter_mono)
qed
*)

end

text \<open>
  Locale cra brings together sequential, parallel and weak conjunction.
\<close>

locale cra = sequential_parallel + conjunction_parallel + conjunction_sequential

end