section {*FUNCTION\_\_DPDA\_EA\_OPT\_\_DPDA\_ENFORCE\_ACCESSIBLE\_OPT\_EXT*}
theory
  FUNCTION__DPDA_EA_OPT__DPDA_ENFORCE_ACCESSIBLE_OPT_EXT

imports
  PRJ_13_04__ENTRY

begin

definition F_DPDA_EA_OPT__SpecInput2 :: "
  ((((('stateA, 'stateB) DT_tuple2), 'stackA) DT_state_and_stack_or_state) DT_state_or_state, 'event, 'stackA) epda
  \<Rightarrow> ('stateB, 'event, 'stackB) epda
  \<Rightarrow> bool"
  where
    "F_DPDA_EA_OPT__SpecInput2 G D \<equiv>
  valid_dpda G
  \<and> nonblockingness_language (epdaS.unmarked_language G) (epdaS.marked_language G)
  \<and> state_stack_unique_for_marking_states G
  \<and> only_executing_edges_from_marking_states G
  \<and> \<not> epdaH_livelock G
  \<and> epdaH_reflection_to_DFA_exists G D (sel_tuple2_2 \<circ> F_DPDA_OTS__get_state \<circ> F_DPDA_EUML__get_state)
  \<and> corresponds_to_top_stack G F_DPDA_EUML__is_auxiliary F_DPDA_EUML__get_stack
  \<and> main_states_have_only_empty_steps G F_DPDA_EUML__is_main
  \<and> main_states_have_all_empty_steps G F_DPDA_EUML__is_main
  \<and> executing_edge_from_auxiliary_to_main_state G F_DPDA_EUML__is_auxiliary F_DPDA_EUML__is_main
  \<and> always_applicable_for_auxiliary_states G F_DPDA_EUML__is_auxiliary
  \<and> main_to_auxiliary_or_auxiliary_to_main G F_DPDA_EUML__is_main"

definition main_states_can_be_left_with_empty_step :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> ('state \<Rightarrow> bool)
  \<Rightarrow> bool"
  where
    "main_states_can_be_left_with_empty_step R F \<equiv>
  \<forall>c \<in> epdaH.get_accessible_configurations R.
    F (epdaH_conf_state c)
    \<longrightarrow>
      (\<exists>e.
        e \<in> epda_delta R
        \<and> edge_src e = epdaH_conf_state c
        \<and> edge_pop e = [hd (epdaH_conf_stack c)]
        \<and> edge_event e = None)"

definition F_DPDA_EA_OPT__SpecOutput2 :: "
  ((((('stateA, 'stateB) DT_tuple2), 'stackA) DT_state_and_stack_or_state) DT_state_or_state, 'event, 'stackA) epda
  \<Rightarrow> (('stateB, 'event, 'stackB) epda \<times> 'event set)
  \<Rightarrow> ((((('stateA, 'stateB) DT_tuple2), 'stackA) DT_state_and_stack_or_state) DT_state_or_state, 'event, 'stackA) epda
  \<Rightarrow> bool"
  where
    "F_DPDA_EA_OPT__SpecOutput2 Gi X Go \<equiv>
  case X of
  (D, \<Sigma>UC) \<Rightarrow>
    valid_dpda Go
    \<and> epdaS.marked_language Gi = epdaS.marked_language Go
    \<and> epdaS.unmarked_language Gi = epdaS.unmarked_language Go
    \<and> nonblockingness_language (epdaS.unmarked_language Go) (epdaS.marked_language Go)
    \<and> state_stack_unique_for_marking_states Go
    \<and> only_executing_edges_from_marking_states Go
    \<and> \<not> epdaH_livelock Go
    \<and> epdaH_reflection_to_DFA_exists Go D (sel_tuple2_2 \<circ> F_DPDA_OTS__get_state \<circ> F_DPDA_EUML__get_state)
    \<and> corresponds_to_top_stack Go F_DPDA_EUML__is_auxiliary F_DPDA_EUML__get_stack
    \<and> epdaH.accessible Go
    \<and> main_states_can_be_left_with_empty_step Go F_DPDA_EUML__is_main
    \<and> main_states_have_only_empty_steps Go F_DPDA_EUML__is_main
    \<and> executing_edge_from_auxiliary_to_main_state Go F_DPDA_EUML__is_auxiliary F_DPDA_EUML__is_main
    \<and> always_applicable_for_auxiliary_states Go F_DPDA_EUML__is_auxiliary
    \<and> main_to_auxiliary_or_auxiliary_to_main Go F_DPDA_EUML__is_main"

lemma epda_sub_preserves_state_stack_unique_for_marking_states: "
  valid_epda G1
  \<Longrightarrow> valid_epda G2
  \<Longrightarrow> epda_sub G1 G2
  \<Longrightarrow> state_stack_unique_for_marking_states G2
  \<Longrightarrow> state_stack_unique_for_marking_states G1"
  apply(simp add: state_stack_unique_for_marking_states_def state_stack_unique_def)
  apply(clarsimp)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(erule_tac
      x="d1"
      in allE)
  apply(erule impE)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(rule epda_sub_preserves_derivation_initial)
      apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
      apply(force)
     apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
     apply(force)
    apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
    apply(force)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(force)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(erule_tac
      x="d2"
      in allE)
  apply(erule impE)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(rule epda_sub_preserves_derivation_initial)
      apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
      apply(force)
     apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
     apply(force)
    apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
    apply(force)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(force)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(erule_tac
      x="e1"
      in allE)
  apply(erule_tac
      x="e2"
      in allE)
  apply(erule_tac
      x="c1"
      in allE)
  apply(erule impE)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(force)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(erule_tac
      x="c2"
      in allE)
  apply(erule impE)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(force)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(erule impE)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(force)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(erule impE)
   apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
   apply(simp add: epda_sub_def)
   apply(force)
  apply(rename_tac d1 d2 e1 e2 c1 n1 c2 n2)(*strict*)
  apply(force)
  done

theorem F_DPDA_EA_OPT__preserves_state_stack_unique_for_marking_states: "
  valid_epda G
  \<Longrightarrow> state_stack_unique_for_marking_states G
  \<Longrightarrow> state_stack_unique_for_marking_states (F_DPDA_EA_OPT G)"
  apply(rule epda_sub_preserves_state_stack_unique_for_marking_states)
     apply(simp add: F_DPDA_EA_OPT_def F_EPDA_RE_def)
     apply(rule F_EPDA_R_preserves_valid_epda)
       apply(force)
      prefer 2
      apply(force)
     apply(force)
    apply(force)
   apply(rule F_DPDA_EA_OPT__constructs_epda_sub)
   apply(force)
  apply(force)
  done

lemma epda_sub_preserves_only_executing_edges_from_marking_states: "
  valid_epda G
  \<Longrightarrow> epda_sub G1 G2
  \<Longrightarrow> only_executing_edges_from_marking_states G2
  \<Longrightarrow> only_executing_edges_from_marking_states G1"
  apply(simp add: only_executing_edges_from_marking_states_def)
  apply(clarsimp)
  apply(rename_tac e)(*strict*)
  apply(simp add: epda_sub_def)
  apply(clarsimp)
  apply(force)
  done

theorem F_DPDA_EA_OPT__preserves_only_executing_edges_from_marking_states: "
  valid_epda G
  \<Longrightarrow> only_executing_edges_from_marking_states G
  \<Longrightarrow> only_executing_edges_from_marking_states (F_DPDA_EA_OPT G)"
  apply(rule epda_sub_preserves_only_executing_edges_from_marking_states)
    apply(force)
   apply(rule F_DPDA_EA_OPT__constructs_epda_sub)
   apply(force)
  apply(force)
  done

lemma epda_sub_preserves_epdaH_reflection_to_DFA_exists: "
  valid_epda G1
  \<Longrightarrow> valid_epda G2
  \<Longrightarrow> epda_sub G1 G2
  \<Longrightarrow> epdaH_reflection_to_DFA_exists G2 D f
  \<Longrightarrow> epdaH_reflection_to_DFA_exists G1 D f"
  apply(simp add: epdaH_reflection_to_DFA_exists_def)
  apply(clarsimp)
  apply(rename_tac d n c)(*strict*)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule impE)
   apply(rename_tac d n c)(*strict*)
   apply(rule epda_sub_preserves_derivation_initial)
      apply(rename_tac d n c)(*strict*)
      prefer 3
      apply(force)
     apply(rename_tac d n c)(*strict*)
     apply(force)
    apply(rename_tac d n c)(*strict*)
    apply(force)
   apply(rename_tac d n c)(*strict*)
   apply(force)
  apply(rename_tac d n c)(*strict*)
  apply(erule_tac
      x="n"
      in allE)
  apply(erule_tac
      x="c"
      in allE)
  apply(erule impE)
   apply(rename_tac d n c)(*strict*)
   apply(simp add: get_configuration_def)
  apply(rename_tac d n c)(*strict*)
  apply(clarsimp)
  done

theorem F_DPDA_EA_OPT__preserves_epdaH_reflection_to_DFA_exists: "
  valid_dpda M
  \<Longrightarrow> epdaH_reflection_to_DFA_exists M D f
  \<Longrightarrow> R = F_DPDA_EA_OPT M
  \<Longrightarrow> epdaH_reflection_to_DFA_exists R D f"
  apply(rule_tac
      ?G1.0="R"
      and ?G2.0="M"
      in epda_sub_preserves_epdaH_reflection_to_DFA_exists)
     apply(simp add: F_DPDA_EA_OPT_def F_EPDA_RE_def)
     apply(rule F_EPDA_R_preserves_valid_epda)
       apply(simp add: valid_dpda_def valid_pda_def)
       apply(force)
      prefer 2
      apply(force)
     apply(force)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(clarsimp)
   apply(rule F_DPDA_EA_OPT__constructs_epda_sub)
   apply(simp add: valid_dpda_def valid_pda_def)
  apply(simp add: valid_dpda_def valid_pda_def)
  done

theorem F_DPDA_EA_OPT__preserves_corresponds_to_top_stack: "
  valid_epda G
  \<Longrightarrow> corresponds_to_top_stack G F_DPDA_EUML__is_auxiliary F_DPDA_EUML__get_stack
  \<Longrightarrow> Go = F_DPDA_EA_OPT G
  \<Longrightarrow> corresponds_to_top_stack Go F_DPDA_EUML__is_auxiliary F_DPDA_EUML__get_stack"
  apply(simp add: corresponds_to_top_stack_def)
  apply(clarsimp)
  apply(rename_tac d n c X)(*strict*)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule impE)
   apply(rename_tac d n c X)(*strict*)
   apply(rule epda_sub_preserves_derivation_initial)
      apply(rename_tac d n c X)(*strict*)
      prefer 4
      apply(force)
     apply(rename_tac d n c X)(*strict*)
     apply(simp add: F_DPDA_EA_OPT_def F_EPDA_RE_def)
     apply(rule F_EPDA_R_preserves_valid_epda)
       apply(simp add: valid_dpda_def valid_pda_def)
      prefer 2
      apply(force)
     apply(force)
    apply(force)
   apply(rule F_DPDA_EA_OPT__constructs_epda_sub)
   apply(simp add: valid_dpda_def valid_pda_def)
  apply(simp add: valid_dpda_def valid_pda_def)
  done

theorem F_DPDA_EA_OPT__transforms_main_states_have_all_empty_steps_into_main_states_can_be_left_with_empty_step: "
  F_DPDA_EA_OPT__SpecInput2 G D
  \<Longrightarrow> valid_dpda G
  \<Longrightarrow> Go = F_DPDA_EA_OPT G
  \<Longrightarrow> valid_dpda Go
  \<Longrightarrow> main_states_have_all_empty_steps G F_DPDA_EUML__is_main
  \<Longrightarrow> epdaH.accessible Go
  \<Longrightarrow> main_states_can_be_left_with_empty_step Go F_DPDA_EUML__is_main"
  apply(simp add: F_DPDA_EUML__SpecInput_def main_states_have_all_empty_steps_def main_states_can_be_left_with_empty_step_def)
  apply(clarsimp)
  apply(rename_tac c)(*strict*)
  apply(simp add: epdaH.get_accessible_configurations_def)
  apply(clarsimp)
  apply(rename_tac c d i)(*strict*)
  apply(case_tac "d i")
   apply(rename_tac c d i)(*strict*)
   apply(clarsimp)
   apply(simp add: get_configuration_def)
  apply(rename_tac c d i a)(*strict*)
  apply(clarsimp)
  apply(simp add: get_configuration_def)
  apply(case_tac a)
  apply(rename_tac c d i a option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac c d i option)(*strict*)
  apply(rename_tac e)
  apply(rename_tac c d i e)(*strict*)
  apply(case_tac c)
  apply(rename_tac c d i e epdaH_conf_statea epdaH_conf_history epdaH_conf_stacka)(*strict*)
  apply(rename_tac q h s)
  apply(rename_tac c d i e q h s)(*strict*)
  apply(clarsimp)
  apply(rename_tac d i e q h s)(*strict*)
  apply(subgoal_tac "epdaH.derivation_initial G d")
   apply(rename_tac d i e q h s)(*strict*)
   prefer 2
   apply(rule_tac
      ?G1.0="F_DPDA_EA_OPT G"
      in epda_sub_preserves_derivation_initial)
      apply(rename_tac d i e q h s)(*strict*)
      prefer 2
      apply(simp add: valid_dpda_def valid_pda_def)
     apply(rename_tac d i e q h s)(*strict*)
     apply(simp add: valid_dpda_def valid_pda_def)
    apply(rename_tac d i e q h s)(*strict*)
    apply(rule F_DPDA_EA_OPT__constructs_epda_sub)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(rename_tac d i e q h s)(*strict*)
   apply(force)
  apply(rename_tac d i e q h s)(*strict*)
  apply(subgoal_tac "\<lparr>epdaH_conf_state = q, epdaH_conf_history = h, epdaH_conf_stack = s\<rparr> \<in> epdaH_configurations G")
   apply(rename_tac d i e q h s)(*strict*)
   prefer 2
   apply(rule_tac
      d="d"
      in epdaH.belongs_configurations)
    apply(rename_tac d i e q h s)(*strict*)
    apply(rule epdaH.derivation_initial_belongs)
     apply(rename_tac d i e q h s)(*strict*)
     apply(simp add: valid_dpda_def valid_pda_def)
    apply(rename_tac d i e q h s)(*strict*)
    apply(force)
   apply(rename_tac d i e q h s)(*strict*)
   apply(force)
  apply(rename_tac d i e q h s)(*strict*)
  apply(erule_tac
      x="q"
      in ballE)
   apply(rename_tac d i e q h s)(*strict*)
   prefer 2
   apply(simp add: epdaH_configurations_def F_DPDA_EA_OPT_def F_ALT_EPDA_RE_def Let_def valid_dpda_def valid_pda_def valid_epda_def)
  apply(rename_tac d i e q h s)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "X" for X)
   apply(rename_tac d i e q h s)(*strict*)
   prefer 2
   apply(rule_tac
      d="d"
      and i="i"
      in epdaH_epda_stack_is_must_terminated_by_prime)
     apply(rename_tac d i e q h s)(*strict*)
     prefer 2
     apply(force)
    apply(rename_tac d i e q h s)(*strict*)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(rename_tac d i e q h s)(*strict*)
   apply(force)
  apply(rename_tac d i e q h s)(*strict*)
  apply(clarsimp)
  apply(case_tac s)
   apply(rename_tac d i e q h s)(*strict*)
   apply(clarsimp)
   apply(rename_tac d i e q h)(*strict*)
   apply(simp add: must_terminated_by_def kleene_star_def append_language_def)
  apply(rename_tac d i e q h s a list)(*strict*)
  apply(clarsimp)
  apply(rename_tac d i e q h a list)(*strict*)
  apply(thin_tac "a # list \<in> must_terminated_by (epda_gamma (F_DPDA_EA_OPT G)) (epda_box (F_DPDA_EA_OPT G))")
  apply(erule_tac
      x="a"
      in ballE)
   apply(rename_tac d i e q h a list)(*strict*)
   prefer 2
   apply(simp add: epdaH_configurations_def F_DPDA_EA_OPT_def F_ALT_EPDA_RE_def Let_def valid_dpda_def valid_pda_def valid_epda_def)
  apply(rename_tac d i e q h a list)(*strict*)
  apply(clarsimp)
  apply(rename_tac d i e h a list ea)(*strict*)
  apply(simp (no_asm) add: F_DPDA_EA_OPT_def F_ALT_EPDA_RE_def Let_def)
  apply(rule_tac
      t="F_DPDA_DRE G (Suc 0)"
      and s="epdaH_required_edges G"
      in ssubst)
   apply(rename_tac d i e h a list ea)(*strict*)
   apply(rule F_DPDA_DRE__are_precisely_reachable)
    apply(force)
   apply(force)
  apply(rename_tac d i e h a list ea)(*strict*)
  apply(rule_tac
      t="epdaS_required_edges G"
      and s="epdaH_required_edges G"
      in ssubst)
   apply(rename_tac d i e h a list ea)(*strict*)
   apply(rule epdaS_required_edges__vs__epdaH_required_edges)
   apply(simp add: valid_dpda_def valid_pda_def)
  apply(rename_tac d i e h a list ea)(*strict*)
  apply(rule_tac
      x="ea"
      in exI)
  apply(clarsimp)
  apply(simp add: F_EPDA_RE_def F_EPDA_R_def Let_def)
  apply(rule context_conjI)
   prefer 2
   apply(rule conjI)
    apply(simp add: valid_dpda_def valid_pda_def valid_epda_def valid_epda_step_label_def)
   apply(rule conjI)
    apply(rule disjI2)
    apply(rule conjI)
     apply(simp add: valid_dpda_def valid_pda_def valid_epda_def valid_epda_step_label_def)
    apply(force)
   apply(rule conjI)
    apply(simp add: valid_dpda_def valid_pda_def valid_epda_def valid_epda_step_label_def)
   apply(rule disjI2)
   apply(rule conjI)
    apply(simp add: valid_dpda_def valid_pda_def valid_epda_def valid_epda_step_label_def)
   apply(force)
  apply(subgoal_tac "epdaH.Nonblockingness_branching G")
   prefer 2
   apply(simp add: F_DPDA_EA_OPT__SpecInput2_def)
   apply(erule conjE)+
   apply (metis DPDA_to_epdaH_determinism epdaH.AX_is_forward_edge_deterministic_correspond_DB_SB epdaH.is_forward_edge_deterministicHist_SB_vs_is_forward_edge_deterministicHist_SB_long epdaH_operational_Nonblockingness_from_language_Nonblockingness epdaS_to_epdaH_nonblockingness_language valid_dpda_def valid_pda_def)
  apply(simp add: epdaH.Nonblockingness_branching_def)
  apply(erule_tac x="derivation_append d (der2 \<lparr>epdaH_conf_state = edge_src ea, epdaH_conf_history = h,
                 epdaH_conf_stack = a # list\<rparr> ea \<lparr>epdaH_conf_state = edge_trg ea, epdaH_conf_history = h,
                 epdaH_conf_stack = (edge_push ea) @ list\<rparr>) i" in allE)
  apply(subgoal_tac "epdaH.derivation_initial G
        (derivation_append d
          (der2 \<lparr>epdaH_conf_state = edge_src ea, epdaH_conf_history = h,
                   epdaH_conf_stack = a # list\<rparr>
            ea \<lparr>epdaH_conf_state = edge_trg ea, epdaH_conf_history = h,
                  epdaH_conf_stack = edge_push ea @ list\<rparr>)
          i)")
   prefer 2
   apply(rule epdaH.derivation_append_preserves_derivation_initial)
     apply(simp add: valid_dpda_def valid_pda_def)
    apply(force)
   apply(rule epdaH.derivation_append_preserves_derivation)
     apply(simp add: epdaH.derivation_initial_def)
    apply(rule epdaH.der2_is_derivation)
    apply(simp add: epdaH_step_relation_def)
    apply(simp add: option_to_list_def)
   apply(clarsimp)
   apply(simp add: der2_def derivation_append_def)
  apply(erule impE)
   apply(force)
  apply(erule_tac x="Suc i" in allE)
  apply(erule impE)
   apply(simp add: der2_def derivation_append_def maximum_of_domain_def)
  apply(clarsimp)
  apply(simp add: epdaH_marking_condition_def)
  apply(clarsimp)
  apply(simp add: epdaH_required_edges_def)
  apply(rule_tac x="derivation_append
           (derivation_append d
             (der2 \<lparr>epdaH_conf_state = edge_src ea, epdaH_conf_history = h,
                      epdaH_conf_stack = a # list\<rparr>
               ea \<lparr>epdaH_conf_state = edge_trg ea, epdaH_conf_history = h,
                     epdaH_conf_stack = edge_push ea @ list\<rparr>)
             i)
           dc (Suc i)" in exI)
  apply(rule context_conjI)
   apply(rule epdaH.derivation_append_preserves_derivation_initial)
     apply(simp add: valid_dpda_def valid_pda_def)
    apply(force)
   apply(rule epdaH.derivation_append_preserves_derivation)
     apply(simp add: epdaH.derivation_initial_def)
    apply(force)
   apply(simp add: derivation_append_def derivation_append_fit_def der2_def)
   apply(case_tac "dc 0")
    apply(simp add: epdaH.derivation_def)
   apply(clarsimp)
   apply(case_tac aa)
   apply(rename_tac x1 x2)
   apply(clarsimp)
   apply(simp add: epdaH.derivation_def)
   apply(case_tac x1)
    apply(clarsimp)
   apply(clarsimp)
  apply(rule_tac x="Suc i" in exI)
  apply(rule conjI)
   apply(simp add: derivation_append_def derivation_append_fit_def der2_def)
  apply(case_tac "ia\<ge>Suc i")
   apply(rule_tac x="ia" in exI)
   apply(simp add: derivation_append_def derivation_append_fit_def der2_def)
  apply(subgoal_tac "ia < Suc i")
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(erule_tac x="Suc ia" in allE)
  apply(clarsimp)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac n="ia" and m="Suc i" and d="derivation_append d
          (der2 \<lparr>epdaH_conf_state = edge_src ea, epdaH_conf_history = h,
                   epdaH_conf_stack = a # list\<rparr>
            ea \<lparr>epdaH_conf_state = edge_trg ea, epdaH_conf_history = h,
                  epdaH_conf_stack = edge_push ea @ list\<rparr>)
          i" in epdaH.step_detail_before_some_position)
     apply(simp add: epdaH.derivation_initial_def)
     apply(force)
    apply(simp add: derivation_append_def derivation_append_fit_def der2_def)
   apply(force)
  apply(clarsimp)
  apply(subgoal_tac "False")
   apply(force)
  apply(subgoal_tac "only_executing_edges_from_marking_states G")
   prefer 2
   apply(simp add: F_DPDA_EA_OPT__SpecInput2_def)
  apply(simp add: only_executing_edges_from_marking_states_def)
  apply(case_tac "edge_event e2")
   apply(erule_tac x="e2" in ballE)
    prefer 2
    apply(simp add: epdaH_step_relation_def)
   apply(erule impE)
    apply(clarsimp)
   apply(simp add: epdaH_marking_configurations_def epdaH_step_relation_def)
   apply(simp add: derivation_append_def derivation_append_fit_def der2_def)
  apply(simp add: derivation_append_def derivation_append_fit_def der2_def epdaH_string_state_def epdaH_step_relation_def option_to_list_def)
  done

theorem F_DPDA_EA_OPT__preserves_main_states_have_only_empty_steps: "
  valid_dpda G
  \<Longrightarrow> Go = F_DPDA_EA_OPT G
  \<Longrightarrow> main_states_have_only_empty_steps G F_DPDA_EUML__is_main
  \<Longrightarrow> main_states_have_only_empty_steps Go F_DPDA_EUML__is_main"
  apply(simp add: F_DPDA_EUML__SpecInput_def main_states_have_only_empty_steps_def)
  apply(clarsimp)
  apply(rename_tac e)(*strict*)
  apply(erule_tac
      x="edge_src e"
      in ballE)
   apply(rename_tac e)(*strict*)
   prefer 2
   apply(simp add: F_DPDA_EA_OPT_def F_ALT_EPDA_RE_def Let_def valid_dpda_def valid_pda_def valid_epda_def)
   apply(rename_tac e)(*strict*)
   apply(clarsimp)
   apply(case_tac "e")
   apply(rename_tac e edge_srca edge_eventa edge_pop edge_push edge_trg)(*strict*)
   apply(clarsimp)
   apply(rename_tac edge_srca edge_eventa edge_pop edge_push edge_trg)(*strict*)
   apply(rename_tac qs re po pu qt)
   apply(rename_tac qs re po pu qt)(*strict*)
   apply(simp add: F_DPDA_EA_OPT_def F_EPDA_R_def F_EPDA_RE_def Let_def)
  apply(clarsimp)
  apply(simp add: F_DPDA_EA_OPT_def F_EPDA_R_def F_EPDA_RE_def Let_def)
  done

theorem F_DPDA_EA_OPT__preserves_executing_edge_from_auxiliary_to_main_state: "
  valid_dpda G
  \<Longrightarrow> Go = F_DPDA_EA_OPT G
  \<Longrightarrow> executing_edge_from_auxiliary_to_main_state G F_DPDA_EUML__is_auxiliary F_DPDA_EUML__is_main
  \<Longrightarrow> executing_edge_from_auxiliary_to_main_state Go F_DPDA_EUML__is_auxiliary F_DPDA_EUML__is_main"
  apply(simp add: executing_edge_from_auxiliary_to_main_state_def)
  apply(clarsimp)
  apply(rename_tac e y)(*strict*)
  apply(erule_tac
      x="e"
      in allE)
  apply(clarsimp)
  apply(simp add: F_DPDA_EA_OPT_def F_ALT_EPDA_RE_def Let_def)
  apply(simp add: F_DPDA_EA_OPT_def F_EPDA_R_def F_EPDA_RE_def Let_def)
  done

theorem F_DPDA_EA_OPT__preserves_always_applicable_for_auxiliary_states: "
  valid_dpda G
  \<Longrightarrow> Go = F_DPDA_EA_OPT G
  \<Longrightarrow> always_applicable_for_auxiliary_states G F_DPDA_EUML__is_auxiliary
  \<Longrightarrow> always_applicable_for_auxiliary_states Go F_DPDA_EUML__is_auxiliary"
  apply(simp add: always_applicable_for_auxiliary_states_def always_applicable_def)
  apply(clarsimp)
  apply(rename_tac d e c n ea)(*strict*)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule impE)
   apply(rename_tac d e c n ea)(*strict*)
   apply(rule epda_sub_preserves_derivation_initial)
      apply(rename_tac d e c n ea)(*strict*)
      prefer 4
      apply(force)
     apply(rename_tac d e c n ea)(*strict*)
     apply(simp add: F_DPDA_EA_OPT_def F_EPDA_RE_def)
     apply(rule F_EPDA_R_preserves_valid_epda)
       apply(simp add: valid_dpda_def valid_pda_def)
       apply(force)
      prefer 2
      apply(force)
     apply(force)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(rule F_DPDA_EA_OPT__constructs_epda_sub)
   apply(simp add: valid_dpda_def valid_pda_def)
  apply(simp add: valid_dpda_def valid_pda_def)
  apply(rename_tac d e c n ea)(*strict*)
  apply(erule_tac
      x="e"
      in allE)
  apply(erule_tac
      x="c"
      in allE)
  apply(erule impE)
   apply(rename_tac d e c n ea)(*strict*)
   apply(rule_tac
      x="n"
      in exI)
   apply(clarsimp)
  apply(rename_tac d e c n ea)(*strict*)
  apply(erule impE)
   apply(rename_tac d e c n ea)(*strict*)
   apply(clarsimp)
  apply(rename_tac d e c n ea)(*strict*)
  apply(erule_tac
      x="ea"
      in ballE)
   apply(rename_tac d e c n ea)(*strict*)
   prefer 2
   apply(simp add: F_EPDA_R_def F_DPDA_EA_OPT_def F_EPDA_RE_def Let_def)
  apply(rename_tac d e c n ea)(*strict*)
  apply(clarsimp)
  apply(rename_tac d e c n ea x)(*strict*)
  apply(rule_tac
      x="x"
      in exI)
  apply(simp add: epdaH_step_relation_def)
  done

theorem F_DPDA_EA_OPT__preserves__main_to_auxiliary_or_auxiliary_to_main: "
  valid_dpda G
  \<Longrightarrow> Go = F_DPDA_EA_OPT G
  \<Longrightarrow> main_to_auxiliary_or_auxiliary_to_main G F_DPDA_EUML__is_main
  \<Longrightarrow> main_to_auxiliary_or_auxiliary_to_main Go F_DPDA_EUML__is_main"
  apply(simp add: main_to_auxiliary_or_auxiliary_to_main_def)
  apply(clarsimp)
  apply(rename_tac e)(*strict*)
  apply(erule_tac
      x="e"
      in ballE)
   apply(rename_tac e)(*strict*)
   apply(force)
  apply(rename_tac e)(*strict*)
  apply(simp add: F_EPDA_R_def F_DPDA_EA_OPT_def F_EPDA_RE_def Let_def)
  done

theorem F_DPDA_EA_OPT__SOUND2: "
  F_DPDA_EA_OPT__SpecInput2 G D
  \<Longrightarrow> F_DPDA_EA_OPT__SpecOutput2 G (D, \<Sigma>UC) (F_DPDA_EA_OPT G)"
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_DPDA_EA_OPT__SOUND)
   apply(simp add: F_DPDA_EA_OPT__SpecInput_def F_DPDA_EA_OPT__SpecInput2_def)
   apply(clarsimp)
   apply(rule valid_epda__no_livelock__implies__epdaH_no_livelocks_from_marking_states)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(force)
  apply(simp add: F_DPDA_EA_OPT__SpecOutput_def F_DPDA_EA_OPT__SpecInput2_def F_DPDA_EA_OPT__SpecOutput2_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_state_stack_unique_for_marking_states)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_only_executing_edges_from_marking_states)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_not_livelock)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_epdaH_reflection_to_DFA_exists)
     prefer 2
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_corresponds_to_top_stack)
     prefer 2
     apply(force)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(force)
  apply(rule context_conjI)
   apply(rule epdaS_to_epdaH_accessible)
    apply(simp add: valid_dpda_def valid_pda_def)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__transforms_main_states_have_all_empty_steps_into_main_states_can_be_left_with_empty_step)
        apply(simp add: F_DPDA_EA_OPT__SpecInput2_def)
        apply(force)
       apply(force)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_main_states_have_only_empty_steps)
     prefer 2
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_executing_edge_from_auxiliary_to_main_state)
     prefer 2
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_OPT__preserves_always_applicable_for_auxiliary_states)
     prefer 2
     apply(force)
    apply(force)
   apply(force)
  apply(rule F_DPDA_EA_OPT__preserves__main_to_auxiliary_or_auxiliary_to_main)
    prefer 2
    apply(force)
   apply(force)
  apply(force)
  done

hide_fact epda_sub_preserves_state_stack_unique_for_marking_states
hide_fact epda_sub_preserves_only_executing_edges_from_marking_states
hide_fact epda_sub_preserves_epdaH_reflection_to_DFA_exists
hide_fact F_DPDA_EA_OPT__preserves_state_stack_unique_for_marking_states
hide_fact F_DPDA_EA_OPT__preserves_only_executing_edges_from_marking_states
hide_fact F_DPDA_EA_OPT__preserves_epdaH_reflection_to_DFA_exists
hide_fact F_DPDA_EA_OPT__preserves_corresponds_to_top_stack
hide_fact F_DPDA_EA_OPT__transforms_main_states_have_all_empty_steps_into_main_states_can_be_left_with_empty_step
hide_fact F_DPDA_EA_OPT__preserves_main_states_have_only_empty_steps
hide_fact F_DPDA_EA_OPT__preserves_executing_edge_from_auxiliary_to_main_state
hide_fact F_DPDA_EA_OPT__preserves_always_applicable_for_auxiliary_states
hide_fact F_DPDA_EA_OPT__preserves__main_to_auxiliary_or_auxiliary_to_main

end


(*  Title:      HOL/MicroJava/Comp/DefsComp.thy
    Author:     Martin Strecker
*)

(* Definitions for accessing parts of methods, states etc. *)

theory DefsComp
imports "../JVM/JVMExec"
begin

definition method_rT :: "cname \<times> ty \<times> 'c \<Rightarrow> ty" where
  "method_rT mtd == (fst (snd mtd))"

(* g = get *)
definition
  gx :: "xstate \<Rightarrow> val option" where "gx \<equiv> fst"

definition
  gs :: "xstate \<Rightarrow> state" where "gs \<equiv> snd"

definition
  gh :: "xstate \<Rightarrow> aheap" where "gh \<equiv> fst\<circ>snd"

definition
  gl :: "xstate \<Rightarrow> State.locals" where "gl \<equiv> snd\<circ>snd"

definition
  gmb :: "'a prog \<Rightarrow> cname \<Rightarrow> sig \<Rightarrow> 'a"
    where "gmb G cn si \<equiv> snd(snd(the(method (G,cn) si)))"

definition
  gis :: "jvm_method \<Rightarrow> bytecode"
    where "gis \<equiv> fst \<circ> snd \<circ> snd"

(* jmb = aus einem JavaMaethodBody *)
definition
  gjmb_pns  :: "java_mb \<Rightarrow> vname list" where "gjmb_pns \<equiv> fst"

definition
  gjmb_lvs  :: "java_mb \<Rightarrow> (vname\<times>ty)list" where  "gjmb_lvs \<equiv> fst\<circ>snd"

definition
  gjmb_blk  :: "java_mb \<Rightarrow> stmt" where  "gjmb_blk \<equiv> fst\<circ>snd\<circ>snd"

definition
  gjmb_res  :: "java_mb \<Rightarrow> expr" where  "gjmb_res \<equiv> snd\<circ>snd\<circ>snd"

definition
  gjmb_plns :: "java_mb \<Rightarrow> vname list"
    where  "gjmb_plns \<equiv> \<lambda>jmb. gjmb_pns jmb @ map fst (gjmb_lvs jmb)"

definition
  glvs :: "java_mb \<Rightarrow> State.locals \<Rightarrow> locvars"
    where "glvs jmb loc \<equiv> map (the\<circ>loc) (gjmb_plns jmb)"

lemmas gdefs = gx_def gh_def gl_def gmb_def gis_def glvs_def
lemmas gjmbdefs = gjmb_pns_def gjmb_lvs_def gjmb_blk_def gjmb_res_def gjmb_plns_def

lemmas galldefs = gdefs gjmbdefs

definition locvars_locals :: "java_mb prog \<Rightarrow> cname \<Rightarrow> sig \<Rightarrow> State.locals \<Rightarrow> locvars" where
  "locvars_locals G C S lvs == the (lvs This) # glvs (gmb G C S) lvs"

definition locals_locvars :: "java_mb prog \<Rightarrow> cname \<Rightarrow> sig \<Rightarrow> locvars \<Rightarrow> State.locals" where
  "locals_locvars G C S lvs ==
  Map.empty ((gjmb_plns (gmb G C S))[\<mapsto>](tl lvs), This\<mapsto>(hd lvs))"

definition locvars_xstate :: "java_mb prog \<Rightarrow> cname \<Rightarrow> sig \<Rightarrow> xstate \<Rightarrow> locvars" where
  "locvars_xstate G C S xs == locvars_locals G C S (gl xs)"

lemma locvars_xstate_par_dep:
  "lv1 = lv2 \<Longrightarrow>
  locvars_xstate G C S (xcpt1, hp1, lv1) = locvars_xstate G C S (xcpt2, hp2, lv2)"
by (simp add: locvars_xstate_def gl_def)

(**********************************************************************)
(* Conversions *)

lemma gx_conv [simp]: "gx (xcpt, s) = xcpt" by (simp add: gx_def)

lemma gh_conv [simp]: "gh (xcpt, h, l) = h" by (simp add: gh_def)

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory KHeapPre_AI
imports Machine_AI
begin

primrec
  same_caps :: "Structures_A.kernel_object \<Rightarrow> Structures_A.kernel_object \<Rightarrow> bool"
where
  "same_caps val (CNode sz cs)       = (val = CNode sz cs)"
| "same_caps val (TCB tcb)           = (\<exists>tcb'. val = TCB tcb'
                                         \<and> (\<forall>(getF, t) \<in> ran tcb_cap_cases. getF tcb' = getF tcb))"
| "same_caps val (Endpoint ep)       = is_ep val"
| "same_caps val (Notification ntfn) = is_ntfn val"
| "same_caps val (ArchObj ao)        = (\<exists>ao'. val = ArchObj ao')"

lemma same_caps_more_simps[simp]:
 "same_caps (CNode sz cs) val       = (val = CNode sz cs)"
 "same_caps (TCB tcb)     val       = (\<exists>tcb'. val = TCB tcb'
                                         \<and> (\<forall>(getF, t) \<in> ran tcb_cap_cases. getF tcb' = getF tcb))"
 "same_caps (Endpoint ep) val       = is_ep val"
 "same_caps (Notification ntfn) val = is_ntfn val"
 "same_caps (ArchObj ao) val        = (\<exists>ao'. val = ArchObj ao')"
 by (cases val, (fastforce simp: is_obj_defs)+)+

lemma dmo_return [simp]:
  "do_machine_op (return x) = return x"
  by (simp add: do_machine_op_def select_f_def return_def gets_def get_def
                bind_def modify_def put_def)

lemma get_object_sp:
  "\<lbrace>P\<rbrace> get_object p \<lbrace>\<lambda>r. P and ko_at r p\<rbrace>"
  apply (simp add: get_object_def)
  apply wp
  apply (auto simp add: obj_at_def)
  done

definition non_arch_obj :: "kernel_object \<Rightarrow> bool" where
  "non_arch_obj \<equiv> \<lambda>ko. \<forall>ako. ko \<noteq> ArchObj ako"

lemma non_arch_objs[intro]:
  "non_arch_obj (Endpoint ep)"
  "non_arch_obj (CNode sz cnode_contents)"
  "non_arch_obj (TCB tcb)"
  "non_arch_obj (Notification notification)"
  by (auto simp add: non_arch_obj_def)

definition arch_obj_pred :: "(kernel_object \<Rightarrow> bool) \<Rightarrow> bool" where
  "arch_obj_pred P \<equiv>
    \<forall>ko ko'. non_arch_obj ko \<longrightarrow> non_arch_obj ko' \<longrightarrow>
      P ko = P ko'"

lemma arch_obj_predE:
  "\<lbrakk>arch_obj_pred P; non_arch_obj ko; non_arch_obj ko'\<rbrakk> \<Longrightarrow> P ko = P ko'"
  apply (unfold arch_obj_pred_def)
  apply (erule allE[where ?x="ko"])
  apply (erule allE[where ?x="ko'"])
  by blast

lemmas arch_obj_pred_defs = non_arch_obj_def arch_obj_pred_def

lemma arch_obj_pred_a_type[intro, simp]: "arch_obj_pred (\<lambda>ko. a_type ko = AArch T)"
  by (auto simp add: arch_obj_pred_defs a_type_def split: kernel_object.splits)

lemma
  arch_obj_pred_arch_obj_l[intro, simp]: "arch_obj_pred (\<lambda>ko. ArchObj ako = ko)" and
  arch_obj_pred_arch_obj_r[intro, simp]: "arch_obj_pred (\<lambda>ko. ko = ArchObj ako)"
  by (auto simp add: arch_obj_pred_defs)

lemma arch_obj_pred_fun_lift: "arch_obj_pred (\<lambda>ko. F (arch_obj_fun_lift P N ko))"
  by (simp add: arch_obj_pred_defs)

lemmas arch_obj_pred_fun_lift_id[simp]
  = arch_obj_pred_fun_lift[where F=id, simplified]

lemmas arch_obj_pred_fun_lift_k[intro]
  = arch_obj_pred_fun_lift[where F="K R" for R, simplified]

lemmas arch_obj_pred_fun_lift_el[simp]
  = arch_obj_pred_fun_lift[where F="\<lambda> S. x \<in> S" for x, simplified]

lemma arch_obj_pred_const_conjI[intro]:
  "arch_obj_pred P \<Longrightarrow>
    arch_obj_pred P' \<Longrightarrow>
    arch_obj_pred (\<lambda>ko. P ko \<and> P' ko)"
  apply (simp only: arch_obj_pred_def)
  apply blast
  done

lemma arch_obj_pred_fI:
  "(\<And>x. arch_obj_pred (P x)) \<Longrightarrow> arch_obj_pred (\<lambda>ko. f (\<lambda>x :: 'a :: type. P x ko))"
  apply (simp only: arch_obj_pred_def)
  apply (intro allI impI)
  apply (rule arg_cong[where f=f])
  by blast

declare
  arch_obj_pred_fI[where f=All, intro]
  arch_obj_pred_fI[where f=Ex, intro]

locale arch_only_obj_pred =
  fixes P :: "kernel_object \<Rightarrow> bool"
  assumes arch_only: "arch_obj_pred P"

lemma set_object_typ_at [wp]:
  "\<lbrace>\<lambda>s. P (typ_at T p' s)\<rbrace>
  set_object p ko \<lbrace>\<lambda>rv s. P (typ_at T p' s)\<rbrace>"
  apply (simp add: set_object_def get_object_def)
  apply wp
  apply clarsimp
  apply (erule rsubst [where P=P])
  apply (clarsimp simp: obj_at_def)
  done

lemma set_object_neg_ko:
  "\<lbrace>not ko_at ko' p' and K (p = p' \<longrightarrow> ko \<noteq> ko')\<rbrace>
  set_object p ko
  \<lbrace>\<lambda>_ s. \<not> ko_at ko' p' s\<rbrace>"
  apply (simp add: set_object_def get_object_def)
  apply wp
  apply (simp add: pred_neg_def obj_at_def)
  done

lemma get_tcb_SomeD: "get_tcb t s = Some v \<Longrightarrow> kheap s t = Some (TCB v)"
  apply (case_tac "kheap s t", simp_all add: get_tcb_def)
  apply (case_tac a, simp_all)
  done

lemma get_tcb_at: "tcb_at t s \<Longrightarrow> (\<exists>tcb. get_tcb t s = Some tcb)"
  by (simp add: tcb_at_def)

lemma typ_at_same_type:
  assumes "typ_at T p s" "a_type k = a_type ko" "kheap s p' = Some ko"
  shows "typ_at T p (s\<lparr>kheap := kheap s(p' \<mapsto> k)\<rparr>)"
  using assms
  by (clarsimp simp: obj_at_def)

lemma hoare_to_pure_kheap_upd:
  assumes hoare[rule_format]:
    "\<And>f. (\<And>P p T. \<lbrace>\<lambda>s. P (typ_at (AArch T) p s)\<rbrace>
      f \<lbrace>\<lambda>r s. P (typ_at (AArch T) p s)\<rbrace>) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
  assumes typ_eq: "a_type k = a_type ko"
  assumes valid: "P (s :: ('z :: state_ext) state)"
  assumes at: "ko_at ko p s"
  shows "P (s\<lparr>kheap := kheap s(p \<mapsto> k)\<rparr>)"
  apply (rule use_valid[where f="
      do
        s' <- get;
        assert (s' = s);
        (modify (\<lambda>s. s\<lparr>kheap := kheap s(p \<mapsto> k)\<rparr>));
        return undefined
      od", OF _ hoare valid])
  apply (fastforce simp add: simpler_modify_def get_def bind_def
                             assert_def return_def[abs_def] fail_def)[1]
  apply wp
  apply (insert typ_eq at)
  apply clarsimp
  apply (erule_tac P=P in rsubst)
  by (auto simp add: obj_at_def a_type_def split: kernel_object.splits if_splits)

lemma set_object_wp:
  "\<lbrace>\<lambda>s. Q (s\<lparr> kheap := kheap s (p \<mapsto> v)\<rparr>) \<rbrace> set_object p v \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (simp add: set_object_def get_object_def)
  apply wp
  apply blast
  done

lemma get_object_wp:
  "\<lbrace>\<lambda>s. \<forall>ko. ko_at ko p s \<longrightarrow> Q ko s\<rbrace> get_object p \<lbrace>Q\<rbrace>"
  apply (clarsimp simp: get_object_def)
  apply wp
  apply (clarsimp simp: obj_at_def)
  done

(* FIXME: move *)
lemma hoare_strengthen_pre_via_assert_forward:
  assumes pos: "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes rel: "\<And>s. S s \<Longrightarrow> P s \<or> N s"
  assumes neg: "\<lbrace> N \<rbrace> f \<lbrace> \<bottom>\<bottom> \<rbrace>"
  shows "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  apply (rule hoare_weaken_pre)
   apply (rule hoare_strengthen_post)
    apply (rule hoare_vcg_disj_lift[OF pos neg])
   apply simp
  apply (erule rel)
  done

lemma hoare_set_object_weaken_pre:
  assumes "\<lbrace>P\<rbrace> set_object p v \<lbrace>\<lambda>_. Q\<rbrace>"
  shows "\<lbrace>\<lambda>s. \<forall>ko. ko_at ko p s \<longrightarrow> (a_type v = a_type ko) \<longrightarrow> P s\<rbrace>
         set_object p v
         \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (rule hoare_strengthen_pre_via_assert_forward
                [OF assms, where N="\<lambda>s. \<forall>ko. ko_at ko p s \<longrightarrow> a_type ko \<noteq> a_type v"])
  apply fastforce
  apply (simp add: set_object_def)
  apply (rule hoare_seq_ext[OF _ get_object_sp])
  apply (rule hoare_seq_ext[OF _ assert_sp])
  apply (fastforce intro: hoare_weaken_pre[OF hoare_pre_cont])
  done

lemmas set_object_wp_strong = hoare_set_object_weaken_pre[OF set_object_wp]

end


(*<*)
theory Monitor_Impl
  imports Monitor
    Optimized_MTL
    "HOL-Library.Code_Target_Nat"
    Containers.Containers
begin
(*>*)

section \<open>Instantiation of the generic algorithm and code setup\<close>

declare [[code drop: card]] Set_Impl.card_code[code]

instantiation enat :: set_impl begin
definition set_impl_enat :: "(enat, set_impl) phantom" where
  "set_impl_enat = phantom set_RBT"

instance ..
end

derive ccompare Formula.trm
derive (eq) ceq Formula.trm
derive (rbt) set_impl Formula.trm
derive (eq) ceq Monitor.mregex
derive ccompare Monitor.mregex
derive (rbt) set_impl Monitor.mregex
derive (rbt) mapping_impl Monitor.mregex
derive (no) cenum Monitor.mregex
derive (rbt) set_impl event_data
derive (rbt) mapping_impl event_data

definition add_new_mmuaux' :: "args \<Rightarrow> event_data table \<Rightarrow> event_data table \<Rightarrow> ts \<Rightarrow> event_data mmuaux \<Rightarrow>
  event_data mmuaux" where
  "add_new_mmuaux' = add_new_mmuaux"

interpretation muaux valid_mmuaux init_mmuaux add_new_mmuaux' length_mmuaux eval_mmuaux
  using valid_init_mmuaux valid_add_new_mmuaux valid_length_mmuaux valid_eval_mmuaux
  unfolding add_new_mmuaux'_def
  by unfold_locales assumption+

type_synonym 'a vmsaux = "nat \<times> (nat \<times> 'a table) list"

definition valid_vmsaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmsaux \<Rightarrow>
  (nat \<times> event_data table) list \<Rightarrow> bool" where
  "valid_vmsaux = (\<lambda>_ cur (t, aux) auxlist. t = cur \<and> aux = auxlist)"

definition init_vmsaux :: "args \<Rightarrow> event_data vmsaux" where
  "init_vmsaux = (\<lambda>_. (0, []))"

definition add_new_ts_vmsaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmsaux \<Rightarrow> event_data vmsaux" where
  "add_new_ts_vmsaux = (\<lambda>args nt (t, auxlist). (nt, filter (\<lambda>(t, rel).
    enat (nt - t) \<le> right (args_ivl args)) auxlist))"

definition join_vmsaux :: "args \<Rightarrow> event_data table \<Rightarrow> event_data vmsaux \<Rightarrow> event_data vmsaux" where
  "join_vmsaux = (\<lambda>args rel1 (t, auxlist). (t, map (\<lambda>(t, rel).
    (t, join rel (args_pos args) rel1)) auxlist))"

