section {*I\_cfg\_lemmas*}
theory
  I_cfg_lemmas

imports
  I_cfgSTD
  I_cfgLM_misc
  I_cfgRM
  I_cfgSTD_cfgRM
  I_cfgSTD_cfgLM
  I_cfgLM_cfgRM

begin

lemma combine_derivation_to_terminating_derivation: "
  valid_cfg G
  \<Longrightarrow> cfgLM.derivation G dc
  \<Longrightarrow> dc 0 = Some (pair None \<lparr>cfg_conf = liftA c'\<rparr>)
  \<Longrightarrow> dc nc = Some (pair ec \<lparr>cfg_conf = []\<rparr>)
  \<Longrightarrow> cfgRM.derivation G d2'
  \<Longrightarrow> d2' 0 = Some (pair None \<lparr>cfg_conf = liftA w1\<rparr>)
  \<Longrightarrow> d2' n2' = Some (pair e2'a \<lparr>cfg_conf = []\<rparr>)
  \<Longrightarrow> cfgLM.derivation_initial G d1
  \<Longrightarrow> d1 (Suc (n1'a + n)) = Some (pair e1 \<lparr>cfg_conf = liftB w\<delta>1 @ teA A2 # liftA w1\<rparr>)
  \<Longrightarrow> d1 (Suc (Suc (n1'a + n))) = Some (pair e2 \<lparr>cfg_conf = liftB w\<delta>1 @ liftA c' @ liftA w1\<rparr>)
  \<Longrightarrow> d1 n1'a = Some (pair e0 \<lparr>cfg_conf = liftB w\<delta>1 @ teA B0 # liftA r0\<rparr>)
  \<Longrightarrow> \<exists>d eX eY.
  cfgLM.derivation_initial G d \<and>
  d n1'a = Some (pair e0 \<lparr>cfg_conf = liftB w\<delta>1 @ teA B0 # liftA r0\<rparr>) \<and>
  d (Suc (n1'a + n)) = Some (pair e1 \<lparr>cfg_conf = liftB w\<delta>1 @ teA A2 # liftA w1\<rparr>) \<and>
  d (Suc (Suc (n1'a + n))) = Some (pair e2 \<lparr>cfg_conf = liftB w\<delta>1 @ liftA c' @ liftA w1\<rparr>) \<and>
  d (Suc (Suc (n1'a + n)) + nc) = Some (pair eX \<lparr>cfg_conf = liftB w\<delta>1 @ liftA w1\<rparr>) \<and>
  d (Suc (Suc (n1'a + n)) + nc + n2') = Some (pair eY \<lparr>cfg_conf = liftB w\<delta>1\<rparr>)"
  apply(subgoal_tac "\<exists>d' e. cfgLM.derivation G d' \<and> maximum_of_domain d' n2' \<and> d' 0 = Some (pair None \<lparr>cfg_conf=liftA w1\<rparr>) \<and> d' n2' = Some (pair e \<lparr>cfg_conf=[]\<rparr>)")
   prefer 2
   apply(rule_tac
      d="derivation_take d2' n2'"
      in cfg_derivation_can_be_translated_to_cfgLM_derivation)
        apply(force)
       apply(rule cfgRM_derivations_are_cfg_derivations)
       apply(rule cfgRM.derivation_take_preserves_derivation)
       apply(force)
      apply(simp add: maximum_of_domain_def derivation_take_def)
     apply(simp add: maximum_of_domain_def derivation_take_def)
    apply(simp add: maximum_of_domain_def derivation_take_def)
   apply(force)
  apply(thin_tac "d2' n2' = Some (pair e2'a \<lparr>cfg_conf = []\<rparr>)")
  apply(thin_tac "cfgRM.derivation G d2'")
  apply(thin_tac "d2' 0 = Some (pair None \<lparr>cfg_conf = liftA w1\<rparr>)")
  apply(clarsimp)
  apply(rename_tac d' e)(*strict*)
  apply(rule_tac
      x="derivation_append (derivation_append d1 (derivation_map dc (\<lambda>v. \<lparr>cfg_conf = (liftB w\<delta>1)@(cfg_conf v)@(liftA w1)\<rparr>)) (Suc (Suc (n1'a + n)))) (derivation_map d' (\<lambda>v. \<lparr>cfg_conf = (liftB w\<delta>1)@(cfg_conf v)\<rparr>)) ((Suc (Suc (n1'a + n)))+nc)"
      in exI)
  apply(rule conjI)
   apply(rename_tac d' e)(*strict*)
   apply(rule cfgLM.derivation_append_preserves_derivation_initial)
     apply(rename_tac d' e)(*strict*)
     apply(force)
    apply(rename_tac d' e)(*strict*)
    apply(rule cfgLM.derivation_append_preserves_derivation_initial)
      apply(rename_tac d' e)(*strict*)
      apply(force)
     apply(rename_tac d' e)(*strict*)
     apply(force)
    apply(rename_tac d' e)(*strict*)
    apply(rule cfgLM.derivation_append_preserves_derivation)
      apply(rename_tac d' e)(*strict*)
      apply(rule cfgLM.derivation_initial_is_derivation)
      apply(force)
     apply(rename_tac d' e)(*strict*)
     apply(rule cfgLM.derivation_map_preserves_derivation2)
      apply(rename_tac d' e)(*strict*)
      apply(force)
     apply(rename_tac d' e)(*strict*)
     apply(clarsimp)
     apply(rename_tac d' e a ea b)(*strict*)
     apply(simp add: cfgLM_step_relation_def)
     apply(clarsimp)
     apply(rename_tac d' e a ea b l r)(*strict*)
     apply(rule_tac
      x="liftB w\<delta>1 @ l"
      in exI)
     apply(clarsimp)
     apply (metis setA_liftB_subset setA_app empty_subsetI subset_empty)
    apply(rename_tac d' e)(*strict*)
    apply(clarsimp)
    apply(simp add: derivation_map_def)
   apply(rename_tac d' e)(*strict*)
   apply(rule cfgLM.derivation_append_preserves_derivation)
     apply(rename_tac d' e)(*strict*)
     apply(rule cfgLM.derivation_append_preserves_derivation)
       apply(rename_tac d' e)(*strict*)
       apply(rule cfgLM.derivation_initial_is_derivation)
       apply(force)
      apply(rename_tac d' e)(*strict*)
      apply(rule cfgLM.derivation_map_preserves_derivation2)
       apply(rename_tac d' e)(*strict*)
       apply(force)
      apply(rename_tac d' e)(*strict*)
      apply(clarsimp)
      apply(rename_tac d' e a ea b)(*strict*)
      apply(simp add: cfgLM_step_relation_def)
      apply(clarsimp)
      apply(rename_tac d' e a ea b l r)(*strict*)
      apply(rule_tac
      x="liftB w\<delta>1 @ l"
      in exI)
      apply(clarsimp)
      apply (metis setA_liftB_subset setA_app empty_subsetI subset_empty)
     apply(rename_tac d' e)(*strict*)
     apply(clarsimp)
     apply(simp add: derivation_map_def)
    apply(rename_tac d' e)(*strict*)
    apply(rule cfgLM.derivation_map_preserves_derivation2)
     apply(rename_tac d' e)(*strict*)
     apply(force)
    apply(rename_tac d' e)(*strict*)
    apply(clarsimp)
    apply(rename_tac d' e a ea b)(*strict*)
    apply(simp add: cfgLM_step_relation_def)
    apply(clarsimp)
    apply(rename_tac d' e a ea b l r)(*strict*)
    apply(rule_tac
      x="liftB w\<delta>1 @ l"
      in exI)
    apply(clarsimp)
    apply (metis setA_liftB_subset setA_app empty_subsetI subset_empty)
   apply(rename_tac d' e)(*strict*)
   apply(clarsimp)
   apply(simp add: derivation_append_def derivation_map_def)
   apply(clarsimp)
  apply(rename_tac d' e)(*strict*)
  apply(simp add: derivation_append_def derivation_map_def)
  apply(rule conjI)
   apply(rename_tac d' e)(*strict*)
   apply(clarsimp)
  apply(rename_tac d' e)(*strict*)
  apply(clarsimp)
  done

lemma cfgRM_Nonblockingness_branching_to_cfgRM_Nonblockingness_branching_hlp_mod: "
       valid_cfg G \<Longrightarrow>
       cfgRM_accessible_nonterminals G \<subseteq> cfgRM_Nonblockingness_nonterminals G \<Longrightarrow>
       ATS.derivation_initial cfg_initial_configurations
        cfgRM_step_relation G dh \<Longrightarrow>
       maximum_of_domain dh n \<Longrightarrow>
       dh n = Some (pair e \<lparr>cfg_conf = w\<rparr>) \<Longrightarrow>
       \<exists>dc. cfgRM.derivation G dc \<and>
            cfgLM.belongs G dc \<and>
            Ex (maximum_of_domain dc) \<and>
            derivation_append_fit dh dc n \<and>
            cfg_marking_condition G (derivation_append dh dc n)"
  apply(induct "length(filterA w)" arbitrary: dh n e w)
   apply(rename_tac w dh n e)(*strict*)
   apply(subgoal_tac "\<exists>wx. liftB wx = w")
    apply(rename_tac w dh n e)(*strict*)
    prefer 2
    apply(rule_tac
      x="filterB w"
      in exI)
    apply(rule liftBDeConv2)
    apply(rule filterA_setA)
    apply(force)
   apply(rename_tac w dh n e)(*strict*)
   apply(clarsimp)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule_tac
      x="der1 \<lparr>cfg_conf = liftB wx\<rparr>"
      in exI)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply (metis cfgRM.der1_is_derivation)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply(rule cfgLM.der1_belongs)
    apply(rule cfgRM.belongs_configurations)
     apply(rename_tac dh n e wx)(*strict*)
     apply(rule cfgRM.derivation_initial_belongs)
      apply(rename_tac dh n e wx)(*strict*)
      apply(force)
     apply(rename_tac dh n e wx)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply(rule_tac
      x="0"
      in exI)
    apply (metis der1_maximum_of_domain)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply(simp add: derivation_append_fit_def der1_def)
   apply(rename_tac dh n e wx)(*strict*)
   apply(simp add: cfg_marking_condition_def derivation_append_def der1_def cfg_marking_configuration_def)
   apply(rule_tac
      x="n"
      in exI)
   apply(clarsimp)
   apply(simp add: setA_liftB)
   apply(rule cfgRM.belongs_configurations)
    apply(rename_tac dh n e wx)(*strict*)
    apply(rule cfgRM.derivation_initial_belongs)
     apply(rename_tac dh n e wx)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx)(*strict*)
   apply(force)
  apply(rename_tac x w dh n e)(*strict*)
  apply(subgoal_tac "\<exists>wx1 A wx2. w = wx1 @[teA A]@ liftB wx2")
   apply(rename_tac x w dh n e)(*strict*)
   prefer 2
   apply(rule filterA_gt_0_then_rm_nonterminal)
   apply(force)
  apply(rename_tac x w dh n e)(*strict*)
  apply(clarsimp)
  apply(rename_tac x dh n e wx1 A wx2)(*strict*)
  apply(simp add: filterA_commutes_over_concat filterA_liftB)
  apply(subgoal_tac "A \<in> cfgRM_Nonblockingness_nonterminals G")
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   prefer 2
   apply(rule_tac
      A="cfgRM_accessible_nonterminals G"
      in set_mp)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(force)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(thin_tac "cfgRM_accessible_nonterminals G \<subseteq> cfgRM_Nonblockingness_nonterminals G")
   apply(simp add: cfgRM_accessible_nonterminals_def)
   apply(subgoal_tac "\<lparr>cfg_conf = wx1 @ teA A # liftB wx2\<rparr> \<in> cfg_configurations G")
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    prefer 2
    apply(rule cfgRM.belongs_configurations)
     apply(rename_tac x dh n e wx1 A wx2)(*strict*)
     apply(rule cfgRM.derivation_initial_belongs)
      apply(rename_tac x dh n e wx1 A wx2)(*strict*)
      apply(force)
     apply(rename_tac x dh n e wx1 A wx2)(*strict*)
     apply(force)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(force)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(rule conjI)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(simp add: cfg_configurations_def setAConcat)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(rule_tac
      x="dh"
      in exI)
   apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2)(*strict*)
   apply(rule_tac
      x="n"
      in exI)
   apply(clarsimp)
   apply(simp add: get_configuration_def)
   apply(force)
  apply(rename_tac x dh n e wx1 A wx2)(*strict*)
  apply(simp add: cfgRM_Nonblockingness_nonterminals_def)
  apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d na ea w')(*strict*)
  apply(case_tac na)
   apply(rename_tac dh n e wx1 A wx2 d na ea w')(*strict*)
   apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d na ea w' nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d ea w' nat)(*strict*)
  apply(rename_tac na)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule_tac
      x="wx1@ w' @ liftB wx2"
      in meta_allE)
  apply(erule_tac
      x="derivation_take (derivation_append dh (derivation_map d (\<lambda>c. \<lparr>cfg_conf=wx1@(cfg_conf c)@liftB wx2\<rparr>)) n) (n+Suc na)"
      in meta_allE)
  apply(erule_tac
      x="n+Suc na"
      in meta_allE)
  apply(erule_tac
      x="ea"
      in meta_allE)
  apply(simp add: filterA_commutes_over_concat filterA_liftB)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule setA_empty_filterA_empty)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule cfgRM.derivation_take_preserves_derivation_initial)
   apply(rule cfgRM.derivation_append_preserves_derivation_initial)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule cfgRM.derivation_append_preserves_derivation)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
     apply(simp add: cfgRM.derivation_initial_def)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
    apply(rule cfgRM.derivation_map_preserves_derivation)
      apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
      apply (metis cfgRM_derivations_are_cfg_derivations)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na i eb c)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na c1 eb c2)(*strict*)
    apply(simp add: cfgRM_step_relation_def)
    apply(clarsimp)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na c1 eb c2 l r)(*strict*)
    apply(rule_tac
      x="wx1 @ l"
      in exI)
    apply(clarsimp)
    apply(simp add: setAConcat setA_liftB)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(clarsimp)
   apply(simp add: derivation_map_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule maximum_of_domain_derivation_take)
   apply(simp add: derivation_append_def derivation_map_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(simp add: derivation_take_def derivation_append_def derivation_map_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule_tac
      x="derivation_take (derivation_append (derivation_map d (\<lambda>c. \<lparr>cfg_conf=wx1@(cfg_conf c)@liftB wx2\<rparr>)) dc (Suc na)) (Suc na+x)"
      in exI)
  apply(rule context_conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(rule cfgRM.derivation_take_preserves_derivation)
   apply(rule cfgRM.derivation_append_preserves_derivation)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     apply(rule cfgRM.derivation_map_preserves_derivation)
       apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
       apply (metis cfgRM_derivations_are_cfg_derivations)
      apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x i eb c)(*strict*)
      apply(force)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x c1 eb c2)(*strict*)
     apply(simp add: cfgRM_step_relation_def)
     apply(clarsimp)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x c1 eb c2 l r)(*strict*)
     apply(rule_tac
      x="wx1 @ l"
      in exI)
     apply(clarsimp)
     apply(simp add: setAConcat setA_liftB)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(simp add: derivation_map_def)
   apply(simp add: derivation_append_fit_def derivation_take_def derivation_append_def derivation_map_def)
   apply(case_tac "dc 0")
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x a option conf)(*strict*)
   apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x option conf)(*strict*)
   apply(case_tac option)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x option conf)(*strict*)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x option conf a)(*strict*)
   apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(rule cfgRM.derivation_belongs)
      apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
      apply(force)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     apply(simp add: derivation_append_fit_def derivation_take_def derivation_append_def derivation_map_def)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(rule_tac
      d="dh"
      in cfgRM.belongs_configurations)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     prefer 2
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(rule cfgRM.derivation_initial_belongs)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(rule_tac
      x="(Suc na + x)"
      in exI)
   apply(rule maximum_of_domain_derivation_take)
   apply(simp add: derivation_append_def derivation_map_def maximum_of_domain_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(simp add: derivation_append_def derivation_map_def maximum_of_domain_def derivation_append_fit_def derivation_take_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(subgoal_tac "(derivation_append (derivation_take (derivation_append dh (derivation_map d (\<lambda>c. \<lparr>cfg_conf = wx1 @ cfg_conf c @ liftB wx2\<rparr>)) n) (Suc (n + na))) dc (Suc (n + na))) = (derivation_append dh (derivation_take (derivation_append (derivation_map d (\<lambda>c. \<lparr>cfg_conf = wx1 @ cfg_conf c @ liftB wx2\<rparr>)) dc (Suc na)) (Suc na + x)) n)")
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule ext)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
  apply(simp add: derivation_append_def derivation_map_def derivation_append_fit_def derivation_take_def)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
  apply(clarsimp)
  apply(case_tac "dc (xa - Suc (n + na))")
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
  apply(rule_tac
      d="dc"
      and n="x"
      and m="(xa - Suc (n + na))"
      in cfgRM.no_some_beyond_maximum_of_domain)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
  apply(force)
  done

corollary cfgRM_accessible_nonterminals_contained_in_cfgRM_Nonblockingness_nonterminals_implies_cfgRM_Nonblockingness_branching: "
  valid_cfg G
  \<Longrightarrow> cfgRM_accessible_nonterminals G \<subseteq> cfgRM_Nonblockingness_nonterminals G
  \<Longrightarrow> cfgRM.Nonblockingness_branching G"
  apply(simp add: cfgRM.Nonblockingness_branching_def)
  apply(clarsimp)
  apply(rename_tac dh n)(*strict*)
  apply(case_tac "dh n")
   apply(rename_tac dh n)(*strict*)
   apply(simp add: maximum_of_domain_def get_configuration_def)
  apply(rename_tac dh n a)(*strict*)
  apply(case_tac a)
  apply(rename_tac dh n a option conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n option conf)(*strict*)
  apply(rename_tac e c)
  apply(rename_tac dh n e c)(*strict*)
  apply(case_tac c)
  apply(rename_tac dh n e c cfg_conf)(*strict*)
  apply(rename_tac w)
  apply(rename_tac dh n e c w)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n e w)(*strict*)
  apply(rule cfgRM_Nonblockingness_branching_to_cfgRM_Nonblockingness_branching_hlp_mod)
      apply(rename_tac dh n e w)(*strict*)
      apply(force)
     apply(rename_tac dh n e w)(*strict*)
     apply(force)
    apply(rename_tac dh n e w)(*strict*)
    apply(force)
   apply(rename_tac dh n e w)(*strict*)
   apply(force)
  apply(rename_tac dh n e w)(*strict*)
  apply(force)
  done

corollary cfg_dependency_between_language_properties1: "
  valid_cfg G
  \<Longrightarrow>
  cfgSTD.marked_language G = cfgLM.marked_language G
  \<and> cfgSTD.marked_language G = cfgRM.marked_language G
  \<and> cfgLM.unmarked_language G \<subseteq> cfgSTD.unmarked_language G
  \<and> cfgRM.unmarked_language G \<subseteq> cfgSTD.unmarked_language G
  \<and> cfgSTD.marked_language G \<subseteq> cfgSTD.unmarked_language G
  \<and> cfgLM.marked_language G \<subseteq> cfgLM.unmarked_language G
  \<and> cfgRM.marked_language G \<subseteq> cfgRM.unmarked_language G"
  apply(rule conjI)
   apply (metis CFG_lang_lm_lang_equal)
  apply(rule conjI)
   apply (metis CFG_lang_rm_lang_equal)
  apply(rule conjI)
   apply(simp add: cfgSTD.unmarked_language_def cfgLM.unmarked_language_def cfgSTD.derivation_initial_def)
   apply(clarsimp)
   apply(rename_tac x d)(*strict*)
   apply(rule_tac
      x="d"
      in exI)
   apply(clarsimp)
   apply(simp add: cfgLM.derivation_initial_def)
   apply (metis cfgLM_derivations_are_cfg_derivations)
  apply(rule conjI)
   apply(simp add: cfgSTD.unmarked_language_def cfgRM.unmarked_language_def cfgSTD.derivation_initial_def)
   apply(clarsimp)
   apply(rename_tac x d)(*strict*)
   apply(rule_tac
      x="d"
      in exI)
   apply(clarsimp)
   apply(simp add: cfgRM.derivation_initial_def)
   apply (metis cfgRM_derivations_are_cfg_derivations)
  apply(rule conjI)
   apply (metis cfgSTD.lang_inclusion)
  apply(rule conjI)
   apply (metis cfgLM.lang_inclusion)
  apply (metis cfgRM.lang_inclusion)
  done

lemma CFGlm2rm_single_step: "
  valid_cfg G
  \<Longrightarrow> e=\<lparr>prod_lhs=A,prod_rhs=liftB w\<rparr>
  \<Longrightarrow> \<lparr>prod_lhs=A,prod_rhs=liftB w\<rparr>\<in> cfg_productions G
  \<Longrightarrow> CFGlm2rm G [e] = [e]"
  apply(subgoal_tac "(\<exists>d' e'. cfgLM.derivation G d' \<and> cfgLM.belongs G d' \<and> d' 0 = Some (pair None \<lparr>cfg_conf = [teA A]\<rparr>) \<and> d' (Suc 0) = Some (pair e' \<lparr>cfg_conf = liftB w\<rparr>) \<and> [e]=CFGlm2rm G (map the (get_labels d' (Suc 0))))")
   prefer 2
   apply(rule_tac
      d="der2 \<lparr>cfg_conf=[teA A]\<rparr> e \<lparr>cfg_conf=liftB w\<rparr>"
      in lemma_4_10)
        apply(force)
       apply(rule cfgRM.der2_is_derivation)
       apply(simp add: cfgRM_step_relation_def)
       apply(rule_tac
      x="[]"
      in exI)
       apply(force)
      apply(rule cfgRM.der2_belongs)
        apply(simp add: cfg_configurations_def)
        apply(clarsimp)
        apply (metis prod_lhs_in_nonterms)
       apply(simp add: cfg_step_labels_def)
      apply(simp add: cfg_configurations_def)
      apply(simp add: valid_cfg_def)
      apply(clarsimp)
      apply(erule_tac
      x="\<lparr>prod_lhs = A, prod_rhs = liftB w\<rparr>"
      in ballE)
       apply(force)
      apply(force)
     apply(simp add: der2_def)
    apply(simp add: der2_def)
   apply(rule sym)
   apply(rule_tac
      t="get_labels (der2 \<lparr>cfg_conf = [teA A]\<rparr> e \<lparr>cfg_conf = liftB w\<rparr>) (Suc 0)"
      and s="[Some e]"
      in ssubst)
    apply (metis der2_get_labels)
   apply(force)
  apply(clarsimp)
  apply(rename_tac d' e')(*strict*)
  apply(simp add: get_labels_def)
  apply(subgoal_tac "nat_seq (Suc 0) (Suc 0)=[Suc 0]")
   apply(rename_tac d' e')(*strict*)
   apply(clarsimp)
   apply(simp add: get_label_def)
   apply(case_tac e')
    apply(rename_tac d' e')(*strict*)
    apply(clarsimp)
    apply(rename_tac d')(*strict*)
    apply (metis cfgLM.derivation_Always_PreEdge_prime cfgLM_derivations_are_cfg_derivations)
   apply(rename_tac d' e' a)(*strict*)
   apply(clarsimp)
   apply(rename_tac d' a)(*strict*)
   apply(subgoal_tac "\<exists>e1 e2 c1 c2. d' 0 = Some (pair e1 c1) \<and> SSd (Suc SSn) = Some (pair (Some e2) c2) \<and> cfgLM_step_relation G c1 e2 c2" for SSd SSn)
    apply(rename_tac d' a)(*strict*)
    prefer 2
    apply(rule_tac
      m="Suc 0"
      in cfgLM.step_detail_before_some_position)
      apply(rename_tac d' a)(*strict*)
      apply(force)
     apply(rename_tac d' a)(*strict*)
     apply(force)
    apply(rename_tac d' a)(*strict*)
    apply(force)
   apply(rename_tac d' a)(*strict*)
   apply(clarsimp)
   apply(simp add: cfgLM_step_relation_def)
   apply(clarsimp)
   apply(rename_tac d' a l r)(*strict*)
   apply(case_tac l)
    apply(rename_tac d' a l r)(*strict*)
    prefer 2
    apply(rename_tac d' a l r aa list)(*strict*)
    apply(force)
   apply(rename_tac d' a l r)(*strict*)
   apply(clarsimp)
   apply(rename_tac d' a)(*strict*)
   apply(case_tac a)
   apply(rename_tac d' a prod_lhsa prod_rhsa)(*strict*)
   apply(clarsimp)
  apply(rename_tac d' e')(*strict*)
  apply (metis natUptTo_n_n)
  done

corollary cfg_dependency_between_language_properties2: "
  valid_cfg G
  \<Longrightarrow> cfgSTD.Nonblockingness_branching G
  \<Longrightarrow> cfgSTD.unmarked_language G \<subseteq> cfgRM.unmarked_language G
  \<and> cfgSTD.unmarked_language G \<subseteq> cfgLM.unmarked_language G"
  apply(rule context_conjI)
   apply(metis cfgSTD_unmarked_in_cfgRM_unmarked)
  apply(metis cfgSTD_unmarked_in_cfgLM_unmarked)
  done

corollary cfg_dependency_between_language_properties3: "
  valid_cfg G
  \<Longrightarrow> cfgLM.unmarked_language G = prefix_closure (cfgLM.unmarked_language G)
  \<and> cfgRM.unmarked_language G = prefix_closure (cfgRM.unmarked_language G)
  \<and> cfgSTD.unmarked_language G = prefix_closure (cfgSTD.unmarked_language G)"
  apply(rule conjI)
   apply(rule antisym)
    apply(clarsimp)
    apply(rename_tac x)(*strict*)
    apply(simp add: prefix_closure_def prefix_def)
    apply(force)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(simp add: prefix_closure_def prefix_def cfgLM.unmarked_language_def)
   apply(clarsimp)
   apply(rename_tac x d c)(*strict*)
   apply(rule_tac
      x="d"
      in exI)
   apply(clarsimp)
   apply(simp add: cfg_unmarked_effect_def)
   apply(clarsimp)
   apply(rename_tac x d c e ca i z)(*strict*)
   apply(case_tac ca)
   apply(rename_tac x d c e ca i z cfg_confa)(*strict*)
   apply(clarsimp)
   apply(rename_tac x d c e i z)(*strict*)
   apply(rule_tac
      x="e"
      in exI)
   apply(rule_tac
      x="\<lparr>cfg_conf = liftB (x @ c) @ z\<rparr>"
      in exI)
   apply(clarsimp)
   apply(simp add: liftB_commutes_over_concat)
   apply(force)
  apply(rule conjI)
   apply(rule antisym)
    apply(clarsimp)
    apply(rename_tac x)(*strict*)
    apply(simp add: prefix_closure_def prefix_def)
    apply(force)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(simp add: prefix_closure_def prefix_def cfgRM.unmarked_language_def)
   apply(clarsimp)
   apply(rename_tac x d c)(*strict*)
   apply(rule_tac
      x="d"
      in exI)
   apply(clarsimp)
   apply(simp add: cfg_unmarked_effect_def)
   apply(clarsimp)
   apply(rename_tac x d c e ca i z)(*strict*)
   apply(case_tac ca)
   apply(rename_tac x d c e ca i z cfg_confa)(*strict*)
   apply(clarsimp)
   apply(rename_tac x d c e i z)(*strict*)
   apply(rule_tac
      x="e"
      in exI)
   apply(rule_tac
      x="\<lparr>cfg_conf = liftB (x @ c) @ z\<rparr>"
      in exI)
   apply(clarsimp)
   apply(simp add: liftB_commutes_over_concat)
   apply(force)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(simp add: prefix_closure_def prefix_def)
   apply(force)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: prefix_closure_def prefix_def cfgSTD.unmarked_language_def)
  apply(clarsimp)
  apply(rename_tac x d c)(*strict*)
  apply(rule_tac
      x="d"
      in exI)
  apply(clarsimp)
  apply(simp add: cfg_unmarked_effect_def)
  apply(clarsimp)
  apply(rename_tac x d c e ca i z)(*strict*)
  apply(case_tac ca)
  apply(rename_tac x d c e ca i z cfg_confa)(*strict*)
  apply(clarsimp)
  apply(rename_tac x d c e i z)(*strict*)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="\<lparr>cfg_conf = liftB (x @ c) @ z\<rparr>"
      in exI)
  apply(clarsimp)
  apply(simp add: liftB_commutes_over_concat)
  apply(force)
  done

corollary cfgSTD_Nonblockingness_branching_implies_equal_langBF: "
  valid_cfg G
  \<Longrightarrow> cfgSTD.Nonblockingness_branching G
  \<Longrightarrow> (nonblockingness_language (cfgSTD.unmarked_language G) (cfgSTD.marked_language G)
  \<longleftrightarrow> nonblockingness_language (cfgLM.unmarked_language G) (cfgLM.marked_language G))
  \<and> (nonblockingness_language (cfgSTD.unmarked_language G) (cfgSTD.marked_language G)
  \<longleftrightarrow> nonblockingness_language (cfgRM.unmarked_language G) (cfgRM.marked_language G))
  \<and> nonblockingness_language (cfgSTD.unmarked_language G) (cfgSTD.marked_language G)"
  apply(rule conjI)
   apply (metis cfgLM_inst_Nonblockingness_branching_correspond1 cfgSTD_Nonblockingness_branching_to_cfgLM_Nonblockingness_branching cfgSTD_inst_Nonblockingness_branching_correspond1)
  apply(rule conjI)
   apply (metis cfgRM_inst_Nonblockingness_branching_correspond1 cfgSTD.AX_BF_Bra_OpLa cfgSTD_Nonblockingness_branching_to_cfgRM_Nonblockingness_branching)
  apply (metis cfgRM_inst_Nonblockingness_branching_correspond1 cfgSTD.AX_BF_Bra_OpLa cfgSTD_Nonblockingness_branching_to_cfgRM_Nonblockingness_branching)
  done

lemma cfgRM_Nonblockingness_branching_to_cfgSTD_Nonblockingness_branching_hlp: "
       valid_cfg G \<Longrightarrow>
       cfgRM.Nonblockingness_branching G \<Longrightarrow>
       ATS.derivation_initial cfg_initial_configurations
        cfgSTD_step_relation G dh \<Longrightarrow>
       maximum_of_domain dh n \<Longrightarrow>
       dh n = Some (pair e \<lparr>cfg_conf = w\<rparr>) \<Longrightarrow>
       \<exists>dc. cfgSTD.derivation G dc \<and>
            cfgLM.belongs G dc \<and>
            Ex (maximum_of_domain dc) \<and>
            derivation_append_fit dh dc n \<and>
            cfg_marking_condition G (derivation_append dh dc n)"
  apply(induct "length(filterA w)" arbitrary: dh n e w)
   apply(rename_tac w dh n e)(*strict*)
   apply(subgoal_tac "\<exists>wx. liftB wx = w")
    apply(rename_tac w dh n e)(*strict*)
    prefer 2
    apply(rule_tac
      x="filterB w"
      in exI)
    apply(rule liftBDeConv2)
    apply(rule filterA_setA)
    apply(force)
   apply(rename_tac w dh n e)(*strict*)
   apply(clarsimp)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule_tac
      x="der1 \<lparr>cfg_conf = liftB wx\<rparr>"
      in exI)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply (metis cfgSTD.der1_is_derivation)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply(rule cfgSTD.der1_belongs)
    apply(rule cfgSTD.belongs_configurations)
     apply(rename_tac dh n e wx)(*strict*)
     apply(rule cfgSTD.derivation_initial_belongs)
      apply(rename_tac dh n e wx)(*strict*)
      apply(force)
     apply(rename_tac dh n e wx)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply(rule_tac
      x="0"
      in exI)
    apply (metis der1_maximum_of_domain)
   apply(rename_tac dh n e wx)(*strict*)
   apply(rule conjI)
    apply(rename_tac dh n e wx)(*strict*)
    apply(simp add: derivation_append_fit_def der1_def)
   apply(rename_tac dh n e wx)(*strict*)
   apply(simp add: cfg_marking_condition_def derivation_append_def der1_def cfg_marking_configuration_def)
   apply(rule_tac
      x="n"
      in exI)
   apply(clarsimp)
   apply(simp add: setA_liftB)
   apply(rule cfgSTD.belongs_configurations)
    apply(rename_tac dh n e wx)(*strict*)
    apply(rule cfgSTD.derivation_initial_belongs)
     apply(rename_tac dh n e wx)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx)(*strict*)
   apply(force)
  apply(rename_tac x w dh n e)(*strict*)
  apply(subgoal_tac "\<exists>wx1 A wx2. w = wx1 @[teA A]@liftB wx2")
   apply(rename_tac x w dh n e)(*strict*)
   prefer 2
   apply(rule filterA_gt_0_then_rm_nonterminal)
   apply(force)
  apply(rename_tac x w dh n e)(*strict*)
  apply(clarsimp)
  apply(rename_tac x dh n e wx1 A wx2)(*strict*)
  apply(simp add: filterA_commutes_over_concat filterA_liftB)
  apply(subgoal_tac "A \<in> cfgRM_Nonblockingness_nonterminals G")
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   prefer 2
   apply(rule_tac
      A="cfgRM_accessible_nonterminals G"
      in set_mp)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(rule cfgRM_Nonblockingness_branching_implies_cfgRM_accessible_nonterminals_contained_in_cfgRM_Nonblockingness_nonterminals)
     apply(rename_tac x dh n e wx1 A wx2)(*strict*)
     apply(force)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(force)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(rule_tac
      A="cfgSTD_accessible_nonterminals_ALT G"
      in set_mp)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(rule cfgSTD_accessible_nonterminals_ALT_contained_in_cfgRM_accessible_nonterminals)
     apply(rename_tac x dh n e wx1 A wx2)(*strict*)
     apply(force)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(force)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(simp add: cfgSTD_accessible_nonterminals_ALT_def)
   apply(subgoal_tac "\<lparr>cfg_conf = wx1 @ teA A # liftB wx2\<rparr> \<in> cfg_configurations G")
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    prefer 2
    apply(rule cfgSTD.belongs_configurations)
     apply(rename_tac x dh n e wx1 A wx2)(*strict*)
     apply(rule cfgSTD.derivation_initial_belongs)
      apply(rename_tac x dh n e wx1 A wx2)(*strict*)
      apply(force)
     apply(rename_tac x dh n e wx1 A wx2)(*strict*)
     apply(force)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(force)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(rule conjI)
    apply(rename_tac x dh n e wx1 A wx2)(*strict*)
    apply(simp add: cfg_configurations_def setAConcat)
   apply(rename_tac x dh n e wx1 A wx2)(*strict*)
   apply(rule_tac
      x="dh"
      in exI)
   apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2)(*strict*)
   apply(rule_tac
      x="n"
      in exI)
   apply(clarsimp)
   apply(simp add: get_configuration_def)
   apply(force)
  apply(rename_tac x dh n e wx1 A wx2)(*strict*)
  apply(simp add: cfgRM_Nonblockingness_nonterminals_def)
  apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d na ea w')(*strict*)
  apply(case_tac na)
   apply(rename_tac dh n e wx1 A wx2 d na ea w')(*strict*)
   apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d na ea w' nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d ea w' nat)(*strict*)
  apply(rename_tac na)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule_tac
      x="wx1@ w' @ liftB wx2"
      in meta_allE)
  apply(erule_tac
      x="derivation_take (derivation_append dh (derivation_map d (\<lambda>c. \<lparr>cfg_conf=wx1@(cfg_conf c)@liftB wx2\<rparr>)) n) (n+Suc na)"
      in meta_allE)
  apply(erule_tac
      x="n+Suc na"
      in meta_allE)
  apply(erule_tac
      x="ea"
      in meta_allE)
  apply(simp add: filterA_commutes_over_concat filterA_liftB)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule setA_empty_filterA_empty)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule cfgSTD.derivation_take_preserves_derivation_initial)
   apply(rule cfgSTD.derivation_append_preserves_derivation_initial)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule cfgSTD.derivation_append_preserves_derivation)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
     apply(simp add: cfgSTD.derivation_initial_def)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
    apply(rule cfgSTD.derivation_map_preserves_derivation)
      apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
      apply (metis cfgRM_derivations_are_cfg_derivations)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na i eb c)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na c1 eb c2)(*strict*)
    apply(simp add: cfgSTD_step_relation_def)
    apply(clarsimp)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na c1 eb c2 l r)(*strict*)
    apply(rule_tac
      x="wx1 @ l"
      in exI)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(clarsimp)
   apply(simp add: derivation_map_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(rule maximum_of_domain_derivation_take)
   apply(simp add: derivation_append_def derivation_map_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
   apply(simp add: derivation_take_def derivation_append_def derivation_map_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule_tac
      x="derivation_take (derivation_append (derivation_map d (\<lambda>c. \<lparr>cfg_conf=wx1@(cfg_conf c)@liftB wx2\<rparr>)) dc (Suc na)) (Suc na+x)"
      in exI)
  apply(rule context_conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(rule cfgSTD.derivation_take_preserves_derivation)
   apply(rule cfgSTD.derivation_append_preserves_derivation)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     apply(rule cfgSTD.derivation_map_preserves_derivation)
       apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
       apply (metis cfgRM_derivations_are_cfg_derivations)
      apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x i eb c)(*strict*)
      apply(force)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x c1 eb c2)(*strict*)
     apply(simp add: cfgSTD_step_relation_def)
     apply(clarsimp)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x c1 eb c2 l r)(*strict*)
     apply(rule_tac
      x="wx1 @ l"
      in exI)
     apply(clarsimp)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(simp add: derivation_map_def)
   apply(simp add: derivation_append_fit_def derivation_take_def derivation_append_def derivation_map_def)
   apply(case_tac "dc 0")
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x a option conf)(*strict*)
   apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x option conf)(*strict*)
   apply(case_tac option)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x option conf)(*strict*)
    apply(clarsimp)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x option conf a)(*strict*)
   apply(clarsimp)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(rule cfgSTD.derivation_belongs)
      apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
      apply(force)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     apply(simp add: derivation_append_fit_def derivation_take_def derivation_append_def derivation_map_def)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(rule_tac
      d="dh"
      in cfgRM.belongs_configurations)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     prefer 2
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(rule cfgSTD.derivation_initial_belongs)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(rule_tac
      x="(Suc na + x)"
      in exI)
   apply(rule maximum_of_domain_derivation_take)
   apply(simp add: derivation_append_def derivation_map_def maximum_of_domain_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(simp add: derivation_append_def derivation_map_def maximum_of_domain_def derivation_append_fit_def derivation_take_def)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(subgoal_tac "(derivation_append (derivation_take (derivation_append dh (derivation_map d (\<lambda>c. \<lparr>cfg_conf = wx1 @ cfg_conf c @ liftB wx2\<rparr>)) n) (Suc (n + na))) dc (Suc (n + na))) = (derivation_append dh (derivation_take (derivation_append (derivation_map d (\<lambda>c. \<lparr>cfg_conf = wx1 @ cfg_conf c @ liftB wx2\<rparr>)) dc (Suc na)) (Suc na + x)) n)")
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x)(*strict*)
  apply(rule ext)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
  apply(simp add: derivation_append_def derivation_map_def derivation_append_fit_def derivation_take_def)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
  apply(clarsimp)
  apply(case_tac "dc (xa - Suc (n + na))")
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
  apply(rule_tac
      d="dc"
      and n="x"
      and m="(xa - Suc (n + na))"
      in cfgSTD.no_some_beyond_maximum_of_domain)
     apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
     apply(force)
    apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
    apply(force)
   apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
   apply(force)
  apply(rename_tac dh n e wx1 A wx2 d ea w' na dc x xa a)(*strict*)
  apply(force)
  done

corollary cfgRM_Nonblockingness_branching_to_cfgSTD_Nonblockingness_branching: "
  valid_cfg G
  \<Longrightarrow> cfgRM.Nonblockingness_branching G
  \<Longrightarrow> cfgSTD.Nonblockingness_branching G"
  apply(simp add: cfgSTD.Nonblockingness_branching_def)
  apply(clarsimp)
  apply(rename_tac dh n)(*strict*)
  apply(case_tac "dh n")
   apply(rename_tac dh n)(*strict*)
   apply(simp add: maximum_of_domain_def get_configuration_def)
  apply(rename_tac dh n a)(*strict*)
  apply(case_tac a)
  apply(rename_tac dh n a option conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n option conf)(*strict*)
  apply(rename_tac e c)
  apply(rename_tac dh n e c)(*strict*)
  apply(case_tac c)
  apply(rename_tac dh n e c cfg_conf)(*strict*)
  apply(rename_tac w)
  apply(rename_tac dh n e c w)(*strict*)
  apply(clarsimp)
  apply(rename_tac dh n e w)(*strict*)
  apply(rule cfgRM_Nonblockingness_branching_to_cfgSTD_Nonblockingness_branching_hlp)
      apply(rename_tac dh n e w)(*strict*)
      apply(force)
     apply(rename_tac dh n e w)(*strict*)
     apply(force)
    apply(rename_tac dh n e w)(*strict*)
    apply(force)
   apply(rename_tac dh n e w)(*strict*)
   apply(force)
  apply(rename_tac dh n e w)(*strict*)
  apply(force)
  done

lemma construct_elimininating_derivation_rm: "
  valid_cfg G'
  \<Longrightarrow> cfg_nonterminals G' = cfgLM_accessible_nonterminals G' \<inter> cfgSTD_Nonblockingness_nonterminals G'
  \<Longrightarrow> setA w \<subseteq> cfg_nonterminals G'
  \<Longrightarrow> \<exists>d n e v.
  cfgRM.derivation G' d
  \<and> d 0 = Some (pair None \<lparr>cfg_conf=w\<rparr>)
  \<and> d n = Some (pair e \<lparr>cfg_conf=liftB v\<rparr>)"
  apply(subgoal_tac "\<exists>d w'. cfgSTD.derivation_from_to G' d {pair None \<lparr>cfg_conf = w\<rparr>} {y. \<exists>x. y = pair x \<lparr>cfg_conf = w'\<rparr>} \<and> setA w' = {}")
   prefer 2
   apply(rule canElimCombine)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rename_tac d w')(*strict*)
  apply(simp add: cfgSTD.derivation_from_to_def)
  apply(simp add: cfgSTD.derivation_to_def)
  apply(simp add: cfgSTD.derivation_from_def)
  apply(clarsimp)
  apply(rename_tac d w' n x)(*strict*)
  apply(case_tac "d 0")
   apply(rename_tac d w' n x)(*strict*)
   apply(clarsimp)
  apply(rename_tac d w' n x a)(*strict*)
  apply(clarsimp)
  apply(rename_tac d w' n x)(*strict*)
  apply(subgoal_tac "\<exists>d' e. cfgRM.derivation G' d' \<and> maximum_of_domain d' n \<and> d' 0 = Some (pair None \<lparr>cfg_conf=w\<rparr>) \<and> d' n = Some (pair e \<lparr>cfg_conf=w'\<rparr>)")
   apply(rename_tac d w' n x)(*strict*)
   prefer 2
   apply(rule cfg_derivation_can_be_translated_to_cfgRM_derivation)
        apply(rename_tac d w' n x)(*strict*)
        apply(force)
       apply(rename_tac d w' n x)(*strict*)
       apply(force)
      apply(rename_tac d w' n x)(*strict*)
      apply(simp add: maximum_of_domain_def)
     apply(rename_tac d w' n x)(*strict*)
     apply(force)
    apply(rename_tac d w' n x)(*strict*)
    apply(force)
   apply(rename_tac d w' n x)(*strict*)
   apply(force)
  apply(rename_tac d w' n x)(*strict*)
  apply(clarsimp)
  apply(rename_tac d w' n x d' e)(*strict*)
  apply(rule_tac
      x="d'"
      in exI)
  apply(clarsimp)
  apply(rule_tac
      x="n"
      in exI)
  apply(clarsimp)
  apply(rule_tac
      x="filterB w'"
      in exI)
  apply (metis liftBDeConv2)
  done

end


(*  Title:      HOL/Auth/n_german_lemma_inv__3_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__3_on_rules imports n_german_lemma_on_inv__3
begin
section{*All lemmas on causal relation between inv__3*}
lemma lemma_inv__3_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__3  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqEIVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqES  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqESVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReq N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvEVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvSVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__3) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


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

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

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

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

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

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

theory XVcg
imports Vcg

begin

text \<open>We introduce a syntactic variant of the let-expression so that we can
safely unfold it during verification condition generation. With the new
theorem attribute \<open>vcg_simp\<close> we can declare equalities to be used
by the verification condition generator, while simplifying assertions.
\<close>

syntax
"_Let'" :: "[letbinds, basicblock] => basicblock"  ("(LET (_)/ IN (_))" 23)

translations
  "_Let' (_binds b bs) e"  == "_Let' b (_Let' bs e)"
  "_Let' (_bind x a) e"    == "CONST Let' a (%x. e)"

lemma Let'_unfold [vcg_simp]: "Let' x f = f x"
  by (simp add: Let'_def Let_def)

lemma Let'_split_conv [vcg_simp]:
  "(Let' x  (\<lambda>p. (case_prod (f p) (g p)))) =
   (Let' x  (\<lambda>p. (f p) (fst (g p)) (snd (g p))))"
  by (simp add: split_def)

end


theory AST
  imports Main
    BinNums Integers Floats
begin

(** This file defines a number of data types and operations used in
  the abstract syntax trees of many of the intermediate languages. *)

(** * Syntactic elements *)

(** Identifiers (names of local variables, of global symbols and functions,
  etc) are represented by strings in this formalization, but with the
  type [positive] in CompCert. Conversion is done at deserialization. *)

type_synonym ident = String.literal

(** The intermediate languages are weakly typed, using the following types: *)

datatype type =
    Tint (* 32-bit integers or pointers *)
  | Tfloat (* 64-bit double-precision floats *)
  | Tlong (* 64-bit integers *)
  | Tsingle (* 32-bit single-precision floats *)
  | Tany32 (* any 32-bit value *)
  | Tany64 (* any 64-bit value, i.e. any value *)

definition Tptr :: type where
"Tptr \<equiv> if ptr64 then Tlong else Tint"

lemma Tptr64[simp]: "Tptr = Tlong" unfolding Tptr_def ptr64_def by simp

(** To describe the values returned by functions, we use the more precise
    types below. *)

datatype rettype =
    Tret type (* like type t *)
  | Tint8signed (* 8-bit signed integer *)
  | Tint8unsigned (* 8-bit unsigned integer *)
  | Tint16signed (* 16-bit signed integer *)
  | Tint16unsigned (* 16-bit unsigned integer *)
  | Tvoid (* no value returned *)

(** Additionally, function definitions and function calls are annotated
  by function signatures indicating:
- the number and types of arguments;
- the type of the returned value;
- additional information on which calling convention to use.

These signatures are used in particular to determine appropriate
calling conventions for the function. *)

record calling_convention =
  cc_vararg :: bool (* variable-arity function *)
  cc_unproto :: bool (* old-style unprototyped function *)
  cc_structret :: bool (* function returning a struct *)

definition cc_default :: calling_convention where
"cc_default \<equiv> (| cc_vararg = False, cc_unproto = False, cc_structret = False |)"

record signature =
  sig_args :: "type list"
  sig_res :: rettype
  sig_cc :: calling_convention

abbreviation "mksignature \<equiv> signature.make"

definition signature_dummy :: signature where
  "signature_dummy \<equiv> (| sig_args = [], sig_res = Tvoid, sig_cc = cc_default |)"

definition signature_main :: signature where
  "signature_main \<equiv> (| sig_args = [], sig_res = (Tret Tint), sig_cc = cc_default |)"

(** Memory accesses (load and store instructions) are annotated by
  a ``memory chunk'' indicating the type, size and signedness of the
  chunk of memory being accessed. *)

datatype memory_chunk =
    Mint8signed (* 8-bit signed integer *)
  | Mint8unsigned (* 8-bit unsigned integer *)
  | Mint16signed (* 16-bit signed integer *)
  | Mint16unsigned (* 16-bit unsigned integer *)
  | Mint32 (* 32-bit integer, or pointer *)
  | Mint64 (* 64-bit integer *)
  | Mfloat32 (* 32-bit single-precision float *)
  | Mfloat64 (* 64-bit double-precision float *)
  | Many32 (* any value that fits in 32 bits *)
  | Many64 (* any value *)

definition Mptr :: memory_chunk where "Mptr \<equiv> if Archi.ptr64 then Mint64 else Mint32"

(** The type (integer/pointer or float) of a chunk. *)

fun type_of_chunk :: "memory_chunk \<Rightarrow> type" where
  "type_of_chunk Mint8signed = Tint"
| "type_of_chunk Mint8unsigned = Tint"
| "type_of_chunk Mint16signed = Tint"
| "type_of_chunk Mint16unsigned = Tint"
| "type_of_chunk Mint32 = Tint"
| "type_of_chunk Mint64 = Tlong"
| "type_of_chunk Mfloat32 = Tsingle"
| "type_of_chunk Mfloat64 = Tfloat"
| "type_of_chunk Many32 = Tany32"
| "type_of_chunk Many64 = Tany64"

(** Same, as a return type. *)

fun rettype_of_chunk :: "memory_chunk \<Rightarrow> rettype" where
  "rettype_of_chunk Mint8signed = Tint8signed"
| "rettype_of_chunk Mint8unsigned = Tint8unsigned"
| "rettype_of_chunk Mint16signed = Tint16signed"
| "rettype_of_chunk Mint16unsigned = Tint16unsigned"
| "rettype_of_chunk Mint32 = Tret Tint"
| "rettype_of_chunk Mint64 = Tret Tlong"
| "rettype_of_chunk Mfloat32 = Tret Tsingle"
| "rettype_of_chunk Mfloat64 = Tret Tfloat"
| "rettype_of_chunk Many32 = Tret Tany32"
| "rettype_of_chunk Many64 = Tret Tany64"

(** Initialization data for global variables. *)

datatype init_data =
  Init_int8 m_int
| Init_int16 m_int
| Init_int32 m_int
| Init_int64 m_int64
| Init_float32 float32
| Init_float64 float64
| Init_space Z
| Init_addrof ident m_ptrofs (* address of symbol + offset *)

fun init_data_size :: "init_data \<Rightarrow> Z" where
  "init_data_size (Init_int8 _) = 1"
| "init_data_size (Init_int16 _) = 2"
| "init_data_size (Init_int32 _) = 4"
| "init_data_size (Init_int64 _) = 8"
| "init_data_size (Init_float32 _) = 4"
| "init_data_size (Init_float64 _) = 8"
| "init_data_size (Init_addrof _ _) = (if Archi.ptr64 then 8 else 4)"
| "init_data_size (Init_space n) = max n 0"

fun init_data_list_size :: "(init_data list) \<Rightarrow> Z" where
  "init_data_list_size [] = 0"
| "init_data_list_size (i # il') = init_data_size i + init_data_list_size il'"

(** Information attached to global variables. *)

record 'v globvar =
  gvar_info :: 'v (* language-dependent info, e.g. a type *)
  gvar_init :: "init_data list" (* initialization data *)
  gvar_readonly :: bool (* read-only variable? (const) *)
  gvar_volatile :: bool (* volatile variable? *)

(** Whole programs consist of:
- a collection of global definitions (name and description);
- a set of public names (the names that are visible outside
  this compilation unit);
- the name of the ``main'' function that serves as entry point in the program.

A global definition is either a global function or a global variable.
The type of function descriptions and that of additional information
for variables vary among the various intermediate languages and are
taken as parameters to the [program] type.  The other parts of whole
programs are common to all languages. *)

datatype ('f, 'v) globdef =
    Gfun 'f
  | Gvar "'v globvar"

record ('f, 'v) program =
  prog_defs :: "(ident * ('f, 'v) globdef) list"
  prog_public :: "ident list"
  prog_main :: ident

(** * External functions *)

(** For most languages, the functions composing the program are either
  internal functions, defined within the language, or external functions,
  defined outside.  External functions include system calls but also
  compiler built-in functions.  We define a type for external functions
  and associated operations. *)

datatype external_function =
(* TODO: not implemented for now
    EF_external (ef_name: String.literal) (ef_sg: signature)
     (** A system call or library function.  Produces an event
         in the trace. *)
  | EF_builtin (ef_name: String.literal) (ef_sg: signature)
     (** A compiler built-in function.  Behaves like an external, but
         can be inlined by the compiler. *)
  | EF_runtime (ef_name: String.literal) (ef_sg: signature)
     (** A function from the run-time library.  Behaves like an
         external, but must not be redefined. *)
  | EF_vload (ef_chunk: memory_chunk)
     (** A volatile read operation.  If the address given as first argument
         points within a volatile global variable, generate an
         event and return the value found in this event.  Otherwise,
         produce no event and behave like a regular memory load. *)
  | EF_vstore (ef_chunk: memory_chunk)
     (** A volatile store operation.   If the address given as first argument
         points within a volatile global variable, generate an event.
         Otherwise, produce no event and behave like a regular memory store. *)
*)
    EF_malloc
     (** Dynamic memory allocation.  Takes the requested size in bytes
         as argument; returns a pointer to a fresh block of the given size.
         Produces no observable event. *)
  | EF_free
     (** Dynamic memory deallocation.  Takes a pointer to a block
         allocated by an [EF_malloc] external call and frees the
         corresponding block.
         Produces no observable event. *)
  | EF_memcpy (ef_sz: Z) (ef_al: Z)
     (** Block copy, of [sz] bytes, between addresses that are [al]-aligned. *)
(* TODO: not implemented for now
  | EF_annot (ef_kind: positive) (ef_text_str: String.literal) (ef_targs: "type list")
     (** A programmer-supplied annotation.  Takes zero, one or several arguments,
         produces an event carrying the text and the values of these arguments,
         and returns no value. *)
  | EF_annot_val (ef_kind: positive) (ef_text_str: String.literal) (ef_targ: type)
     (** Another form of annotation that takes one argument, produces
         an event carrying the text and the value of this argument,
         and returns the value of the argument. *)
  | EF_inline_asm (ef_text_str: String.literal) (ef_sg: signature) (ef_clobbers: "String.literal list")
     (** Inline [asm] statements.  Semantically, treated like an
         annotation with no parameters ([EF_annot text nil]).  To be
         used with caution, as it can invalidate the semantic
         preservation theorem.  Generated only if [-finline-asm] is
         given. *)
  | EF_debug (ef_kind: positive) (ef_text_id: ident) (ef_targs: "type list")
     (** Transport debugging information from the front-end to the generated
         assembly.  Takes zero, one or several arguments like [EF_annot].
         Unlike [EF_annot], produces no observable event. *)
*)

(** The type signature of an external function. *)

fun ef_sig :: "external_function \<Rightarrow> signature" where
(* TODO: not implemented for now
  "ef_sig (EF_external name sg) = sg"
| "ef_sig (EF_builtin name sg) = sg"
| "ef_sig (EF_runtime name sg) = sg"
| "ef_sig (EF_vload chunk) = mksignature (Tptr # []) (rettype_of_chunk chunk) cc_default"
| "ef_sig (EF_vstore chunk) = mksignature (Tptr # type_of_chunk chunk # []) Tvoid cc_default"
*)
  "ef_sig EF_malloc = mksignature (Tptr # []) (Tret Tptr) cc_default"
| "ef_sig EF_free = mksignature (Tptr # []) Tvoid cc_default"
| "ef_sig (EF_memcpy sz al) = mksignature (Tptr # Tptr # []) Tvoid cc_default"
(* TODO: not implemented for now
| "ef_sig (EF_annot kind text targs) = mksignature targs Tvoid cc_default"
| "ef_sig (EF_annot_val kind text targ) = mksignature (targ # []) targ cc_default"
| "ef_sig (EF_inline_asm text sg clob) = sg"
| "ef_sig (EF_debug kind text targs) = mksignature targs Tvoid cc_default"
*)

(** Function definitions are the union of internal and external functions. *)

datatype 'a fundef = Internal 'a | External external_function

end


(*
 * Copyright 2018, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

(* Preprocess AutoCorres translation of Cogent compiler's output code. *)
theory Tidy
  imports
    "AutoCorres.AutoCorres"
    "Cogent.ML_Old"
begin

(* Each Cogent_Corres rule expects (at most) one guard *)
lemma join_guards:
  "do g1 <- guard G1; g2 <- guard G2; P g1 g2 od
    =
   do g1 <- guard (\<lambda>s. G1 s \<and> G2 s); P g1 g1 od"
  by monad_eq

(* C-parser function epilogue *)
lemma return_exn_simp:
  "do ret <- A;
      _ <- gets (\<lambda>_. x :: c_exntype);
      _ <- gets (\<lambda>_. ());
      gets (\<lambda>_. ret) od = A"
  by simp

(* Cogent function epilogue *)
lemma return_cogent_simp:
  "do a \<leftarrow> A;
      r \<leftarrow> gets (\<lambda>_. a);
      gets (\<lambda>_. r) od = A"
  by simp

lemma simp_unit_return:
  "\<And>A. (do (x::unit) \<leftarrow> A; gets (\<lambda>_. ()) od) = A"
  by simp

(* Compose variant constructor with the gets immediately after it *)
(* TODO: this should be more specific, and only instantiated when variant_init is an actual variant constructor *)
lemma compose_gets_variant_con:
  "do a \<leftarrow> select UNIV;
      b \<leftarrow> gets (\<lambda>_. payload_update (\<lambda>_. payload) (tag_update (\<lambda>_. tag) variant_init));
      c \<leftarrow> gets (\<lambda>_. b);
      A c
   od =
   do
      b \<leftarrow> gets (\<lambda>_. payload_update (\<lambda>_. payload) (tag_update (\<lambda>_. tag) variant_init));
      A b
  od"
  by monad_eq
lemma compose_gets_variant_con_2:
  "do a \<leftarrow> select UNIV;
      b \<leftarrow> gets (\<lambda>_. payload_update (\<lambda>_. payload) (tag_update (\<lambda>_. tag) variant_init));
      gets (\<lambda>_. b)
   od =
      gets (\<lambda>_. payload_update (\<lambda>_. payload) (tag_update (\<lambda>_. tag) variant_init))"
  by monad_eq

(* Cogent compiler adds one assignment at the end of every block; remove it *)
definition "simp_last_bind = id"

lemma simp_last_bind:
  "\<And>A B C. simp_last_bind (do x \<leftarrow> A; y \<leftarrow> B x; C x y od) = do x \<leftarrow> A; simp_last_bind (do y \<leftarrow> B x; C x y od) od"
  "\<And>A. simp_last_bind (do x \<leftarrow> A; gets (\<lambda>_. x) od) = A"
  "\<And>A. simp_last_bind A = A"
  by (simp_all add: simp_last_bind_def)

lemma simp_last_bindI:
  "simp_last_bind A = B \<Longrightarrow> A = B"
  by (simp add: simp_last_bind_def)
lemma simp_last_bind_recI:
  "condition C (simp_last_bind L) R = B \<Longrightarrow> condition C L R = B"
  by (simp add: simp_last_bind_def)

(* Simplify uninitialised variables. *)
lemma unknown_bind_ignore:
  "select UNIV >>= (\<lambda>_. A) = A"
  by monad_eq

(* The True condition will also be instantiated with LET_TRUE and LET_BANG_TRUE per program *)
lemma unknown_bind_if_True:
  "do x \<leftarrow> select UNIV;
      condition (\<lambda>_. True) T (F x) >>= R od
   = condition (\<lambda>_. True) T (F undefined) >>= R"
  by monad_eq

ML \<open>
fun tidy_C_fun_def f ctxt = let
  val fun_term = Syntax.read_term ctxt (f ^ "'")
  (* Guess whether the function is recursive.
   * FIXME: use AutoCorresFunctionInfo instead *)
  val ([fun_def], fun_rec) = (Proof_Context.get_thms ctxt (f ^ "'.simps"), true)
                             handle ERROR _ => (Proof_Context.get_thms ctxt (f ^ "'_def"), false)

  (* Helper theorems for LET_TRUE and LETBANG_TRUE, if they exist *)
  val unknown_bind_more_thms = ["LET_TRUE", "LETBANG_TRUE"]
        |> maps (fn c => case Syntax.read_term ctxt c of
                             c' as Const _ => [Goal.prove ctxt [] []
                                                (@{mk_term "True \<equiv> (?c \<noteq> 0)" (c)} c')
                                                (K (simp_tac (ctxt addsimps (Proof_Context.get_thms ctxt (c ^ "_def"))) 1))]
                           | _ => [])
        |> map (fn thm => Simplifier.rewrite_rule ctxt [thm] @{thm unknown_bind_if_True})

  (* Use a schematic lemma to rewrite AutoCorres function defs.
   * We can assume the Cogent compiler generates all functions with only one argument. *)
  val prop = if fun_rec then @{mk_term "Trueprop (?f m a = ?A)" f} fun_term
                        else @{mk_term "Trueprop (?f a = ?A)" f} fun_term

  fun subst thms = EqSubst.eqsubst_tac ctxt [0] thms 1

  (* clarsimp won't touch the schematic ?A *)
  fun subst' thms = Clasimp.clarsimp_tac (put_simpset HOL_basic_ss ctxt addsimps thms) 1

  val tacs = subst [fun_def] (* get function definition *)
             THEN subst' @{thms bind_assoc}          (* normalise binds *)
             THEN subst' @{thms join_guards}         (* normalise guards *)
             THEN subst' @{thms simp_thms(21-22,25)} (* simplify conj in guards *)
             THEN subst' @{thms guard_True_bind}     (* remove unnecessary guards *)
             THEN subst @{thms return_exn_simp}      (* remove C parser's function epilogue *)
             (* Remove exactly one bind-gets from the end of the program,
              * which is inserted by the Cogent code generator *)
             THEN rtac (if fun_rec then @{thm simp_last_bind_recI} else @{thm simp_last_bindI}) 1
             THEN subst' @{thms simp_last_bind(1-2) simp_unit_return}
             (* Cleanup any remaining @{term simp_last_bind}s *)
             THEN subst' @{thms simp_last_bind(3)}
             (* Compose variant constructor with the gets immediately after it *)
             THEN subst' @{thms compose_gets_variant_con compose_gets_variant_con_2}
             (* Simplify uninitialised variables *)
             THEN subst' (@{thms unknown_bind_ignore unknown_bind_if_True} @ unknown_bind_more_thms)
             THEN rtac @{thm refl} 1 (* final definition *)
  in Goal.prove ctxt (if fun_rec then ["m", "a"] else ["a"]) [] prop (K tacs) end

fun tidy_C_fun_def' f ctxt =
  Utils.define_lemmas (f ^ "'_def'") [tidy_C_fun_def f ctxt] ctxt |> snd
\<close>

end


theory Capabilities_lemmas
imports Capabilities
begin

subsection \<open>Helper definitions and lemmas\<close>

locale Capabilities =
  fixes CC :: "'cap Capability_class"
  assumes is_tagged_set_tag[simp]: "\<And>c tag. is_tagged_method CC (set_tag_method CC c tag) = tag"
    and is_tagged_set_seal[simp]: "\<And>c s. is_tagged_method CC (set_seal_method CC c s) = is_tagged_method CC c"
    and is_tagged_set_obj_type[simp]: "\<And>c t. is_tagged_method CC (set_obj_type_method CC c t) = is_tagged_method CC c"
    and is_tagged_set_perms[simp]: "\<And>c p. is_tagged_method CC (set_perms_method CC c p) = is_tagged_method CC c"
    and is_tagged_cap_of_mem_bytes[simp]: "\<And>c bytes tag. cap_of_mem_bytes_method CC bytes tag = Some c \<Longrightarrow> is_tagged_method CC c \<longleftrightarrow> tag = B1"
begin

inductive_set derivable :: "'cap set \<Rightarrow> 'cap set" for C :: "'cap set" where
  Copy: "c \<in> C \<Longrightarrow> c \<in> derivable C"
| Restrict: "c' \<in> derivable C \<Longrightarrow> leq_cap CC c c' \<Longrightarrow> c \<in> derivable C"
| Unseal:
    "\<lbrakk>c' \<in> derivable C; c'' \<in> derivable C; is_tagged_method CC c'; is_tagged_method CC c'';
      \<not>is_sealed_method CC c''; is_sealed_method CC c'; permit_unseal (get_perms_method CC c'');
      get_obj_type_method CC c' = get_cursor_method CC c''\<rbrakk> \<Longrightarrow>
     unseal CC c' (get_global_method CC c'') \<in> derivable C"
| Seal:
    "\<lbrakk>c' \<in> derivable C; c'' \<in> derivable C; is_tagged_method CC c'; is_tagged_method CC c'';
      \<not>is_sealed_method CC c''; \<not>is_sealed_method CC c'; permit_seal (get_perms_method CC c'')\<rbrakk> \<Longrightarrow>
     seal CC c' (get_cursor_method CC c'') \<in> derivable C"

lemma leq_cap_refl[simp, intro]:
  "leq_cap CC c c"
  by (simp add: leq_cap_def)

lemma leq_cap_tag_imp[intro]:
  assumes "leq_cap CC c c'"
    and "is_tagged_method CC c"
  shows "is_tagged_method CC c'"
  using assms
  by (auto simp: leq_cap_def)

lemma derivable_mono:
  assumes "C \<subseteq> C'"
  shows "derivable C \<subseteq> derivable C'"
proof
  fix c
  assume "c \<in> derivable C"
  then show "c \<in> derivable C'" using assms by induction (auto intro: derivable.intros)
qed

lemma cap_derivable_bounded_gteq:
  assumes c: "cap_derivable_bounded CC n C c"
    and m: "m \<ge> n"
  shows "cap_derivable_bounded CC m C c"
proof -
  from m obtain k where "m = n + k" using less_iff_Suc_add[of n m] by auto
  also have "cap_derivable_bounded CC (n + k) C c" using c by (induction k) (auto)
  finally show ?thesis .
qed

lemma derivable_refl: "C \<subseteq> derivable C" by (auto intro: derivable.intros)

lemma derivable_union_subseteq_absorb:
  assumes "C' \<subseteq> derivable C"
  shows "derivable (C \<union> C') = derivable C"
proof
  show "derivable (C \<union> C') \<subseteq> derivable C"
  proof
    fix c
    assume "c \<in> derivable (C \<union> C')"
    then show "c \<in> derivable C" using assms by induction (auto intro: derivable.intros)
  qed
  show "derivable C \<subseteq> derivable (C \<union> C')" by (intro derivable_mono) auto
qed

lemma derivable_minus_subseteq: "derivable (C - C') \<subseteq> derivable C"
proof
  fix c
  assume "c \<in> derivable (C - C')"
  then show "c \<in> derivable C" by induction (auto intro: derivable.intros)
qed

lemma cap_derivable_iff_derivable: "cap_derivable CC C c \<longleftrightarrow> c \<in> derivable C"
proof
  assume "cap_derivable CC C c"
  then obtain n where c: "cap_derivable_bounded CC n C c" by (auto simp: cap_derivable_def)
  then show "c \<in> derivable C"
    by (induction CC \<equiv> CC n C c rule: cap_derivable_bounded.induct)
       (auto intro: derivable.intros)
next
  assume c: "c \<in> derivable C"
  then have "\<exists>n. cap_derivable_bounded CC n C c"
  proof (induction rule: derivable.induct)
    case (Copy c)
    then have "cap_derivable_bounded CC 0 C c" by auto
    then show ?case by blast
  next
    case (Restrict c' c)
    then obtain n where "cap_derivable_bounded CC n C c'" by auto
    then have "cap_derivable_bounded CC (Suc n) C c" using Restrict.hyps by auto
    then show ?case by blast
  next
    case (Unseal c' c'')
    then obtain n' n''
      where "cap_derivable_bounded CC n' C c'" and "cap_derivable_bounded CC n'' C c''"
      by blast
    then have "cap_derivable_bounded CC (max n' n'') C c'"
      and "cap_derivable_bounded CC (max n' n'') C c''"
      by (auto intro: cap_derivable_bounded_gteq)
    then have "cap_derivable_bounded CC (Suc (max n' n'')) C (unseal CC c' (get_global_method CC c''))"
      using Unseal.hyps
      by auto
    then show ?case by blast
  next
    case (Seal c' c'')
    then obtain n' n''
      where "cap_derivable_bounded CC n' C c'" and "cap_derivable_bounded CC n'' C c''"
      by blast
    then have "cap_derivable_bounded CC (max n' n'') C c'"
      and "cap_derivable_bounded CC (max n' n'') C c''"
      by (auto intro: cap_derivable_bounded_gteq)
    then have "cap_derivable_bounded CC (Suc (max n' n'')) C (seal CC c' (get_cursor_method CC c''))"
      using Seal.hyps
      by auto
    then show ?case by blast
  qed
  then show "cap_derivable CC C c" by (simp add: cap_derivable_def)
qed

end

end


theory DeadCodeRemovalCorrect
imports Launchbury LaunchburyAbstractTransformation DeadCodeRemoval
begin

definition rdcH :: "var set \<Rightarrow> heap \<Rightarrow> heap"
  where "rdcH S \<Gamma> = [ (x, remove_dead_code e) . (x,e) \<leftarrow> \<Gamma>, x \<notin> S]"

inductive dc_rel :: "(heap \<times> exp) \<Rightarrow> var list \<Rightarrow> (heap \<times> exp) \<Rightarrow>  bool" ("_ \<triangleright>\<^bsub>_\<^esub> _" [50,50,50] 50 )
  where "S \<subseteq> domA \<Gamma> \<union> set L \<Longrightarrow> S \<inter> fv (rdcH S \<Gamma>, remove_dead_code e, L) = {} \<Longrightarrow> (\<Gamma>, e) \<triangleright>\<^bsub>L\<^esub> (rdcH S \<Gamma>, remove_dead_code e)"

lemma map_of_rdcH: "map_of (rdcH S \<Gamma>) x = (if x \<in> S then None else map_option remove_dead_code (map_of \<Gamma> x))"
  by (induction \<Gamma>) (auto simp add: rdcH_def split: if_splits)

lemma delete_rdcH[simp]: "delete x (rdcH S \<Gamma>) = rdcH S (delete x \<Gamma>)"
  by (induction \<Gamma>) (auto simp add: rdcH_def split: if_splits)

lemma rdcH_append[simp]: "rdcH S (as @ \<Gamma>) = rdcH S as @ rdcH S \<Gamma>"
  unfolding rdcH_def by simp

lemma rdcH_nil[simp]: "rdcH S [] = []"
  unfolding rdcH_def by simp

lemma rdcH_is_nil: "domA \<Gamma> \<subseteq> S \<Longrightarrow>  rdcH S \<Gamma> = []"
  by (induction \<Gamma>) (auto simp add: rdcH_def split: if_splits)

lemma rdcH_cong_set: "S \<inter> domA \<Gamma> = S' \<inter> domA \<Gamma> \<Longrightarrow> rdcH S \<Gamma> = rdcH S' \<Gamma>"
by(induction \<Gamma> rule: heapToAssn.induct)(auto simp add: rdcH_def split: if_splits )

interpretation rel_lambda_cong dc_rel
  by default (auto elim!: dc_rel.cases simp del: exp_assn.eq_iff(4))
interpretation rel_app_cong dc_rel
  by default (auto elim: dc_rel.cases)
interpretation rel_var_cong dc_rel
  by default (auto elim: dc_rel.cases)

lemma rdcH_eqvt[eqvt]: "\<pi> \<bullet> (rdcH S \<Gamma>) = rdcH (\<pi> \<bullet> S) (\<pi> \<bullet> \<Gamma>)"
  unfolding rdcH_def by perm_simp rule

lemma rdch_fresh[intro]: "a \<sharp> \<Gamma> \<Longrightarrow> a \<sharp> rdcH S \<Gamma>"
  by (induction \<Gamma>)
     (auto simp add:  rdcH_def fresh_Nil fresh_Pair fresh_Cons  eqvt_fresh_cong1[OF remove_dead_code.eqvt] )

lemma rdch_fv_subset: "fv (rdcH S \<Gamma>) \<subseteq> fv \<Gamma>"
  using rdch_fresh unfolding fresh_def fv_def by auto

interpretation reds_rel_fresh dc_rel
  by default (auto elim!: dc_rel.cases intro: eqvt_fresh_cong1[OF remove_dead_code.eqvt])

interpretation rel_lambda_case dc_rel by default

lemma Lam_eq_same_var[simp]: "Lam [y]. e = Lam [y]. e' \<longleftrightarrow>  e = e'"
  by auto (metis fresh_PairD(2) obtain_fresh)

interpretation rel_app_case dc_rel
proof
  fix \<Gamma> e x L \<Gamma>' e''
  assume "(\<Gamma>, App e x) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', App e'' x)"
  thus "(\<Gamma>, e) \<triangleright>\<^bsub>x # L\<^esub> (\<Gamma>', e'')"
    by (fastforce elim!: dc_rel.cases intro!: dc_rel.intros)
next
  fix \<Gamma> y body x L \<Gamma>' body'
  assume "(\<Gamma>, Lam [y]. body) \<triangleright>\<^bsub>x # L\<^esub> (\<Gamma>', Lam [y]. body')"
  thus "(\<Gamma>, body[y::=x]) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', body'[y::=x])"
    apply (auto elim!: dc_rel.cases intro!: dc_rel.intros dest: set_mp  simp del: exp_assn.eq_iff(4) simp add: subst_remove_dead_code disjoint_iff_not_equal fv_subst_eq split: if_splits)
    apply (auto simp add: subst_remove_dead_code[symmetric] fv_subst_eq  split: if_splits)
    done
qed

interpretation rel_var_case dc_rel
proof
  case (goal1 \<Gamma> x L \<Gamma>' e thesis)
  show thesis
  proof (rule goal1)

    from goal1(1)
    obtain S where "\<Gamma>' = rdcH S \<Gamma>"
      and "S \<subseteq> domA \<Gamma> \<union> set L" and "S \<inter> fv (rdcH S \<Gamma>, Var x, L) = {}" by (auto elim!: dc_rel.cases)
    hence "x \<notin> S" by auto

    from `map_of \<Gamma> x = Some e` and `\<Gamma>' = _` and `x \<notin> S`
    show "map_of \<Gamma>' x = Some (remove_dead_code e)" by (auto simp add: map_of_rdcH)

    have *: "\<And> S . fv (rdcH S (delete x \<Gamma>)) \<subseteq> fv (rdcH S \<Gamma>)" by (metis delete_rdcH fv_delete_subset)

    from `map_of \<Gamma>' x = Some (remove_dead_code e)`
    have **: "fv (remove_dead_code e) \<subseteq> fv \<Gamma>'" by (metis domA_from_set map_of_fv_subset map_of_is_SomeD option.sel)

    from goal1(1)
    show "(delete x \<Gamma>, e) \<triangleright>\<^bsub>x # L\<^esub> (delete x \<Gamma>', remove_dead_code e)"
      by (fastforce elim!: dc_rel.cases intro!: dc_rel.intros dest: set_mp[OF *]  set_mp[OF **]  simp add: disjoint_iff_not_equal)
  qed
next
  fix \<Gamma> z x L \<Gamma>' z'
  assume "(\<Gamma>, z) \<triangleright>\<^bsub>x # L\<^esub> (\<Gamma>', z')"
  then obtain S where "\<Gamma>' = rdcH S \<Gamma>" and "z' = remove_dead_code z"
      and "S \<subseteq> insert x (domA \<Gamma> \<union> set L)" and "S \<inter> fv (rdcH S \<Gamma>, remove_dead_code z, x # L) = {}" by (auto elim!: dc_rel.cases)

  from this(4)
  have "x \<notin> S" by auto
  hence [simp]: "rdcH S ((x, z) # \<Gamma>) = (x,remove_dead_code z) # rdcH S \<Gamma>"
    unfolding rdcH_def by auto

  have  "((x, z) # \<Gamma>, z) \<triangleright>\<^bsub>L\<^esub> (rdcH S ((x, z) # \<Gamma>), remove_dead_code z)"
    apply (rule dc_rel.intros) using `S \<subseteq>  _` `S \<inter> _ = _`  by auto
  thus "((x, z) # \<Gamma>, z) \<triangleright>\<^bsub>L\<^esub> ((x, z') # \<Gamma>', z')"
    unfolding `\<Gamma>' = _` `z' = _` by auto
qed

locale let_removed =
  fixes \<Gamma> as body
  assumes "domA as \<inter> fv body = {} "

lemma map_fst_map_ran[simp]: "map fst (map_ran f l) = map fst l" by (induction l) auto

lemma permute_list_id: "supp p \<subseteq> set xs \<Longrightarrow>  p \<bullet> xs = xs \<Longrightarrow> p = 0"
proof (induction xs)
  case Nil
  hence "supp p = {}" by auto
  thus "p = 0" by (metis empty_subsetI supp_perm_singleton)
next
  case (Cons x xs)
  hence "p \<bullet> x = x" by auto
  hence "x \<notin> supp p" by (metis fresh_def fresh_perm)
  with Cons show "p = 0" by auto
qed

lemma Abs_lst_same[simp]: "[xs]lst. (y::'a::fs) = [xs]lst. y' \<longleftrightarrow> y = y'"
  apply rule
  prefer 2
  apply simp
  unfolding Abs_eq_iff2
  apply (erule exE)
  apply auto
  unfolding alpha_lst.simps
  apply (subgoal_tac "p = 0")
  apply auto[1]
  apply (auto simp add: permute_list_id)
  done

lemma Let_eq_same_var[simp]:
  assumes "map fst as = map fst as'"
  shows "Let as e = Let as' e' \<longleftrightarrow> (as = as' \<and> e = e')"
proof-
  from assms have  "map (\<lambda>x. atom (fst x)) as = map (\<lambda>x. atom (fst x)) as'"
    by (induction as as' rule: list_induct2') auto
  thus ?thesis by auto
qed

locale let_not_removed =
  fixes as :: heap and  body :: exp
  assumes let_not_removed: " domA as \<inter> fv body \<noteq> {} "
begin
  sublocale rel_let_cong dc_rel  \<Gamma> as body for \<Gamma>
  by default (auto elim!: dc_rel.cases simp add: if_not_P[OF let_not_removed] simp del: Let_eq_iff)

  sublocale rel_let_case dc_rel  \<Gamma> as body for \<Gamma>
  proof
    fix L \<Gamma>' as' body'
    assume "(\<Gamma>, Let as body) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', Let as' body')" and "map fst as = map fst as'"
    then obtain S where "\<Gamma>' = rdcH S \<Gamma>" and "body' = remove_dead_code body" and "as' = map_ran (\<lambda>_. remove_dead_code) as"
      and "S \<subseteq> domA \<Gamma> \<union> set L" and "S \<inter> fv (rdcH S \<Gamma>, remove_dead_code (Let as body), L) = {}"
      by (fastforce elim!: dc_rel.cases simp add: if_not_P[OF let_not_removed] simp del: Let_eq_iff)

    assume fresh: "atom ` domA as \<sharp>* \<Gamma>"
    hence "domA as \<inter> domA \<Gamma> = {}" by (metis fresh_distinct)
    moreover
    assume "atom ` domA as \<sharp>* L"
    hence "domA as \<inter> set L = {}" by (induction L) (auto simp add: fresh_star_Cons fresh_star_at_base)
    ultimately
    have * : "domA as \<inter> S = {}" using `S \<subseteq> domA \<Gamma> \<union> set L` by auto
    hence [simp]: "rdcH S as = map_ran (\<lambda>_. remove_dead_code) as"
      unfolding rdcH_def by (induction as) auto

    have "(as @ \<Gamma>, body) \<triangleright>\<^bsub>L\<^esub> (rdcH S (as @ \<Gamma>), remove_dead_code body)"
    proof
      show "S \<subseteq> domA (as @ \<Gamma>) \<union> set L" using * `S \<subseteq> _` by auto
      show "S \<inter> fv (rdcH S (as @ \<Gamma>), remove_dead_code body, L) = {}" using `S \<inter> _ = _` *
        apply (simp add: if_not_P[OF let_not_removed])
        apply (auto simp add: disjoint_iff_not_equal)
        done
    qed
    thus "(as @ \<Gamma>, body) \<triangleright>\<^bsub>L\<^esub> (as' @ \<Gamma>', body')" unfolding `as' = _` `\<Gamma>' = _` `body' = _` by simp
qed

end

theorem DeadCodeRemovalCorrect:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  assumes "(\<Gamma>, e) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', e')"
   shows  "\<exists> \<Delta>' z'. (\<Delta>, z) \<triangleright>\<^bsub>L\<^esub> (\<Delta>', z') \<and> \<Gamma>' : e' \<Down>\<^bsub>L\<^esub> \<Delta>' : z'"
  using assms
proof(nominal_induct arbitrary: \<Gamma>' e' rule:reds.strong_induct)
case (Lambda \<Gamma> x e L) thus ?case by (rule lambda_case)
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> z body) thus ?case by (rule app_case)
next
case (Variable \<Gamma> x e L \<Delta> z \<Gamma>' var) thus ?case by (rule var_case)
next
case (Let as \<Gamma> L body \<Delta> z \<Gamma>' let')
  show ?case
  proof (cases "domA as \<inter> fv body = {}")
  case True
    with `(\<Gamma>, Let as body) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', let')`
    obtain S where "\<Gamma>' = rdcH S \<Gamma>" and "let' = remove_dead_code body"
    and "S \<subseteq> domA \<Gamma> \<union> set L" and "S \<inter> fv (rdcH S \<Gamma>, remove_dead_code body, L) = {}"   by (auto elim!: dc_rel.cases)

    have [simp]: "(rdcH (domA as \<union> S) as) = []" by (rule rdcH_is_nil) auto

    have [simp]: "(rdcH (domA as \<union> S) \<Gamma>) = (rdcH S \<Gamma>)"
      using fresh_distinct[OF Let(1)]
      by (auto intro: rdcH_cong_set simp add: fresh_star_at_base)

    have "(as @ \<Gamma>, body) \<triangleright>\<^bsub>L\<^esub> (rdcH (domA as \<union> S) (as @ \<Gamma>), remove_dead_code body)"
    proof (rule dc_rel.intros)
      show "(domA as \<union> S) \<subseteq> domA (as @ \<Gamma>) \<union> set L" using `S \<subseteq> domA \<Gamma> \<union> set L` by auto

      from True
      have "atom ` domA as \<sharp>* body" by (auto simp add: fresh_star_def fv_def fresh_def)
      from Let(1,2) True this
      have "atom ` domA as \<sharp>* (rdcH S \<Gamma>, remove_dead_code body, L)"
        by (auto simp add: fresh_star_def fresh_Pair  intro!: eqvt_fresh_cong1[OF remove_dead_code.eqvt])
      hence "domA as \<inter> fv (rdcH S \<Gamma>, remove_dead_code body, L) = {}"
        by (auto simp add: fresh_star_def fv_def fresh_def)
      moreover
      have "S \<inter> fv (rdcH S \<Gamma>, remove_dead_code body, L) = {}" using `S \<inter> _ = {}` by auto
      ultimately
      show "(domA as \<union> S) \<inter> fv (rdcH (domA as \<union> S) (as @ \<Gamma>), remove_dead_code body, L) = {}" by auto
    qed
    hence "(as @ \<Gamma>, body) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', remove_dead_code body)" unfolding `\<Gamma>'=_` by simp
    from Let(4)[OF this]
    show ?thesis unfolding `let' = _`.
  next
  case False
    interpret let_not_removed as body apply default using False.
    show ?thesis using Let by (rule let_case)
  qed
qed

corollary
  assumes "[] : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
   shows  "\<exists> \<Delta>' z'. [] : remove_dead_code e \<Down>\<^bsub>L\<^esub> \<Delta>' : z'"
proof-
  have "([], e) \<triangleright>\<^bsub>L\<^esub> (rdcH {} [], remove_dead_code e)" by (rule dc_rel.intros) auto
  hence "([], e) \<triangleright>\<^bsub>L\<^esub> ([], remove_dead_code e)" by simp
  from DeadCodeRemovalCorrect[OF assms this]
  show ?thesis by auto
qed

end