theory EventSystemSwitchScheduler
  imports EventSystemExBase
begin

subsection \<open>Abstract scheduler\<close>

record astate_scheduler =
  cur_ttbl_id :: ttbl_id    \<comment> \<open>ID of current table\<close>
  window_id :: nat          \<comment> \<open>Current window in the frame\<close>
  reset :: bool             \<comment> \<open>Reset state for intermediate computations\<close>
  next_ttbl_id :: ttbl_id   \<comment> \<open>ID of next table (0 when not switching\<close>
  next_mode :: switch_mode  \<comment> \<open>Switch mode\<close>

definition init_astate :: astate_scheduler where
  "init_astate = \<lparr>cur_ttbl_id = 0, window_id = 0, reset = False, next_ttbl_id = 0, next_mode = NO_SWITCH\<rparr>"

context global_state
begin

definition cur_ttbl :: "astate_scheduler \<Rightarrow> time_table" where
  "cur_ttbl st = time_tables (cur_ttbl_id st)"

definition next_ttbl :: "astate_scheduler \<Rightarrow> time_table" where
  "next_ttbl st = time_tables (next_ttbl_id st)"

definition cur_frame_length :: "astate_scheduler \<Rightarrow> nat" where
  "cur_frame_length st = frame_length (cur_ttbl st)"

text \<open>Invariant for abstract scheduler\<close>
definition ainv :: "astate_scheduler \<Rightarrow> bool" where
  "ainv st \<longleftrightarrow>
     \<not>reset st \<and>
     cur_ttbl_id st < 256 \<and>
     next_ttbl_id st < 256 \<and>
     window_id st < length (cur_ttbl st)"

text \<open>Specification for executing a dispatch.\<close>
definition spec_dispatch :: "astate_scheduler \<Rightarrow> astate_scheduler \<times> event list" where
  "spec_dispatch st =
    (if next_mode st = NEXT_WINDOW then
       (\<lparr>cur_ttbl_id = next_ttbl_id st, window_id = 0, reset = False, next_ttbl_id = 0, next_mode = ONGOING\<rparr>,
        [PARTITION (fst (next_ttbl st ! 0)),
         WATCHDOG_ADD (0, snd (next_ttbl st ! 0))])
     else if window_id st = length (cur_ttbl st) - 1 \<and> next_mode st = NEXT_FRAME then
       (\<lparr>cur_ttbl_id = next_ttbl_id st, window_id = 0, reset = False, next_ttbl_id = 0, next_mode = ONGOING\<rparr>,
        [PARTITION (fst (next_ttbl st ! 0)),
         WATCHDOG_ADD (0, snd (next_ttbl st ! 0))])
     else if window_id st = length (cur_ttbl st) - 1 \<and> next_mode st = ONGOING then
       (st\<lparr>window_id := 0, next_mode := NO_SWITCH\<rparr>,
        [PARTITION (fst (cur_ttbl st ! 0)),
         WATCHDOG_ADD (0, snd (cur_ttbl st ! 0))])
     else
       (st\<lparr>window_id := (window_id st + 1) mod length (cur_ttbl st)\<rparr>,
        [PARTITION (fst (cur_ttbl st ! ((window_id st + 1) mod length (cur_ttbl st)))),
         WATCHDOG_ADD (0, snd (cur_ttbl st ! ((window_id st + 1) mod length (cur_ttbl st))))]))"

text \<open>Specification for executing a switch command.

  If there is no existing switch, store the next table and switch mode.
  Otherwise do nothing.
\<close>
definition spec_switch :: "ttbl_id \<Rightarrow> switch_mode \<Rightarrow> astate_scheduler \<Rightarrow> astate_scheduler" where
  "spec_switch nxt_tbl nxt_mode st =
    (if nxt_tbl \<ge> 256 then
       st
     else if nxt_mode \<noteq> NO_SWITCH then
       if cur_ttbl_id st = nxt_tbl \<and> next_mode st \<noteq> NO_SWITCH then
         st\<lparr>next_ttbl_id := nxt_tbl, next_mode := NO_SWITCH\<rparr>
       else
         st\<lparr>next_ttbl_id := nxt_tbl, next_mode := nxt_mode\<rparr>
     else
       st)"

end

subsection \<open>Concrete scheduler\<close>

record cstate =
  cur_ttbl_id :: ttbl_id    \<comment> \<open>ID of current table\<close>
  window_time :: nat        \<comment> \<open>Length of current window\<close>
  cur_frame_time :: nat     \<comment> \<open>Current time within the frame\<close>
  cur_window :: nat         \<comment> \<open>Current window in the frame\<close>
  total_frame_time :: nat   \<comment> \<open>Total length of frame\<close>
  next_ttbl_id :: ttbl_id   \<comment> \<open>ID of next table (0 when not switching)\<close>
  next_mode :: switch_mode  \<comment> \<open>Switch mode\<close>

definition get_cur_ttbl_id :: "(cstate, event, ttbl_id) event_monad" where
  "get_cur_ttbl_id = get \<bind> (\<lambda>st. return (cur_ttbl_id st))"

definition get_window_time :: "(cstate, event, nat) event_monad" where
  "get_window_time = get \<bind> (\<lambda>st. return (window_time st))"

definition get_cur_frame_time :: "(cstate, event, nat) event_monad" where
  "get_cur_frame_time = get \<bind> (\<lambda>st. return (cur_frame_time st))"

definition get_cur_window :: "(cstate, event, nat) event_monad" where
  "get_cur_window = get \<bind> (\<lambda>st. return (cur_window st))"

definition get_total_frame_time :: "(cstate, event, nat) event_monad" where
  "get_total_frame_time = get \<bind> (\<lambda>st. return (total_frame_time st))"

definition get_next_ttbl_id :: "(cstate, event, ttbl_id) event_monad" where
  "get_next_ttbl_id = get \<bind> (\<lambda>st. return (next_ttbl_id st))"

definition get_next_mode :: "(cstate, event, switch_mode) event_monad" where
  "get_next_mode = get \<bind> (\<lambda>st. return (next_mode st))"

definition set_cur_ttbl_id :: "ttbl_id \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_cur_ttbl_id ttbl = modify (cur_ttbl_id_update (\<lambda>_. ttbl))"

definition set_window_time :: "nat \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_window_time t = modify (window_time_update (\<lambda>_. t))"

definition set_cur_frame_time :: "nat \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_cur_frame_time t = modify (cur_frame_time_update (\<lambda>_. t))"

definition set_cur_window :: "nat \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_cur_window n = modify (cur_window_update (\<lambda>_. n))"

definition set_total_frame_time :: "nat \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_total_frame_time t = modify (total_frame_time_update (\<lambda>_. t))"

definition set_next_ttbl_id :: "ttbl_id \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_next_ttbl_id ttbl = modify (next_ttbl_id_update (\<lambda>_. ttbl))"

definition set_next_mode :: "switch_mode \<Rightarrow> (cstate, event, unit) event_monad" where
  "set_next_mode mode = modify (next_mode_update (\<lambda>_. mode))"

context global_state
begin

text \<open>Get partition and duration for a given window\<close>
definition get_partition :: "ttbl_id \<Rightarrow> nat \<Rightarrow> nat" where
  "get_partition tbl_id wid = fst (time_tables tbl_id ! wid)"

definition get_duration :: "ttbl_id \<Rightarrow> nat \<Rightarrow> nat" where
  "get_duration tbl_id wid = snd (time_tables tbl_id ! wid)"

definition get_frame_time :: "ttbl_id \<Rightarrow> nat" where
  "get_frame_time tbl_id = frame_length (time_tables tbl_id)"

text \<open>Initial state.

  We assume the initial time table is the zeroth time table in the global state.
\<close>
definition init_cstate :: cstate where
  "init_cstate = \<lparr>cur_ttbl_id = 0, window_time = get_duration 0 0,
    cur_frame_time = 0, cur_window = 0, total_frame_time = get_frame_time 0, next_ttbl_id = 0,
    next_mode = NO_SWITCH\<rparr>"

text \<open>Concrete switch operation\<close>
fun switch :: "ttbl_id \<Rightarrow> switch_mode \<Rightarrow> (cstate, event, unit) event_monad" where
  "switch nxt_tbl nxt_mode =
    (if nxt_tbl \<ge> 256 then
      return ()
     else
      get_next_mode \<bind> (\<lambda>mode.
      get_cur_ttbl_id \<bind> (\<lambda>cur_ttbl.
      get_next_ttbl_id \<bind> (\<lambda>nxt_ttbl.
      if (nxt_mode \<noteq> NO_SWITCH) then
        set_next_ttbl_id nxt_tbl \<bind> (\<lambda>_.
        if (cur_ttbl = nxt_tbl \<and> mode \<noteq> NO_SWITCH) then
          set_next_mode NO_SWITCH
        else
          set_next_mode nxt_mode)
      else
        return ()))))"

lemma get_cur_ttbl_id_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (cur_ttbl_id s) s \<rbrace>
     get_cur_ttbl_id
   \<lbrace> P \<rbrace>!"
  unfolding get_cur_ttbl_id_def by wp

lemma get_window_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (window_time s) s \<rbrace>
     get_window_time
   \<lbrace> P \<rbrace>!"
  unfolding get_window_time_def by wp

lemma get_cur_frame_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (cur_frame_time s) s \<rbrace>
     get_cur_frame_time
   \<lbrace> P \<rbrace>!"
  unfolding get_cur_frame_time_def by wp

lemma get_cur_window_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (cur_window s) s \<rbrace>
     get_cur_window
   \<lbrace> P \<rbrace>!"
  unfolding get_cur_window_def by wp

lemma get_total_frame_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (total_frame_time s) s \<rbrace>
     get_total_frame_time
   \<lbrace> P \<rbrace>!"
  unfolding get_total_frame_time_def by wp

lemma get_next_ttbl_id_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (next_ttbl_id s) s \<rbrace>
     get_next_ttbl_id
   \<lbrace> P \<rbrace>!"
  unfolding get_next_ttbl_id_def by wp

lemma get_next_mode_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (next_mode s) s \<rbrace>
     get_next_mode
   \<lbrace> P \<rbrace>!"
  unfolding get_next_mode_def by wp

lemma set_cur_ttbl_id_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_ttbl_id := cur_id\<rparr>) \<rbrace>
     set_cur_ttbl_id cur_id
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_cur_ttbl_id_def by wp

lemma set_window_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>window_time := wtime\<rparr>) \<rbrace>
     set_window_time wtime
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_window_time_def by wp

lemma set_cur_frame_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_frame_time := ftime\<rparr>) \<rbrace>
     set_cur_frame_time ftime
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_cur_frame_time_def by wp

lemma set_cur_window_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_window := window\<rparr>) \<rbrace>
     set_cur_window window
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_cur_window_def by wp

lemma set_total_frame_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>total_frame_time := tftime\<rparr>) \<rbrace>
     set_total_frame_time tftime
   \<lbrace> \<lambda>r s. P s \<rbrace>!"
  unfolding set_total_frame_time_def by wp

lemma set_next_ttbl_id_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>next_ttbl_id := nxt_tbl\<rparr>) \<rbrace>
     set_next_ttbl_id nxt_tbl
   \<lbrace> \<lambda>r s. P s \<rbrace>!"
  unfolding set_next_ttbl_id_def by wp

lemma set_next_mode_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>next_mode := nxt_mode\<rparr>) \<rbrace>
     set_next_mode nxt_mode
   \<lbrace> \<lambda>r s. P s \<rbrace>!"
  unfolding set_next_mode_def by wp

lemma switch_NF_rule [wp]:
  "\<lbrace> \<lambda>s. if nxt_tbl \<ge> 256 then P s
         else (if nxt_mode \<noteq> NO_SWITCH
               then if (cur_ttbl_id s = nxt_tbl \<and> next_mode s \<noteq> NO_SWITCH)
                    then P (s\<lparr>next_ttbl_id := nxt_tbl, next_mode := NO_SWITCH\<rparr>)
                    else P (s\<lparr>next_ttbl_id := nxt_tbl, next_mode := nxt_mode\<rparr>)
         else P s) \<rbrace>
     switch nxt_tbl nxt_mode
   \<lbrace> \<lambda>r s. P s \<rbrace>!"
  apply (unfold switch.simps)
  apply wp by auto

definition update_cur_frame_time :: "(cstate, event, unit) event_monad" where
  "update_cur_frame_time =
     get_window_time \<bind> (\<lambda>w_time.
     get_cur_frame_time \<bind> (\<lambda>f_time.
     set_cur_frame_time (f_time + w_time)))"

lemma update_cur_frame_time_NF_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_frame_time := cur_frame_time s + window_time s\<rparr>) \<rbrace>
     update_cur_frame_time
   \<lbrace> \<lambda>r. P \<rbrace>!"
  unfolding update_cur_frame_time_def by wp

subsection \<open>Refinement\<close>