definition add_new_table_vmsaux :: "args \<Rightarrow> event_data table \<Rightarrow> event_data vmsaux \<Rightarrow>
  event_data vmsaux" where
  "add_new_table_vmsaux = (\<lambda>args rel2 (cur, auxlist). (cur, (case auxlist of
    [] => [(cur, rel2)]
  | ((t, y) # ts) \<Rightarrow> if t = cur then (t, y \<union> rel2) # ts else (cur, rel2) # auxlist)))"

definition result_vmsaux :: "args \<Rightarrow> event_data vmsaux \<Rightarrow> event_data table" where
  "result_vmsaux = (\<lambda>args (cur, auxlist).
    foldr (\<union>) [rel. (t, rel) \<leftarrow> auxlist, left (args_ivl args) \<le> cur - t] {})"

type_synonym 'a vmuaux = "nat \<times> (nat \<times> 'a table \<times> 'a table) list"

definition valid_vmuaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmuaux \<Rightarrow>
  (nat \<times> event_data table \<times> event_data table) list \<Rightarrow> bool" where
  "valid_vmuaux = (\<lambda>_ cur (t, aux) auxlist. t = cur \<and> aux = auxlist)"

definition init_vmuaux :: "args \<Rightarrow> event_data vmuaux" where
  "init_vmuaux = (\<lambda>_. (0, []))"

