section {*L\_ATS\_String\_State\_Modification*}
theory
  L_ATS_String_State_Modification

imports
  L_ATS_List_Based_Effects

begin

locale ATS_String_State_Modification =
  ATS_List_Based_Effects
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event list set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> 'event list set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> 'event list set"
  for
    TSstructure configurations initial_configurations step_labels step_relation effects marking_condition marked_effect unmarked_effect
    +

fixes decreasing :: "bool"

fixes string_state :: "'conf \<Rightarrow> 'event list"

assumes AX_string_state_decreases: "
  TSstructure G
  \<Longrightarrow> decreasing
  \<Longrightarrow> c1 \<in> configurations G
  \<Longrightarrow> step_relation G c1 e c2
  \<Longrightarrow> \<exists>w. string_state c1 = w @ (string_state c2)"

assumes AX_string_state_increases: "
  TSstructure G
  \<Longrightarrow> \<not> decreasing
  \<Longrightarrow> c1 \<in> configurations G
  \<Longrightarrow> step_relation G c1 e c2
  \<Longrightarrow> \<exists>w. string_state c1 @ w = (string_state c2)"

context ATS_String_State_Modification
begin

lemma derivation_monotonically_prime: "
  TSstructure P
  \<Longrightarrow> belongs P d
  \<Longrightarrow> derivation P d
  \<Longrightarrow> d i = Some(pair ei ci)
  \<Longrightarrow> d (i+j) = Some(pair eij cij)
  \<Longrightarrow> if decreasing then (\<exists>w. string_state ci = w@ string_state cij) else (\<exists>w. string_state ci @ w = string_state cij)"
  apply(subgoal_tac "\<forall>eij cij. d (i+j) = Some(pair eij cij) \<longrightarrow> (if decreasing then \<exists>w. string_state ci = w @ string_state cij else \<exists>w. string_state ci @ w = string_state cij)")
   apply(force)
  apply(rule_tac
      P="\<lambda>W. (\<forall>eij cij. W = Some (pair eij cij) \<longrightarrow> (if decreasing then \<exists>w. string_state ci = w @ string_state cij else \<exists>w. string_state ci @ w = string_state cij))"
      and G="P"
      and d="d"
      and m="i"
      and x="i+j"
      and n="j"
      in property_preseved_under_steps_is_invariant2)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rename_tac ia eija cija)(*strict*)
  apply(case_tac "d(Suc ia)")
   apply(rename_tac ia eija cija)(*strict*)
   apply(clarsimp)
  apply(rename_tac ia eija cija a)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "\<exists>e c. d (Suc ia) = Some (pair (Some e) c)")
   apply(rename_tac ia eija cija a)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc ia"
      in pre_some_position_is_some_position_prime)
      apply(rename_tac ia eija cija a)(*strict*)
      apply(force)
     apply(rename_tac ia eija cija a)(*strict*)
     apply(force)
    apply(rename_tac ia eija cija a)(*strict*)
    apply(force)
   apply(rename_tac ia eija cija a)(*strict*)
   apply(force)
  apply(rename_tac ia eija cija a)(*strict*)
  apply(clarsimp)
  apply(rename_tac ia eija cija e c)(*strict*)
  apply(subgoal_tac "\<exists>e c. d ia = Some (pair e c)")
   apply(rename_tac ia eija cija e c)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc ia"
      in pre_some_position_is_some_position)
     apply(rename_tac ia eija cija e c)(*strict*)
     apply(force)
    apply(rename_tac ia eija cija e c)(*strict*)
    apply(force)
   apply(rename_tac ia eija cija e c)(*strict*)
   apply(force)
  apply(rename_tac ia eija cija e c)(*strict*)
  apply(clarsimp)
  apply(rename_tac ia eija cija e c ea ca)(*strict*)
  apply(erule_tac
      x="ea"
      in allE)
  apply(erule_tac
      x="ca"
      in allE)
  apply(clarsimp)
  apply(subgoal_tac "step_relation P ca e c")
   apply(rename_tac ia eija cija e c ea ca)(*strict*)
   prefer 2
   apply(rule position_change_due_to_step_relation)
     apply(rename_tac ia eija cija e c ea ca)(*strict*)
     apply(force)
    apply(rename_tac ia eija cija e c ea ca)(*strict*)
    apply(force)
   apply(rename_tac ia eija cija e c ea ca)(*strict*)
   apply(force)
  apply(rename_tac ia eija cija e c ea ca)(*strict*)
  apply(case_tac decreasing)
   apply(rename_tac ia eija cija e c ea ca)(*strict*)
   apply(clarsimp)
   apply(rename_tac ia cija e ea ca w)(*strict*)
   apply(subgoal_tac "\<exists>w. string_state ca = w @ (string_state cija)")
    apply(rename_tac ia cija e ea ca w)(*strict*)
    prefer 2
    apply(rule_tac
      e="e"
      in AX_string_state_decreases)
       apply(rename_tac ia cija e ea ca w)(*strict*)
       apply(force)
      apply(rename_tac ia cija e ea ca w)(*strict*)
      apply(force)
     apply(rename_tac ia cija e ea ca w)(*strict*)
     apply(simp add: belongs_def)
     apply(erule_tac
      x="ia"
      in allE)
     apply(force)
    apply(rename_tac ia cija e ea ca w)(*strict*)
    apply(force)
   apply(rename_tac ia cija e ea ca w)(*strict*)
   apply(force)
  apply(rename_tac ia eija cija e c ea ca)(*strict*)
  apply(clarsimp)
  apply(rename_tac ia cija e ea ca w)(*strict*)
  apply(subgoal_tac "\<exists>w. string_state ca @ w = (string_state cija)")
   apply(rename_tac ia cija e ea ca w)(*strict*)
   prefer 2
   apply(rule_tac
      e="e"
      in AX_string_state_increases)
      apply(rename_tac ia cija e ea ca w)(*strict*)
      apply(force)
     apply(rename_tac ia cija e ea ca w)(*strict*)
     apply(force)
    apply(rename_tac ia cija e ea ca w)(*strict*)
    apply(simp add: belongs_def)
    apply(erule_tac
      x="ia"
      in allE)
    apply(force)
   apply(rename_tac ia cija e ea ca w)(*strict*)
   apply(force)
  apply(rename_tac ia cija e ea ca w)(*strict*)
  apply(clarsimp)
  apply(rename_tac ia cija e ea ca w wa)(*strict*)
  apply(rule_tac
      x="w@wa"
      in exI)
  apply(rule_tac
      t="string_state cija"
      and s="string_state ca @ wa"
      in ssubst)
   apply(rename_tac ia cija e ea ca w wa)(*strict*)
   apply(force)
  apply(rename_tac ia cija e ea ca w wa)(*strict*)
  apply(simp (no_asm_use))
  done

lemma derivation_monotonically_dec: "
  TSstructure P
  \<Longrightarrow> decreasing
  \<Longrightarrow> belongs P d
  \<Longrightarrow> derivation P d
  \<Longrightarrow> d i = Some(pair ei ci)
  \<Longrightarrow> d (i+j) = Some(pair eij cij)
  \<Longrightarrow> \<exists>w. string_state ci = w@ string_state cij"
  apply(subgoal_tac "if decreasing then (\<exists>w. string_state ci = w@ string_state cij) else (\<exists>w. string_state ci @ w = string_state cij)")
   apply(force)
  apply(rule derivation_monotonically_prime)
      apply(force)+
  done

lemma derivation_monotonically_inc: "
  TSstructure P
  \<Longrightarrow> \<not> decreasing
  \<Longrightarrow> belongs P d
  \<Longrightarrow> derivation P d
  \<Longrightarrow> d i = Some(pair ei ci)
  \<Longrightarrow> d (i+j) = Some(pair eij cij)
  \<Longrightarrow> \<exists>w. string_state ci @ w = string_state cij"
  apply(subgoal_tac "if decreasing then (\<exists>w. string_state ci = w@ string_state cij) else (\<exists>w. string_state ci @ w = string_state cij)")
   apply(force)
  apply(rule derivation_monotonically_prime)
      apply(force)+
  done

definition trans_point :: "
  ('label,'conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat
  \<Rightarrow> nat
  \<Rightarrow> nat
  \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> bool)
  \<Rightarrow> bool"
  where
    "trans_point d i j l k R \<equiv> k \<le> j \<and>
            (\<forall>xl\<le>k.
                R l (case d (xl + i) of None \<Rightarrow> 0
                      | Some (pair e c) \<Rightarrow> length (string_state c))) \<and>
            (\<forall>xl>k.
                xl \<le> j \<longrightarrow>
                \<not> (R l (case d (xl + i) of None \<Rightarrow> 0
                 | Some (pair e c) \<Rightarrow> length (string_state c))
             ))"

lemma derivation_monotonically_decreasing_transition_point: "
  TSstructure P
  \<Longrightarrow> decreasing
  \<Longrightarrow> belongs P d
  \<Longrightarrow> derivation P d
  \<Longrightarrow> d i = Some(pair ei ci)
  \<Longrightarrow> d (i+j) = Some(pair eij cij)
  \<Longrightarrow> l \<le> length (string_state ci)
  \<Longrightarrow> length (string_state cij) \<le> l
  \<Longrightarrow> \<exists>!k. trans_point d i j l k ((\<le>))"
  apply(unfold trans_point_def)
  apply(rule monotonicSelector2)
    apply(clarsimp)
    apply(rename_tac ia ja)(*strict*)
    apply(subgoal_tac "\<exists>e c. d (ja+i) = Some (pair (Some e) c)")
     apply(rename_tac ia ja)(*strict*)
     prefer 2
     apply(rule_tac
      m="i+j"
      in pre_some_position_is_some_position_prime)
        apply(rename_tac ia ja)(*strict*)
        apply(force)
       apply(rename_tac ia ja)(*strict*)
       apply(force)
      apply(rename_tac ia ja)(*strict*)
      apply(force)
     apply(rename_tac ia ja)(*strict*)
     apply(force)
    apply(rename_tac ia ja)(*strict*)
    apply(subgoal_tac "\<exists>e c. d (ia+i) = Some (pair e c)")
     apply(rename_tac ia ja)(*strict*)
     prefer 2
     apply(rule_tac
      m="i+j"
      in pre_some_position_is_some_position)
       apply(rename_tac ia ja)(*strict*)
       apply(force)
      apply(rename_tac ia ja)(*strict*)
      apply(force)
     apply(rename_tac ia ja)(*strict*)
     apply(force)
    apply(rename_tac ia ja)(*strict*)
    apply(clarsimp)
    apply(rename_tac ia ja e ea c ca)(*strict*)
    apply(subgoal_tac "\<exists>w. string_state ca = w@ string_state c")
     apply(rename_tac ia ja e ea c ca)(*strict*)
     prefer 2
     apply(rule_tac
      i="ia + i"
      and j="ja - ia"
      in derivation_monotonically_dec)
          apply(rename_tac ia ja e ea c ca)(*strict*)
          apply(force)
         apply(rename_tac ia ja e ea c ca)(*strict*)
         apply(force)
        apply(rename_tac ia ja e ea c ca)(*strict*)
        apply(force)
       apply(rename_tac ia ja e ea c ca)(*strict*)
       apply(force)
      apply(rename_tac ia ja e ea c ca)(*strict*)
      apply(rule_tac
      t="(ia + i + (ja - ia))"
      and s="ja+i"
      in ssubst)
       apply(rename_tac ia ja e ea c ca)(*strict*)
       apply(force)
      apply(rename_tac ia ja e ea c ca)(*strict*)
      apply(force)
     apply(rename_tac ia ja e ea c ca)(*strict*)
     apply(clarsimp)
     apply(rule_tac
      t="i+ja"
      and s="ja+i"
      in ssubst)
      apply(rename_tac ia ja e ea c ca)(*strict*)
      apply(force)
     apply(rename_tac ia ja e ea c ca)(*strict*)
     apply(force)
    apply(rename_tac ia ja e ea c ca)(*strict*)
    apply(force)
   apply(force)
  apply(rule_tac
      t="j+i"
      and s="i+j"
      in ssubst)
   apply(force)
  apply(force)
  done