text \<open>Refinement relation between abstract and concrete scheduler.\<close>
definition rel :: "astate_scheduler \<Rightarrow> cstate \<Rightarrow> bool" where
  "rel as cs \<longleftrightarrow> astate_scheduler.cur_ttbl_id as = cstate.cur_ttbl_id cs \<and>
                 astate_scheduler.window_id as = cur_window cs \<and>
                 (if astate_scheduler.reset as then window_time cs = 0 else window_time cs \<noteq> 0) \<and>
                 astate_scheduler.next_ttbl_id as = cstate.next_ttbl_id cs \<and>
                 astate_scheduler.next_mode as = cstate.next_mode cs"

definition c_cur_ttbl :: "cstate \<Rightarrow> time_table" where
  "c_cur_ttbl st = time_tables (cur_ttbl_id st)"

text \<open>Main invariant for concrete scheduler, to be held before and after
  each dispatch.
\<close>
definition cinv :: "cstate \<Rightarrow> bool" where
  "cinv cs \<longleftrightarrow> cur_ttbl_id cs < 256 \<and>
               next_ttbl_id cs < 256 \<and>
               cur_window cs < length (c_cur_ttbl cs) \<and>
               total_frame_time cs = frame_length (c_cur_ttbl cs) \<and>
               window_time cs = get_duration (cur_ttbl_id cs) (cur_window cs) \<and>
               cur_frame_time cs = frame_time_to_window (c_cur_ttbl cs) (cur_window cs)"

text \<open>Auxiliary invariant to be held during the computation.\<close>
definition cinv2 :: "cstate \<Rightarrow> bool" where
  "cinv2 cs \<longleftrightarrow> cur_ttbl_id cs < 256 \<and>
                next_ttbl_id cs < 256 \<and>
                cur_window cs < length (c_cur_ttbl cs) \<and>
                total_frame_time cs = frame_length (c_cur_ttbl cs) \<and>
                (if window_time cs = 0 then cur_frame_time cs = 0 \<and> cur_window cs = 0
                 else window_time cs = get_duration (cur_ttbl_id cs) (cur_window cs) \<and>
                      cur_frame_time cs = frame_time_to_window (c_cur_ttbl cs) (cur_window cs + 1))"

lemma cinv_duration_nonzero:
  assumes "cinv cs"
  shows "snd (time_tables (cur_ttbl_id cs) ! cur_window cs) \<noteq> 0"
proof -
  have "is_valid_time_table (time_tables (cstate.cur_ttbl_id cs))"
    apply (rule valid_time_table)
    using cinv_def assms by auto
  also have "cur_window cs < length (time_tables (cstate.cur_ttbl_id cs))"
    using cinv_def assms c_cur_ttbl_def by auto
  ultimately show ?thesis
    using window_time_pos by auto
qed

subsection \<open>Dispatch\<close>

text \<open>Due to the length of the dispatch function, we prove it in several
  sections: dispatch_part1, dispatch_part2, dispatch_part3. The overall
  implementation is dispatch_all.
\<close>

definition dispatch_part1 :: "(cstate, event, unit) event_monad" where
  "dispatch_part1 = get_next_mode \<bind> (\<lambda>mode.

    \<comment>\<open>If switching at next window\<close>
    (if (mode = NEXT_WINDOW) then
      set_window_time 0 \<bind> (\<lambda>_.
      set_cur_frame_time 0 \<bind> (\<lambda>_.
      set_cur_window 0 \<bind> (\<lambda>_.
      get_next_ttbl_id \<bind> (\<lambda>next_ttbl_id.
      set_cur_ttbl_id next_ttbl_id \<bind> (\<lambda>_.
      get_cur_ttbl_id \<bind> (\<lambda>cur_tbl.
      set_total_frame_time (get_frame_time cur_tbl) \<bind> (\<lambda>_.
      set_next_mode ONGOING \<bind> (\<lambda>_.
      set_next_ttbl_id 0))))))))
    else
      return ())
    \<bind> (\<lambda>_.

    \<comment> \<open>Update total frame time\<close>
    update_cur_frame_time))"

definition dispatch_part_a1 :: "astate_scheduler \<Rightarrow> astate_scheduler" where
  "dispatch_part_a1 st =
   (if astate_scheduler.next_mode st = NEXT_WINDOW then
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id st,
       window_id = 0,
       reset = True,
       next_ttbl_id = 0,
       next_mode = ONGOING\<rparr>)
    else st)"

lemma dispatch_part1_rule:
  assumes "\<not>reset as"
  shows
  "\<lbrace> \<lambda>cs es. cinv cs \<and> rel as cs \<and> P es \<rbrace>
     dispatch_part1
   \<lbrace> \<lambda>_ cs es. cinv2 cs \<and> rel (dispatch_part_a1 as) cs \<and> P es \<rbrace>!"
  unfolding dispatch_part1_def apply wp apply auto
  unfolding rel_def rel_def dispatch_part_a1_def apply auto
  subgoal for cs e
    apply (auto simp add: cinv2_def cinv_def c_cur_ttbl_def)
    using valid_time_table apply auto[1]
    using get_frame_time_def
     apply fastforce
    using get_frame_time_def by blast
  subgoal for cs e
    apply (auto simp add: cinv2_def cinv_def c_cur_ttbl_def get_duration_def cinv_duration_nonzero)
    by (simp add: frame_time_to_window_next)
  done

definition dispatch_part2 :: "(cstate, event, unit) event_monad" where
  "dispatch_part2 =
     get_next_mode \<bind> (\<lambda>mode.
        (if mode = NEXT_FRAME then
          set_window_time 0 \<bind> (\<lambda>_.
          set_cur_frame_time 0 \<bind> (\<lambda>_.
          set_cur_window 0 \<bind> (\<lambda>_.
          get_next_ttbl_id \<bind> (\<lambda>next_ttbl_id.
          set_cur_ttbl_id next_ttbl_id \<bind> (\<lambda>_.
          get_cur_ttbl_id \<bind> (\<lambda>cur_tbl.
          set_total_frame_time (get_frame_time cur_tbl) \<bind> (\<lambda>_.
          set_next_mode ONGOING \<bind> (\<lambda>_.
          set_next_ttbl_id 0 ))))))))
        else if mode = ONGOING then
          set_next_mode NO_SWITCH
        else
          return ()) \<bind> (\<lambda>_.
        get_cur_ttbl_id \<bind> (\<lambda>cur_tbl.
        set_window_time 0 \<bind> (\<lambda>_.
        set_cur_frame_time 0 \<bind> (\<lambda>_.
        set_cur_window 0)))))"

text \<open>Expect to be called only when frame time equals total frame time.\<close>
definition dispatch_part_a2 :: "astate_scheduler \<Rightarrow> astate_scheduler" where
  "dispatch_part_a2 st =
   (if astate_scheduler.next_mode st = NEXT_FRAME then
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id st,
        window_id = 0,
        reset = True,
        astate_scheduler.next_ttbl_id = 0,
        next_mode = ONGOING\<rparr>)
    else if astate_scheduler.next_mode st = ONGOING then
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.cur_ttbl_id st,
        window_id = 0,
        reset = True,
        astate_scheduler.next_ttbl_id = astate_scheduler.next_ttbl_id st,
        next_mode = NO_SWITCH\<rparr>)
    else
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.cur_ttbl_id st,
        window_id = 0,
        reset = True,
        astate_scheduler.next_ttbl_id = astate_scheduler.next_ttbl_id st,
        next_mode = astate_scheduler.next_mode st\<rparr>))"

lemma dispatch_part2_rule:
  "\<lbrace> \<lambda>cs es. cinv2 cs \<and> rel as cs \<and> P es \<rbrace>
     dispatch_part2
   \<lbrace> \<lambda>_ cs es. cinv2 cs \<and> rel (dispatch_part_a2 as) cs \<and>
               cur_window cs = 0 \<and> window_time cs = 0 \<and> cur_frame_time cs = 0 \<and> P es\<rbrace>!"
  unfolding dispatch_part2_def apply wp
  apply (auto simp add: rel_def dispatch_part_a2_def)
  using valid_time_table
  apply (auto simp add: cinv2_def c_cur_ttbl_def get_frame_time_def)
  by fastforce

definition dispatch_part3 :: "(cstate, event, unit) event_monad" where
  "dispatch_part3 =
    get_cur_frame_time \<bind> (\<lambda>f_time.
    get_total_frame_time \<bind> (\<lambda>total_time.
    if f_time = 0 \<or> f_time = total_time then
      ((if (f_time = total_time) then
        (dispatch_part2) else return ()) \<bind> (\<lambda>_.
      get_cur_ttbl_id \<bind> (\<lambda>cur_tbl.
      set_window_time (get_duration cur_tbl 0) \<bind> (\<lambda>_.
      signal (PARTITION (get_partition cur_tbl 0))) \<bind> (\<lambda>_.
      signal (WATCHDOG_ADD (0, get_duration cur_tbl 0))))))
    else
      get_cur_ttbl_id \<bind> (\<lambda>cur_tbl.
      get_cur_window \<bind> (\<lambda>cur_window.
      set_cur_window (cur_window + 1) \<bind> (\<lambda>_.
      set_window_time (get_duration cur_tbl (cur_window + 1)) \<bind> (\<lambda>_.
      signal (PARTITION (get_partition cur_tbl (cur_window + 1))) \<bind> (\<lambda>_.
      signal (WATCHDOG_ADD (0, get_duration cur_tbl (cur_window + 1))))))))))"

definition dispatch_part_a3 :: "astate_scheduler \<Rightarrow> astate_scheduler \<times> event list" where
  "dispatch_part_a3 st =
    (if astate_scheduler.window_id st = length (cur_ttbl st) - 1 then
       ((dispatch_part_a2 st)\<lparr>reset := False\<rparr>,
        [PARTITION (fst (cur_ttbl (dispatch_part_a2 st) ! 0)),
         WATCHDOG_ADD (0, snd (cur_ttbl (dispatch_part_a2 st) ! 0))])
     else if astate_scheduler.reset st then
       (st\<lparr>reset := False\<rparr>, [PARTITION (fst (cur_ttbl st ! 0)), WATCHDOG_ADD (0, snd (cur_ttbl st ! 0))])
     else (st\<lparr>window_id := window_id st + 1\<rparr>,
           [PARTITION (fst (cur_ttbl st ! (window_id st + 1))),
            WATCHDOG_ADD (0, snd (cur_ttbl st ! (window_id st + 1)))]))"

lemma dispatch_part2_rule'':
  assumes "window_id as = length (cur_ttbl as) - 1"
  shows
  "\<lbrace> \<lambda>cs es. cinv2 cs \<and> rel as cs \<and> es = [] \<rbrace>
     dispatch_part2
   \<lbrace> \<lambda>_ cs es. cinv (cs\<lparr>window_time := get_duration (cstate.cur_ttbl_id cs) 0\<rparr>) \<and>
            rel (fst (dispatch_part_a3 as)) (cs\<lparr>window_time := get_duration (cstate.cur_ttbl_id cs) 0\<rparr>) \<and>
            es @ [PARTITION (get_partition (cstate.cur_ttbl_id cs) 0),
                  WATCHDOG_ADD (0, get_duration (cstate.cur_ttbl_id cs) 0)] = snd (dispatch_part_a3 as) \<rbrace>!"
proof -
  have a: "dispatch_part_a3 as =
    ((dispatch_part_a2 as)\<lparr>reset := False\<rparr>,
     [PARTITION (fst (cur_ttbl (dispatch_part_a2 as) ! 0)),
      WATCHDOG_ADD (0, snd (cur_ttbl (dispatch_part_a2 as) ! 0))])"
    unfolding dispatch_part_a3_def using assms by auto
  show ?thesis
    apply (rule validNF_strengthen_post)
    apply (rule validNF_weaken_pre)
      apply (rule dispatch_part2_rule[where as=as and P="\<lambda>e. e = []"])
     apply auto[1]
    subgoal for r cs e
      apply simp apply (intro conjI)
      subgoal by (auto simp add: cinv_def cinv2_def c_cur_ttbl_def)
      subgoal apply (auto simp add: rel_def cinv2_def c_cur_ttbl_def a)
        using get_duration_def window_time_pos global_state_axioms valid_time_table by auto
      subgoal by (auto simp add: cinv2_def cinv_def c_cur_ttbl_def cur_ttbl_def rel_def a get_partition_def get_duration_def)
      done
    done
qed

lemma dispatch_part2_rule':
  "\<lbrace> \<lambda>cs es. window_id as = length (cur_ttbl as) - 1 \<and> cinv2 cs \<and> rel as cs \<and> es = [] \<rbrace>
     dispatch_part2
   \<lbrace> \<lambda>_ cs es. cinv (cs\<lparr>window_time := get_duration (cstate.cur_ttbl_id cs) 0\<rparr>) \<and>
            rel (fst (dispatch_part_a3 as)) (cs\<lparr>window_time := get_duration (cstate.cur_ttbl_id cs) 0\<rparr>) \<and>
            (es @ [PARTITION (get_partition (cstate.cur_ttbl_id cs) 0)]) @
                 [WATCHDOG_ADD (0, get_duration (cstate.cur_ttbl_id cs) 0)] = snd (dispatch_part_a3 as) \<rbrace>!"
  unfolding validNF_conj_pre
  using dispatch_part2_rule'' by auto