definition add_new_vmuaux ::  "args \<Rightarrow> event_data table \<Rightarrow> event_data table \<Rightarrow> nat \<Rightarrow>
  event_data vmuaux \<Rightarrow> event_data vmuaux" where
  "add_new_vmuaux = (\<lambda>args rel1 rel2 nt (t, auxlist). (nt, update_until args rel1 rel2 nt auxlist))"

definition length_vmuaux :: "args \<Rightarrow> event_data vmuaux \<Rightarrow> nat" where
  "length_vmuaux = (\<lambda>_ (_, auxlist). length auxlist)"

definition eval_vmuaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmuaux \<Rightarrow>
  event_data table list \<times> event_data vmuaux" where
  "eval_vmuaux = (\<lambda>args nt (t, auxlist).
    (let (res, auxlist') = eval_until (args_ivl args) nt auxlist in (res, (t, auxlist'))))"

global_interpretation verimon_maux: maux valid_vmsaux init_vmsaux add_new_ts_vmsaux join_vmsaux
  add_new_table_vmsaux result_vmsaux valid_vmuaux init_vmuaux add_new_vmuaux length_vmuaux
  eval_vmuaux
  defines vminit0 = "maux.minit0 (init_vmsaux :: _ \<Rightarrow> event_data vmsaux) (init_vmuaux :: _ \<Rightarrow> event_data vmuaux) :: _ \<Rightarrow> Formula.formula \<Rightarrow> _"
  and vminit = "maux.minit (init_vmsaux :: _ \<Rightarrow> event_data vmsaux) (init_vmuaux :: _ \<Rightarrow> event_data vmuaux) :: Formula.formula \<Rightarrow> _"
  and vminit_safe = "maux.minit_safe (init_vmsaux :: _ \<Rightarrow> event_data vmsaux) (init_vmuaux :: _ \<Rightarrow> event_data vmuaux) :: Formula.formula \<Rightarrow> _"
  and vmupdate_since = "maux.update_since add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> event_data table)"
  and vmeval = "maux.meval add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmstep = "maux.mstep add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmsteps0_stateless = "maux.msteps0_stateless add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmsteps_stateless = "maux.msteps_stateless add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmonitor = "maux.monitor init_vmsaux add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) init_vmuaux add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  unfolding valid_vmsaux_def init_vmsaux_def add_new_ts_vmsaux_def join_vmsaux_def
    add_new_table_vmsaux_def result_vmsaux_def valid_vmuaux_def init_vmuaux_def add_new_vmuaux_def
    length_vmuaux_def eval_vmuaux_def
  by unfold_locales auto