lemma at_most_one_input_read_trans_point_prefix_closureise: "
  TSstructure P
  \<Longrightarrow> decreasing
  \<Longrightarrow> belongs P d
  \<Longrightarrow> derivation P d
  \<Longrightarrow> d i = Some(pair ei ci)
  \<Longrightarrow> d (i+j) = Some(pair eij cij)
  \<Longrightarrow> l \<le> length (string_state ci)
  \<Longrightarrow> length (string_state cij) \<le> l
  \<Longrightarrow> trans_point d i j l k ((\<le>))
  \<Longrightarrow> k<j
  \<Longrightarrow> d (k+i) = Some(pair ek ck)
  \<Longrightarrow> (\<forall>e\<in> step_labels P. \<forall>c1 c2. step_relation P c1 e c2 \<longrightarrow> length(string_state c1) > length(string_state c2) \<longrightarrow> (\<exists>a. string_state c1 = a#(string_state c2)))
  \<Longrightarrow> length (string_state ck) = l"
  apply(subgoal_tac "\<exists>ek' ck'. d (Suc(k+i)) = Some(pair (Some ek') ck')")
   apply(erule exE)+
   apply(rename_tac ek' ck')(*strict*)
   apply(subgoal_tac "ek' \<in> step_labels P")
    apply(rename_tac ek' ck')(*strict*)
    apply(simp add: trans_point_def)
    apply(clarsimp)
    apply(erule_tac x="k" and P="\<lambda>x. x \<le> k \<longrightarrow> l \<le> case_option 0 (case_derivation_configuration (\<lambda>e c. length (string_state c))) (d (x + i))"in allE)
    apply(rename_tac ek' ck')(*strict*)
    apply(erule_tac
      x="Suc k"
      in allE)
    apply(clarsimp)
    apply(erule_tac
      x="ek'"
      in ballE)
     apply(rename_tac ek' ck')(*strict*)
     prefer 2
     apply(force)
    apply(rename_tac ek' ck')(*strict*)
    apply(erule_tac
      x="ck"
      in allE)
    apply(erule_tac
      x="ck'"
      in allE)
    apply(erule impE)
     apply(rename_tac ek' ck')(*strict*)
     apply(rule position_change_due_to_step_relation)
       apply(rename_tac ek' ck')(*strict*)
       apply(force)
      apply(rename_tac ek' ck')(*strict*)
      apply(force)
     apply(rename_tac ek' ck')(*strict*)
     apply(force)
    apply(rename_tac ek' ck')(*strict*)
    apply(erule impE)
     apply(rename_tac ek' ck')(*strict*)
     apply(force)
    apply(rename_tac ek' ck')(*strict*)
    apply(force)
   apply(rename_tac ek' ck')(*strict*)
   apply(rule belongs_step_labels)
    apply(rename_tac ek' ck')(*strict*)
    apply(force)
   apply(rename_tac ek' ck')(*strict*)
   apply(force)
  apply(rule_tac
      m="i+j"
      in pre_some_position_is_some_position_prime)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma context_extend_preserves_string_state_prefix: "
  TSstructure M
  \<Longrightarrow> decreasing
  \<Longrightarrow> belongs M d
  \<Longrightarrow> derivation M d
  \<Longrightarrow> d' = derivation_map d C
  \<Longrightarrow> derivation M d'
  \<Longrightarrow> (\<And>c1 c2 e w.
  step_relation M c1 e c2
  \<Longrightarrow> step_relation M (C c1) e (C c2)
  \<Longrightarrow> string_state c1 = w @ string_state c2
  \<Longrightarrow> string_state (C c1) = w @ string_state (C c2))
  \<Longrightarrow> d 0 = Some (pair None c1)
  \<Longrightarrow>
(\<lambda>x. case x of None \<Rightarrow> True | Some (pair e c) \<Rightarrow>
  (\<lambda>x. case x of None \<Rightarrow> False | Some (pair e c') \<Rightarrow> c = C c'
  \<and> (\<exists>w. string_state c1 = w @ (string_state c'))
  \<and> (\<forall>w. string_state c1 = w @ (string_state c') \<longrightarrow> string_state (C c1) = w @ (string_state c))
  ) (d n)
) (d' n)"
  apply(rule_tac m="0" and n="n" in property_preseved_under_steps_is_invariant2_prime)
     apply(clarsimp)
     apply(simp add: derivation_map_def)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac "d (Suc i)")
   apply(rename_tac i)(*strict*)
   apply(simp add: derivation_map_def)
  apply(rename_tac i a)(*strict*)
  apply(case_tac a)
  apply(rename_tac i a option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b)(*strict*)
  apply(case_tac "derivation_map d C (Suc i)")
   apply(rename_tac i option b)(*strict*)
   apply(simp add: derivation_map_def)
  apply(rename_tac i option b a)(*strict*)
  apply(case_tac a)
  apply(rename_tac i option b a optiona ba)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b optiona ba)(*strict*)
  apply(subgoal_tac "\<exists>e c. d i = Some (pair e c)")
   apply(rename_tac i option b optiona ba)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc i"
      in pre_some_position_is_some_position)
     apply(rename_tac i option b optiona ba)(*strict*)
     apply(force)
    apply(rename_tac i option b optiona ba)(*strict*)
    apply(force)
   apply(rename_tac i option b optiona ba)(*strict*)
   apply(force)
  apply(rename_tac i option b optiona ba)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b optiona ba e c)(*strict*)
  apply(case_tac "derivation_map d C i")
   apply(rename_tac i option b optiona ba e c)(*strict*)
   apply(simp add: derivation_map_def)
  apply(rename_tac i option b optiona ba e c a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac i option b optiona ba e c a optionb bb)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b optiona ba e c optionb w)(*strict*)
  apply(subgoal_tac "e=optionb \<and> option=optiona")
   apply(rename_tac i option b optiona ba e c optionb w)(*strict*)
   prefer 2
   apply(simp add: derivation_map_def)
  apply(rename_tac i option b optiona ba e c optionb w)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b optiona ba c optionb w)(*strict*)
  apply(subgoal_tac "ba = C b")
   apply(rename_tac i b optiona ba c optionb w)(*strict*)
   prefer 2
   apply(simp add: derivation_map_def)
  apply(rename_tac i b optiona ba c optionb w)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b optiona c optionb w)(*strict*)
  apply(subgoal_tac "\<exists>e c. d (Suc i) = Some (pair (Some e) c)")
   apply(rename_tac i b optiona c optionb w)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc i"
      in pre_some_position_is_some_position_prime)
      apply(rename_tac i b optiona c optionb w)(*strict*)
      apply(force)
     apply(rename_tac i b optiona c optionb w)(*strict*)
     apply(force)
    apply(rename_tac i b optiona c optionb w)(*strict*)
    apply(force)
   apply(rename_tac i b optiona c optionb w)(*strict*)
   apply(clarsimp)
  apply(rename_tac i b optiona c optionb w)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(subgoal_tac "step_relation M c e b")
   apply(rename_tac i b c optionb w e)(*strict*)
   prefer 2
   apply(rule position_change_due_to_step_relation)
     apply(rename_tac i b c optionb w e)(*strict*)
     apply(force)
    apply(rename_tac i b c optionb w e)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(subgoal_tac "e \<in> step_labels M")
   apply(rename_tac i b c optionb w e)(*strict*)
   prefer 2
   apply(simp add: belongs_def)
   apply(erule_tac
      x="Suc i"
      in allE)
   apply(clarsimp)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(subgoal_tac "\<exists>w. string_state c = w @ (string_state b)")
   apply(rename_tac i b c optionb w e)(*strict*)
   prefer 2
   apply(rule AX_string_state_decreases)
      apply(rename_tac i b c optionb w e)(*strict*)
      apply(force)
     apply(rename_tac i b c optionb w e)(*strict*)
     apply(force)
    apply(rename_tac i b c optionb w e)(*strict*)
    apply(simp add: belongs_def)
    apply(erule_tac
      x="i"
      in allE)+
    apply(force)
   apply(rename_tac i b c optionb w e)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b c optionb w e wa)(*strict*)
  apply(erule_tac
      x="c"
      in meta_allE)
  apply(erule_tac
      x="b"
      in meta_allE)
  apply(erule_tac
      x="e"
      in meta_allE)
  apply(erule_tac
      x="wa"
      in meta_allE)
  apply(clarsimp)
  apply(erule meta_impE)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(rule_tac
      d="derivation_map d C"
      in position_change_due_to_step_relation)
     apply(rename_tac i b c optionb w e wa)(*strict*)
     apply(force)
    apply(rename_tac i b c optionb w e wa)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa)(*strict*)
  apply(force)
  done

lemma context_extend_preserves_string_state_suffix: "
  TSstructure M
  \<Longrightarrow> \<not> decreasing
  \<Longrightarrow> belongs M d
  \<Longrightarrow> derivation M d
  \<Longrightarrow> d' = derivation_map d C
  \<Longrightarrow> derivation M d'
  \<Longrightarrow> (\<And>c1 c2 e w i e'.
  d i = Some (pair e' c1)
  \<Longrightarrow> d (Suc i) = Some (pair (Some e) c2)
  \<Longrightarrow> step_relation M c1 e c2
  \<Longrightarrow> step_relation M (C c1) e (C c2)
  \<Longrightarrow> string_state c1 @ w = string_state c2
  \<Longrightarrow> string_state (C c1) @ w= string_state (C c2))
  \<Longrightarrow> d 0 = Some (pair None c1)
  \<Longrightarrow>
(\<lambda>x. case x of None \<Rightarrow> True | Some (pair e c) \<Rightarrow>
  (\<lambda>x. case x of None \<Rightarrow> False | Some (pair e c') \<Rightarrow> c = C c'
  \<and> (\<exists>w. string_state c1 @ w = (string_state c'))
  \<and> (\<forall>w. string_state c1 @ w = (string_state c') \<longrightarrow> string_state (C c1) @ w = (string_state c))
  ) (d n)
) (d' n)"
  apply(rule_tac m="0" and n="n" in property_preseved_under_steps_is_invariant2_prime)
     apply(clarsimp)
     apply(simp add: derivation_map_def)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac "d (Suc i)")
   apply(rename_tac i)(*strict*)
   apply(simp add: derivation_map_def)
  apply(rename_tac i a)(*strict*)
  apply(case_tac a)
  apply(rename_tac i a option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b)(*strict*)
  apply(case_tac "derivation_map d C (Suc i)")
   apply(rename_tac i option b)(*strict*)
   apply(simp add: derivation_map_def)
  apply(rename_tac i option b a)(*strict*)
  apply(case_tac a)
  apply(rename_tac i option b a optiona ba)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b optiona ba)(*strict*)
  apply(subgoal_tac "\<exists>e c. d i = Some (pair e c)")
   apply(rename_tac i option b optiona ba)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc i"
      in pre_some_position_is_some_position)
     apply(rename_tac i option b optiona ba)(*strict*)
     apply(force)
    apply(rename_tac i option b optiona ba)(*strict*)
    apply(force)
   apply(rename_tac i option b optiona ba)(*strict*)
   apply(force)
  apply(rename_tac i option b optiona ba)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b optiona ba e c)(*strict*)
  apply(case_tac "derivation_map d C i")
   apply(rename_tac i option b optiona ba e c)(*strict*)
   apply(simp add: derivation_map_def)
  apply(rename_tac i option b optiona ba e c a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac i option b optiona ba e c a optionb bb)(*strict*)
  apply(clarsimp)
  apply(rename_tac i option b optiona ba e c optionb w)(*strict*)
  apply(subgoal_tac "e=optionb \<and> option=optiona")
   apply(rename_tac i option b optiona ba e c optionb w)(*strict*)
   prefer 2
   apply(simp add: derivation_map_def)
  apply(rename_tac i option b optiona ba e c optionb w)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b optiona ba c optionb w)(*strict*)
  apply(subgoal_tac "ba = C b")
   apply(rename_tac i b optiona ba c optionb w)(*strict*)
   prefer 2
   apply(simp add: derivation_map_def)
  apply(rename_tac i b optiona ba c optionb w)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b optiona c optionb w)(*strict*)
  apply(subgoal_tac "\<exists>e c. d (Suc i) = Some (pair (Some e) c)")
   apply(rename_tac i b optiona c optionb w)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc i"
      in pre_some_position_is_some_position_prime)
      apply(rename_tac i b optiona c optionb w)(*strict*)
      apply(force)
     apply(rename_tac i b optiona c optionb w)(*strict*)
     apply(force)
    apply(rename_tac i b optiona c optionb w)(*strict*)
    apply(force)
   apply(rename_tac i b optiona c optionb w)(*strict*)
   apply(clarsimp)
  apply(rename_tac i b optiona c optionb w)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(subgoal_tac "step_relation M c e b")
   apply(rename_tac i b c optionb w e)(*strict*)
   prefer 2
   apply(rule position_change_due_to_step_relation)
     apply(rename_tac i b c optionb w e)(*strict*)
     apply(force)
    apply(rename_tac i b c optionb w e)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(subgoal_tac "e \<in> step_labels M")
   apply(rename_tac i b c optionb w e)(*strict*)
   prefer 2
   apply(simp add: belongs_def)
   apply(erule_tac
      x="Suc i"
      in allE)
   apply(clarsimp)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(subgoal_tac "\<exists>w. string_state c @ w= (string_state b)")
   apply(rename_tac i b c optionb w e)(*strict*)
   prefer 2
   apply(rule AX_string_state_increases)
      apply(rename_tac i b c optionb w e)(*strict*)
      apply(force)
     apply(rename_tac i b c optionb w e)(*strict*)
     apply(force)
    apply(rename_tac i b c optionb w e)(*strict*)
    apply(simp add: belongs_def)
    apply(erule_tac
      x="i"
      in allE)+
    apply(force)
   apply(rename_tac i b c optionb w e)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b c optionb w e wa)(*strict*)
  apply(erule_tac
      x="c"
      in meta_allE)
  apply(erule_tac
      x="b"
      in meta_allE)
  apply(erule_tac
      x="e"
      in meta_allE)
  apply(erule_tac
      x="wa"
      in meta_allE)
  apply(erule_tac
      x="i"
      in meta_allE)
  apply(erule_tac
      x="optionb"
      in meta_allE)
  apply(clarsimp)
  apply(erule meta_impE)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(rule_tac
      d="derivation_map d C"
      in position_change_due_to_step_relation)
     apply(rename_tac i b c optionb w e wa)(*strict*)
     apply(force)
    apply(rename_tac i b c optionb w e wa)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa)(*strict*)
  apply(rule conjI)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(rule_tac
      x="w@wa"
      in exI)
   apply(rule_tac
      t="string_state b"
      and s="string_state c @ wa"
      in ssubst)
    apply(rename_tac i b c optionb w e wa)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(rule_tac
      t="string_state c"
      and s="string_state c1 @ w"
      in ssubst)
    apply(rename_tac i b c optionb w e wa)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e wa)(*strict*)
   apply(simp (no_asm_use))
  apply(rename_tac i b c optionb w e wa)(*strict*)
  apply(clarsimp)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(erule_tac
      x="w"
      in allE)
  apply(erule impE)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(rule_tac
      t="string_state b"
      and s="string_state c @ wa"
      in ssubst)
    apply(rename_tac i b c optionb w e wa wb)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(rule_tac
      t="string_state c"
      and s="string_state c1 @ w"
      in ssubst)
    apply(rename_tac i b c optionb w e wa wb)(*strict*)
    apply(force)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(rule_tac
      t="string_state (C b)"
      and s="string_state (C c) @ wa"
      in ssubst)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(rule_tac
      t="string_state (C c)"
      and s="string_state (C c1) @ w"
      in ssubst)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(rule_tac
      t="wb"
      and s="w@wa"
      in ssubst)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   prefer 2
   apply(simp (no_asm_use))
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(case_tac "wb=w@wa")
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(subgoal_tac "string_state c1 @ wb\<noteq>string_state b")
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(rule_tac
      t="string_state b"
      and s="string_state c @ wa"
      in ssubst)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(rule_tac
      t="string_state c"
      and s="string_state c1 @ w"
      in ssubst)
   apply(rename_tac i b c optionb w e wa wb)(*strict*)
   apply(force)
  apply(rename_tac i b c optionb w e wa wb)(*strict*)
  apply(simp (no_asm_use))
  done