lemma dispatch_part3_rule:
  "\<lbrace> \<lambda>cs es. cinv2 cs \<and> rel as cs \<and> es = []\<rbrace>
     dispatch_part3
   \<lbrace> \<lambda>_ cs es. cinv cs \<and> rel (fst (dispatch_part_a3 as)) cs \<and> es = snd (dispatch_part_a3 as)\<rbrace>!"
proof -
  have 2: "cinv (cs\<lparr>window_time := get_duration (cstate.cur_ttbl_id cs) 0\<rparr>)"
    if "cinv2 cs" and "cur_frame_time cs = 0" for cs
    using that
    by (smt add_gr_0 c_cur_ttbl_def cstate.select_convs cstate.surjective cstate.update_convs(2)
            frame_time_to_window_mono_strict frame_time_to_window_zero global_state.cinv2_def
            global_state.cinv_def global_state_axioms gr0I is_valid_time_table.elims(2)
            less_numeral_extra(2) less_numeral_extra(3) valid_time_table)
  have 4: "length (cur_ttbl as) > 1" if "cinv2 cs" "rel as cs" for cs
    using global_state.cinv2_def global_state.cur_ttbl_def global_state_axioms rel_def that(1) that(2) valid_time_table by auto
  have 5: "cur_window cs = length (c_cur_ttbl cs) - 1"
    if "cinv2 cs" "rel as cs" "cur_frame_time cs = total_frame_time cs" for cs
  proof -
    note that1 = that
    have a1: "cur_window cs < length (c_cur_ttbl cs)"
      using cinv2_def nat_le_linear not_le that(1) by blast
    have a2: "is_valid_time_table (c_cur_ttbl cs)"
      using c_cur_ttbl_def cinv2_def that(1) valid_time_table by auto
    have a3: False if "Suc (cur_window cs) < length (c_cur_ttbl cs)"
    proof -
      have "frame_time_to_window (c_cur_ttbl cs) (Suc (cur_window cs)) < frame_time_to_window (c_cur_ttbl cs) (length (c_cur_ttbl cs))"
        by (rule frame_time_to_window_mono_strict[OF a2 that that])
      then show ?thesis
        using that1 cinv2_def frame_time_to_window_total
        by (metis Suc_eq_plus1 gr_implies_not0 less_not_refl2)
    qed
    show ?thesis
      using a1 a3 by fastforce
  qed
  have 6: "rel (fst (dispatch_part_a3 as)) (cs\<lparr>window_time := get_duration (cstate.cur_ttbl_id cs) 0\<rparr>)"
    if "cinv2 cs" "rel as cs" "cur_frame_time cs = 0" for cs
  proof -
    have a1: "window_time cs = 0" "cur_window cs = 0"
      using that(1,3) unfolding cinv2_def
       apply (metis Suc_eq_plus1 c_cur_ttbl_def frame_time_to_window_mono_strict less_add_same_cancel2
                    less_numeral_extra(1) not_less_zero plus_1_eq_Suc valid_time_table)
      by (metis Suc_eq_plus1 Suc_leI cinv2_def diff_Suc_1 diff_less frame_time_to_window_mono_strict
                global_state.c_cur_ttbl_def global_state_axioms less_numeral_extra(1) not_le
                that(1) that(3) valid_time_table zero_less_Suc)
    have a2: "window_id as = 0"
      using a1(2) that(2) unfolding rel_def by auto
    have a3: "reset as"
      using that(2) unfolding rel_def that(3)
      by (meson a1(1))
    have a4: "fst (dispatch_part_a3 as) = as\<lparr>reset := False\<rparr>"
      unfolding dispatch_part_a3_def
      using a2 4[OF that(1,2)] a3 by auto
    show ?thesis
      using that(2) unfolding a4 rel_def
      using 2 a2 astate_scheduler.ext_inject cinv_duration_nonzero cstate.surjective
            get_duration_def that(1) that(3) by force
  qed
  have 7: "rel (fst (dispatch_part_a3 as))
     (cs\<lparr>cur_window := cur_window cs + 1, window_time := get_duration (cstate.cur_ttbl_id cs) (cur_window cs + 1)\<rparr>)"
    "[PARTITION (get_partition (cstate.cur_ttbl_id cs) (cur_window cs + 1)),
      WATCHDOG_ADD (0, get_duration (cstate.cur_ttbl_id cs) (cur_window cs + 1))] = snd (dispatch_part_a3 as)"
    if "cinv2 cs" "rel as cs" "\<not> (cur_frame_time cs = 0 \<or> cur_frame_time cs = total_frame_time cs)" for cs
  proof -
    have a1: "cur_window cs < length (c_cur_ttbl cs)"
      using that(1) unfolding cinv2_def by auto
    have a2: "window_time cs = get_duration (cstate.cur_ttbl_id cs) (cur_window cs)"
       "cur_frame_time cs = frame_time_to_window (c_cur_ttbl cs) (cur_window cs + 1)"
      using that(1,3) unfolding cinv2_def
      apply meson
      using cinv2_def that(1) that(3) by presburger
    have a3: "cur_window cs + 1 \<noteq> length (c_cur_ttbl cs)"
      using a2(2) that(3)
      using cinv2_def frame_time_to_window_total that(1) by auto
    have a4: "\<not>reset as"
      using cinv2_def rel_def that(1) that(2) that(3) by auto
    have a5: "fst (dispatch_part_a3 as) = as\<lparr>window_id := window_id as + 1\<rparr>"
      using a3 a4 that(2)
      by (smt Suc_eq_plus1 add_diff_inverse_nat 4[OF that(1,2)] astate_scheduler.surjective
              astate_scheduler.update_convs(2) c_cur_ttbl_def cur_ttbl_def dispatch_part_a3_def
              fst_conv length_0_conv length_greater_0_conv less_one less_trans plus_1_eq_Suc rel_def)
    have a6: "snd (dispatch_part_a3 as) = [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
                                           WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))]"
      using a3 a4 that(2)
      by (smt Suc_eq_plus1 add_diff_inverse_nat 4[OF that(1,2)] c_cur_ttbl_def cur_ttbl_def dispatch_part_a3_def
              length_0_conv length_greater_0_conv less_one less_trans plus_1_eq_Suc rel_def snd_conv)
    show "rel (fst (dispatch_part_a3 as))
     (cs\<lparr>cur_window := cur_window cs + 1, window_time := get_duration (cstate.cur_ttbl_id cs) (cur_window cs + 1)\<rparr>)"
      using a4 that(2) unfolding a5 rel_def apply auto
      using a3 c_cur_ttbl_def get_duration_def global_state.cinv2_def
            window_time_pos global_state_axioms that(1) valid_time_table by auto
    show "[PARTITION (get_partition (cstate.cur_ttbl_id cs) (cur_window cs + 1)),
           WATCHDOG_ADD (0, get_duration (cstate.cur_ttbl_id cs) (cur_window cs + 1))] = snd (dispatch_part_a3 as)"
      unfolding a6 apply (auto simp add: get_partition_def get_duration_def cur_ttbl_def)
      using rel_def that(2) by auto
  qed
  show ?thesis
    unfolding dispatch_part3_def
    apply (rule validNF_bind)
     prefer 2 apply (rule validNF_bind)
      prefer 2 apply (rule validNF_if_split)
    apply (rule validNF_bind)
        prefer 2 apply (rule validNF_bind)
         prefer 2 apply (rule validNF_bind)
          prefer 2 apply (rule validNF_signal)
    apply (rule validNF_bind)
          prefer 2 apply (rule validNF_signal)
    apply (rule set_window_time_NF_rule)
    apply (rule get_cur_ttbl_id_NF_rule)
    apply (rule validNF_if_split)
        apply (rule dispatch_part2_rule')
       apply (rule validNF_return)
      apply wp apply wp apply wp
    subgoal for cs e
      apply (intro conjI)
      subgoal apply (intro impI conjI)
        subgoal using 5 c_cur_ttbl_def cur_ttbl_def rel_def by auto
        subgoal by auto
        subgoal by auto
        subgoal by auto
        subgoal using 2 by auto
        subgoal using 6 by auto
        subgoal using 4 cinv2_def cur_ttbl_def dispatch_part_a3_def rel_def
        proof -
          assume a1: "cur_frame_time cs = 0 \<or> cur_frame_time cs = total_frame_time cs"
          assume a2: "cur_frame_time cs \<noteq> total_frame_time cs"
          assume a3: "cinv2 cs \<and> rel as cs \<and> e = []"
          then have "window_time cs = 0"
            using a2 a1
            by (smt One_nat_def Suc_lessD add_gr_0 4 c_cur_ttbl_def cur_ttbl_def
                    frame_time_to_window_mono_strict frame_time_to_window_zero global_state.cinv2_def
                    global_state_axioms less_numeral_extra(1) less_numeral_extra(3) rel_def valid_time_table)
          then have f4: "reset as"
            using a3 by (metis (no_types) rel_def)
          have "1 < length (c_cur_ttbl cs)"
            using a3 by (metis (no_types) 4 c_cur_ttbl_def cur_ttbl_def rel_def)
          then show ?thesis
            using f4 a3
            by (simp add: c_cur_ttbl_def cinv2_def cur_ttbl_def dispatch_part_a3_def get_partition_def get_duration_def rel_def)
        qed
        done
      subgoal apply (intro impI conjI)
        subgoal apply (auto simp add: cinv_def cinv2_def c_cur_ttbl_def)
           apply (metis Suc_eq_plus1 Suc_lessI c_cur_ttbl_def frame_time_to_window_total not_less_zero)
          using Suc_eq_plus1 c_cur_ttbl_def by presburger
        subgoal using 7(1) by blast
        subgoal using 7(2) by auto
        done
      done
    done
qed

definition dispatch_all :: "(cstate, event, unit) event_monad" where
  "dispatch_all = dispatch_part1 \<bind> (\<lambda>_. dispatch_part3)"

lemma dispatch_all_rule':
  "\<lbrace> \<lambda>cs es. \<not>reset as \<and> cinv cs \<and> rel as cs \<and> es = [] \<rbrace>
     dispatch_all
   \<lbrace> \<lambda>_ cs es. cinv cs \<and> rel (fst (dispatch_part_a3 (dispatch_part_a1 as))) cs
      \<and> es = snd (dispatch_part_a3 (dispatch_part_a1 as)) \<rbrace>!"
  unfolding dispatch_all_def
  apply (subst validNF_conj_pre)
  apply auto
  apply (rule validNF_bind)
  apply (rule dispatch_part1_rule) apply auto
  by (rule dispatch_part3_rule)

subsection \<open>Equivalence with spec_dispatch\<close>

lemma spec_dispatch_equal_next_window:
  assumes "astate_scheduler.next_mode as = NEXT_WINDOW"
    and "ainv as"
  shows "spec_dispatch as = dispatch_part_a3 (dispatch_part_a1 as)"
proof -
  have a1: "spec_dispatch as =
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id as, window_id = 0, reset = False, next_ttbl_id = 0,
        next_mode = ONGOING\<rparr>,
       [PARTITION (fst (next_ttbl as ! 0)), WATCHDOG_ADD (0, snd (next_ttbl as ! 0))])"
    unfolding spec_dispatch_def using assms(1) by auto
  have a2: "dispatch_part_a1 as =
      \<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id as, window_id = 0, reset = True, next_ttbl_id = 0,
       next_mode = ONGOING\<rparr>"
    unfolding dispatch_part_a1_def using assms(1) by auto
  have a3: "length (time_tables (astate_scheduler.next_ttbl_id as)) > 1"
    using ainv_def assms(2) valid_time_table by auto
  have a4: "dispatch_part_a3 (dispatch_part_a1 as) =
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id as, window_id = 0, reset = False, next_ttbl_id = 0,
        next_mode = ONGOING\<rparr>,
       [PARTITION (fst (next_ttbl as ! 0)), WATCHDOG_ADD (0, snd (next_ttbl as ! 0))])"
    unfolding a2 dispatch_part_a3_def using a3 by (auto simp add: cur_ttbl_def next_ttbl_def)
  show ?thesis
    using a1 a4 by auto
qed

lemma spec_dispatch_equal_next_frame:
  assumes "astate_scheduler.next_mode as = NEXT_FRAME"
    and "ainv as"
  shows "spec_dispatch as = dispatch_part_a3 (dispatch_part_a1 as)"