global_interpretation default_maux: maux valid_mmsaux "init_mmsaux :: _ \<Rightarrow> event_data mmsaux" add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux result_mmsaux
  valid_mmuaux "init_mmuaux :: _ \<Rightarrow> event_data mmuaux" add_new_mmuaux' length_mmuaux eval_mmuaux
  defines minit0 = "maux.minit0 (init_mmsaux :: _ \<Rightarrow> event_data mmsaux) (init_mmuaux :: _ \<Rightarrow> event_data mmuaux) :: _ \<Rightarrow> Formula.formula \<Rightarrow> _"
  and minit = "maux.minit (init_mmsaux :: _ \<Rightarrow> event_data mmsaux) (init_mmuaux :: _ \<Rightarrow> event_data mmuaux) :: Formula.formula \<Rightarrow> _"
  and minit_safe = "maux.minit_safe (init_mmsaux :: _ \<Rightarrow> event_data mmsaux) (init_mmuaux :: _ \<Rightarrow> event_data mmuaux) :: Formula.formula \<Rightarrow> _"
  and mupdate_since = "maux.update_since add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> event_data table)"
  and meval = "maux.meval add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and mstep = "maux.mstep add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and msteps0_stateless = "maux.msteps0_stateless add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and msteps_stateless = "maux.msteps_stateless add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and monitor = "maux.monitor init_mmsaux add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) init_mmuaux add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  by unfold_locales