end

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Set Implementation by List with explicit invariants}\<close>
theory ListSetImpl_Invar
  imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Dlist_add"
begin
text_raw \<open>\label{thy:ListSetImpl_Invar}\<close>

(*@impl Set
  @type 'a lsi
  @abbrv lsi,l
  Sets by lists with distinct elements. Version with explicit invariant that
  supports efficient @{text "insert_dj"} operation.
*)

type_synonym
  'a lsi = "'a list"

subsection "Definitions"

definition lsi_ins :: "'a \<Rightarrow> 'a lsi \<Rightarrow> 'a lsi" where "lsi_ins x l == if  List.member l x then l else x#l"

definition lsi_basic_ops :: "('a,'a lsi) set_basic_ops" where
  [icf_rec_def]: "lsi_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = set,
    bset_op_invar = distinct,
    bset_op_empty = \<lambda>_. [],
    bset_op_memb = (\<lambda>x s. List.member s x),
    bset_op_ins = lsi_ins,
    bset_op_ins_dj = (#),
    bset_op_delete = \<lambda>x l. Dlist_add.dlist_remove1' x [] l,
    bset_op_list_it = foldli
    \<rparr>"

setup Locale_Code.open_block
interpretation lsi_basic: StdBasicSet lsi_basic_ops
  apply unfold_locales
  unfolding lsi_basic_ops_def lsi_ins_def[abs_def]
  apply (auto simp: List.member_def set_dlist_remove1'
  distinct_remove1')
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsi_ops \<equiv> lsi_basic.dflt_ops \<lparr>
  set_op_union_dj := (@),
  set_op_to_list := id
\<rparr>"

setup Locale_Code.open_block
interpretation lsi: StdSet lsi_ops
proof -
  interpret aux: StdSet lsi_basic.dflt_ops by (rule lsi_basic.dflt_ops_impl)

  show "StdSet lsi_ops"
    unfolding lsi_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales, auto)
    done
qed
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "lsi"\<close>

lemma pi_lsi[proper_it]:
  "proper_it' foldli foldli"
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lsi: proper_it_loc foldli foldli
  apply unfold_locales by (rule pi_lsi)

definition test_codegen where "test_codegen \<equiv> (
  lsi.empty,
  lsi.memb,
  lsi.ins,
  lsi.delete,
  lsi.list_it,
  lsi.sng,
  lsi.isEmpty,
  lsi.isSng,
  lsi.ball,
  lsi.bex,
  lsi.size,
  lsi.size_abort,
  lsi.union,
  lsi.union_dj,
  lsi.diff,
  lsi.filter,
  lsi.inter,
  lsi.subset,
  lsi.equal,
  lsi.disjoint,
  lsi.disjoint_witness,
  lsi.sel,
  lsi.to_list,
  lsi.from_list
)"

export_code test_codegen checking SML

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section \<open>\isaheader{Hash Maps}\<close>
theory HashMap
  imports HashMap_Impl
begin
text_raw \<open>\label{thy:HashMap}\<close>

(*@impl Map
  @type 'a::hashable hm
  @abbrv hm,h
  Hash maps based on red-black trees.
*)

subsection "Type definition"

typedef (overloaded) ('k, 'v) hashmap = "{hm :: ('k :: hashable, 'v) hm_impl. HashMap_Impl.invar hm}"
  morphisms impl_of_RBT_HM RBT_HM