proof -
  have a1: "spec_dispatch as =
      (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id as,
        window_id = 0, reset = False, next_ttbl_id = 0, next_mode = ONGOING\<rparr>,
       [PARTITION (fst (next_ttbl as ! 0)),
        WATCHDOG_ADD (0, snd (next_ttbl as ! 0))])" if "window_id as = length (cur_ttbl as) - 1"
    unfolding spec_dispatch_def using assms(1) that by auto
  have a2: "dispatch_part_a1 as = as"
    unfolding dispatch_part_a1_def using assms(1) by auto
  have a3: "dispatch_part_a3 (dispatch_part_a1 as) =
     (\<lparr>astate_scheduler.cur_ttbl_id = astate_scheduler.next_ttbl_id as,
       window_id = 0, reset = False, next_ttbl_id = 0, next_mode = ONGOING\<rparr>,
      [PARTITION (fst (next_ttbl as ! 0)),
       WATCHDOG_ADD (0, snd (next_ttbl as ! 0))])" if "window_id as = length (cur_ttbl as) - 1"
    unfolding a2 dispatch_part_a3_def
    by (auto simp add: that assms(1) dispatch_part_a2_def cur_ttbl_def next_ttbl_def)
  have a4: "spec_dispatch as =
     (as\<lparr>window_id := window_id as + 1\<rparr>,
      [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))])" if "window_id as \<noteq> length (cur_ttbl as) - 1"
    unfolding spec_dispatch_def using assms(1) that apply auto
    by (metis Euclidean_Division.mod_less One_nat_def Suc_lessI ainv_def assms(2) diff_Suc_1)+
  have a5: "dispatch_part_a3 (dispatch_part_a1 as) =
     (as\<lparr>window_id := window_id as + 1\<rparr>,
      [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))])" if "window_id as \<noteq> length (cur_ttbl as) - 1"
    unfolding a2 dispatch_part_a3_def
    using that assms(2) ainv_def by auto
  show ?thesis
    apply (cases "window_id as = length (cur_ttbl as) - 1")
    using a1 a3 apply auto[1]
    using a4 a5 by auto
qed

lemma spec_dispatch_equal_no_switch:
  assumes "astate_scheduler.next_mode as = NO_SWITCH"
    and "ainv as"
  shows "spec_dispatch as = dispatch_part_a3 (dispatch_part_a1 as)"
proof -
  have a1: "spec_dispatch as =
     (as\<lparr>window_id := window_id as + 1\<rparr>,
      [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))])" if "window_id as \<noteq> length (cur_ttbl as) - 1"
    unfolding spec_dispatch_def using assms(1) that apply auto
    by (metis Euclidean_Division.mod_less One_nat_def Suc_lessI ainv_def assms(2) diff_Suc_1)+
  have a2: "dispatch_part_a1 as = as"
    using assms(1) dispatch_part_a1_def by auto
  have a3: "dispatch_part_a3 as =
     (as\<lparr>window_id := window_id as + 1\<rparr>,
      [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))])" if "window_id as \<noteq> length (cur_ttbl as) - 1"
    unfolding dispatch_part_a3_def using assms(2) that by (auto simp add: ainv_def)
  have a4: "spec_dispatch as =
     (as\<lparr>window_id := 0\<rparr>,
      [PARTITION (fst (cur_ttbl as ! 0)),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! 0))])" if "window_id as = length (cur_ttbl as) - 1"
    unfolding spec_dispatch_def using assms(1) that apply auto
    by (metis One_nat_def assms(2) diff_Suc_1 global_state.ainv_def global_state_axioms mod_self not0_implies_Suc not_less_zero)+
  have a5: "dispatch_part_a3 as =
     (as\<lparr>window_id := 0\<rparr>,
      [PARTITION (fst (cur_ttbl as ! 0)),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! 0))])" if "window_id as = length (cur_ttbl as) - 1"
    unfolding dispatch_part_a3_def using assms(1,2) that
    by (auto simp add: dispatch_part_a2_def ainv_def cur_ttbl_def)
  show ?thesis
    apply (cases "window_id as = length (cur_ttbl as) - 1")
    using a2 a4 a5 apply auto[1]
    using a1 a2 a3 by auto
qed

lemma spec_dispatch_equal_ongoing:
  assumes "astate_scheduler.next_mode as = ONGOING"
    and "ainv as"
  shows "spec_dispatch as = dispatch_part_a3 (dispatch_part_a1 as)"
proof -
  have a1: "spec_dispatch as =
     (as\<lparr>window_id := window_id as + 1\<rparr>,
      [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))])" if "window_id as \<noteq> length (cur_ttbl as) - 1"
    unfolding spec_dispatch_def using assms(1) that apply auto
    by (metis Euclidean_Division.mod_less One_nat_def Suc_lessI ainv_def assms(2) diff_Suc_1)+
  have a2: "dispatch_part_a1 as = as"
    using assms(1) dispatch_part_a1_def by auto
  have a3: "dispatch_part_a3 as =
     (as\<lparr>window_id := window_id as + 1\<rparr>,
      [PARTITION (fst (cur_ttbl as ! (window_id as + 1))),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! (window_id as + 1)))])" if "window_id as \<noteq> length (cur_ttbl as) - 1"
    unfolding dispatch_part_a3_def using assms(2) that by (auto simp add: ainv_def)
  have a4: "spec_dispatch as =
     (as\<lparr>window_id := 0, astate_scheduler.next_mode := NO_SWITCH\<rparr>,
      [PARTITION (fst (cur_ttbl as ! 0)),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! 0))])" if "window_id as = length (cur_ttbl as) - 1"
    unfolding spec_dispatch_def using assms(1) that by auto
  have a5: "dispatch_part_a3 as =
     (as\<lparr>window_id := 0, astate_scheduler.next_mode := NO_SWITCH\<rparr>,
      [PARTITION (fst (cur_ttbl as ! 0)),
       WATCHDOG_ADD (0, snd (cur_ttbl as ! 0))])" if "window_id as = length (cur_ttbl as) - 1"
    unfolding dispatch_part_a3_def using assms(1,2) that
    by (auto simp add: dispatch_part_a2_def ainv_def cur_ttbl_def)
  show ?thesis
    apply (cases "window_id as = length (cur_ttbl as) - 1")
    using a2 a4 a5 apply auto[1]
    using a1 a2 a3 by auto
qed

lemma spec_dispatch_equal:
  assumes "astate_scheduler.next_mode as \<noteq> NEXT_TICK"
    and "ainv as"
  shows "spec_dispatch as = dispatch_part_a3 (dispatch_part_a1 as)"
  using assms spec_dispatch_equal_next_frame spec_dispatch_equal_next_window
        spec_dispatch_equal_no_switch spec_dispatch_equal_ongoing switch_mode.exhaust by blast

subsection \<open>Overall refinement relation\<close>

definition rel_scheduler :: "astate_scheduler \<Rightarrow> cstate \<Rightarrow> bool" where
  "rel_scheduler as cs \<longleftrightarrow> ainv as \<and> cinv cs \<and> rel as cs"

lemma ainv_spec_dispatch:
  assumes "ainv as"
  shows "ainv (fst (spec_dispatch as))"
proof -
  have "time_tables (astate_scheduler.next_ttbl_id as) \<noteq> []"
    using ainv_def assms valid_time_table by fastforce
  then show ?thesis
    unfolding spec_dispatch_def using assms
    apply (auto simp add: ainv_def cur_ttbl_def)
    by (simp add: length_ineq_not_Nil(1))
qed

lemma dispatch_all_rule'':
  assumes "astate_scheduler.next_mode as \<noteq> NEXT_TICK"
  shows
  "\<lbrace> \<lambda>cs es. ainv as \<and> cinv cs \<and> rel_scheduler as cs \<and> es = [] \<rbrace>
     dispatch_all
   \<lbrace> \<lambda>_ cs es. cinv cs \<and> rel_scheduler (fst (spec_dispatch as)) cs \<and> es = snd (spec_dispatch as) \<rbrace>!"
  apply (subst validNF_conj_pre)
  apply auto
  apply (rule validNF_strengthen_post)
  apply (rule validNF_weaken_pre)
    apply (rule dispatch_all_rule'[of as])
  subgoal unfolding rel_scheduler_def ainv_def by auto
  using spec_dispatch_equal[OF assms]
  unfolding rel_scheduler_def apply auto
  unfolding spec_dispatch_equal[OF assms, symmetric]
  apply (rule ainv_spec_dispatch) by auto

lemma dispatch_all_rule:
  assumes "astate_scheduler.next_mode as \<noteq> NEXT_TICK"
  shows
  "\<lbrace> \<lambda>cs es. rel_scheduler as cs \<and> nil\<^sub>e es \<rbrace>
     dispatch_all
   \<lbrace> \<lambda>_ cs es. rel_scheduler (fst (spec_dispatch as)) cs \<and> es = snd (spec_dispatch as) \<rbrace>!"
  apply (rule validNF_weaken_pre)
  apply (rule validNF_strengthen_post)
   apply (rule dispatch_all_rule''[OF assms])
  unfolding rel_scheduler_def nil_event_def by auto

end

end


theory TransactionBound
  imports Main Semantics PositiveAccounts QuiescentResult ValidState
begin

fun countWhensCaseList :: "Case list \<Rightarrow> nat"
and countWhens :: "Contract \<Rightarrow> nat" where
"countWhensCaseList (Cons (Case _ c) tail) = max (countWhens c) (countWhensCaseList tail)" |
"countWhensCaseList Nil = 0" |
"countWhens Close = 0" |
"countWhens (Pay _ _ _ _ c) = countWhens c" |
"countWhens (If _ c c2) = max (countWhens c) (countWhens c2)" |
"countWhens (When cl t c) = Suc (max (countWhensCaseList cl) (countWhens c))" |
"countWhens (Contract.Let _ _ c) = countWhens c" |
"countWhens (Assert _ c) = Suc (countWhens c)"

fun maxTransactionsCaseList :: "Case list \<Rightarrow> State \<Rightarrow> nat" where
"maxTransactionsCaseList caLi st = Suc (countWhensCaseList caLi)"

fun maxTransactions :: "Contract \<Rightarrow> State \<Rightarrow> nat" where
"maxTransactions c st = (if (isQuiescent c st)
                         then countWhens c
                         else Suc (countWhens c))"

lemma reduceContractStep_quiescent_reduces : "isQuiescent c st \<Longrightarrow>
                                              reduceContractStep env st c = Reduced wa ef nst nc \<Longrightarrow>
                                              countWhens nc < countWhens c"
  apply (induction env st c rule:reduceContractStep.induct)
  apply auto
  by (smt ReduceStepResult.distinct(1) ReduceStepResult.distinct(3) ReduceStepResult.inject Suc_n_not_le_n case_prod_beta le_less_linear max.coboundedI2)