lemma image_these: "f ` Option.these X = Option.these (map_option f ` X)"
  by (force simp: in_these_eq Bex_def image_iff map_option_case split: option.splits)

thm default_maux.meval.simps(2)

lemma meval_MPred: "meval n t db (MPred e ts) =
  (case Mapping.lookup db e of None \<Rightarrow> [{}] | Some Xs \<Rightarrow> map (\<lambda>X. \<Union>v \<in> X.
  (set_option (map_option (\<lambda>f. Table.tabulate f 0 n) (match ts v)))) Xs, MPred e ts)"
  by (force split: option.splits simp: Option.these_def image_iff)

lemmas meval_code[code] = default_maux.meval.simps(1) meval_MPred default_maux.meval.simps(3-)

definition mk_db :: "(Formula.name \<times> event_data list set) list \<Rightarrow> _" where
  "mk_db t = Monitor.mk_db (\<Union>n \<in> set (map fst t). (\<lambda>v. (n, v)) ` the (map_of t n))"

definition rbt_fold :: "_ \<Rightarrow> event_data tuple set_rbt \<Rightarrow> _ \<Rightarrow> _" where
  "rbt_fold = RBT_Set2.fold"

definition rbt_empty :: "event_data list set_rbt" where
  "rbt_empty = RBT_Set2.empty"