proof
  show "HashMap_Impl.empty () \<in> {hm. HashMap_Impl.invar hm}"
    by(simp add: HashMap_Impl.empty_correct')
qed

lemma impl_of_RBT_HM_invar [simp, intro!]: "HashMap_Impl.invar (impl_of_RBT_HM hm)"
using impl_of_RBT_HM[of hm] by simp

lemma RBT_HM_imp_of_RBT_HM [code abstype]:
  "RBT_HM (impl_of_RBT_HM hm) = hm"
by(fact impl_of_RBT_HM_inverse)

definition hm_empty_const :: "('k :: hashable, 'v) hashmap"
where "hm_empty_const = RBT_HM (HashMap_Impl.empty ())"

definition hm_empty :: "unit \<Rightarrow> ('k :: hashable, 'v) hashmap"
where "hm_empty = (\<lambda>_. hm_empty_const)"

definition "hm_lookup k hm == HashMap_Impl.lookup k (impl_of_RBT_HM hm)"

definition hm_update :: "('k :: hashable) \<Rightarrow> 'v \<Rightarrow> ('k, 'v) hashmap \<Rightarrow> ('k, 'v) hashmap"
where "hm_update k v hm = RBT_HM (HashMap_Impl.update k v (impl_of_RBT_HM hm))"

definition hm_update_dj :: "('k :: hashable) \<Rightarrow> 'v \<Rightarrow> ('k, 'v) hashmap \<Rightarrow> ('k, 'v) hashmap"
where "hm_update_dj = hm_update"

definition hm_delete :: "('k :: hashable) \<Rightarrow> ('k, 'v) hashmap \<Rightarrow> ('k, 'v) hashmap"
where "hm_delete k hm = RBT_HM (HashMap_Impl.delete k (impl_of_RBT_HM hm))"

definition hm_isEmpty :: "('k :: hashable, 'v) hashmap \<Rightarrow> bool"
where "hm_isEmpty hm = HashMap_Impl.isEmpty (impl_of_RBT_HM hm)"

(*definition hm_sel :: "('k :: hashable, 'v) hashmap \<Rightarrow> ('k \<times> 'v \<rightharpoonup> 'a) \<rightharpoonup> 'a"
  where "hm_sel hm = HashMap_Impl.sel (impl_of_RBT_HM hm)"*)

(*definition "hm_sel' = MapGA.sel_sel' hm_sel"*)

definition "hm_iteratei hm == HashMap_Impl.iteratei (impl_of_RBT_HM hm)"

lemma impl_of_hm_empty [simp, code abstract]:
  "impl_of_RBT_HM (hm_empty_const) = HashMap_Impl.empty ()"
by(simp add: hm_empty_const_def empty_correct' RBT_HM_inverse)

lemma impl_of_hm_update [simp, code abstract]:
  "impl_of_RBT_HM (hm_update k v hm) = HashMap_Impl.update k v (impl_of_RBT_HM hm)"
by(simp add: hm_update_def update_correct' RBT_HM_inverse)

lemma impl_of_hm_delete [simp, code abstract]:
  "impl_of_RBT_HM (hm_delete k hm) = HashMap_Impl.delete k (impl_of_RBT_HM hm)"
by(simp add: hm_delete_def delete_correct' RBT_HM_inverse)

subsection "Correctness w.r.t. Map"
text \<open>
  The next lemmas establish the correctness of the hashmap operations w.r.t. the
  associated map. This is achieved by chaining the correctness lemmas of the
  concrete hashmap w.r.t. the abstract hashmap and the correctness lemmas of the
  abstract hashmap w.r.t. maps.
\<close>

type_synonym ('k, 'v) hm = "('k, 'v) hashmap"

  \<comment> \<open>Abstract concrete hashmap to map\<close>
definition "hm_\<alpha> == ahm_\<alpha> \<circ> hm_\<alpha>' \<circ> impl_of_RBT_HM"

abbreviation (input) hm_invar :: "('k :: hashable, 'v) hashmap \<Rightarrow> bool"
where "hm_invar == \<lambda>_. True"

lemma hm_aux_correct:
  "hm_\<alpha> (hm_empty ()) = Map.empty "
  "hm_lookup k m = hm_\<alpha> m k"
  "hm_\<alpha> (hm_update k v m) = (hm_\<alpha> m)(k\<mapsto>v)"
  "hm_\<alpha> (hm_delete k m) = (hm_\<alpha> m) |` (-{k})"
by(auto simp add: hm_\<alpha>_def hm_correct' hm_empty_def ahm_correct hm_lookup_def)

lemma hm_finite[simp, intro!]:
  "finite (dom (hm_\<alpha> m))"
proof(cases m)
  case (RBT_HM m')
  hence SS: "dom (hm_\<alpha> m) \<subseteq> \<Union>{ dom (lm.\<alpha> lm) | lm hc. rm.\<alpha> m' hc = Some lm }"
    apply(clarsimp simp add: RBT_HM_inverse hm_\<alpha>_def hm_\<alpha>'_def [abs_def] ahm_\<alpha>_def [abs_def])
    apply(auto split: option.split_asm option.split)
    done
  moreover have "finite \<dots>" (is "finite (\<Union>?A)")
  proof
    have "{ dom (lm.\<alpha> lm) | lm hc. rm.\<alpha> m' hc = Some lm }
          \<subseteq> (\<lambda>hc. dom (lm.\<alpha> (the (rm.\<alpha> m' hc)) )) ` (dom (rm.\<alpha> m'))"
      (is "?S \<subseteq> _")
      by force
    thus "finite ?A" by(rule finite_subset) auto
  next
    fix M
    assume "M \<in> ?A"
    thus "finite M" by auto
  qed
  ultimately show ?thesis unfolding RBT_HM by(rule finite_subset)
qed

lemma hm_iteratei_impl:
  "map_iterator (hm_iteratei m) (hm_\<alpha> m)"
  apply (unfold hm_\<alpha>_def hm_iteratei_def o_def)
  apply(rule iteratei_correct'[OF impl_of_RBT_HM_invar])
  done

subsection "Integration in Isabelle Collections Framework"
text \<open>
  In this section, we integrate hashmaps into the Isabelle Collections Framework.
\<close>

definition [icf_rec_def]: "hm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = hm_\<alpha>,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = hm_empty,
  bmap_op_lookup = hm_lookup,
  bmap_op_update = hm_update,
  bmap_op_update_dj = hm_update, \<comment> \<open>TODO: Optimize bucket-ins here\<close>
  bmap_op_delete = hm_delete,
  bmap_op_list_it = hm_iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation hm_basic: StdBasicMap hm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf hm_aux_correct hm_iteratei_impl)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "hm_ops \<equiv> hm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation hm: StdMapDefs hm_ops .
interpretation hm: StdMap hm_ops
  unfolding hm_ops_def
  by (rule hm_basic.dflt_ops_impl)
interpretation hm: StdMap_no_invar hm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "hm"\<close>

lemma pi_hm[proper_it]:
  shows "proper_it' hm_iteratei hm_iteratei"
  apply (rule proper_it'I)
  unfolding hm_iteratei_def HashMap_Impl.iteratei_alt_def
  by (intro icf_proper_iteratorI)

interpretation pi_hm: proper_it_loc hm_iteratei hm_iteratei
  apply unfold_locales
  apply (rule pi_hm)
  done

text \<open>Code generator test\<close>

definition test_codegen where "test_codegen \<equiv> (
  hm.add ,
  hm.add_dj ,
  hm.ball ,
  hm.bex ,
  hm.delete ,
  hm.empty ,
  hm.isEmpty ,
  hm.isSng ,
  hm.iterate ,
  hm.iteratei ,
  hm.list_it ,
  hm.lookup ,
  hm.restrict ,
  hm.sel ,
  hm.size ,
  hm.size_abort ,
  hm.sng ,
  hm.to_list ,
  hm.to_map ,
  hm.update ,
  hm.update_dj)"

export_code test_codegen checking SML

end


theory Fofu_Abs_Base
imports
  Complex_Main
  "HOL-Library.Rewrite"
  Automatic_Refinement.Misc
  Refine_Imperative_HOL.Sepref_Misc
  "Program-Conflict-Analysis.LTS"
begin

  (* TODO: Move *)
  lemma swap_in_iff_inv: "prod.swap p \<in> S \<longleftrightarrow> p \<in> S\<inverse>"
    apply (cases p) by auto

(* TODO: Move *)
lemma length_filter_disj_or_conv:
  assumes "\<And>x. x\<in>set xs \<longrightarrow> \<not>(P x \<and> Q x)"
  shows "length [x \<leftarrow> xs. P x \<or> Q x] = length (filter P xs) + length (filter Q xs)"
  using assms
  by (induction xs) auto

(* TODO: Move. Extract an element from a summation, combined with congruence. *)
lemma sum_arb:
  assumes A_fin: "finite A"
      and x_mem: "x \<in> A"
      and x_dif: "\<forall>y\<in>A. y \<noteq> x \<longrightarrow> g y = h y"
    shows "(\<Sum>a\<in>A. g a) = (\<Sum>a\<in>A - {x}. h a) + g x"
proof -
  have "A = (A - {x}) \<union> {x}" using x_mem by auto
  moreover note sum.union_disjoint[of "A - {x}" "{x}" g]
  moreover note sum.cong[of "A - {x}" "A - {x}" g h]
  ultimately show ?thesis using A_fin x_dif by auto
qed

lemma trcl_cons_conv:
  "(u,a#xs,v)\<in>trcl R \<longleftrightarrow> (\<exists>uh. (u,a,uh)\<in>R \<and> (uh,xs,v)\<in>trcl R)"
  by (auto dest!: trcl_uncons)

lemma trcl_conc_conv:
  "(u,xs@ys,v)\<in>trcl R \<longleftrightarrow> (\<exists>uh. (u,xs,uh)\<in>trcl R \<and> (uh,ys,v)\<in>trcl R)"
  by (auto dest!: trcl_unconcat intro: trcl_concat)

lemmas trcl_conv = trcl_cons_conv trcl_conc_conv
  \<comment> \<open>Adding these to simpset will split all cons and append operations in paths\<close>

end


(* Author: Bernhard Stöckl *)

theory IKKBZ_Examples
  imports IKKBZ_Optimality
begin

section \<open>Examples of Applying IKKBZ\<close>

subsection \<open>Computing Contributing Selectivity without Lists\<close>

context directed_tree
begin

definition contr_sel :: "'a selectivity \<Rightarrow> 'a \<Rightarrow> real" where
  "contr_sel sel y = (if \<exists>x. x \<rightarrow>\<^bsub>T\<^esub> y then sel (THE x. x \<rightarrow>\<^bsub>T\<^esub> y) y else 1)"

definition tree_sel :: "'a selectivity \<Rightarrow> bool" where
  "tree_sel sel = (\<forall>x y. \<not>(x \<rightarrow>\<^bsub>T\<^esub> y \<or> y \<rightarrow>\<^bsub>T\<^esub> x) \<longrightarrow> sel x y = 1)"

lemma contr_sel_gt0: "sel_reasonable sf \<Longrightarrow> contr_sel sf x > 0"
  unfolding contr_sel_def sel_reasonable_def by simp

lemma contr_sel_le1: "sel_reasonable sf \<Longrightarrow> contr_sel sf x \<le> 1"
  unfolding contr_sel_def sel_reasonable_def by simp

lemma nempty_if_not_fwd_conc: "\<not>forward_arcs (y#xs) \<Longrightarrow> xs \<noteq> []"
  by auto

lemma len_gt1_if_not_fwd_conc: "\<not>forward_arcs (y#xs) \<Longrightarrow> length (y#xs) > 1"
  by auto

lemma two_elems_if_not_fwd_conc: "\<not>forward_arcs (y#xs) \<Longrightarrow> \<exists>a b cs. a # b # cs = y#xs"
  by (metis forward_arcs.cases forward_arcs.simps(2))

lemma hd_reach_all_if_nfwd_app_fwd:
  "\<lbrakk>\<not>forward_arcs (y#xs); forward_arcs (y#ys@xs); x \<in> set (y#ys@xs)\<rbrakk>
    \<Longrightarrow> hd (rev (y#ys@xs)) \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x"
  using hd_reach_all_forward'[of "rev (y#ys@xs)"] len_gt1_if_not_fwd_conc forward_arcs_alt by auto

lemma hd_not_y_if_if_nfwd_app_fwd:
  assumes "\<not>forward_arcs (y#xs)" and "forward_arcs (y#ys@xs)"
  shows "hd (rev (y#ys@xs)) \<noteq> y"
proof -
  obtain a where a_def: "a \<in> set (ys@xs)" "a \<rightarrow>\<^bsub>T\<^esub> y"
    by (metis assms Nil_is_append_conv forward_arcs.simps(3) neq_Nil_conv)
  then have "hd (rev (y#ys@xs)) \<rightarrow>\<^sup>*\<^bsub>T\<^esub> a" using hd_reach_all_if_nfwd_app_fwd[OF assms] by simp
  then show ?thesis
    using a_def(2) reachable1_not_reverse
    by (metis loopfree.adj_not_same reachable_adjI reachable_neq_reachable1)
qed

lemma hd_reach1_y_if_nfwd_app_fwd:
  "\<lbrakk>\<not>forward_arcs (y#xs); forward_arcs (y#ys@xs)\<rbrakk> \<Longrightarrow> hd (rev (y#ys@xs)) \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
  using hd_not_y_if_if_nfwd_app_fwd hd_reach_all_if_nfwd_app_fwd by auto

lemma not_fwd_if_skip1:
  "\<lbrakk>\<not> forward_arcs (y#x#x'#xs); forward_arcs (x#x'#xs)\<rbrakk> \<Longrightarrow> \<not> forward_arcs (y#x'#xs)"
  by auto

lemma fwd_arcs_conc_nlast_elem:
  assumes "forward_arcs xs" and "y \<in> set xs" and "y \<noteq> last xs"
  shows "forward_arcs (y#xs)"
proof -
  obtain as bs where as_def: "as @ y # bs = xs" "bs \<noteq> []"
    using split_list_not_last[OF assms(2,3)] by blast
  then have "forward_arcs (y#bs)" using assms(1) forward_arcs_split by blast
  then obtain x where x_def: "x \<in> set bs" "x \<rightarrow>\<^bsub>T\<^esub> y"
    using as_def(2) by (force intro: list.exhaust)
  then have "x \<in> set xs" using as_def(1) by auto
  then show ?thesis using assms(1) x_def(2) forward_arcs.elims(3) by blast
qed

lemma fwd_app_nhead_elem: "\<lbrakk>forward xs; y \<in> set xs; y \<noteq> hd xs\<rbrakk> \<Longrightarrow> forward (xs@[y])"
  using fwd_arcs_conc_nlast_elem forward_arcs_alt by (simp add: last_rev)

lemma hd_last_not_fwd_arcs: "\<not>forward_arcs (x#xs@[x])"
proof
  assume asm: "forward_arcs (x#xs@[x])"
  then obtain y where y_def: "y \<in> set (xs@[x])" "y \<rightarrow>\<^bsub>T\<^esub> x"
    by (metis append_is_Nil_conv forward_arcs.simps(3) no_back_arcs.cases)
  then have hd_in_verts: "hd (rev (xs @ [x])) \<in> verts T" by auto
  have "forward_arcs (xs@[x])" using asm forward_arcs_split[of "[x]" "xs@[x]"] by simp
  then have "x \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y" using hd_reach_all_forward[OF hd_in_verts] y_def forward_arcs_alt by simp
  then show False using y_def(2) reachable1_not_reverse by auto
qed

lemma hd_not_fwd_arcs: "\<not>forward_arcs (ys@x#xs@[x])"
  using hd_last_not_fwd_arcs forward_arcs_split by blast

lemma hd_last_not_fwd: "\<not>forward (x#xs@[x])"
  using hd_last_not_fwd_arcs forward_arcs_alt by simp

lemma hd_not_fwd: "\<not>forward (x#xs@[x]@ys)"
  using hd_not_fwd_arcs forward_arcs_alt by simp

lemma y_not_dom_if_nfwd_app_fwd:
  "\<lbrakk>\<not>forward_arcs (y#xs); forward_arcs (y#ys@xs); x \<in> set xs\<rbrakk> \<Longrightarrow> \<not> x \<rightarrow>\<^bsub>T\<^esub> y"
  using forward_arcs_split[of "y#ys" xs] two_elems_if_not_fwd_conc by force

lemma not_y_dom_if_nfwd_app_fwd:
  "\<lbrakk>\<not>forward_arcs (y#xs); forward_arcs (y#ys@xs); x \<in> set xs\<rbrakk> \<Longrightarrow> \<not> y \<rightarrow>\<^bsub>T\<^esub> x"
  by (smt (verit, ccfv_threshold) append_is_Nil_conv forward_arcs_alt' forward_arcs_split
      forward_cons fwd_app_nhead_elem hd_append hd_reach1_y_if_nfwd_app_fwd
      hd_reachable1_from_outside' list.distinct(1) reachable1_not_reverse reachable_adjI
      reachable_neq_reachable1 rev.simps(2) rev_append set_rev split_list)

lemma list_sel_aux'1_if_tree_sel_nfwd:
  "\<lbrakk>tree_sel sel; \<not>forward_arcs (y#xs); forward_arcs (y#ys@xs)\<rbrakk>
    \<Longrightarrow> list_sel_aux' sel xs y = 1"
proof(induction xs arbitrary: ys rule: forward_arcs.induct)
  case (2 x)
  then show ?case using not_y_dom_if_nfwd_app_fwd[OF 2(2,3)] by (auto simp: tree_sel_def)
next
  case (3 x x' xs)
  then have "forward_arcs (x # x' # xs)"
    using forward_arcs_split[of "y#ys" "x#x'#xs"] by simp
  then have "\<not> forward_arcs (y # x' # xs)" using not_fwd_if_skip1 "3.prems"(2) by blast
  moreover have "forward_arcs (y # (ys@[x]) @ x' # xs)" using 3 by simp
  ultimately have "list_sel_aux' sel (x' # xs) y = 1" using "3.IH"[OF "3.prems"(1)] by blast
  then show ?case
    using "3.prems"(1) y_not_dom_if_nfwd_app_fwd[OF "3.prems"(2,3)]
      not_y_dom_if_nfwd_app_fwd[OF "3.prems"(2,3)]
    by (simp add: tree_sel_def)
qed(simp)

lemma contr_sel_eq_list_sel_aux'_if_tree_sel:
  "\<lbrakk>tree_sel sel; distinct (y#xs); forward_arcs (y#xs); xs \<noteq> []\<rbrakk>
    \<Longrightarrow> contr_sel sel y = list_sel_aux' sel xs y"
proof(induction xs rule: forward_arcs.induct)
  case (2 x)
  then have "x \<rightarrow>\<^bsub>T\<^esub> y" by simp
  then have "(THE x. x \<rightarrow>\<^bsub>T\<^esub> y) = x" using two_in_arcs_contr by blast
  then show ?case using \<open>x \<rightarrow>\<^bsub>T\<^esub> y\<close> unfolding contr_sel_def by auto
next
  case (3 x x' xs)
  then show ?case
  proof(cases "x \<rightarrow>\<^bsub>T\<^esub> y")
    case True
    then have "(THE x. x \<rightarrow>\<^bsub>T\<^esub> y) = x" using two_in_arcs_contr by blast
    then have contr_sel: "contr_sel sel y = sel x y" using True unfolding contr_sel_def by auto
    have "\<not>forward_arcs (y#x'#xs)" using True "3.prems"(2) two_in_arcs_contr by auto
    then have "list_sel_aux' sel (x'#xs) y = 1"
      using list_sel_aux'1_if_tree_sel_nfwd[of sel y "x'#xs" "[x]"] "3.prems"(1,3) by auto
    then show ?thesis using contr_sel by simp
  next
    case False
    have "\<not>y \<rightarrow>\<^bsub>T\<^esub> x"
      using "3.prems"(2,3) forward_arcs_alt' no_back_arc_if_fwd_dstct
      by (metis distinct_rev list.set_intros(1) rev.simps(2) set_rev)
    then have "sel x y = 1" using "3.prems"(1) False unfolding tree_sel_def by blast
    then show ?thesis using 3 False by simp
  qed
qed(simp)

corollary contr_sel_eq_list_sel_aux'_if_tree_sel':
  "\<lbrakk>tree_sel sel; distinct (xs@[y]); forward (xs@[y]); xs \<noteq> []\<rbrakk>
    \<Longrightarrow> contr_sel sel y = list_sel_aux' sel (rev xs) y"
  by (simp add: contr_sel_eq_list_sel_aux'_if_tree_sel forward_arcs_alt)

corollary contr_sel_eq_list_sel_aux'_if_tree_sel'':
  "\<lbrakk>tree_sel sel; distinct (xs@[y]); forward (xs@[y]); xs \<noteq> []\<rbrakk>
    \<Longrightarrow> contr_sel sel y = list_sel_aux' sel xs y"
  by (simp add: contr_sel_eq_list_sel_aux'_if_tree_sel' mset_x_eq_list_sel_aux'_eq[of "rev xs"])

lemma contr_sel_root[simp]: "contr_sel sel root = 1"
  by (auto simp: contr_sel_def dest: dominated_not_root)

lemma contr_sel_notvert[simp]: "v \<notin> verts T \<Longrightarrow> contr_sel sel v = 1"
  by (auto simp: contr_sel_def)

lemma hd_reach_all_forward_verts:
  "\<lbrakk>forward xs; set xs = verts T; v \<in> verts T\<rbrakk> \<Longrightarrow> hd xs \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v"
  using hd_reach_all_forward list.set_sel(1)[of xs] by force

lemma hd_eq_root_if_forward_verts: "\<lbrakk>forward xs; set xs = verts T\<rbrakk> \<Longrightarrow> hd xs = root"
  using hd_reach_all_forward_verts root_if_all_reach by simp

lemma contr_sel_eq_ldeep_s_if_tree_dst_fwd_verts:
  assumes "tree_sel sel" and "distinct xs" and "forward xs" and "set xs = verts T"
  shows "contr_sel sel y = ldeep_s sel (rev xs) y"
proof -
  have hd_root: "hd xs = root" using hd_eq_root_if_forward_verts assms(3,4) by blast
  consider "y \<in> set xs" "y = root" | "y \<in> set xs" "y \<noteq> root" | "y \<notin> set xs" by blast
  then show ?thesis
  proof(cases)
    case 1
    then show ?thesis using hd_root ldeep_s_revhd1_if_distinct assms(2) by auto
  next
    case 2
    then obtain as bs where as_def: "as @ y # bs = xs" using split_list[of y] by fastforce
    then have "forward (as@[y])" using assms(3) forward_split[of "as@[y]"] by auto
    moreover have "distinct (as@[y])" using assms(2) as_def by auto
    moreover have "as \<noteq> []" using 2 hd_root as_def by fastforce
    ultimately have "contr_sel sel y = list_sel_aux' sel (rev as) y"
      using contr_sel_eq_list_sel_aux'_if_tree_sel'[OF assms(1)] by blast
    then show ?thesis using as_def distinct_ldeep_s_eq_aux'[of "rev xs"] assms(2) by auto
  next
    case 3
    then have "contr_sel sel y = 1" using assms(4) by simp
    then show ?thesis using 3 ldeep_s_1_if_nelem set_rev by fastforce
  qed
qed

corollary contr_sel_eq_ldeep_s_if_tree_dst_fwd_verts':
  "\<lbrakk>tree_sel sel; distinct xs; forward xs; set xs = verts T\<rbrakk>
    \<Longrightarrow> contr_sel sel = ldeep_s sel (rev xs)"
  using contr_sel_eq_ldeep_s_if_tree_dst_fwd_verts by blast

lemma add_leaf_forward_arcs_preserv:
  "\<lbrakk>a \<notin> arcs T; u \<in> verts T; v \<notin> verts T; forward_arcs xs\<rbrakk>
    \<Longrightarrow> directed_tree.forward_arcs \<lparr>verts = verts T \<union> {v}, arcs = arcs T \<union> {a},
              tail = (tail T)(a := u), head = (head T)(a := v)\<rparr> xs"
proof(induction xs rule: forward_arcs.induct)
  case 1
  then show ?case using directed_tree.forward_arcs.simps(1) add_leaf_dir_tree by fast
next
  case (2 x)
  then show ?case using directed_tree.forward_arcs.simps(2) add_leaf_dir_tree by fast
next
  case (3 x y xs)
  let ?T = "\<lparr>verts = verts T \<union> {v}, arcs = arcs T \<union> {a},
            tail = (tail T)(a := u), head = (head T)(a := v)\<rparr>"
  interpret T: directed_tree ?T root using add_leaf_dir_tree[OF "3.prems"(1-3)] by blast
  have "T.forward_arcs (y # xs)" using 3 by fastforce
  then show ?case
    using T.forward_arcs.simps(3)[of x y xs] add_leaf_dom_preserv "3.prems"(1,4) by fastforce
qed

end

subsection \<open>Contributing Selectivity Satisfies ASI Property\<close>

context finite_directed_tree
begin

lemma dst_fwd_arcs_all_verts_ex: "\<exists>xs. forward_arcs xs \<and> distinct xs \<and> set xs = verts T"
using finite_verts proof(induction rule: finite_directed_tree_induct)
  case (single_vert t h root)
  then show ?case using directed_tree.forward_arcs.simps(2)[OF dir_tree_single] by fastforce
next
  case (add_leaf T' V A t h u root a v)
  define T where "T \<equiv> \<lparr>verts = V \<union> {v}, arcs = A \<union> {a}, tail = t(a := u), head = h(a := v)\<rparr>"
  interpret T': directed_tree T' root using add_leaf.hyps(3) by blast
  interpret T: directed_tree T root using add_leaf.hyps(1,4-6) T'.add_leaf_dir_tree T_def by simp
  obtain xs where xs_def: "T'.forward_arcs xs" "distinct xs" "set xs = verts T'"
    using add_leaf.IH by blast
  then have "T.forward_arcs xs"
    using T'.add_leaf_forward_arcs_preserv add_leaf.hyps(1,4,5,6) T_def by simp
  moreover have "\<exists>y\<in>set xs. y \<rightarrow>\<^bsub>T\<^esub> v"
    using add_leaf.hyps(1,4) T_def xs_def(3) unfolding arcs_ends_def arc_to_ends_def by force
  ultimately have "T.forward_arcs (v#xs)" using T.forward_arcs.elims(3) by blast
  then show ?case using xs_def(2,3) add_leaf.hyps(1,5) T_def by auto
qed

lemma dst_fwd_all_verts_ex: "\<exists>xs. forward xs \<and> distinct xs \<and> set xs = verts T"
  using dst_fwd_arcs_all_verts_ex forward_arcs_alt'[symmetric] by auto

lemma c_list_asi_if_tree_sel:
  fixes sf cf h r
  defines "rank \<equiv> (\<lambda>l. (ldeep_T (contr_sel sf) cf l - 1) / c_list (contr_sel sf) cf h r l)"
  assumes "tree_sel sf"
      and "sel_reasonable sf"
      and "\<forall>x. cf x > 0"
      and "\<forall>x. h x > 0"
    shows "asi rank r (c_list (contr_sel sf) cf h r)"
  using c_list_asi assms contr_sel_eq_ldeep_s_if_tree_dst_fwd_verts' dst_fwd_all_verts_ex
  by fastforce

end

context tree_query_graph
begin

abbreviation sel_r :: "'a \<Rightarrow> 'a \<Rightarrow> real" where
  "sel_r r \<equiv> directed_tree.contr_sel (dir_tree_r r) match_sel"

text \<open>
  Since cf is only required to be positive for verts of G, we map all others to 1.
\<close>

definition cf' :: "'a \<Rightarrow> real" where
  "cf' x = (if x \<in> verts G then cf x else 1)"

definition c_list_r  :: "('a \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> real" where
  "c_list_r h r = c_list (sel_r r) cf' h r"

definition rank_r  :: "('a \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> real" where
  "rank_r h r xs = (ldeep_T (sel_r r) cf' xs - 1) / c_list_r h r xs"

lemma dom_in_dir_tree_r:
  assumes "r \<in> verts G" and "x \<rightarrow>\<^bsub>G\<^esub> y"
  shows "x \<rightarrow>\<^bsub>dir_tree_r r\<^esub> y \<or> y \<rightarrow>\<^bsub>dir_tree_r r\<^esub> x"
proof -
  obtain e1 where e1_def: "e1 \<in> arcs G" "tail G e1 = x" "head G e1 = y"
    using assms(2) unfolding arcs_ends_def arc_to_ends_def by blast
  then show ?thesis
  proof(cases "e1 \<in> arcs (dir_tree_r r)")
    case True
    moreover have "tail (dir_tree_r r) e1 = x"
      using e1_def(2) tail_dir_tree_r_eq[OF assms(1)] by blast
    moreover have "head (dir_tree_r r) e1 = y"
      using e1_def(3) head_dir_tree_r_eq[OF assms(1)] by blast
    ultimately show ?thesis using e1_def(1) unfolding arcs_ends_def arc_to_ends_def by blast
  next
    case False
    then obtain e2 where e2_def: "e2 \<in> arcs (dir_tree_r r)" "tail G e2 = y" "head G e2 = x"
      using arcs_compl_un_eq_arcs[OF assms(1)] e1_def by force
    have "tail (dir_tree_r r) e2 = y"
      using e2_def(2) tail_dir_tree_r_eq[OF assms(1)] by blast
    moreover have "head (dir_tree_r r) e2 = x"
      using e2_def(3) head_dir_tree_r_eq[OF assms(1)] by blast
    ultimately show ?thesis using e2_def(1) unfolding arcs_ends_def arc_to_ends_def by blast
  qed
qed

lemma dom_in_dir_tree_r_iff_aux:
  "r \<in> verts G \<Longrightarrow> (x \<rightarrow>\<^bsub>dir_tree_r r\<^esub> y \<or> y \<rightarrow>\<^bsub>dir_tree_r r\<^esub> x) \<longleftrightarrow> (x \<rightarrow>\<^bsub>G\<^esub> y \<or> y \<rightarrow>\<^bsub>G\<^esub> x)"
  using dir_tree_r_dom_in_G dom_in_dir_tree_r by blast

lemma dom_in_dir_tree_r_iff:
  "r \<in> verts G \<Longrightarrow> (x \<rightarrow>\<^bsub>dir_tree_r r\<^esub> y \<or> y \<rightarrow>\<^bsub>dir_tree_r r\<^esub> x) \<longleftrightarrow> x \<rightarrow>\<^bsub>G\<^esub> y"
  using dom_in_dir_tree_r_iff_aux dominates_sym by blast

lemma dir_tree_sel[intro]: "r \<in> verts G \<Longrightarrow> directed_tree.tree_sel (dir_tree_r r) match_sel"
  unfolding directed_tree.tree_sel_def[OF directed_tree_r]
  using match_sel1_if_no_arc dom_in_dir_tree_r_iff by blast

lemma pos_cards'[intro!]: "\<forall>x. cf' x > 0"
  unfolding cf'_def using pos_cards by simp

theorem c_list_asi: "\<lbrakk>r \<in> verts G; \<forall>x. h x > 0\<rbrakk> \<Longrightarrow> asi (rank_r h r) r (c_list_r h r)"
  using finite_directed_tree.c_list_asi_if_tree_sel[OF fin_directed_tree_r]
  unfolding c_list_r_def rank_r_def by blast

subsection \<open>Applying IKKBZ\<close>

lemma cf'_simp: "x \<in> verts G \<Longrightarrow> cf' x = cf x"
  unfolding cf'_def by simp

lemma ldeep_T_cf'_eq: "set xs \<subseteq> verts G \<Longrightarrow> ldeep_T sf cf' xs = ldeep_T sf cf xs"
  using ldeep_T_eq_if_cf_eq[of xs] cf'_simp by blast

lemma clist_cf'_eq: "set xs \<subseteq> verts G \<Longrightarrow> c_list sf cf' h r xs = c_list sf cf h r xs"
  by (simp add: clist_eq_if_cf_eq ldeep_T_cf'_eq)

lemma card_cf'_eq: "matching_rels t \<Longrightarrow> card cf' f t = card cf f t"
  by (induction cf' f t rule: card.induct) (auto simp: matching_rels_def cf'_simp)

lemma c_IKKBZ_cf'_eq: "matching_rels t \<Longrightarrow> c_IKKBZ h cf' sf t = c_IKKBZ h cf sf t"
  by (induction h cf' sf t rule: c_IKKBZ.induct) (auto simp: card_cf'_eq cf'_simp matching_rels_def)

lemma c_IKKBZ_cf'_eq': "valid_tree t \<Longrightarrow> c_IKKBZ h cf' sf t = c_IKKBZ h cf sf t"
  by (simp add: c_IKKBZ_cf'_eq matching_rels_def valid_tree_def)

lemma c_out_cf'_eq: "matching_rels t \<Longrightarrow> c_out cf' sf t = c_out cf sf t"
  by (induction cf' sf t rule: c_out.induct) (auto simp: card_cf'_eq cf'_simp matching_rels_def)

lemma c_out_cf'_eq': "valid_tree t \<Longrightarrow> c_out cf' sf t = c_out cf sf t"
  by (simp add: c_out_cf'_eq matching_rels_def valid_tree_def)

lemma joinTree_card'_pos[intro]: "pos_rel_cards cf' t"
  by (induction t) (auto simp: pos_cards' pos_rel_cards_def)

lemma match_reasonable_cards'[intro]: "reasonable_cards cf' match_sel t"
  using pos_sel_reason_impl_reason by blast

lemma sel_r_gt0: "r \<in> verts G \<Longrightarrow> sel_r r x > 0"
  using directed_tree.contr_sel_gt0[OF directed_tree_r] by blast

lemma sel_r_le1: "r \<in> verts G \<Longrightarrow> sel_r r x \<le> 1"
  using directed_tree.contr_sel_le1[OF directed_tree_r] by blast

lemma sel_r_eq_ldeep_s_if_dst_fwd_verts:
  "\<lbrakk>r \<in> verts G; distinct xs; directed_tree.forward (dir_tree_r r) xs; set xs = verts G\<rbrakk>
    \<Longrightarrow> sel_r r = ldeep_s match_sel (rev xs)"
  using directed_tree.contr_sel_eq_ldeep_s_if_tree_dst_fwd_verts'[OF directed_tree_r]
    verts_dir_tree_r_eq
  by blast

lemma sel_r_eq_ldeep_s_if_valid_fwd:
  "\<lbrakk>r \<in> verts G; valid_tree t; directed_tree.forward (dir_tree_r r) (inorder t)\<rbrakk>
    \<Longrightarrow> sel_r r = ldeep_s match_sel (revorder t)"
  unfolding valid_tree_def distinct_relations_def inorder_eq_set[symmetric] revorder_eq_rev_inorder
  using sel_r_eq_ldeep_s_if_dst_fwd_verts by blast

lemma sel_r_eq_ldeep_s_if_valid_no_cross:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> sel_r (first_node t) = ldeep_s match_sel (revorder t)"
  using sel_r_eq_ldeep_s_if_valid_fwd forward_if_ldeep_no_cross'
    valid_tree_def first_node_in_verts_if_valid
  by blast

lemma c_list_ldeep_s_eq_c_list_r_if_valid_no_cross:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> c_list (ldeep_s match_sel (revorder t)) cf' h (first_node t) xs
      = c_list_r h (first_node t) xs"
  using sel_r_eq_ldeep_s_if_valid_no_cross c_list_r_def by simp

lemma c_IKKBZ_list_correct_if_simple_h:
  assumes "valid_tree t" and "no_cross_products t" and "left_deep t"
  shows "c_list_r (\<lambda>x. h x (cf' x)) (first_node t) (revorder t) = c_IKKBZ h cf match_sel t"
proof -
  have "(\<lambda>t. c_IKKBZ h cf' match_sel t) t
      = c_list (ldeep_s match_sel (revorder t)) cf' (\<lambda>x. h x (cf' x)) (first_node t) (revorder t)"
    using c_IKKBZ_eq_c_list assms(1,3) valid_tree_def by fast
  then show ?thesis
    using c_list_ldeep_s_eq_c_list_r_if_valid_no_cross assms by (simp add: c_IKKBZ_cf'_eq')
qed

end

subsubsection \<open>Applying IKKBZ on Simple Cost Functions\<close>

text \<open>
  For simple cost functions like @{term c_nlj} and @{term c_hj} that do not depend on the
  contributing selectivies as @{term c_out} does, the h function does not change. Therefore, we can
  apply it directly using @{term c_IKKBZ} and @{term c_list}.
\<close>

context cmp_tree_query_graph
begin

context
  fixes h :: "'a \<Rightarrow> real \<Rightarrow> real"
  assumes h_pos: "\<forall>x. h x (cf' x) > 0"
begin

theorem ikkbz_query_graph_if_simple_h:
  defines "cost \<equiv> c_IKKBZ h cf match_sel"
  defines "h' \<equiv> (\<lambda>x. h x (cf' x))"
  shows "ikkbz_query_graph bfs sel cf G cmp cost (c_list_r h') (rank_r h')"
  unfolding ikkbz_query_graph_def ikkbz_query_graph_axioms_def assms
  by (auto simp: cmp_tree_query_graph_axioms c_list_asi c_IKKBZ_list_correct_if_simple_h h_pos)

interpretation ikkbz_query_graph bfs sel cf G cmp
    "c_IKKBZ h cf match_sel" "c_list_r (\<lambda>x. h x (cf' x))" "rank_r (\<lambda>x. h x (cf' x))"
  by (fact ikkbz_query_graph_if_simple_h)

corollary ikkbz_simple_h_nempty: "ikkbz \<noteq> []"
  by (rule ikkbz_nempty)

corollary ikkbz_simple_h_valid_tree: "valid_tree (create_ldeep ikkbz)"
  by (rule ikkbz_valid_tree)

corollary ikkbz_simple_h_no_cross:
  "no_cross_products (create_ldeep ikkbz)"
  by (rule ikkbz_no_cross)

theorem ikkbz_simple_h_optimal:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> c_IKKBZ h cf match_sel (create_ldeep ikkbz) \<le> c_IKKBZ h cf match_sel t"
  by (rule ikkbz_optimal_tree)

abbreviation ikkbz_simple_h :: "'a list" where
  "ikkbz_simple_h \<equiv> ikkbz"
end

text \<open>
  We can now apply these results directly to valid cost functions like @{term c_nlj} and
  @{term c_hj}.
\<close>

lemma id_cf'_gt0: "\<forall>x. id (cf' x) > 0"
  by auto

corollary ikkbz_nempty_nlj: "ikkbz_simple_h (\<lambda>_. id) \<noteq> []"
  using ikkbz_simple_h_nempty[of "\<lambda>_. id", OF id_cf'_gt0] by blast

corollary ikkbz_valid_tree_nlj: "valid_tree (create_ldeep (ikkbz_simple_h (\<lambda>_. id)))"
  using ikkbz_simple_h_valid_tree[of "\<lambda>_. id", OF id_cf'_gt0] by blast

corollary ikkbz_no_cross_nlj: "no_cross_products (create_ldeep (ikkbz_simple_h (\<lambda>_. id)))"
  using ikkbz_simple_h_no_cross[of "\<lambda>_. id", OF id_cf'_gt0] by blast

corollary ikkbz_optimal_nlj:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> c_nlj cf match_sel (create_ldeep (ikkbz_simple_h (\<lambda>_. id))) \<le> c_nlj cf match_sel t"
  using ikkbz_simple_h_optimal[of "\<lambda>_. id", OF id_cf'_gt0] ikkbz_nempty_nlj
  by (fastforce simp: c_nlj_IKKBZ create_ldeep_ldeep)

corollary ikkbz_nempty_hj: "ikkbz_simple_h (\<lambda>_ _. 1.2) \<noteq> []"
  using ikkbz_simple_h_nempty by force

corollary ikkbz_valid_tree_hj: "valid_tree (create_ldeep (ikkbz_simple_h (\<lambda>_ _. 1.2)))"
  using ikkbz_simple_h_valid_tree by force

corollary ikkbz_no_cross_hj: "no_cross_products (create_ldeep (ikkbz_simple_h (\<lambda>_ _. 1.2)))"
  using ikkbz_simple_h_no_cross by force

corollary ikkbz_optimal_hj:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> c_hj cf match_sel (create_ldeep (ikkbz_simple_h (\<lambda>_ _. 1.2))) \<le> c_hj cf match_sel t"
  using ikkbz_simple_h_optimal[of "\<lambda>_ _. 1.2"] ikkbz_nempty_hj
  by (fastforce simp: c_hj_IKKBZ create_ldeep_ldeep)

end

subsubsection \<open>Applying IKKBZ on C\_out\<close>

text \<open>
  Since @{term c_out} uses the contributing selectivity as part of its h, we can not use the general
  approach we used for the "simple" cost functions. Instead, we show the applicability directly.
\<close>

context tree_query_graph
begin

definition c_out_list_r  :: "'a \<Rightarrow> 'a list \<Rightarrow> real" where
  "c_out_list_r r = c_list_r (\<lambda>a. sel_r r a * cf' a) r"

definition c_out_rank_r  :: "'a \<Rightarrow> 'a list \<Rightarrow> real" where
  "c_out_rank_r r = rank_r (\<lambda>a. sel_r r a * cf' a) r"

lemma c_out_eq_c_list_cf':
  fixes t
  defines "xs \<equiv> revorder t"
  defines "h \<equiv> (\<lambda>a. ldeep_s match_sel xs a * cf' a)"
  assumes "distinct_relations t" and "left_deep t"
  shows "c_list (ldeep_s match_sel xs) cf' h (first_node t) xs = c_out cf' match_sel t"
  using c_out_eq_c_list assms by blast

lemma c_out_list_correct_cf':
  fixes t
  defines "h \<equiv> (\<lambda>a. sel_r (first_node t) a * cf' a)"
  assumes "valid_tree t" and "no_cross_products t" and "left_deep t"
  shows "c_list_r h (first_node t) (revorder t) = c_out cf' match_sel t"
  using c_out_eq_c_list_cf' assms sel_r_eq_ldeep_s_if_valid_no_cross
  by (fastforce simp: valid_tree_def c_list_ldeep_s_eq_c_list_r_if_valid_no_cross)

lemma c_out_list_correct_cf:
  fixes t
  defines "h \<equiv> (\<lambda>a. sel_r (first_node t) a * cf' a)"
  assumes "valid_tree t" and "no_cross_products t" and "left_deep t"
  shows "c_list_r h (first_node t) (revorder t) = c_out cf match_sel t"
  using c_out_list_correct_cf' c_out_cf'_eq' assms by simp

lemma c_out_list_correct:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> c_out_list_r (first_node t) (revorder t) = c_out cf match_sel t"
  using c_out_list_correct_cf c_out_list_r_def by simp

lemma c_out_h_gt0: "r \<in> verts G \<Longrightarrow> (\<lambda>a. sel_r r a * cf' a) x > 0"
  using sel_r_gt0 by (simp add: pos_cards')

lemma c_out_r_asi: "r \<in> verts G \<Longrightarrow> asi (c_out_rank_r r) r (c_out_list_r r)"
  using c_out_h_gt0 by (simp add: c_list_asi c_out_list_r_def c_out_rank_r_def)

end

context cmp_tree_query_graph
begin

theorem ikkbz_query_graph_c_out:
  "ikkbz_query_graph bfs sel cf G cmp (c_out cf match_sel) c_out_list_r c_out_rank_r"
  unfolding ikkbz_query_graph_def ikkbz_query_graph_axioms_def
  by (auto simp: cmp_tree_query_graph_axioms c_out_r_asi c_out_list_correct)

interpretation QG\<^sub>o\<^sub>u\<^sub>t:
  ikkbz_query_graph bfs sel cf G cmp "c_out cf match_sel" c_out_list_r c_out_rank_r
  by (rule ikkbz_query_graph_c_out)

corollary ikkbz_nempty_cout: "QG\<^sub>o\<^sub>u\<^sub>t.ikkbz \<noteq> []"
  using QG\<^sub>o\<^sub>u\<^sub>t.ikkbz_nempty .

corollary ikkbz_valid_tree_cout: "valid_tree (create_ldeep QG\<^sub>o\<^sub>u\<^sub>t.ikkbz)"
  using QG\<^sub>o\<^sub>u\<^sub>t.ikkbz_valid_tree .

corollary ikkbz_no_cross_cout: "no_cross_products (create_ldeep QG\<^sub>o\<^sub>u\<^sub>t.ikkbz)"
  using QG\<^sub>o\<^sub>u\<^sub>t.ikkbz_no_cross .

corollary ikkbz_optimal_cout:
  "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk>
    \<Longrightarrow> c_out cf match_sel (create_ldeep QG\<^sub>o\<^sub>u\<^sub>t.ikkbz) \<le> c_out cf match_sel t"
  using QG\<^sub>o\<^sub>u\<^sub>t.ikkbz_optimal_tree .

end

subsection \<open>Instantiating Comparators with Linorders\<close>

(* possible cmp definition based on 'a::linorder *)
locale alin_tree_query_graph = tree_query_graph bfs sel cf G
  for bfs sel and cf :: "'a :: linorder \<Rightarrow> real" and G
begin

lift_definition cmp :: "('a list\<times>'b) comparator" is
  "(\<lambda>x y. if hd (fst x) < hd (fst y) then Less
    else if hd (fst x) > hd (fst y) then Greater else Equiv)"
  by(unfold_locales) (auto split: if_splits)

lemma cmp_hd_eq_if_equiv: "compare cmp (v1,e1) (v2,e2) = Equiv \<Longrightarrow> hd v1 = hd v2"
  by(auto simp: cmp.rep_eq split: if_splits)

lemma cmp_sets_not_dsjnt_if_equiv:
  "\<lbrakk>v1 \<noteq> []; v2 \<noteq> []; compare cmp (v1,e1) (v2,e2) = Equiv\<rbrakk> \<Longrightarrow> set v1 \<inter> set v2 \<noteq> {}"
  using cmp_hd_eq_if_equiv disjoint_iff_not_equal hd_in_set[of v1] by auto

lemma cmp_tree_qg: "cmp_tree_query_graph bfs sel cf G cmp"
  by standard (simp add: cmp_sets_not_dsjnt_if_equiv)

interpretation cmp_tree_query_graph bfs sel cf G cmp
  by (rule cmp_tree_qg)

(* The results are now useable: *)
thm ikkbz_optimal_hj ikkbz_optimal_cout

end

(* possible cmp definition based on 'b::linorder *)
locale blin_tree_query_graph = tree_query_graph bfs sel cf G
  for bfs and sel :: "'b :: linorder \<Rightarrow> real" and cf G
begin

lift_definition cmp :: "('a list\<times>'b) comparator" is
  "(\<lambda>x y. if snd x < snd y then Less
    else if snd x > snd y then Greater else Equiv)"
  by(unfold_locales) (auto split: if_splits)

lemma cmp_arcs_eq_if_equiv: "compare cmp (v1,e1) (v2,e2) = Equiv \<Longrightarrow> e1 = e2"
  by(auto simp: cmp.rep_eq split: if_splits)

lemma cmp_tree_qg: "cmp_tree_query_graph bfs sel cf G cmp"
  by standard (simp add: cmp_arcs_eq_if_equiv)

interpretation cmp_tree_query_graph bfs sel cf G cmp
  by (rule cmp_tree_qg)

(* The results are now useable: *)
thm ikkbz_optimal_hj ikkbz_optimal_cout

end

end


(*header{* Theory of Events for Security Protocols that use Smartphones with QR-Code readers *}*)

theory EventSP imports "~~/src/HOL/Auth/Message" begin

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent => msg set"

datatype smartphone = Smarphone agent

datatype
  event = Says    agent agent msg
        | Notes   agent       msg
        | Gets    agent       msg
        | Inputs  agent       smartphone msg (* Agent visually displays message to smartphone... *)
        | Gets_s  smartphone  msg (* ... smartphone receives it. *)
        | Outputs smartphone  agent msg (* Smartphone gives information to be inputed in agent... *)
        | Gets_a  agent       msg (* ... agent receives it. *)

consts
 bad        :: "agent set"  (* compromised agents *)
 connected  :: "smartphone set" (* network connected smartphones *)
 badp       :: "smartphone set" (* compromised smartphones *)
 stolen     :: "smartphone set" (* stolen smartphones *)

specification (bad)
  Spy_in_bad  [iff]: "Spy \<in> bad"
  Server_not_bad [iff]: "Server \<notin> bad"
  apply (rule exI [of _ "{Spy}"], simp)
  done

specification (stolen)
  Server_phone_not_stolen [iff]: "Smartphone Server \<notin> stolen"
  Spy_phone_not_stolen [iff]: "Smartphone Spy \<notin> stolen"
  apply blast
  done

specification (badp)
  (* Spy phone is secured because she already can use it freely *)
  Spy_phone_in_bad [iff]: "Smartphone Spy \<notin> badp"
  Server_phone_not_bad [iff]: "Smartphone Server \<notin> badp"
  apply blast
  done

(* Agents' knowledge definition over a trace is extended to comprehend new Smartphone events *)
primrec knows :: "agent \<Rightarrow> event list \<Rightarrow> msg set" where
  knows_Nil :  "knows A [] = initState A" |
  knows_Cons : "knows A (ev # evs) =
    (case ev of
      Says A' B X \<Rightarrow>
        if (A = A' | A = Spy) then insert X (knows A evs)
        else (knows A evs)
      | Notes A' X \<Rightarrow>
        if (A = A' | (A = Spy & A' \<in> bad)) then insert X (knows A evs)
        else knows A evs
      | Gets A' X \<Rightarrow>
        if (A = A' & A \<noteq> Spy) then insert X (knows A evs)
        else knows A evs
      | Inputs A' P X \<Rightarrow>
        if (A = A') then insert X (knows A evs)
        else knows A evs
      | Gets_s P X \<Rightarrow>
        if (A = Spy & P \<in> connected & P \<in> badp) then insert X (knows A evs)
        else knows A evs
      | Outputs P A' X \<Rightarrow>
        if (A = A' | (A = Spy & P \<in> connected & P \<in> badp)) then insert X (knows A evs)
        else knows A evs
      | Gets_a A' X \<Rightarrow>
        if (A = A' & A \<noteq> Spy) then insert X (knows A evs)
        else knows A evs
  )"

primrec used :: "event list \<Rightarrow> msg set" where
  used_Nil  : "used [] = (\<Union> B. parts (initState B))" |
  used_Cons : "used (ev # evs) =
    (case ev of
        Says A B X \<Rightarrow> parts {X} \<union> (used evs)
      | Notes A X \<Rightarrow> parts {X} \<union> (used evs)
      | Gets A X \<Rightarrow> used evs
      | Inputs A P X \<Rightarrow> parts {X} \<union> used evs
      | Gets_s P X \<Rightarrow> used evs
      | Outputs P A X \<Rightarrow> parts {X} \<union> used evs
      | Gets_a A X \<Rightarrow> used evs
  )"

lemma Notes_imp_used [rule_format] :
  "Notes A X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format] :
  "Says A B X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

(* AGENTS' KNOWLEDGE LEMMAS *)

lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

lemma knows_Spy_Says [simp] :
  "knows Spy (Says A B X # evs) = insert X (knows Spy evs)"
by simp

lemma knows_Spy_Gets [simp] :
  "knows Spy (Gets B X # evs) = knows Spy evs"
by simp

lemma knows_Spy_Notes [simp] :
  "knows Spy (Notes A X # evs) =
    (if A \<in> bad then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Inputs [simp] :
  "knows Spy (Inputs A P X # evs) =
    (if A = Spy then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Gets_s [simp] :
  "knows Spy (Gets_s P X # evs) =
    (if (P \<in> connected & P \<in> badp) then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Outputs [simp] :
  "knows Spy (Outputs P A X # evs) =
    (
      if A = Spy then insert X (knows Spy evs)
      else if (P \<in> connected & P \<in> badp) then insert X (knows Spy evs)
      else knows Spy evs
    )"
by simp

lemma knows_Spy_Gets_a [simp] :
  "knows Spy (Gets_a A X # evs) = knows Spy evs"
by simp

(* ===== *)

lemma knows_Spy_subset_knows_Spy_Says :
  "knows Spy evs \<subseteq> knows Spy (Says A B X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Notes :
  "knows Spy evs \<subseteq> knows Spy (Notes A X # evs)"
by force

lemma knows_Spy_subset_knows_Spy_Gets :
  "knows Spy evs \<subseteq> knows Spy (Gets A X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Inputs :
  "knows Spy evs \<subseteq> knows Spy (Inputs A P X # evs)"
by auto

lemma knows_Spy_subset_knows_Spy_Gets_s :
  "knows Spy evs \<subseteq> knows Spy (Gets_s P X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Outputs :
  "knows Spy evs \<subseteq> knows Spy (Outputs P A X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Gets_a :
  "knows Spy evs \<subseteq> knows Spy (Gets_a A X # evs)"
by (simp add: subset_insertI)

(* ===== *)

lemma Says_imp_knows_Spy [rule_format] :
  "Says A B X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp) (* first case is evs = [] \<rightarrow> trivial *)
apply (simp_all split: event.split)
done

lemma Notes_imp_knows_Spy [rule_format] :
  "Notes A X \<in> set evs \<longrightarrow> A \<in> bad \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Inputs_imp_knows_Spy [rule_format] :
  "Inputs Spy P X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Gets_s_imp_knows_Spy [rule_format] :
  "Gets_s P X \<in> set evs \<longrightarrow> P \<in> connected \<longrightarrow> P \<in> badp \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Outputs_imp_knows_Spy [rule_format] :
  "Outputs P Spy X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Outputs_imp_knows_Spy_by_smartphone [rule_format] :
  "Outputs P A X \<in> set evs \<longrightarrow> P \<in> connected \<longrightarrow> P \<in> badp \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(* ===== *)

lemmas knows_Spy_partsEs =
     Says_imp_knows_Spy [THEN parts.Inj, elim_format]
     parts.Body [elim_format]

lemma knows_Says: "knows A (Says A B X # evs) = insert X (knows A evs)"
by simp

lemma knows_Notes: "knows A (Notes A X # evs) = insert X (knows A evs)"
by simp

lemma knows_Gets:
  "A \<noteq> Spy \<longrightarrow> knows A (Gets A X # evs) = insert X (knows A evs)"
by simp

lemma knows_Inputs: "knows A (Inputs A C X # evs) = insert X (knows A evs)"
by simp

lemma knows_Gets_s:
  "A \<noteq> Spy \<longrightarrow> knows A (Gets_s C X # evs) = knows A evs"
by simp

lemma knows_Outputs:
  "knows A (Outputs C A X # evs) = insert X (knows A evs)"
by simp

lemma knows_Gets_a:
  "A \<noteq> Spy \<longrightarrow> knows A (Gets_a A X # evs) = insert X (knows A evs)"
by simp

(* ===== *)

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Inputs: "knows A evs \<subseteq> knows A (Inputs A' C X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets_s: "knows A evs \<subseteq> knows A (Gets_s C X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Outputs: "knows A evs \<subseteq> knows A (Outputs C A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets_a: "knows A evs \<subseteq> knows A (Gets_a A' X # evs)"
by (simp add: subset_insertI)

(* ===== *)

(* Agents know what they say *)
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply auto
done

(* Agents know what they note *)
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply auto
done

(* Agents know what they receive *)
lemma Gets_imp_knows [rule_format]: "A \<noteq> Spy \<longrightarrow> Gets A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(* Agents know what they *)
lemma Inputs_imp_knows [rule_format]: "Inputs A P X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply auto
done

(* Agents do NOT know what they smartphones reads... *)
(* So no rule for this *)

(* Agents knows what their smartphones shows to them *)
lemma Outputs_imp_knows [rule_format]: "Outputs P A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply auto
done

(* END LEMMAS FOR AGENTS' KNOWLEDGE *)

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A split: event.split)
apply (auto)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) ==> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split: event.split, blast)
done

(* USED FUNCTION LEMMAS *)

lemma Says_parts_used [rule_format (no_asm)] :
  "Says A B X \<in> set evs \<longrightarrow> (parts {X}) \<subseteq> used evs "
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply (auto)
done

lemma Notes_parts_used [rule_format (no_asm)] :
  "Notes A X \<in> set evs \<longrightarrow> (parts {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply (auto)
done

lemma Inputs_parts_used [rule_format (no_asm)] :
  "Inputs A P X \<in> set evs \<longrightarrow> (parts {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply (auto)
done

lemma Outputs_parts_used [rule_format (no_asm)] :
  "Outputs P A X \<in> set evs \<longrightarrow> (parts {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply (auto)
done

(* END USED FUNCTION LEMMAS *)

text{*NOTE REMOVAL--laws above are cleaner, as they don't involve "case"*}
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (induct e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

end


section "Subsumption and change of environment"

theory ChangeEnv
  imports Main Lambda DeclSemAsDenotFSet ValuesFSetProps
begin

lemma e_cons_intro[intro]: "\<lbrakk> v1 \<in> E e1 \<rho>; v2 \<in> E e2 \<rho>; v = VPair v1 v2 \<rbrakk>
  \<Longrightarrow> v \<in> E (ECons e1 e2) \<rho>" by auto

lemma e_cons_elim[elim]: "\<lbrakk> v \<in> E (ECons e1 e2) \<rho>;
  \<And> v1 v2. \<lbrakk> v1 \<in> E e1 \<rho>; v2 \<in> E e2 \<rho>; v \<sqsubseteq> VPair v1 v2 \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" by auto

lemma e_car_intro[intro]: "\<lbrakk> (VPair v1 v2) \<in> E e \<rho>; v = v1\<rbrakk> \<Longrightarrow> v \<in> E (ECar e) \<rho>"
  using DeclSemAsDenotFSet.Ecar by blast

lemma e_car_elim[elim]: "\<lbrakk> v \<in> E (ECar e) \<rho>;
  \<And> v1 v2. \<lbrakk> VPair v1 v2 \<in> E e \<rho>; v \<sqsubseteq> v1\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" using val_le_refl by auto

lemma e_cdr_intro[intro]: "\<lbrakk> VPair v1 v2 \<in> E e \<rho>; v = v2 \<rbrakk> \<Longrightarrow> v \<in> E (ECdr e) \<rho>"
  by auto

lemma e_cdr_elim[elim]: "\<lbrakk> v \<in> E (ECdr e) \<rho>;
  \<And> v1 v2. \<lbrakk> VPair v1 v2 \<in> E e \<rho>; v \<sqsubseteq> v2 \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" by auto

lemma e_prim_intro[intro]: "\<lbrakk> VNat n1 \<in> E e1 \<rho>; VNat n2 \<in> E e2 \<rho>; v = VNat (f n1 n2) \<rbrakk>
    \<Longrightarrow> v \<in> E (EPrim f e1 e2) \<rho>" by auto

lemma e_prim_elim[elim]: "\<lbrakk> v \<in> E (EPrim f e1 e2) \<rho>;
   \<And> n1 n2. \<lbrakk> VNat n1 \<in> E e1 \<rho>; VNat n2 \<in> E e2 \<rho>; v = VNat (f n1 n2) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_app_elim[elim]: "\<lbrakk> v3 \<in> E (EApp e1 e2) \<rho>;
  \<And> f v2 v2' v3'. \<lbrakk> VFun f \<in> E e1 \<rho>; v2 \<in> E e2 \<rho>; (v2',v3') \<in> fset f; v2' \<sqsubseteq> v2; v3 \<sqsubseteq> v3' \<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_app_intro[intro]: "\<lbrakk> VFun f \<in> E e1 \<rho>; v2 \<in> E e2 \<rho>; (v2',v3') \<in> fset f; v2' \<sqsubseteq> v2; v \<sqsubseteq> v3'\<rbrakk>
     \<Longrightarrow> v \<in> E (EApp e1 e2) \<rho>" by auto

lemma e_lam_intro[intro]: "\<lbrakk> v = VFun f;
      \<forall> v1 v2. (v1,v2) \<in> fset f \<longrightarrow> v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk>
    \<Longrightarrow> v \<in> E (ELam x e) \<rho>"
  by auto

lemma e_lam_intro2[intro]:
  "\<lbrakk> VFun f \<in> E (ELam x e) \<rho>; v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk>
  \<Longrightarrow> VFun (finsert (v1,v2) f) \<in> E (ELam x e) \<rho>"
  by auto

lemma e_lam_intro3[intro]: "VFun {||} \<in> E (ELam x e) \<rho>"
  by auto

lemma e_if_intro[intro]: "\<lbrakk> VNat n \<in> E e1 \<rho>; n = 0 \<longrightarrow> v \<in> E e3 \<rho>; n \<noteq> 0 \<longrightarrow> v \<in> E e2 \<rho> \<rbrakk>
    \<Longrightarrow> v \<in> E (EIf e1 e2 e3) \<rho>"
  by auto

lemma e_var_intro[elim]: "\<lbrakk> lookup \<rho> x = Some v'; v \<sqsubseteq> v' \<rbrakk> \<Longrightarrow> v \<in> E (EVar x) \<rho>"
  by auto

lemma e_var_elim[elim]: "\<lbrakk> v \<in> E (EVar x) \<rho>;
   \<And> v'. \<lbrakk> lookup \<rho> x = Some v'; v \<sqsubseteq> v' \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_lam_elim[elim]: "\<lbrakk> v \<in> E (ELam x e) \<rho>;
   \<And> f. \<lbrakk> v = VFun f; \<forall> v1 v2. (v1,v2) \<in> fset f \<longrightarrow> v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk>
    \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_lam_elim2[elim]: "\<lbrakk> VFun (finsert (v1,v2) f) \<in> E (ELam x e) \<rho>;
   \<lbrakk> v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_if_elim[elim]: "\<lbrakk> v \<in> E (EIf e1 e2 e3) \<rho>;
   \<And> n. \<lbrakk> VNat n \<in> E e1 \<rho>; n = 0 \<longrightarrow> v \<in> E e3 \<rho>; n \<noteq> 0 \<longrightarrow> v \<in> E e2 \<rho> \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

definition xenv_le :: "name set \<Rightarrow> env \<Rightarrow> env \<Rightarrow> bool" ("_ \<turnstile> _ \<sqsubseteq> _" [51,51,51] 52) where
  "X \<turnstile> \<rho> \<sqsubseteq> \<rho>' \<equiv> \<forall> x v. x \<in> X \<and> lookup \<rho> x = Some v \<longrightarrow> (\<exists> v'. lookup \<rho>' x = Some v' \<and> v \<sqsubseteq> v')"
declare xenv_le_def[simp]

proposition change_env_le: fixes v::val and \<rho>::env
  assumes de: "v \<in> E e \<rho>" and vp_v: "v' \<sqsubseteq> v" and rr: "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>'"
  shows "v' \<in> E e \<rho>'"
  using de rr vp_v
proof (induction e arbitrary: v v' \<rho> \<rho>' rule: exp.induct)
  case (EVar x v v' \<rho> \<rho>')
  from EVar obtain v2 where lx: "lookup \<rho> x = Some v2" and v_v2: "v \<sqsubseteq> v2" by auto
  from lx EVar obtain v3 where
    lx2: "lookup \<rho>' x = Some v3" and v2_v3: "v2 \<sqsubseteq> v3" by force
  from v_v2 v2_v3 have v_v3: "v \<sqsubseteq> v3" by (rule val_le_trans)
  from EVar v_v3 have vp_v3: "v' \<sqsubseteq> v3" using val_le_trans by blast
  from lx2 vp_v3 show ?case by (rule e_var_intro)
next
  case (ENat n) then show ?case by simp
next
  case (ELam x e)
  from ELam(2) obtain f where v: "v = VFun f" and
    body: "\<forall> v1 v2. (v1,v2) \<in> fset f \<longrightarrow> v2 \<in> E e ((x,v1)#\<rho>)" by auto
  from v ELam(4) obtain f' where vp: "v' = VFun f'" and fp_f: "fset f' \<subseteq> fset f"
    by (case_tac v') auto
  from vp show ?case
  proof (simp,clarify)
    fix v1 v2 assume v12: "(v1,v2)\<in> fset f'"
    from v12 fp_f have v34: "(v1,v2) \<in> fset f" by blast
    from v34 body have v4_E: "v2 \<in> E e ((x,v1)#\<rho>)" by blast
    from ELam(3) have rr2: "FV e \<turnstile> ((x,v1)#\<rho>) \<sqsubseteq> ((x,v1)#\<rho>')" by auto
    from ELam(1) v4_E rr2 show "v2 \<in> E e ((x,v1)#\<rho>')" by auto
  qed
next
  case (ECons e1 e2)
  from ECons(3) obtain v1 v2 where v: "v = VPair v1 v2" and
    e1_v1: "v1 \<in> E e1 \<rho>" and e2_v2: "v2 \<in> E e2 \<rho>" by auto
  from v ECons(5) obtain v1' v2' where vp: "v' = VPair v1' v2'"
    by (case_tac v') auto

  from ECons(4) have fv_e1: "FV e1 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" and
    fv_e2: "FV e2 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto

  from ECons(1) e1_v1 fv_e1 have v1_envp: "v1 \<in> E e1 \<rho>'" by auto
  from ECons(2) e2_v2 fv_e2 have v2_envp: "v2 \<in> E e2 \<rho>'" by auto

  from ECons(5) v vp e1_v1 have v1_v1: "v1' \<sqsubseteq> v1" by auto
  from ECons(5) v vp e2_v2 have v2_v2: "v2' \<sqsubseteq> v2" by auto

  from ECons(1) v1_v1 v1_envp have 1:  "v1' \<in> E e1 \<rho>'" by auto
  from ECons(2) v2_v2 v2_envp have 2:  "v2' \<in> E e2 \<rho>'" by auto

  from vp 1 2 show ?case by auto
next
  case (ECar e)
  from ECar(2) obtain v1 v2 where p_e: "VPair v1 v2 \<in> E e \<rho>" and v: "v \<sqsubseteq> v1" by blast
  from ECar(3) have fv_e: "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from ECar(1) fv_e p_e have p_e_rp: "VPair v1 v2 \<in> E e \<rho>'" by auto
  from ECar(4) v have vp: "v' \<sqsubseteq> v1" by (rule val_le_trans)
  from p_e_rp vp show ?case by (meson ECar.IH e_car_intro fv_e p_e val_le_refl vpair_le)
next
  case (ECdr e)
  from ECdr(2) obtain v1 v2 where p_e: "VPair v1 v2 \<in> E e \<rho>" and v: "v \<sqsubseteq> v2" by blast
  from ECdr(3) have fv_e: "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from ECdr(1) fv_e p_e have p_e_rp: "VPair v1 v2 \<in> E e \<rho>'" by auto
  from ECdr(4) v have vp: "v' \<sqsubseteq> v2" by (rule val_le_trans)
  from p_e_rp vp show ?case by (meson ECdr.IH e_cdr_intro fv_e p_e val_le_refl vpair_le)
next
  case (EApp e1 e2)
  from EApp(3) obtain f and v2::val and v2' v3' where
    f_e1: "VFun f \<in> E e1 \<rho>" and v2_e2: "v2 \<in> E e2 \<rho>" and
    v23p_f: "(v2',v3') \<in> fset f" and v2p_v2: "v2' \<sqsubseteq> v2" and v_v3: "v \<sqsubseteq> v3'" by blast
  from EApp(4) have 1: "FV e1 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  have f_f: "VFun f \<sqsubseteq> VFun f" by auto
  from EApp(1) f_e1 1 f_f have f_e1b: "VFun f \<in> E e1 \<rho>'" by blast
  from EApp(4) have 2: "FV e2 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from EApp(2) v2_e2 2 have v2_e2b: "v2 \<in> E e2 \<rho>'" by auto
  from EApp(5) v_v3 have vp_v3p: "v' \<sqsubseteq> v3'" by (rule val_le_trans)
  from f_e1b v2_e2b v23p_f v2p_v2 vp_v3p
  show ?case by auto
next
  case (EPrim f e1 e2)
  from EPrim(3) obtain n1 n2 where n1_e1: "VNat n1 \<in> E e1 \<rho>" and
    n2_e2: "VNat n2 \<in> E e2 \<rho>" and v: "v = VNat (f n1 n2)" by blast
  from EPrim(4) have 1: "FV e1 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from EPrim(1) n1_e1 1 have n1_e1b: "VNat n1 \<in> E e1 \<rho>'" by blast
  from EPrim(4) have 2: "FV e2 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from EPrim(2) n2_e2 2 have n2_e2b: "VNat n2 \<in> E e2 \<rho>'" by blast
  from v EPrim(5) have vp: "v' = VNat (f n1 n2)" by auto
  from n1_e1b n2_e2b vp show ?case by auto
next
  case (EIf e1 e2 e3)
  then show ?case apply simp apply clarify apply (rule_tac x=n in exI) apply (rule conjI)
    apply force apply force done
qed

-- "Subsumption is admissible"
proposition e_sub: "\<lbrakk> v \<in> E e \<rho>; v' \<sqsubseteq> v \<rbrakk> \<Longrightarrow> v' \<in> E e \<rho>"
  apply (subgoal_tac "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>") using change_env_le apply blast apply auto done

lemma env_le_ext: fixes \<rho>::env assumes rr: "\<rho> \<sqsubseteq> \<rho>'" shows "((x,v)#\<rho>) \<sqsubseteq> ((x,v)#\<rho>')"
  using rr apply (simp add: env_le_def) done

lemma change_env: fixes \<rho>::env assumes de: "v \<in> E e \<rho>" and rr: "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>'" shows "v \<in> E e \<rho>'"
proof -
  have vv: "v \<sqsubseteq> v" by auto
  from de rr vv show ?thesis using change_env_le by blast
qed

lemma raise_env: fixes \<rho>::env assumes de: "v \<in> E e \<rho>" and rr: "\<rho> \<sqsubseteq> \<rho>'" shows "v \<in> E e \<rho>'"
  using de rr change_env env_le_def by auto

lemma env_eq_refl[simp]: fixes \<rho>::env shows "\<rho> \<approx> \<rho>" by (simp add: env_eq_def)

lemma eq_implies_le: fixes \<rho>::env shows "\<rho> \<approx> \<rho>' \<Longrightarrow> \<rho> \<sqsubseteq> \<rho>'"
  by (simp add: env_le_def env_eq_def)

lemma env_swap: fixes \<rho>::env assumes rr: "\<rho> \<approx> \<rho>'" and ve: "v \<in> E e \<rho>" shows "v \<in> E e \<rho>'"
  using rr ve apply (subgoal_tac "\<rho> \<sqsubseteq> \<rho>'") prefer 2 apply (rule eq_implies_le) apply blast
  apply (rule raise_env) apply auto done

lemma env_strengthen: "\<lbrakk> v \<in> E e \<rho>; \<forall> x. x \<in> FV e \<longrightarrow> lookup \<rho>' x = lookup \<rho> x \<rbrakk> \<Longrightarrow> v \<in> E e \<rho>'"
  using change_env by auto

end