lemma reduceContractStep_not_quiescent_reduces : "\<not> isQuiescent c st \<Longrightarrow>
                                                  reduceContractStep env st c = Reduced wa ef nst nc \<Longrightarrow>
                                                  countWhens nc \<le> countWhens c"
  apply (induction env st c rule:reduceContractStep.induct)
  apply auto
  subgoal for state
    apply (cases "refundOne (accounts state)")
    by (simp_all add: prod.case_eq_if)
  subgoal for env state accId payee token val cont
    apply (cases token)
    subgoal for tok curr
      apply (cases "evalValue env state val \<le> 0")
      apply simp
      apply simp
      apply (cases "let moneyToPay = evalValue env state val;
                        balance = case lookup (accId, Token tok curr) (accounts state) of None \<Rightarrow> 0 | Some x \<Rightarrow> x;
                        paidMoney = min balance moneyToPay
                    in giveMoney accId payee (Token tok curr) paidMoney (if balance \<le> moneyToPay
                                                                         then MList.delete (accId, Token tok curr) (accounts state)
                                                                         else MList.insert (accId, Token tok curr) (balance - paidMoney) (accounts state))")
      apply (simp add:Let_def)
    done
  done
  by (metis ReduceStepResult.inject eq_imp_le)

lemma reduceContractStep_doesnt_increase_maxTransactions : "reduceContractStep env st c = Reduced wa ef nst nc \<Longrightarrow>
                                                            maxTransactions nc nst \<le> maxTransactions c st"
  using reduceContractStep_not_quiescent_reduces reduceContractStep_quiescent_reduces by fastforce

lemma reductionLoop_doesnt_increase_maxTransactions : "reductionLoop reduced env st c wa ef = ContractQuiescent newReduced nwa nef nst nc \<Longrightarrow>
                                                       maxTransactions nc nst \<le> maxTransactions c st"
  apply (induction reduced env st c wa ef rule:reductionLoop.induct)
  subgoal for reduced env state contract warnings payments
    apply (subst (asm) reductionLoop.simps[of reduced env state contract warnings payments])
    apply (cases "reduceContractStep env state contract")
    subgoal for x11 x12 x13 x14
      apply (simp only:ReduceStepResult.simps)
      by (metis dual_order.trans reduceContractStep_doesnt_increase_maxTransactions)
      by simp_all
  done

lemma reductionLoop_reduces_maxTransactions : "validAndPositive_state st \<Longrightarrow>
                                               reductionLoop reduced env st c wa ef = ContractQuiescent newReduced nwa nef nst nc \<Longrightarrow>
                                               (maxTransactions nc nst < maxTransactions c st \<or> (c = nc \<and> reduced = newReduced))"
  apply (induction reduced env st c wa ef rule:reductionLoop.induct)
  subgoal for reduced env state contract warnings payments
    apply (subst (asm) reductionLoop.simps[of reduced env state contract warnings payments])
     apply (cases "reduceContractStep env state contract")
     subgoal for x11 x12 x13 x14
       apply (simp only:ReduceStepResult.simps)
       by (metis le_imp_less_Suc less_le_trans maxTransactions.elims reduceContractStep_doesnt_increase_maxTransactions reduceContractStep_not_quiescent_reduces reduceContractStep_preserves_validAndPositive_state reduceContractStep_quiescent_reduces reductionLoopIsQuiescent)
      apply simp
      by simp
    done

lemma reductionLoop_doesnt_increase_countWhens : "reductionLoop reduced env st c wa ef = ContractQuiescent newReduced nwa nef nst nc \<Longrightarrow>
                                                  countWhens nc \<le> countWhens c"
  apply (induction reduced env st c wa ef rule:reductionLoop.induct)
  subgoal for reduced env state contract warnings payments
    apply (subst (asm) reductionLoop.simps[of reduced env state contract warnings payments])
    apply (cases "reduceContractStep env state contract")
    subgoal for x11 x12 x13 x14
      apply (simp only:ReduceStepResult.simps)
      by (metis le_eq_less_or_eq less_trans reduceContractStep_not_quiescent_reduces reduceContractStep_quiescent_reduces)
      by simp_all
    done

lemma applyCases_doesnt_increase_countWhens :
  "validAndPositive_state st \<Longrightarrow>
   applyCases env sta inp casLi = Applied wa nsta ncon \<Longrightarrow>
   countWhens ncon \<le> countWhensCaseList casLi"
  apply (induction env sta inp casLi rule:applyCases.induct)
  apply (simp only:applyCases.simps)
  apply (smt ApplyResult.inject countWhensCaseList.simps(1) le_refl max.coboundedI1 max.coboundedI2)
  apply (simp only:applyCases.simps)
  apply (metis ApplyResult.inject countWhensCaseList.simps(1) le_refl max.coboundedI1 max.coboundedI2)
  apply (simp only:applyCases.simps)
  apply (metis ApplyResult.inject countWhensCaseList.simps(1) le_refl max.coboundedI1 max.coboundedI2)
  apply (simp only:applyCases.simps)
  by simp_all

lemma applyInput_decreases_countWhens :
  "validAndPositive_state st \<Longrightarrow>
   applyInput env sta inp cont = Applied nwa nsta ncon \<Longrightarrow>
   countWhens ncon < countWhens cont"
  apply (cases cont)
  apply simp
  apply simp
  apply simp
  using applyCases_doesnt_increase_countWhens apply fastforce
  apply simp
  by simp

lemma applyCases_doesnt_increase_maxTransactions :
  "validAndPositive_state st \<Longrightarrow>
   applyCases env sta inp casLi = Applied wa nsta ncon \<Longrightarrow>
   maxTransactions ncon nsta \<le> maxTransactionsCaseList casLi sta"
  by (simp add: applyCases_doesnt_increase_countWhens le_SucI)

lemma applyInput_doesnt_increase_maxTransactions :
  "validAndPositive_state st \<Longrightarrow>
   applyInput env sta inp cont = Applied nwa nsta ncon \<Longrightarrow>
   maxTransactions ncon nsta \<le> maxTransactions cont sta"
  apply (cases cont)
  apply simp
  apply simp
  apply simp
  using applyCases_doesnt_increase_countWhens apply fastforce
  apply simp
  by simp

lemma applyAllLoop_doesnt_increase_maxTransactions :
  "validAndPositive_state sta \<Longrightarrow>
   applyAllLoop reduced env sta cont inpList wa pa = ApplyAllSuccess newReduced nwa npa nsta ncont \<Longrightarrow>
   maxTransactions ncont nsta \<le> maxTransactions cont sta"
  apply (induction inpList arbitrary:reduced env sta cont wa pa)
  subgoal for reduced env sta cont wa pa
  apply (simp only:applyAllLoop.simps[of reduced env sta cont "[]" wa pa] list.case)
  apply (cases "reduceContractUntilQuiescent env sta cont")
  subgoal for x11 x12 x13 x14 x15
    apply (simp only:ReduceResult.case)
    using reductionLoop_doesnt_increase_maxTransactions by auto
    by simp
  subgoal for head tail reduced env sta cont wa pa
    apply (simp only:applyAllLoop.simps[of reduced env sta cont "head # tail" wa pa] list.case)
    apply (cases "reduceContractUntilQuiescent env sta cont")
    subgoal for x11 x12 x13 x14 x15
      apply (simp only:ReduceResult.case)
      apply (cases "applyInput env x14 head x15")
       apply (simp only:ApplyResult.case)
      apply (metis (full_types) applyInput_doesnt_increase_maxTransactions applyInput_preserves_preserves_validAndPositive_state le_trans reduceContractUntilQuiescent.simps reduceContractUntilQuiescent_preserves_validAndPositive_state reductionLoop_doesnt_increase_maxTransactions)
      by simp
    by simp
  done

lemma reduceContractUntilQuiescent_doesnt_increase_countWhens : "validAndPositive_state state \<Longrightarrow>
      reduceContractUntilQuiescent env state contract = ContractQuiescent x11 x12 x13 x14 x15 \<Longrightarrow>
      countWhens x15 \<le> countWhens contract"
  by (simp add: reductionLoop_doesnt_increase_countWhens)

lemma applyAllLoop_doesnt_increase_countWhens :
  "validAndPositive_state sta \<Longrightarrow>
   applyAllLoop reduced env sta cont inpList wa pa = ApplyAllSuccess newReduced nwa npa nsta ncont \<Longrightarrow>
   countWhens ncont \<le> countWhens cont"
  apply (induction reduced env sta cont inpList wa pa rule:applyAllLoop.induct)
  subgoal for reduced env state contract inputs warnings payments
    apply (simp only:applyAllLoop.simps[of reduced env state contract inputs warnings payments])
    apply (cases "reduceContractUntilQuiescent env state contract")
    subgoal for x11 x12 x13 x14 x15
      apply (simp only:ReduceResult.case)
      apply (cases "inputs")
       apply (simp only:list.case)
      apply (simp add: reductionLoop_doesnt_increase_countWhens)
      subgoal for head tail
        apply (simp only:list.case)
        apply (cases "applyInput env x14 head x15")
        apply (simp only:ApplyResult.case)
        apply (smt applyInput_decreases_countWhens applyInput_preserves_preserves_validAndPositive_state leI less_le_trans less_not_refl order.strict_trans reduceContractUntilQuiescent_doesnt_increase_countWhens reduceContractUntilQuiescent_preserves_validAndPositive_state)
        by simp
      done
    by simp
  done

lemma applyAllLoop_decreases_maxTransactions :
  "validAndPositive_state sta \<Longrightarrow>
   applyAllLoop reduced env sta cont inpList wa pa = ApplyAllSuccess newReduced nwa npa nsta ncont \<Longrightarrow>
   maxTransactions ncont nsta < maxTransactions cont sta \<or> (reduced = newReduced)"
  apply (induction reduced env sta cont inpList wa pa rule:applyAllLoop.induct)
  subgoal for reduced env state contract inputs warnings payments
    apply (simp only:applyAllLoop.simps[of reduced env state contract inputs warnings payments] list.case)
    apply (cases "reduceContractUntilQuiescent env state contract")
    subgoal for newReduced rwa rpa rsta rcon
      apply (simp only:ReduceResult.case)
      apply (cases inputs)
      using reductionLoop_reduces_maxTransactions apply fastforce
      apply (simp only:list.case)
      subgoal for head tail
        apply (cases "applyInput env rsta head rcon")
        subgoal for awa asta acon
          apply (simp only:ApplyResult.case)
          apply (cases "isQuiescent contract state")
           apply (simp only:maxTransactions.simps)
          apply (metis (mono_tags) applyAllInputsLoopIsQuiescent applyAllLoop_doesnt_increase_countWhens applyInput_decreases_countWhens applyInput_preserves_preserves_validAndPositive_state max.coboundedI2 max_absorb1 not_le reduceContractUntilQuiescent_doesnt_increase_countWhens reduceContractUntilQuiescent_preserves_validAndPositive_state)
          apply (simp only:maxTransactions.simps if_False)
          by (metis (mono_tags, lifting) applyAllInputsLoopIsQuiescent applyAllLoop_doesnt_increase_countWhens applyInput_decreases_countWhens applyInput_preserves_preserves_validAndPositive_state dual_order.strict_trans1 le_less_trans less_SucI reduceContractUntilQuiescent_doesnt_increase_countWhens reduceContractUntilQuiescent_preserves_validAndPositive_state)
      by simp
      done
    by simp
  done

lemma minTime_doesnt_affect_maxTransactions :
  "maxTransactions cont (sta\<lparr>minTime := y\<rparr>) = maxTransactions cont sta"
  apply (cases cont)
  by simp_all

lemma fixInterval_preserves_maxTransactions :
  "fixInterval interv sta = IntervalTrimmed env fixedState \<Longrightarrow>
   maxTransactions cont fixedState = maxTransactions cont sta"
  apply (cases interv)
  apply (simp only:fixInterval.simps)
  subgoal for left right
    apply (cases "right < left")
    apply simp
    apply (cases "right < minTime sta")
    apply simp
    apply (simp del:maxTransactions.simps add:Let_def)
    using minTime_doesnt_affect_maxTransactions by blast
  done

lemma computeTransaction_decreases_maxTransactions_aux :
  "validAndPositive_state fixedState \<Longrightarrow>
   applyAllInputs env fixedState cont inps = ApplyAllSuccess reduced nwarn npay nstate ncont \<Longrightarrow>
   reduced \<Longrightarrow> maxTransactions ncont nstate < maxTransactions cont fixedState"
  using applyAllLoop_decreases_maxTransactions by fastforce

lemma computeTransaction_decreases_maxTransactions :
  "validAndPositive_state sta \<Longrightarrow>
   computeTransaction tra sta cont = TransactionOutput txOut \<Longrightarrow>
   maxTransactions (txOutContract txOut) (txOutState txOut) < maxTransactions cont sta"
  apply (simp only:computeTransaction.simps)
  apply (cases "fixInterval (interval tra) sta")
  apply (simp only:IntervalResult.case)
  subgoal for env fixedState
    apply (cases "applyAllInputs env fixedState cont (inputs tra)")
    subgoal for newReduced nwarn npay nstate ncont
      apply (cases "\<not> newReduced \<and> (cont = Close \<longrightarrow> accounts sta = [])")
      apply (simp only:Let_def ApplyAllResult.case)
      apply (simp add:refl Let_def)
      apply (simp del:validAndPositive_state.simps fixInterval.simps applyAllInputs.simps maxTransactions.simps)
      by (metis TransactionOutputRecord.select_convs(3) TransactionOutputRecord.select_convs(4) applyAllInputs.simps applyAllInputsIsQuiescent applyAllLoop_doesnt_increase_countWhens computeTransaction_decreases_maxTransactions_aux fixInterval_preserves_maxTransactions fixInterval_preserves_preserves_validAndPositive_state isQuiescent.simps(1) le_neq_implies_less maxTransactions.simps not_less_eq not_less_iff_gr_or_eq)
     apply simp
    by simp
  by simp

lemma playTraceAux_only_accepts_maxTransactions_aux :
  "validAndPositive_state (txOutState txIn) \<Longrightarrow>
   l \<noteq> Nil \<Longrightarrow>
   playTraceAux txIn l = TransactionOutput txOut \<Longrightarrow>
   maxTransactions (txOutContract txOut) (txOutState txOut) < maxTransactions (txOutContract txIn) (txOutState txIn)"
  apply (induction txIn l rule:playTraceAux.induct)
  apply blast
  subgoal for warnings payments state cont h t
    apply (cases "computeTransaction h state cont")
    apply (simp del:validAndPositive_state.simps computeTransaction.simps maxTransactions.simps add:Let_def)
    apply (metis TransactionOutput.inject(1) TransactionOutputRecord.select_convs(3) TransactionOutputRecord.select_convs(4) TransactionOutputRecord.surjective TransactionOutputRecord.update_convs(1) TransactionOutputRecord.update_convs(2) computeTransaction_decreases_maxTransactions computeTransaction_preserves_validAndPositive_state dual_order.strict_trans playTraceAux.simps(1))
    by simp
  done

lemma playTraceAux_only_accepts_maxTransactions :
  "validAndPositive_state (txOutState txIn) \<Longrightarrow>
   playTraceAux txIn tList = TransactionOutput txOut \<Longrightarrow>
   length tList \<le> maxTransactions (txOutContract txIn) (txOutState txIn)"
  apply (induction tList arbitrary: txIn txOut)
  apply simp
  subgoal for head tail txIn txOut
    apply (cases txIn)
    apply (simp only:playTraceAux.simps)
    subgoal for txOutWarningsa txOutPaymentsa txOutStatea txOutContracta
      apply (cases "computeTransaction head txOutStatea txOutContracta")
      apply (simp del:validAndPositive_state.simps computeTransaction.simps maxTransactions.simps add:Let_def)
      apply (metis (mono_tags, lifting) TransactionOutputRecord.select_convs(3) TransactionOutputRecord.select_convs(4) TransactionOutputRecord.surjective TransactionOutputRecord.update_convs(1) TransactionOutputRecord.update_convs(2) computeTransaction_decreases_maxTransactions computeTransaction_preserves_validAndPositive_state le_trans not_le not_less_eq)
      by simp
    done
  done

fun maxTransactionsInitialStateSN :: "int \<Rightarrow> Contract \<Rightarrow> nat" where
  "maxTransactionsInitialStateSN sl c = maxTransactions c (emptyState sl)"

lemma playTrace_only_accepts_maxTransactionsInitialStateSN :
  "playTrace sl c l = TransactionOutput txOut \<Longrightarrow>
   length l \<le> maxTransactionsInitialStateSN sl c"
  apply (simp only:playTrace.simps maxTransactionsInitialStateSN.simps)
  using playTraceAux_only_accepts_maxTransactions validAndPositive_initial_state by force

fun maxTransactionsInitialState :: "Contract \<Rightarrow> nat" where
  "maxTransactionsInitialState (When cl n c) = countWhens (When cl n c)" |
  "maxTransactionsInitialState Close = countWhens Close" |
  "maxTransactionsInitialState cont = Suc (countWhens cont)"

lemma maxTransactionsInitialState_equiv_maxTransactionsInitialStateSN :
  "maxTransactionsInitialStateSN sl c = maxTransactionsInitialState c"
  apply simp
  apply (cases c)
  by (simp_all add:MList.empty_def)

lemma playTrace_only_accepts_maxTransactionsInitialState :
  "playTrace sl c l = TransactionOutput txOut \<Longrightarrow>
   length l \<le> maxTransactionsInitialState c"
  using maxTransactionsInitialState_equiv_maxTransactionsInitialStateSN playTrace_only_accepts_maxTransactionsInitialStateSN by auto

end


theory LTSGA
  imports LTSSpec
  "../..//Collections/Refine_Dflt"
  "../../Collections/ICF/CollectionsV1"
begin

subsection \<open> Copy \<close>

  definition ltsga_copy ::
     "('V,'W,_,'L) lts_it \<Rightarrow> ('V,'W,'L2) lts_empty \<Rightarrow> ('V,'W,'L2) lts_add \<Rightarrow> 'L \<Rightarrow> 'L2"
  where
    "ltsga_copy it emp add l =
     it l (\<lambda>_. True) (\<lambda>(q, a, q') l. add q a q' l)  (emp ())"

  lemma ltsga_copy_correct:
    assumes it_OK: "lts_iterator \<alpha> invar it"
        and emp_OK: "lts_empty \<alpha>2 invar2 emp"
        and add_OK: "lts_add \<alpha>2 invar2 add"
    shows "lts_copy \<alpha> invar \<alpha>2 invar2 (ltsga_copy it emp add)"
  proof (intro lts_copy.intro)
    fix l
    assume invar_l: "invar l"

    have it_OK': "set_iterator (it l) (\<alpha> l)"
      using lts_iterator.lts_it_correct[OF it_OK, OF invar_l] by simp

    note rule = set_iterator_no_cond_rule_insert_P[OF it_OK']

    have "\<alpha>2 (ltsga_copy it emp add l) = \<alpha> l \<and>
          invar2 (ltsga_copy it emp add l)"
      unfolding ltsga_copy_def
    proof (rule rule [where ?I = "\<lambda>L l. L = (\<alpha>2 l) \<and> invar2 l"])
      from lts_empty.lts_empty_correct[OF emp_OK]
      show "{} = \<alpha>2 (emp ()) \<and> invar2 (emp ())" by simp
    next
       fix L l' qaq
       assume "L = \<alpha>2 l' \<and> invar2 l'"
       with lts_add.lts_add_correct[OF add_OK, of l']
       show "insert qaq L = \<alpha>2 ((\<lambda>(q, a, q'). add q a q') qaq l') \<and>
             invar2 ((\<lambda>(q, a, q'). add q a q') qaq l')"
         by (cases qaq) simp
    qed simp
    thus "\<alpha>2 (ltsga_copy it emp add l) = \<alpha> l"
         "invar2 (ltsga_copy it emp add l)" by simp_all
  qed

subsection\<open> get successor \<close>

  definition ltsga_succ where
    "ltsga_succ it l q a = iterate_sel_no_map (it l q a) (\<lambda>_. True)"

  lemma ltsga_succ_alt_def :
     "ltsga_succ it = (\<lambda>l q a. it l q a (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. Some x) None)"
    unfolding ltsga_succ_def[abs_def] iterate_sel_no_map_alt_def by simp

  lemma ltsga_succ_correct :
    assumes succ_it: "lts_succ_it \<alpha> invar it"
    shows "lts_succ \<alpha> invar (ltsga_succ it)"
    proof
      fix l v w
      assume inv_l: "invar l"

      note it_OK = lts_succ_it.lts_succ_it_correct [OF succ_it, OF inv_l]
      note succ_OK = iterate_sel_no_map_correct [OF it_OK, where P = "\<lambda>_. True", folded ltsga_succ_def]

      from succ_OK
      show "ltsga_succ it l v w = None \<Longrightarrow> \<forall>v'. (v, w, v') \<notin> \<alpha> l" by simp

      fix v'
      from succ_OK
      show "ltsga_succ it l v w = Some v' \<Longrightarrow> (v, w, v') \<in> \<alpha> l" by simp
    qed

subsection\<open> add successors \<close>

  lemma ltsga_it_implies_finite :
    "lts_iterator \<alpha> invar it \<Longrightarrow>
     finite_lts \<alpha> invar"
    unfolding finite_lts_def lts_iterator_def
    by (metis set_iterator_finite)

  definition ltsga_add_succs ::
    "('V,'W,'L) lts_add \<Rightarrow> ('V,'W,'L) lts_add_succs" where
    "ltsga_add_succs a v e vs l = foldl (\<lambda>l v'. a v e v' l) l vs"

  lemma ltsga_add_succs_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes add_OK: "lts_add \<alpha> invar a"
    shows "lts_add_succs \<alpha> invar (ltsga_add_succs a)"
  proof
    fix l v e vs
    assume invar: "invar l"

    note add_OK' = lts_add.lts_add_correct [OF add_OK]

    from invar
    have "invar (ltsga_add_succs a v e vs l) \<and>
           (\<alpha> (ltsga_add_succs a v e vs l) =
            \<alpha> l \<union> {(v, e, v') |v'. v' \<in> set vs})"
    unfolding ltsga_add_succs_def
      by (induct vs arbitrary: l)
         (auto simp add: add_OK')
    thus "invar (ltsga_add_succs a v e vs l)"
         "\<alpha> (ltsga_add_succs a v e vs l) =
          \<alpha> l \<union> {(v, e, v') |v'. v' \<in> set vs}"
    by simp_all
  qed

subsection\<open> connection to lists \<close>

  definition ltsga_from_list_aux ::
    "'L \<Rightarrow> ('V,'W,'L) lts_add \<Rightarrow> ('V,'W,'L) lts_from_list"
    where
    "ltsga_from_list_aux l a ll \<equiv> foldl (\<lambda>l vev. a (fst vev) (fst (snd vev)) (snd (snd vev)) l) l ll"

  definition ltsga_from_list ::
    "('V,'W,'L) lts_empty \<Rightarrow> ('V,'W,'L) lts_add \<Rightarrow> ('V,'W,'L) lts_from_list"
    where
    "ltsga_from_list e a ll \<equiv> ltsga_from_list_aux (e ()) a ll"

  lemma ltsga_from_list_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes "lts_empty \<alpha> invar e"
    assumes "lts_add \<alpha> invar a"
    shows "lts_from_list \<alpha> invar (ltsga_from_list e a)"
  proof -
    interpret
      lts_empty \<alpha> invar e +
      lts_add \<alpha> invar a
      by fact+

    {
      fix ll
      have "invar (ltsga_from_list e a ll) \<and>
            \<alpha> (ltsga_from_list e a ll) = set ll"
        unfolding ltsga_from_list_def[abs_def] ltsga_from_list_aux_def[abs_def]
        apply (induct ll rule: rev_induct)
          apply (simp add: lts_empty_correct)
          apply (simp add: lts_add_correct split: prod.split)
      done
    }
    thus ?thesis
      by unfold_locales simp_all
  qed

  lemma dltsga_from_list_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes "lts_empty \<alpha> invar e"
    assumes "dlts_add \<alpha> invar a"
    shows "dlts_from_list \<alpha> invar (ltsga_from_list e a)"
  proof
    interpret
      lts_empty \<alpha> invar e +
      dlts_add \<alpha> invar a
      by fact+

    fix ll :: "('V \<times> 'W \<times> 'V) list"
    assume "\<forall>v w v' v''. (v, w, v') \<in> set ll \<and> (v, w, v'') \<in> set ll \<longrightarrow> v' = v''"
    hence "invar (ltsga_from_list e a ll) \<and> \<alpha> (ltsga_from_list e a ll) = set ll"
      unfolding ltsga_from_list_def[abs_def] ltsga_from_list_aux_def[abs_def]
      proof (induct ll rule: rev_induct)
        case Nil thus ?case by (simp add: lts_empty_correct)
      next
        case (snoc x xs)
        obtain v w v' where x_eq[simp]: "x = (v, w, v')" by (metis prod.exhaust)

        from snoc(2) have dist_xs: "\<forall>v w v' v''. (v, w, v') \<in> set xs \<and> (v, w, v'') \<in> set xs \<longrightarrow> v' = v''"
          apply (simp only: x_eq set_append Un_iff set_simps singleton_iff)
          apply metis
        done

        from snoc(2) have x_nin: "\<And>v''. v'' \<noteq> v' \<Longrightarrow> (v, w, v'') \<notin> set xs"
          apply (simp only: x_eq set_append Un_iff set_simps singleton_iff)
          apply (meson list.set_intros(1))
        done

        let ?l = "foldl (\<lambda>l vev. a (fst vev) (fst (snd vev)) (snd (snd vev)) l) (e()) xs"
        from snoc(1) [OF dist_xs] have ind_hyp: "invar ?l \<and> \<alpha> ?l = set xs" by simp

        from dlts_add_correct[where l="?l" and v=v and e=w and v'=v']
        show ?case
          apply (simp)
          apply (simp add: ind_hyp x_nin)
        done
      qed
      thus "invar (ltsga_from_list e a ll)" "\<alpha> (ltsga_from_list e a ll) = set ll" by simp_all
  qed

  fun ltsga_collect_list_to_list where
     "ltsga_collect_list_to_list [] = []"
   | "ltsga_collect_list_to_list ((v, [], v') # l) =
      ltsga_collect_list_to_list l"
   | "ltsga_collect_list_to_list ((v, w # ws, v') # l) =
      (v, w, v') # (ltsga_collect_list_to_list ((v, ws, v') # l))"

  lemma ltsga_collect_list_to_list_set :
    "set (ltsga_collect_list_to_list ll) = {(v, e, v'). \<exists>es. (v, es, v') \<in> set ll \<and> e \<in> set es} "
  proof (induct ll)
    case Nil thus ?case by auto
  next
    case (Cons vev' ll) note ind_hyp = this
    obtain v ws v' where vev'_eq[simp]: "vev' = (v, ws, v')" by (cases vev', blast)

    show ?case unfolding vev'_eq
      by (induct ws, auto simp add: ind_hyp)
  qed

  definition ltsga_from_collect_list_aux ::
    "'L \<Rightarrow> ('V,'W,'L) lts_add \<Rightarrow> ('V,'W,'L) lts_from_collect_list"
    where
    "ltsga_from_collect_list_aux l a ll \<equiv> ltsga_from_list_aux l a (ltsga_collect_list_to_list ll)"

  definition ltsga_from_collect_list ::
    "('V,'W,'L) lts_empty \<Rightarrow> ('V,'W,'L) lts_add \<Rightarrow> ('V,'W,'L) lts_from_collect_list"
    where
    "ltsga_from_collect_list e a ll \<equiv> ltsga_from_collect_list_aux (e ()) a ll"

  lemma ltsga_from_collect_list_alt_def :
    "ltsga_from_collect_list e a ll \<equiv> ltsga_from_list e a (ltsga_collect_list_to_list ll)"
    unfolding ltsga_from_collect_list_def ltsga_from_list_def ltsga_from_collect_list_aux_def .

  lemma ltsga_from_collect_list_aux_alt_def [code] :
   "ltsga_from_collect_list_aux l a [] = l"
   "ltsga_from_collect_list_aux l a ((v, [], v') # ll) = ltsga_from_collect_list_aux l a ll"
   "ltsga_from_collect_list_aux l a ((v, (w # ws), v') # ll) =
    ltsga_from_collect_list_aux (a v w v' l) a ((v, ws, v') # ll)"
  unfolding ltsga_from_collect_list_aux_def ltsga_from_list_aux_def
  by simp_all

  lemma ltsga_from_collect_list_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes "lts_empty \<alpha> invar e"
    assumes "lts_add \<alpha> invar a"
    shows "lts_from_collect_list \<alpha> invar (ltsga_from_collect_list e a)"
  proof
    fix ll
    note from_list_OK = ltsga_from_list_correct [OF assms]
    note step1 = lts_from_list.lts_from_list_correct [OF from_list_OK, of "ltsga_collect_list_to_list ll",
      folded ltsga_from_collect_list_alt_def]

    from step1 ltsga_collect_list_to_list_set[of ll]
    show "invar (ltsga_from_collect_list e a ll)"
         "\<alpha> (ltsga_from_collect_list e a ll) =
          {(v, e, v'). \<exists>es. (v, es, v') \<in> set ll \<and> e \<in> set es}"
    by simp_all
  qed

  lemma dltsga_from_collect_list_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes "lts_empty \<alpha> invar e"
    assumes "dlts_add \<alpha> invar a"
    shows "dlts_from_collect_list \<alpha> invar (ltsga_from_collect_list e a)"
  proof
    fix ll :: "('V \<times> 'W list \<times> 'V) list"
    note from_list_OK = dltsga_from_list_correct [OF assms]
    note step1 = dlts_from_list.dlts_from_list_correct [OF from_list_OK, of "ltsga_collect_list_to_list ll",
      folded ltsga_from_collect_list_alt_def]

    assume "\<forall>v ws ws' w v' v''.
            (v, ws, v') \<in> set ll \<and> (v, ws', v'') \<in> set ll \<and> w \<in> set ws \<and> w \<in> set ws' \<longrightarrow>
            v' = v''"
    hence "\<forall>v w v' v''.
     (v, w, v') \<in> set (ltsga_collect_list_to_list ll) \<and>
     (v, w, v'') \<in> set (ltsga_collect_list_to_list ll) \<longrightarrow>
     v' = v''" by (simp add: ltsga_collect_list_to_list_set) metis

    with step1
    show "invar (ltsga_from_collect_list e a ll)"
         "\<alpha> (ltsga_from_collect_list e a ll) =
          {(v, e, v'). \<exists>es. (v, es, v') \<in> set ll \<and> e \<in> set es}"
      by (simp_all add: ltsga_collect_list_to_list_set)
  qed

  definition ltsga_to_list ::
    "('V,'W,_,'L) lts_it \<Rightarrow> ('V,'W,'L) lts_to_list"
    where "ltsga_to_list it \<equiv> iterate_to_list \<circ> it"

  lemma ltsga_to_list_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes it_OK: "lts_iterator \<alpha> invar it"
    shows "lts_to_list \<alpha> invar (ltsga_to_list it)"
  proof -
    note it_OK' = lts_iterator.lts_it_correct [OF it_OK]
    note to_list = iterate_to_list_correct [OF it_OK']

    from to_list show ?thesis
      unfolding lts_to_list_def ltsga_to_list_def o_def by simp
  qed

  fun ltsga_list_to_collect_list where
     "ltsga_list_to_collect_list [] = []"
   | "ltsga_list_to_collect_list ((v, e, v') # l) =
      (let (yes, no) = partition (\<lambda>vev'. (fst vev' = v) \<and> (snd (snd vev') = v')) l in
       (v, e # (map (fst \<circ> snd) yes), v') # (ltsga_list_to_collect_list no))"

  lemma ltsga_list_to_collect_list_props :
    "distinct (ltsga_list_to_collect_list (l::('V \<times> 'W \<times> 'V) list)) \<and>
     set (ltsga_list_to_collect_list l) = {(v, es, v') .
     (es \<noteq> [] \<and> es = (map (fst \<circ> snd) (filter (\<lambda>vev'. (fst vev' = v) \<and> (snd (snd vev') = v')) l)))}"
     (is "?P l")
  proof (rule length_induct[of _ l])
    fix l :: "('V \<times> 'W \<times> 'V) list"
    assume ind_hyp: "\<forall>l'. length l' < length l \<longrightarrow> ?P l'"
    show "?P l"
    proof (cases l)
      case Nil thus ?thesis by simp
    next
      case (Cons vev' l') note l_eq[simp] = this
      obtain v e v' where vev'_eq [simp]: "vev' = (v, e, v')" by (cases vev', blast)

      define yes where "yes \<equiv> [vev'\<leftarrow>l' . fst vev' = v \<and> snd (snd vev') = v']"
      define no where "no \<equiv> filter (Not \<circ> (\<lambda>vev'. fst vev' = v \<and> snd (snd vev') = v')) l'"

      have step: "ltsga_list_to_collect_list l =
          (v, e # map (fst \<circ> snd) yes, v') # ltsga_list_to_collect_list no"
        by (simp add: yes_def[symmetric] no_def[symmetric])

      have "length no \<le> length l'" unfolding no_def by (rule length_filter_le)
      hence pre_no: "length no < length l" by simp
      from pre_no ind_hyp have ind_hyp_no: "?P no" by simp

      have aux: "\<And>a b. v \<noteq> a \<or> v' \<noteq> b \<Longrightarrow> map (\<lambda>a. fst (snd a))
         [x\<leftarrow>l' .
         (fst x = v \<longrightarrow> snd (snd x) \<noteq> v') \<and>
         fst x = a \<and> snd (snd x) = b] =
       map (\<lambda>a. fst (snd a))
        [vev'\<leftarrow>l' . fst vev' = a \<and> snd (snd vev') = b]"
        by (induct l', auto)

      show ?thesis
        unfolding step
        apply (simp add: ind_hyp_no)
        apply (simp add: no_def yes_def set_eq_iff)
        apply (auto simp add: aux)
      done
    qed
  qed

  lemma ltsga_list_to_collect_list_props2 :
    "set l = {(v::'V, e::'W, v'::'V). \<exists>es. (v, es, v') \<in> set (ltsga_list_to_collect_list l) \<and> e \<in> set es}"
    "distinct (map (\<lambda>vesv'. (fst vesv', snd (snd vesv'))) (ltsga_list_to_collect_list l))"
    "(v, es, v') \<in> set (ltsga_list_to_collect_list l) \<longleftrightarrow>
     (es \<noteq> [] \<and> es = (map (fst \<circ> snd) (filter (\<lambda>vev'. (fst vev' = v) \<and> (snd (snd vev') = v')) l)))"
    by (auto simp add: ltsga_list_to_collect_list_props image_iff filter_empty_conv Bex_def
                       distinct_map inj_on_def)

  definition ltsga_to_collect_list ::
    "('V,'W,'L) lts_to_list \<Rightarrow> ('V,'W,'L) lts_to_collect_list"
    where "ltsga_to_collect_list to_list l \<equiv> ltsga_list_to_collect_list (to_list l)"

  lemma ltsga_to_collect_list_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes to_list_OK: "lts_to_list \<alpha> invar to_list"
    shows "lts_to_collect_list \<alpha> invar (ltsga_to_collect_list to_list)"
  proof
    fix l
    assume "invar l"
    note to_list_OK = lts_to_list.lts_to_list_correct [OF to_list_OK, OF `invar l`]
    note props = ltsga_list_to_collect_list_props [of "to_list l"]
    note props2 = ltsga_list_to_collect_list_props2 [of "to_list l"]

    from props2
    show "\<alpha> l =
        {(v, e, v').
         \<exists>es. (v, es, v') \<in> set (ltsga_to_collect_list to_list l) \<and>
              e \<in> set es}"
        "distinct (map (\<lambda>vesv'. (fst vesv', snd (snd vesv')))
           (ltsga_to_collect_list to_list l))"
      unfolding ltsga_to_collect_list_def
      by (simp_all add: to_list_OK)

    { fix v es v'
      assume "(v, es, v') \<in> set (ltsga_to_collect_list to_list l)"
      with props show "es \<noteq> []"
        unfolding ltsga_to_collect_list_def
        by (auto simp add: to_list_OK)
    }
  qed

subsection\<open> reverse \<close>

  definition ltsga_reverse ::
    "('V, 'W, 'L2) lts_empty \<Rightarrow>
     ('V, 'W, 'L2) lts_add \<Rightarrow>
     ('V,'W,_,'L1) lts_it \<Rightarrow> ('V,'W,'L1,'L2) lts_reverse"
    where "ltsga_reverse e a it l \<equiv>
           it l (\<lambda>_. True) (\<lambda>(v, e, v') l'. a v' e v l') (e ())"

  lemma ltsga_reverse_correct :
    fixes \<alpha>1 :: "('V,'W,'L1) lts_\<alpha>"
    fixes \<alpha>2 :: "('V,'W,'L2) lts_\<alpha>"
    assumes "lts_empty \<alpha>2 invar2 e"
    assumes "lts_add \<alpha>2 invar2 a"
    assumes "lts_iterator \<alpha>1 invar1 it"
    shows "lts_reverse \<alpha>1 invar1 \<alpha>2 invar2 (ltsga_reverse e a it)"
  proof -
    interpret
      lts_empty \<alpha>2 invar2 e +
      lts_add \<alpha>2 invar2 a +
      lts_iterator \<alpha>1 invar1 it
      by fact+

    {
      fix l
      assume invar_l: "invar1 l"
      have "invar2 (ltsga_reverse e a it l) \<and>
            \<alpha>2 (ltsga_reverse e a it l) = {(v', e, v) |v e v'. (v, e, v') \<in> \<alpha>1 l}"
        unfolding ltsga_reverse_def
        apply (rule_tac set_iterator_no_cond_rule_P[OF lts_it_correct, where
                 ?I="\<lambda>it \<sigma>. invar2 \<sigma> \<and>
                             \<alpha>2 \<sigma> = {(v', e, v) |v e v'. (v, e, v') \<in> (\<alpha>1 l) - it}"])
        apply (auto simp add: lts_add_correct lts_empty_correct invar_l)
      done
    }
    thus ?thesis
      by unfold_locales simp_all
  qed

subsection\<open> Quantifiers \<close>

  definition "ltsga_succ_ball it l P v e \<equiv> iterate_ball (it l v e) P"
  definition "ltsga_succ_bex it l P v e \<equiv> iterate_bex (it l v e) P"
  definition "ltsga_pre_ball it l P v' e \<equiv> iterate_ball (it l v' e) P"
  definition "ltsga_pre_bex it l P v' e \<equiv> iterate_bex (it l v' e) P"

  lemma ltsga_succ_ball_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes it_OK: "lts_succ_it \<alpha> invar it"
    shows "lts_succ_ball \<alpha> invar (ltsga_succ_ball it)"
  proof -
    note step1 = lts_succ_it.lts_succ_it_correct [OF it_OK]
    note step2 = iterate_ball_correct [OF step1]
    thus ?thesis
      unfolding lts_succ_ball_def ltsga_succ_ball_def by simp
  qed

  lemma ltsga_succ_bex_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes it_OK: "lts_succ_it \<alpha> invar it"
    shows "lts_succ_bex \<alpha> invar (ltsga_succ_bex it)"
  proof -
    note step1 = lts_succ_it.lts_succ_it_correct [OF it_OK]
    note step2 = iterate_bex_correct [OF step1]
    thus ?thesis
      unfolding lts_succ_bex_def ltsga_succ_bex_def by simp
  qed

  lemma ltsga_pre_ball_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes it_OK: "lts_pre_it \<alpha> invar it"
    shows "lts_pre_ball \<alpha> invar (ltsga_pre_ball it)"
  proof -
    note step1 = lts_pre_it.lts_pre_it_correct [OF it_OK]
    note step2 = iterate_ball_correct [OF step1]
    thus ?thesis
      unfolding lts_pre_ball_def ltsga_pre_ball_def by simp
  qed

  lemma ltsga_pre_bex_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes it_OK: "lts_pre_it \<alpha> invar it"
    shows "lts_pre_bex \<alpha> invar (ltsga_pre_bex it)"
  proof -
    note step1 = lts_pre_it.lts_pre_it_correct [OF it_OK]
    note step2 = iterate_bex_correct [OF step1]
    thus ?thesis
      unfolding lts_pre_bex_def ltsga_pre_bex_def by simp
  qed

subsection\<open> iterators \<close>

  definition ltsga_iterator where
    "ltsga_iterator it = it (\<lambda>_. True) (\<lambda>_. True) (\<lambda>_. True) (\<lambda>_. True)"

  lemma ltsga_iterator_correct:
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes it_OK: "lts_filter_it \<alpha> invar it"
    shows "lts_iterator \<alpha> invar (ltsga_iterator it)"
  proof (rule lts_iterator.intro)
    fix l
    assume "invar l"

    from lts_filter_it.lts_filter_it_correct [OF it_OK, OF `invar l`,
      of "\<lambda>_. True" "\<lambda>_. True" "\<lambda>_. True" "\<lambda>_. True", folded ltsga_iterator_def]
    show "set_iterator (ltsga_iterator it l) (\<alpha> l)" by simp
  qed

subsection\<open> image and filter \<close>

  definition ltsga_image_filter where
    "ltsga_image_filter e a it f P_v1 P_e P_v2 P l =
      (it::('V,'W,'\<sigma>,'L) lts_filter_it) P_v1 P_e P_v2 P l (\<lambda>_. True)
      (\<lambda>vev l. let (v, e, v') = f vev in a v e v' l) (e ())"

  definition ltsga_filter where
    "ltsga_filter e a it = ltsga_image_filter e a it id"

  lemma ltsga_image_filter_correct :
    fixes \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>"
    fixes \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>"
    assumes "lts_empty \<alpha>2 invar2 e"
    assumes "lts_add \<alpha>2 invar2 a"
    assumes "lts_filter_it \<alpha>1 invar1 it"
    shows "lts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 (ltsga_image_filter e a it)"
  proof
    interpret
      lts_empty \<alpha>2 invar2 e +
      lts_add \<alpha>2 invar2 a +
      lts_filter_it \<alpha>1 invar1 it
      by fact+

    fix l P_v1 P_e P_v2 P and f :: "('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)"
    assume invar: "invar1 l"

    have it: "set_iterator (it P_v1 P_e P_v2 P l)
                {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"
      using lts_filter_it_correct [of l P_v1 P_e P_v2 P, OF invar] .

    let ?I = "\<lambda>S \<sigma>. invar2 \<sigma> \<and> \<alpha>2 \<sigma> = f ` S"

    have "?I {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}
             (ltsga_image_filter e a it f P_v1 P_e P_v2 P l)"
      unfolding ltsga_image_filter_def
      apply (rule set_iterator_no_cond_rule_insert_P [OF it, where I = "?I"])
      apply (simp_all add: lts_empty_correct lts_add_correct Let_def split: prod.splits)
    done
    thus "invar2 (ltsga_image_filter e a it f P_v1 P_e P_v2 P l)"
         "\<alpha>2 (ltsga_image_filter e a it f P_v1 P_e P_v2 P l) =
          f ` {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"
      by simp_all
  qed

  lemma ltsga_filter_correct :
    fixes \<alpha> :: "('V1,'W1,'L1) lts_\<alpha>"
    assumes e_OK: "lts_empty \<alpha> invar e"
    assumes a_OK: "lts_add \<alpha> invar a"
    assumes it_OK: "lts_filter_it \<alpha> invar it"
    shows "lts_filter \<alpha> invar (ltsga_filter e a it)"
    using ltsga_image_filter_correct [OF e_OK a_OK it_OK]
    unfolding lts_filter_def lts_image_filter_def ltsga_filter_def
    by simp

  lemma dltsga_image_filter_correct :
    fixes \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>"
    fixes \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>"
    assumes "lts_empty \<alpha>2 invar2 e"
    assumes "dlts_add \<alpha>2 invar2 a"
    assumes "lts_filter_it \<alpha>1 invar1 it"
    shows "dlts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 (ltsga_image_filter e a it)"
  proof
    interpret
      lts_empty \<alpha>2 invar2 e +
      dlts_add \<alpha>2 invar2 a +
      lts_filter_it \<alpha>1 invar1 it
      by fact+

    fix l P_v1 P_e P_v2 P and f :: "('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)"
    assume invar: "invar1 l"
       and weak_det: "LTS_is_deterministic (f ` {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)})"

    define D where "D \<equiv> {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

    have it: "set_iterator (it P_v1 P_e P_v2 P l) D"
      using lts_filter_it_correct [of l P_v1 P_e P_v2 P, OF invar] unfolding D_def .

    let ?I = "\<lambda>S \<sigma>. invar2 \<sigma> \<and> \<alpha>2 \<sigma> = f ` S"

    have "?I D (ltsga_image_filter e a it f P_v1 P_e P_v2 P l)"
      unfolding ltsga_image_filter_def
      apply (rule set_iterator_no_cond_rule_insert_P [OF it, where I = "?I"])
      apply (simp_all add: lts_empty_correct Let_def split: prod.splits)
      apply clarify
      apply (rename_tac S \<sigma> v1 w v2 v1' w' v2')
      proof -
        fix S \<sigma> v1 w v2 v1' w' v2'
        assume "S \<subseteq> D" and in_D: "(v1, w, v2) \<in> D" and "(v1, w, v2) \<notin> S" and
               invar: "invar2 \<sigma>" and \<alpha>2_\<sigma>: "\<alpha>2 \<sigma> = f ` S" and
               f_eq: "f (v1, w, v2) = (v1', w', v2')"

        { fix v''
          assume "(v1', w', v'') \<in> \<alpha>2 \<sigma>"
          with \<alpha>2_\<sigma> `S \<subseteq> D` have "(v1', w', v'') \<in> f ` D" by auto
          moreover
            from in_D f_eq have "(v1', w', v2') \<in> f ` D" by (simp add: image_iff Bex_def) metis
          ultimately have "v'' = v2'"
            using weak_det[folded D_def]
            unfolding LTS_is_deterministic_def by metis
        } note dist = this

        from dlts_add_correct[OF invar, of v2' v1' w'] dist \<alpha>2_\<sigma>
        show "invar2 (a v1' w' v2' \<sigma>) \<and> \<alpha>2 (a v1' w' v2' \<sigma>) = insert (v1', w', v2') (f ` S)"
          by metis
      qed

    thus "invar2 (ltsga_image_filter e a it f P_v1 P_e P_v2 P l)"
         "\<alpha>2 (ltsga_image_filter e a it f P_v1 P_e P_v2 P l) =
          f ` {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"
      by (simp_all add: D_def[symmetric])
  qed

  lemma dltsga_inj_image_filter_correct :
    fixes \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>"
    fixes \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>"
    assumes e_OK: "lts_empty \<alpha>2 invar2 e"
    assumes a_OK: "dlts_add \<alpha>2 invar2 a"
    assumes it_OK: "lts_filter_it \<alpha>1 invar1 it"
    assumes dlts: "dlts \<alpha>1 invar1"
    shows "lts_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 (ltsga_image_filter e a it)"
  proof
    interpret
      dlts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 "ltsga_image_filter e a it"
      using dltsga_image_filter_correct [OF e_OK a_OK it_OK] .

    fix l P_v1 P_e P_v2 P and f :: "('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)"
    assume invar: "invar1 l"
       and f_inj_on: "LTS_image_filter_inj_on f {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

    define D where "D \<equiv> {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

    have D_subset: "D \<subseteq> \<alpha>1 l" unfolding D_def by (simp add: subset_iff)
    from dlts invar have weak_det: "LTS_is_deterministic (\<alpha>1 l)"
      unfolding dlts_def by simp

    have weak_det': "LTS_is_deterministic (f ` D)"
    proof
      fix v1 w1 v2 v3
      assume v2_in: "(v1, w1, v2) \<in> f ` D"
      assume v3_in: "(v1, w1, v3) \<in> f ` D"

      from v2_in obtain v1' w1' v2' where
         v2_in': "(v1', w1', v2') \<in> D" and f_v2: "f (v1', w1', v2') = (v1, w1, v2)" by auto
      from v3_in obtain v1'' w1'' v3'' where
         v3_in': "(v1'', w1'', v3'') \<in> D" and f_v3: "f (v1'', w1'', v3'') = (v1, w1, v3)" by auto

      from f_inj_on f_v3 f_v2 v2_in' v3_in' have v1''_eq[simp]: "v1'' = v1'"  and w1''_eq[simp]: "w1'' = w1'"
        unfolding LTS_image_filter_inj_on_def[abs_def] D_def[symmetric]
        by (simp_all add: Bex_def Ball_def)

      with weak_det D_subset v2_in' v3_in' have v3''_eq[simp]: "v3'' = v2'"
        unfolding LTS_is_deterministic_def by (simp add: subset_iff) metis

      from f_v2 f_v3 show "v2 = v3" by simp
    qed

    from dlts_image_filter_correct [OF invar, of f P_v1 P_e P_v2 P, folded D_def, OF weak_det']
    show "invar2 (ltsga_image_filter e a it f P_v1 P_e P_v2 P l)"
         "\<alpha>2 (ltsga_image_filter e a it f P_v1 P_e P_v2 P l) =
          f ` {(v1, e, v2). (v1, e, v2) \<in> \<alpha>1 l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"
      by (simp_all add: D_def[symmetric])
  qed

  lemma dltsga_filter_correct :
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes e_OK: "lts_empty \<alpha> invar e"
    assumes a_OK: "dlts_add \<alpha> invar a"
    assumes it_OK: "lts_filter_it \<alpha> invar it"
    assumes dlts: "dlts \<alpha> invar"
    shows "lts_filter \<alpha> invar (ltsga_filter e a it)"
    using dltsga_inj_image_filter_correct [OF e_OK a_OK it_OK dlts]
    unfolding lts_filter_def lts_inj_image_filter_def ltsga_filter_def
    by (simp add: LTS_image_filter_inj_on_id)

  definition ltsga_image where
    "ltsga_image imf f = imf f (\<lambda>_. True) (\<lambda>_. True) (\<lambda>_. True) (\<lambda>_. True)"

  lemma ltsga_image_correct :
    "lts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 imf \<Longrightarrow>
     lts_image \<alpha>1 invar1 \<alpha>2 invar2 (ltsga_image imf)"
  unfolding lts_image_filter_def lts_image_def ltsga_image_def by simp

  lemma dltsga_image_correct :
    "dlts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 imf \<Longrightarrow>
     dlts_image \<alpha>1 invar1 \<alpha>2 invar2 (ltsga_image imf)"
  unfolding dlts_image_filter_def dlts_image_def ltsga_image_def by simp

subsection \<open> All successors of a set \<close>

  text \<open> Iterators visit each element exactly once.
          For getting all the successors of a set of nodes, it is therefore benefitial
          to collect the successors in a set and then later iterate over this set. \<close>

  definition ltsga_set_succs where
    "ltsga_set_succs
       (v_ops :: ('V, 'V_set, _) set_ops_scheme)
       (succ_it :: ('V,'W,'V_set,'L) lts_succ_it)
       (v_it :: ('V_set2 \<Rightarrow> ('V,'V_set) set_iterator))
       (d :: 'L)
       V e =
     (v_it V (\<lambda>_. True) (\<lambda>v. succ_it d v e (\<lambda>_. True) (set_op_ins v_ops)) (set_op_empty v_ops ()))"

(* Unused in Cava, hence not ported
  lemma ltsga_set_succs_correct :
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
      and v_ops :: "('V, 'V_set, _) set_ops_scheme"
      and v2_ops :: "('V, 'V_set2, _) set_ops_scheme"
      and succ_it :: "('V,'W,'V_set,'L) lts_succ_it"
      and v_it :: "'V_set2 \<Rightarrow> ('V,'V_set) set_iterator"
      and e V
    assumes succ_it_OK: "lts_succ_it \<alpha> invar succ_it"
        and set_OK: "StdSet v_ops"
        and set_OK2: "StdSet v_ops2"
        and it_OK: "poly_set_iteratei
          (set_op_\<alpha> v_ops2) (set_op_invar v_ops2) v_it"
        and invar_d: "invar d"
        and invar_V: "set_op_invar v_ops2 V"
    defines "res \<equiv> ltsga_set_succs v_ops succ_it v_it d V e"
    shows "set_op_invar v_ops res"
          "set_op_\<alpha> v_ops res = {v' |v v'. (v, e, v') \<in> \<alpha> d \<and> v \<in> set_op_\<alpha> v_ops2 V}"
   proof -
     interpret v: StdSet v_ops by fact
     interpret v2: StdSet v_ops2 by fact

     def inner \<equiv> "\<lambda>v s. succ_it d v e (\<lambda>_. True) (\<lambda>x s. v.ins x s) s"

     from lts_succ_it.lts_succ_it_correct[OF succ_it_OK, OF invar_d, of _ e]
     have succ_it_OK': "\<And>v. set_iterator (succ_it d v e) {v' |v'. (v, e, v') \<in> \<alpha> d}"
       by simp

     { fix v s
       assume invar_s: "v.invar s"

       let ?I = "\<lambda>S \<sigma>. v.invar \<sigma> \<and> v.\<alpha> \<sigma> = v.\<alpha> s \<union> S"

       have "?I {v' . (v, e, v') \<in> \<alpha> d} (inner v s)"
         apply (unfold inner_def)
         apply (rule set_iterator_no_cond_rule_insert_P [OF succ_it_OK', where I = ?I])
         apply (simp_all add: invar_s v.correct)
       done
     } note inner_OK = this

     thm it_OK

     let ?I2 = "\<lambda>S \<sigma>. v.invar \<sigma> \<and> v.\<alpha> \<sigma> = {v' |v v'. (v, e, v') \<in> \<alpha> d \<and> v \<in> S}"
     have "?I2 (v2.\<alpha> V) (v_it V (\<lambda>_. True) (\<lambda>v s. inner v s) (v.empty ()))"

       thm it_OK
       thm set_iterate.iterate_rule_insert_P

       apply (rule set_iteratei.iteratei_rule_insert_P [OF it_OK, OF invar_V, where I = ?I2])
       apply (simp_all add: v.correct inner_OK)
       apply auto
     done

     thus "v.invar res"
          "v.\<alpha> res = {v' |v v'. (v, e, v') \<in> \<alpha> d \<and> v \<in> v2.\<alpha> V}"
       unfolding inner_def res_def ltsga_set_succs_def
       by simp_all
  qed
*)

end