definition rbt_insert :: "_ \<Rightarrow> _ \<Rightarrow> event_data list set_rbt" where
  "rbt_insert = RBT_Set2.insert"

lemma saturate_commute:
  assumes "\<And>s. r \<in> g s" "\<And>s. g (insert r s) = g s" "\<And>s. r \<in> s \<Longrightarrow> h s = g s"
  and terminates: "mono g" "\<And>X. X \<subseteq> C \<Longrightarrow> g X \<subseteq> C" "finite C"
shows "saturate g {} = saturate h {r}"
proof (cases "g {} = {r}")
  case True
  with assms have "g {r} = {r}" "h {r} = {r}" by auto
  with True show ?thesis
    by (subst (1 2) saturate_code; subst saturate_code) (simp add: Let_def)
next
  case False
  then show ?thesis
    unfolding saturate_def while_def
    using while_option_finite_subset_Some[OF terminates] assms(1-3)
    by (subst while_option_commute_invariant[of "\<lambda>S. S = {} \<or> r \<in> S" "\<lambda>S. g S \<noteq> S" g "\<lambda>S. h S \<noteq> S" "insert r" h "{}", symmetric])
      (auto 4 4 dest: while_option_stop[of "\<lambda>S. g S \<noteq> S" g "{}"])
qed

definition "RPDs_aux = saturate (\<lambda>S. S \<union> \<Union> (RPD ` S))"

lemma RPDs_aux_code[code]:
  "RPDs_aux S = (let S' = S \<union> Set.bind S RPD in if S' \<subseteq> S then S else RPDs_aux S')"
  unfolding RPDs_aux_def bind_UNION
  by (subst saturate_code) auto

declare RPDs_code[code del]
lemma RPDs_code[code]: "RPDs r = RPDs_aux {r}"
  unfolding RPDs_aux_def RPDs_code
  by (rule saturate_commute[where C="RPDs r"])
     (auto 0 3 simp: mono_def subset_singleton_iff RPDs_refl RPDs_trans finite_RPDs)

definition "LPDs_aux = saturate (\<lambda>S. S \<union> \<Union> (LPD ` S))"

lemma LPDs_aux_code[code]:
  "LPDs_aux S = (let S' = S \<union> Set.bind S LPD in if S' \<subseteq> S then S else LPDs_aux S')"
  unfolding LPDs_aux_def bind_UNION
  by (subst saturate_code) auto

declare LPDs_code[code del]
lemma LPDs_code[code]: "LPDs r = LPDs_aux {r}"
  unfolding LPDs_aux_def LPDs_code
  by (rule saturate_commute[where C="LPDs r"])
     (auto 0 3 simp: mono_def subset_singleton_iff LPDs_refl LPDs_trans finite_LPDs)

lemma is_empty_table_unfold [code_unfold]:
  "X = empty_table \<longleftrightarrow> Set.is_empty X"
  "empty_table = X \<longleftrightarrow> Set.is_empty X"
  "set_eq X empty_table \<longleftrightarrow> Set.is_empty X"
  "set_eq empty_table X \<longleftrightarrow> Set.is_empty X"
  "X = (set_empty impl) \<longleftrightarrow> Set.is_empty X"
  "(set_empty impl) = X \<longleftrightarrow> Set.is_empty X"
  "set_eq X (set_empty impl) \<longleftrightarrow> Set.is_empty X"
  "set_eq (set_empty impl) X \<longleftrightarrow> Set.is_empty X"
  unfolding set_eq_def set_empty_def empty_table_def Set.is_empty_def by auto

lemma tabulate_rbt_code[code]: "Monitor.mrtabulate (xs :: mregex list) f =
  (case ID CCOMPARE(mregex) of None \<Rightarrow> Code.abort (STR ''tabulate RBT_Mapping: ccompare = None'') (\<lambda>_. Monitor.mrtabulate (xs :: mregex list) f)
  | _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.bulkload (List.map_filter (\<lambda>k. let fk = f k in if fk = empty_table then None else Some (k, fk)) xs)))"
  unfolding mrtabulate.abs_eq RBT_Mapping_def
  by (auto split: option.splits)

lemma combine_Mapping[code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.combine f (RBT_Mapping t) (RBT_Mapping u) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''combine RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.combine f (RBT_Mapping t) (RBT_Mapping u))
                     | Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.join (\<lambda>_. f) t u))"
  by (auto simp add: Mapping.combine.abs_eq Mapping_inject lookup_join split: option.split)

lemma upd_set_empty[simp]: "upd_set m f {} = m"
  by transfer auto

lemma upd_set_insert[simp]: "upd_set m f (insert x A) = Mapping.update x (f x) (upd_set m f A)"
  by (rule mapping_eqI) (auto simp: Mapping_lookup_upd_set Mapping.lookup_update')

lemma upd_set_fold:
  assumes "finite A"
  shows "upd_set m f A = Finite_Set.fold (\<lambda>a. Mapping.update a (f a)) m A"
proof -
  interpret comp_fun_idem "\<lambda>a. Mapping.update a (f a)"
    by unfold_locales (transfer; auto simp: fun_eq_iff)+
  from assms show ?thesis
    by (induct A arbitrary: m rule: finite.induct) auto
qed

lift_definition upd_cfi :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, ('a, 'b) mapping) comp_fun_idem"
  is "\<lambda>f a m. Mapping.update a (f a) m"
  by unfold_locales (transfer; auto simp: fun_eq_iff)+

lemma upd_set_code[code]:
  "upd_set m f A = (if finite A then set_fold_cfi (upd_cfi f) m A else Code.abort (STR ''upd_set: infinite'') (\<lambda>_. upd_set m f A))"
  by (transfer fixing: m) (auto simp: upd_set_fold)

lemma lexordp_eq_code[code]: "lexordp_eq xs ys \<longleftrightarrow> (case xs of [] \<Rightarrow> True
  | x # xs \<Rightarrow> (case ys of [] \<Rightarrow> False
    | y # ys \<Rightarrow> if x < y then True else if x > y then False else lexordp_eq xs ys))"
  by (subst lexordp_eq.simps) (auto split: list.split)

definition "filter_set m X t = Mapping.filter (filter_cond X m t) m"

declare [[code drop: shift_end]]
declare shift_end.simps[folded filter_set_def, code]

lemma upd_set'_empty[simp]: "upd_set' m d f {} = m"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup)

lemma upd_set'_insert: "d = f d \<Longrightarrow> (\<And>x. f (f x) = f x) \<Longrightarrow> upd_set' m d f (insert x A) =
  (let m' = (upd_set' m d f A) in case Mapping.lookup m' x of None \<Rightarrow> Mapping.update x d m'
  | Some v \<Rightarrow> Mapping.update x (f v) m')"
  by (rule mapping_eqI) (auto simp: upd_set'_lookup Mapping.lookup_update' split: option.splits)

lemma upd_set'_aux1: "upd_set' Mapping.empty d f {b. b = k \<or> (a, b) \<in> A} =
  Mapping.update k d (upd_set' Mapping.empty d f {b. (a, b) \<in> A})"
  by (rule mapping_eqI) (auto simp add: Let_def upd_set'_lookup Mapping.lookup_update'
      Mapping.lookup_empty split: option.splits)

lemma upd_set'_aux2: "Mapping.lookup m k = None \<Longrightarrow> upd_set' m d f {b. b = k \<or> (a, b) \<in> A} =
  Mapping.update k d (upd_set' m d f {b. (a, b) \<in> A})"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup Mapping.lookup_update' split: option.splits)

lemma upd_set'_aux3: "Mapping.lookup m k = Some v \<Longrightarrow> upd_set' m d f {b. b = k \<or> (a, b) \<in> A} =
  Mapping.update k (f v) (upd_set' m d f {b. (a, b) \<in> A})"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup Mapping.lookup_update' split: option.splits)

lemma upd_set'_aux4: "k \<notin> fst ` A \<Longrightarrow> upd_set' Mapping.empty d f {b. (k, b) \<in> A} = Mapping.empty"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup Mapping.lookup_update' Domain.DomainI fst_eq_Domain
      split: option.splits)

lemma upd_nested_empty[simp]: "upd_nested m d f {} = m"
  by (rule mapping_eqI) (auto simp add: upd_nested_lookup split: option.splits)

definition upd_nested_step :: "'c \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> ('a, ('b, 'c) mapping) mapping \<Rightarrow>
  ('a, ('b, 'c) mapping) mapping" where
  "upd_nested_step d f x m = (case x of (k, k') \<Rightarrow>
    (case Mapping.lookup m k of Some m' \<Rightarrow>
      (case Mapping.lookup m' k' of Some v \<Rightarrow> Mapping.update k (Mapping.update k' (f v) m') m
      | None \<Rightarrow> Mapping.update k (Mapping.update k' d m') m)
    | None \<Rightarrow> Mapping.update k (Mapping.update k' d Mapping.empty) m))"

lemma upd_nested_insert:
  "d = f d \<Longrightarrow> (\<And>x. f (f x) = f x) \<Longrightarrow> upd_nested m d f (insert x A) =
  upd_nested_step d f x (upd_nested m d f A)"
  unfolding upd_nested_step_def
  using upd_set'_aux1[of d f _ _ A] upd_set'_aux2[of _ _ d f _ A] upd_set'_aux3[of _ _ _ d f _ A]
    upd_set'_aux4[of _ A d f]
  by (auto simp add: Let_def upd_nested_lookup upd_set'_lookup Mapping.lookup_update'
      Mapping.lookup_empty split: option.splits prod.splits if_splits intro!: mapping_eqI)

definition upd_nested_max_tstp where
  "upd_nested_max_tstp m d X = upd_nested m d (max_tstp d) X"

lemma upd_nested_max_tstp_fold:
  assumes "finite X"
  shows "upd_nested_max_tstp m d X = Finite_Set.fold (upd_nested_step d (max_tstp d)) m X"
proof -
  interpret comp_fun_idem "upd_nested_step d (max_tstp d)"
    by (unfold_locales; rule ext)
      (auto simp add: comp_def upd_nested_step_def Mapping.lookup_update' Mapping.lookup_empty
       update_update max_tstp_d_d max_tstp_idem' split: option.splits)
  note upd_nested_insert' = upd_nested_insert[of d "max_tstp d",
    OF max_tstp_d_d[symmetric] max_tstp_idem']
  show ?thesis
    using assms
    by (induct X arbitrary: m rule: finite.induct)
       (auto simp add: upd_nested_max_tstp_def upd_nested_insert')
qed

lift_definition upd_nested_max_tstp_cfi ::
  "ts + tp \<Rightarrow> ('a \<times> 'b, ('a, ('b, ts + tp) mapping) mapping) comp_fun_idem"
  is "\<lambda>d. upd_nested_step d (max_tstp d)"
  by (unfold_locales; rule ext)
    (auto simp add: comp_def upd_nested_step_def Mapping.lookup_update' Mapping.lookup_empty
      update_update max_tstp_d_d max_tstp_idem' split: option.splits)

lemma upd_nested_max_tstp_code[code]:
  "upd_nested_max_tstp m d X = (if finite X then set_fold_cfi (upd_nested_max_tstp_cfi d) m X
    else Code.abort (STR ''upd_nested_max_tstp: infinite'') (\<lambda>_. upd_nested_max_tstp m d X))"
  by transfer (auto simp add: upd_nested_max_tstp_fold)

declare [[code drop: add_new_mmuaux']]
declare add_new_mmuaux'_def[unfolded add_new_mmuaux.simps, folded upd_nested_max_tstp_def, code]

lemma filter_set_empty[simp]: "filter_set m {} t = m"
  unfolding filter_set_def
  by transfer (auto simp: fun_eq_iff split: option.splits)

lemma filter_set_insert[simp]: "filter_set m (insert x A) t = (let m' = filter_set m A t in
  case Mapping.lookup m' x of Some u \<Rightarrow> if t = u then Mapping.delete x m' else m' | _ \<Rightarrow> m')"
  unfolding filter_set_def
  by transfer (auto simp: fun_eq_iff Let_def Map_To_Mapping.map_apply_def split: option.splits)

lemma filter_set_fold:
  assumes "finite A"
  shows "filter_set m A t = Finite_Set.fold (\<lambda>a m.
    case Mapping.lookup m a of Some u \<Rightarrow> if t = u then Mapping.delete a m else m | _ \<Rightarrow> m) m A"
proof -
  interpret comp_fun_idem "\<lambda>a m.
    case Mapping.lookup m a of Some u \<Rightarrow> if t = u then Mapping.delete a m else m | _ \<Rightarrow> m"
    by unfold_locales
      (transfer; auto simp: fun_eq_iff Map_To_Mapping.map_apply_def split: option.splits)+
  from assms show ?thesis
    by (induct A arbitrary: m rule: finite.induct) (auto simp: Let_def)
qed

lift_definition filter_cfi :: "'b \<Rightarrow> ('a, ('a, 'b) mapping) comp_fun_idem"
  is "\<lambda>t a m.
    case Mapping.lookup m a of Some u \<Rightarrow> if t = u then Mapping.delete a m else m | _ \<Rightarrow> m"
  by unfold_locales
    (transfer; auto simp: fun_eq_iff Map_To_Mapping.map_apply_def split: option.splits)+

lemma filter_set_code[code]:
  "filter_set m A t = (if finite A then set_fold_cfi (filter_cfi t) m A else Code.abort (STR ''upd_set: infinite'') (\<lambda>_. filter_set m A t))"
  by (transfer fixing: m) (auto simp: filter_set_fold)

lemma filter_Mapping[code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.filter P (RBT_Mapping t) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''filter RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.filter P (RBT_Mapping t))
                     | Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.filter (case_prod P) t))"
  by (auto simp add: Mapping.filter.abs_eq Mapping_inject split: option.split)

definition "filter_join pos X m = Mapping.filter (join_filter_cond pos X) m"

declare [[code drop: join_mmsaux]]
declare join_mmsaux.simps[folded filter_join_def, code]

lemma filter_join_False_empty: "filter_join False {} m = m"
  unfolding filter_join_def
  by transfer (auto split: option.splits)

lemma filter_join_False_insert: "filter_join False (insert a A) m =
  filter_join False A (Mapping.delete a m)"
proof -
  {
    fix x
    have "Mapping.lookup (filter_join False (insert a A) m) x =
      Mapping.lookup (filter_join False A (Mapping.delete a m)) x"
      by (auto simp add: filter_join_def Mapping.lookup_filter Mapping_lookup_delete
          split: option.splits)
  }
  then show ?thesis
    by (simp add: mapping_eqI)
qed

lemma filter_join_False:
  assumes "finite A"
  shows "filter_join False A m = Finite_Set.fold Mapping.delete m A"
proof -
  interpret comp_fun_idem "Mapping.delete"
    by (unfold_locales; transfer) (fastforce simp add: comp_def)+
  from assms show ?thesis
    by (induction A arbitrary: m rule: finite.induct)
       (auto simp add: filter_join_False_empty filter_join_False_insert fold_fun_left_comm)
qed

lift_definition filter_not_in_cfi :: "('a, ('a, 'b) mapping) comp_fun_idem" is "Mapping.delete"
  by (unfold_locales; transfer) (fastforce simp add: comp_def)+

lemma filter_join_code[code]:
  "filter_join pos A m =
    (if \<not>pos \<and> finite A \<and> card A < Mapping.size m then set_fold_cfi filter_not_in_cfi m A
    else Mapping.filter (join_filter_cond pos A) m)"
  unfolding filter_join_def
  by (transfer fixing: m) (use filter_join_False in \<open>auto simp add: filter_join_def\<close>)

definition set_minus :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "set_minus X Y = X - Y"

lift_definition remove_cfi :: "('a, 'a set) comp_fun_idem"
  is "\<lambda>b a. a - {b}"
  by unfold_locales auto

lemma set_minus_finite:
  assumes fin: "finite Y"
  shows "set_minus X Y = Finite_Set.fold (\<lambda>a X. X - {a}) X Y"
proof -
  interpret comp_fun_idem "\<lambda>a X. X - {a}"
    by unfold_locales auto
  from assms show ?thesis
    by (induction Y arbitrary: X rule: finite.induct) (auto simp add: set_minus_def)
qed

lemma set_minus_code[code]: "set_minus X Y =
  (if finite Y \<and> card Y < card X then set_fold_cfi remove_cfi X Y else X - Y)"
  by transfer (use set_minus_finite in \<open>auto simp add: set_minus_def\<close>)

declare [[code drop: bin_join]]
declare bin_join.simps[folded set_minus_def, code]

definition remove_Union where
  "remove_Union A X B = A - (\<Union>x \<in> X. B x)"

lemma remove_Union_finite:
  assumes "finite X"
  shows "remove_Union A X B = Finite_Set.fold (\<lambda>x A. A - B x) A X"
proof -
  interpret comp_fun_idem "\<lambda>x A. A - B x"
    by unfold_locales auto
  from assms show ?thesis
    by (induct X arbitrary: A rule: finite_induct) (auto simp: remove_Union_def)
qed

lift_definition remove_Union_cfi :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a, 'b set) comp_fun_idem" is "\<lambda>B x A. A - B x"
  by unfold_locales auto

lemma remove_Union_code[code]: "remove_Union A X B =
  (if finite X then set_fold_cfi (remove_Union_cfi B) A X else A - (\<Union>x \<in> X. B x))"
  by (transfer fixing: A X B) (use remove_Union_finite[of X A B] in \<open>auto simp add: remove_Union_def\<close>)

lemma tabulate_remdups: "Mapping.tabulate xs f = Mapping.tabulate (remdups xs) f"
  by (transfer fixing: xs f) (auto simp: map_of_map_restrict)

lift_definition clearjunk :: "(String.literal \<times> event_data list set) list \<Rightarrow> (String.literal, event_data list set list) alist" is
  "\<lambda>t. List.map_filter (\<lambda>(p, X). if X = {} then None else Some (p, [X])) (AList.clearjunk t)"
  unfolding map_filter_def o_def list.map_comp
  by (subst map_cong[OF refl, of _ _ fst]) (auto simp: map_filter_def distinct_map_fst_filter split: if_splits)

lemma map_filter_snd_map_filter: "List.map_filter (\<lambda>(a, b). if P b then None else Some (f a b)) xs =
    map (\<lambda>(a, b). f a b) (filter (\<lambda>x. \<not> P (snd x)) xs)"
  by (simp add: map_filter_def prod.case_eq_if)

lemma mk_db_code_alist:
  "mk_db t = Assoc_List_Mapping (clearjunk t)"
  unfolding mk_db_def Assoc_List_Mapping_def
  by (transfer' fixing: t)
    (auto simp: map_filter_snd_map_filter fun_eq_iff map_of_map image_iff map_of_clearjunk
      map_of_filter_apply dest: weak_map_of_SomeI intro!: bexI[rotated, OF map_of_SomeD]
      split: if_splits option.splits)

lemma mk_db_code[code]:
  "mk_db t = Mapping.of_alist (List.map_filter (\<lambda>(p, X). if X = {} then None else Some (p, [X])) (AList.clearjunk t))"
  unfolding mk_db_def
  by (transfer' fixing: t) (auto simp: map_filter_snd_map_filter fun_eq_iff map_of_map image_iff
      map_of_clearjunk map_of_filter_apply dest: weak_map_of_SomeI intro!: bexI[rotated, OF map_of_SomeD]
      split: if_splits option.splits)

declare [[code drop: New_max_getIJ_genericJoin New_max_getIJ_wrapperGenericJoin]]
declare New_max.genericJoin.simps[folded remove_Union_def, code]
declare New_max.wrapperGenericJoin.simps[folded remove_Union_def, code]

(*<*)
end
(*>*)