theory AGTT
  imports GTT GTT_Transitive_Closure Pair_Automaton
begin

definition AGTT_union where
  "AGTT_union \<G>\<^sub>1 \<G>\<^sub>2 \<equiv> (ta_union (fst \<G>\<^sub>1) (fst \<G>\<^sub>2),
                       ta_union (snd \<G>\<^sub>1) (snd \<G>\<^sub>2))"

abbreviation AGTT_union' where
  "AGTT_union' \<G>\<^sub>1 \<G>\<^sub>2 \<equiv> AGTT_union (fmap_states_gtt Inl \<G>\<^sub>1) (fmap_states_gtt Inr \<G>\<^sub>2)"

lemma disj_gtt_states_disj_fst_ta_states:
  assumes dist_st: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "\<Q> (fst \<G>\<^sub>1) |\<inter>| \<Q> (fst \<G>\<^sub>2) = {||}"
  using assms unfolding gtt_states_def by auto

lemma disj_gtt_states_disj_snd_ta_states:
  assumes dist_st: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "\<Q> (snd \<G>\<^sub>1) |\<inter>| \<Q> (snd \<G>\<^sub>2) = {||}"
  using assms unfolding gtt_states_def by auto

lemma ta_der_not_contains_undefined_state:
  assumes "q |\<notin>| \<Q> T" and "ground t"
  shows "q |\<notin>| ta_der T t"
  using ground_ta_der_states[OF assms(2)] assms(1)
  by blast

lemma AGTT_union_sound1:
  assumes dist_st: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "agtt_lang (AGTT_union \<G>\<^sub>1 \<G>\<^sub>2) \<subseteq> agtt_lang \<G>\<^sub>1 \<union> agtt_lang \<G>\<^sub>2"
proof -
  let ?TA_A = "ta_union (fst \<G>\<^sub>1) (fst \<G>\<^sub>2)"
  let ?TA_B = "ta_union (snd \<G>\<^sub>1) (snd \<G>\<^sub>2)"
  {fix s t assume ass: "(s, t) \<in> agtt_lang (AGTT_union \<G>\<^sub>1 \<G>\<^sub>2)"
    then obtain q where ls: "q |\<in>| ta_der ?TA_A (term_of_gterm s)" and
      rs: "q |\<in>| ta_der ?TA_B (term_of_gterm t)"
      by (auto simp add: AGTT_union_def agtt_lang_def gta_der_def)
    then have "(s, t) \<in> agtt_lang \<G>\<^sub>1 \<or> (s, t) \<in> agtt_lang \<G>\<^sub>2"
    proof (cases "q |\<in>| gtt_states \<G>\<^sub>1")
      case True
      then have "q |\<notin>| gtt_states \<G>\<^sub>2" using dist_st
        by blast
      then have nt_fst_st: "q |\<notin>| \<Q> (fst \<G>\<^sub>2)" and
        nt_snd_state: "q |\<notin>| \<Q> (snd \<G>\<^sub>2)" by (auto simp add: gtt_states_def)
      from True show ?thesis
        using ls rs
        using ta_der_not_contains_undefined_state[OF nt_fst_st]
        using ta_der_not_contains_undefined_state[OF nt_snd_state]
        unfolding gtt_states_def agtt_lang_def gta_der_def
        using ta_union_der_disj_states[OF disj_gtt_states_disj_fst_ta_states[OF dist_st]]
        using ta_union_der_disj_states[OF disj_gtt_states_disj_snd_ta_states[OF dist_st]]
        using ground_term_of_gterm by blast
    next
      case False
      then have "q |\<notin>| gtt_states \<G>\<^sub>1" by (metis IntI dist_st emptyE)
      then have nt_fst_st: "q |\<notin>| \<Q> (fst \<G>\<^sub>1)" and
        nt_snd_state: "q |\<notin>| \<Q> (snd \<G>\<^sub>1)" by (auto simp add: gtt_states_def)
      from False show ?thesis
        using ls rs
        using ta_der_not_contains_undefined_state[OF nt_fst_st]
        using ta_der_not_contains_undefined_state[OF nt_snd_state]
        unfolding gtt_states_def agtt_lang_def gta_der_def
        using ta_union_der_disj_states[OF disj_gtt_states_disj_fst_ta_states[OF dist_st]]
        using ta_union_der_disj_states[OF disj_gtt_states_disj_snd_ta_states[OF dist_st]]
        using ground_term_of_gterm by blast
    qed}
  then show ?thesis by auto
qed

lemma AGTT_union_sound2:
  shows "agtt_lang \<G>\<^sub>1 \<subseteq> agtt_lang (AGTT_union \<G>\<^sub>1 \<G>\<^sub>2)"
    "agtt_lang \<G>\<^sub>2 \<subseteq> agtt_lang (AGTT_union \<G>\<^sub>1 \<G>\<^sub>2)"
  unfolding agtt_lang_def gta_der_def AGTT_union_def
  by auto (meson fin_mono ta_der_mono' ta_union_ta_subset)+

lemma AGTT_union_sound:
  assumes dist_st: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "agtt_lang (AGTT_union \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang \<G>\<^sub>1 \<union> agtt_lang \<G>\<^sub>2"
  using AGTT_union_sound1[OF assms] AGTT_union_sound2 by blast

lemma AGTT_union'_sound:
  fixes \<G>\<^sub>1 :: "('q, 'f) gtt" and \<G>\<^sub>2 :: "('q, 'f) gtt"
  shows "agtt_lang (AGTT_union' \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang \<G>\<^sub>1 \<union> agtt_lang \<G>\<^sub>2"
proof -
  have map: "agtt_lang (AGTT_union' \<G>\<^sub>1 \<G>\<^sub>2) =
    agtt_lang (fmap_states_gtt CInl \<G>\<^sub>1) \<union> agtt_lang (fmap_states_gtt CInr \<G>\<^sub>2)"
    by (intro  AGTT_union_sound) (auto simp add: agtt_lang_fmap_states_gtt)
  then show ?thesis by (simp add: agtt_lang_fmap_states_gtt finj_CInl_CInr)
qed

subsection \<open>Anchord gtt compositon\<close>

definition AGTT_comp :: "('q, 'f) gtt \<Rightarrow> ('q, 'f) gtt \<Rightarrow> ('q, 'f) gtt" where
  "AGTT_comp \<G>\<^sub>1 \<G>\<^sub>2 = (let (\<A>, \<B>) = (fst \<G>\<^sub>1, snd \<G>\<^sub>2) in
    (TA (rules \<A>) (eps \<A> |\<union>| (\<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2) |\<inter>| (gtt_interface \<G>\<^sub>1 |\<times>| gtt_interface \<G>\<^sub>2))),
     TA (rules \<B>) (eps \<B>)))"

abbreviation AGTT_comp' where
  "AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 \<equiv> AGTT_comp (fmap_states_gtt Inl \<G>\<^sub>1) (fmap_states_gtt Inr \<G>\<^sub>2)"

lemma AGTT_comp_sound:
  assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "agtt_lang (AGTT_comp \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang \<G>\<^sub>1 O agtt_lang \<G>\<^sub>2"
proof -
  let ?Q\<^sub>1 = "fId_on (gtt_interface \<G>\<^sub>1)" let ?Q\<^sub>2 = "fId_on (gtt_interface \<G>\<^sub>2)"
  have lan: "agtt_lang \<G>\<^sub>1 = pair_at_lang \<G>\<^sub>1 ?Q\<^sub>1" "agtt_lang \<G>\<^sub>2 = pair_at_lang \<G>\<^sub>2 ?Q\<^sub>2"
    using pair_at_agtt[of \<G>\<^sub>1] pair_at_agtt[of \<G>\<^sub>2]
    by auto
  have "agtt_lang \<G>\<^sub>1 O agtt_lang \<G>\<^sub>2 = pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 ?Q\<^sub>1 \<G>\<^sub>2 ?Q\<^sub>2)"
    using pair_comp_sound1 pair_comp_sound2
    by (auto simp add: lan pair_comp_sound1 pair_comp_sound2 relcomp.simps)
  moreover have "AGTT_comp \<G>\<^sub>1 \<G>\<^sub>2 = pair_at_to_agtt (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 ?Q\<^sub>1 \<G>\<^sub>2 ?Q\<^sub>2)"
    by (auto simp: AGTT_comp_def pair_at_to_agtt_def gtt_interface_def \<Delta>\<^sub>\<epsilon>_def' \<Delta>_eps_pair_def)
  ultimately show ?thesis using pair_at_agtt_conv[of "\<Delta>_eps_pair \<G>\<^sub>1 ?Q\<^sub>1 \<G>\<^sub>2 ?Q\<^sub>2" "(fst \<G>\<^sub>1, snd \<G>\<^sub>2)"]
    using assms
    by (auto simp: \<Delta>_eps_pair_def gtt_states_def gtt_interface_def)
qed

lemma AGTT_comp'_sound:
  "agtt_lang (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang \<G>\<^sub>1 O agtt_lang \<G>\<^sub>2"
  using AGTT_comp_sound[of "fmap_states_gtt (Inl :: 'b \<Rightarrow> 'b + 'c) \<G>\<^sub>1"
    "fmap_states_gtt (Inr :: 'c \<Rightarrow> 'b + 'c) \<G>\<^sub>2"]
  by (auto simp add: agtt_lang_fmap_states_gtt disjoint_iff_not_equal agtt_lang_Inl_Inr_states_agtt)

subsection \<open>Anchord gtt transitivity\<close>

definition AGTT_trancl :: "('q, 'f) gtt \<Rightarrow> ('q + 'q, 'f) gtt" where
  "AGTT_trancl \<G> = (let \<A> = fmap_states_ta Inl (fst \<G>) in
    (TA (rules \<A>) (eps \<A> |\<union>| map_prod CInl CInr |`| (\<Delta>_Atrans_gtt \<G> (fId_on (gtt_interface \<G>)))),
     TA (map_ta_rule CInr id |`| (rules (snd \<G>))) (map_both CInr |`| (eps (snd \<G>)))))"

lemma AGTT_trancl_sound:
  shows "agtt_lang (AGTT_trancl \<G>) = (agtt_lang \<G>)\<^sup>+"
proof -
  let ?P = "map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) \<G>"
  let ?Q = "fId_on (gtt_interface \<G>)" let ?Q' = "map_prod CInl CInr |`| ?Q"
  have inv: "finj_on CInl (\<Q> (fst \<G>))" "finj_on CInr (\<Q> (snd \<G>))"
    "?Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
    by (auto simp: gtt_interface_def finj_CInl_CInr)
  have *: "fst |`| map_prod CInl CInr |`| \<Delta>_Atrans_gtt \<G> (fId_on (gtt_interface \<G>)) |\<subseteq>| CInl |`| \<Q> (fst \<G>)"
    using fsubsetD[OF \<Delta>_Atrans_states_stable[OF inv(3)]]
    by (auto simp add: gtt_interface_def)
  from pair_at_lang_fun_states[OF inv]
  have "agtt_lang \<G> = pair_at_lang ?P ?Q'" using pair_at_agtt[of \<G>] by auto
  moreover then have "(agtt_lang \<G>)\<^sup>+ = pair_at_lang ?P (\<Delta>_Atrans_gtt ?P ?Q')"
    by (simp add: pair_trancl_sound)
  moreover have "AGTT_trancl \<G> = pair_at_to_agtt ?P (\<Delta>_Atrans_gtt ?P ?Q')"
    using \<Delta>_Atrans_states_stable[OF inv(3)] \<Delta>_Atrans_map_prod[OF inv, symmetric]
    using fId_on_frelcomp_id[OF *]
    by (auto simp: AGTT_trancl_def pair_at_to_agtt_def gtt_interface_def Let_def fmap_states_ta_def)
       (metis fmap_prod_fimageI fmap_states fmap_states_ta_def)
  moreover have "gtt_interface (map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) \<G>) = {||}"
    by (auto simp: gtt_interface_def)
  ultimately show ?thesis using pair_at_agtt_conv[of "\<Delta>_Atrans_gtt ?P ?Q'" ?P] \<Delta>_Atrans_states_stable[OF inv(3)]
    unfolding \<Delta>_Atrans_map_prod[OF inv, symmetric]
    by (simp add: fimage_mono gtt_interface_def map_prod_ftimes)
qed

subsection \<open>Anchord gtt triming\<close>

abbreviation "trim_agtt \<equiv> trim_gtt"

lemma agtt_only_prod_lang:
  "agtt_lang (gtt_only_prod \<G>) = agtt_lang \<G>" (is "?Ls = ?Rs")
proof -
  let ?A = "fst \<G>" let ?B = "snd \<G>"
  have "?Ls \<subseteq> ?Rs" unfolding agtt_lang_def gtt_only_prod_def
    by (auto simp: Let_def gta_der_def dest: ta_der_ta_only_prod_ta_der)
  moreover
  {fix s t assume "(s, t) \<in> ?Rs"
    then obtain q where r: "q |\<in>| ta_der (fst \<G>) (term_of_gterm s)" "q |\<in>| ta_der (snd \<G>) (term_of_gterm t)"
      by (auto simp: agtt_lang_def gta_der_def)
    then have " q |\<in>| gtt_interface \<G>" by (auto simp: gtt_interface_def)
    then have "(s, t) \<in> ?Ls" using r
      by (auto simp: agtt_lang_def gta_der_def gtt_only_prod_def Let_def intro!: exI[of _ q] ta_der_only_prod ta_productive_setI)}
  ultimately show ?thesis by auto
qed

lemma agtt_only_reach_lang:
  "agtt_lang (gtt_only_reach \<G>) = agtt_lang \<G>"
  unfolding agtt_lang_def gtt_only_reach_def
  by (auto simp: gta_der_def simp flip: ta_der_gterm_only_reach)

lemma trim_agtt_lang [simp]:
  "agtt_lang (trim_agtt G) = agtt_lang G"
  unfolding trim_gtt_def comp_def agtt_only_prod_lang agtt_only_reach_lang ..

end


theory Proofs_2
  imports Requirements ExtraInv VCTheoryLemmas
begin

definition inv2 where "inv2 s \<equiv> R2 s \<and> extraInv s"

definition pred2 where "pred2 s1 s2 s s5\<equiv>
substate s1 s2 \<and> substate s2 s5 \<and> substate s5 s \<and> toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s5 \<and> toEnvNum s1 s2 = 1 \<and> toEnvNum s2 s = DELAY'TIMEOUT \<and>
(getVarBool s1 up' = True \<or> getVarBool s1 down' = True) \<and> \<not> getVarBool s2 userAtTop' \<and> \<not> getVarBool s2 userAtBottom' \<and>
(\<forall> s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s5 \<and> s4 \<noteq> s5 \<longrightarrow>
(getVarBool s4 up' = True \<or> getVarBool s4 down' = True) \<and> \<not> getVarBool s4 userAtTop' \<and> \<not> getVarBool s4 userAtBottom')
\<longrightarrow>
(\<exists> s4. toEnvP s4 \<and> substate s5 s4 \<and> substate s4 s \<and> toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
(getVarBool s4 up' = False \<and> getVarBool s4 down' = False \<or> getVarBool s4 userAtTop' \<or> getVarBool s4 userAtBottom') \<and>
(\<forall> s3. toEnvP s3 \<and> substate s5 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
(getVarBool s3 up' = True \<or> getVarBool s3 down' = True) \<and> \<not> getVarBool s3 userAtTop' \<and> \<not> getVarBool s3 userAtBottom'))"

lemma goUp_notMoving: "toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Ctrl' = Ctrl'goUp \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Ctrl'goUp \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goUp) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = UP') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s \<and> getPstate s3 ERROR = Ctrl'stuckState \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 ERROR \<longrightarrow>
            getPstate s1 ERROR = Ctrl'stuckState \<and>
            getVarBool s1 moving' = getVarBool s3 moving' \<and> getVarBool s1 direction' = getVarBool s3 direction') \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 < ltime s3 ERROR - ERROR \<longrightarrow>
            \<not> getVarBool s2 alarmButton' \<and> \<not> getVarBool s2 stuck' \<and> getVarBool s2 up' = DOWN' \<and> getVarBool s2 down' = DOWN')) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Ctrl'motionless \<longrightarrow>
      getVarBool s1 up' = DOWN' \<and> getVarBool s1 down' = DOWN' \<and> \<not> getVarBool s1 moving')  \<Longrightarrow>
\<exists> s2. toEnvP s2 \<and> substate s2 s1 \<and> toEnvNum s2 s1 \<le> ltime s1 Ctrl' \<and>
 (getVarBool s2 up' = False \<and> getVarBool s2 down' = False \<or> getVarBool s2 userAtTop' \<or> getVarBool s2 userAtBottom')\<and>
(toEnvNum s2 s1 = ltime s1 Ctrl' \<longrightarrow> getVarBool s2 up' = False \<and> getVarBool s2 down' = False)
"
  apply(rule exE[of "(\<lambda> s2. \<exists> s3.
toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goUp) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = UP') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')"])
   apply blast
apply(drule exE)
   prefer 2
   apply assumption
  subgoal for s2 s3
    apply(cases "getPstate s2 Ctrl' = Ctrl'motionless")
     apply (smt (verit, best) nat_le_linear substate_trans)
    apply(cases "getPstate s2 Ctrl' = Ctrl'goUp")
    apply(rule exI[of _ s3])
    apply (smt (z3) nat_le_linear not_one_le_zero numeral_eq_iff semiring_norm(85) semiring_norm(90) shift_toEnvNum substate_antisym substate_shift substate_trans toEnvNum_id)
       apply(rule cut_rl[of "getPstate s2 Ctrl' = Ctrl'stuckState"])
     apply (smt (z3) nat_le_linear one_less_numeral_iff semiring_norm(76) substate_linear substate_trans toEnvNum_id zero_less_diff)
    by blast
  done

lemma goDown_notMoving: "toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Ctrl' = Ctrl'goDown \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Ctrl'goDown \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goDown) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = DOWN') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s \<and> getPstate s3 ERROR = Ctrl'stuckState \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 ERROR \<longrightarrow>
            getPstate s1 ERROR = Ctrl'stuckState \<and>
            getVarBool s1 moving' = getVarBool s3 moving' \<and> getVarBool s1 direction' = getVarBool s3 direction') \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 < ltime s3 ERROR - ERROR \<longrightarrow>
            \<not> getVarBool s2 alarmButton' \<and> \<not> getVarBool s2 stuck' \<and> getVarBool s2 up' = DOWN' \<and> getVarBool s2 down' = DOWN')) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Ctrl'motionless \<longrightarrow>
      getVarBool s1 up' = DOWN' \<and> getVarBool s1 down' = DOWN' \<and> \<not> getVarBool s1 moving')  \<Longrightarrow>
\<exists> s2. toEnvP s2 \<and> substate s2 s1 \<and> toEnvNum s2 s1 \<le> ltime s1 Ctrl' \<and>
 (getVarBool s2 up' = False \<and> getVarBool s2 down' = False \<or> getVarBool s2 userAtTop' \<or> getVarBool s2 userAtBottom')
"
 apply(rule exE[of "(\<lambda> s2. \<exists> s3.
 toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goDown) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = DOWN') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')"])
   apply blast
apply(drule exE)
   prefer 2
   apply assumption
  subgoal for s2 s3
    apply(cases "getPstate s2 Ctrl' = Ctrl'motionless")
     apply (smt (verit, best) nat_le_linear substate_trans)
    apply(cases "getPstate s2 Ctrl' = Ctrl'goDown")
    apply(rule exI[of _ s3])
     apply (metis (mono_tags, opaque_lifting) eval_nat_numeral(3) n_not_Suc_n nat_le_linear shift_toEnvNum substate_antisym substate_shift substate_trans)
    apply(rule cut_rl[of "getPstate s2 Ctrl' = Ctrl'stuckState"])
    apply (smt (z3) nat_le_linear one_less_numeral_iff semiring_norm(76) substate_linear substate_trans toEnvNum_id zero_less_diff)
    by blast
  done

theorem proof_2_7: "VC7 inv2 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC7_def)
  by auto

end


theory BTree_ImpSet
  imports
    BTree_Imp
    BTree_Set
begin

section "Imperative Set operations"

subsection "Auxiliary operations"

definition "split_relation xs \<equiv>
   \<lambda>(as,bs) i. i \<le> length xs \<and> as = take i xs \<and> bs = drop i xs"

lemma split_relation_alt:
  "split_relation as (ls,rs) i = (as = ls@rs \<and> i = length ls)"
  by (auto simp add: split_relation_def)

lemma split_relation_length: "split_relation xs (ls,rs) (length xs) = (ls = xs \<and> rs = [])"
  by (simp add: split_relation_def)

(* auxiliary lemmas on assns *)
(* simp? not sure if it always makes things more easy *)
lemma list_assn_prod_map: "list_assn (A \<times>\<^sub>a B) xs ys = list_assn B (map snd xs) (map snd ys) * list_assn A (map fst xs) (map fst ys)"
  apply(induct "(A \<times>\<^sub>a B)" xs ys rule: list_assn.induct)
     apply(auto simp add: ab_semigroup_mult_class.mult.left_commute ent_star_mono star_aci(2) star_assoc)
  done

(* concrete *)
lemma id_assn_list: "h \<Turnstile> list_assn id_assn (xs::'a list) ys \<Longrightarrow> xs = ys"
  apply(induction "id_assn::('a \<Rightarrow> 'a \<Rightarrow> assn)" xs ys rule: list_assn.induct)
     apply(auto simp add: less_Suc_eq_0_disj pure_def)
  done

lemma snd_map_help:
  "x \<le> length tsi \<Longrightarrow>
       (\<forall>j<x. snd (tsi ! j) = ((map snd tsi)!j))"
  "x < length tsi \<Longrightarrow> snd (tsi!x) = ((map snd tsi)!x)"
  by auto

lemma split_ismeq: "((a::nat) \<le> b \<and> X) = ((a < b \<and> X) \<or> (a = b \<and> X))"
  by auto

lemma split_relation_map: "split_relation as (ls,rs) i \<Longrightarrow> split_relation (map f as) (map f ls, map f rs) i"
  apply(induction as arbitrary: ls rs i)
   apply(auto simp add: split_relation_def take_map drop_Cons')
  apply(metis list.simps(9) take_map)
  done

lemma split_relation_access: "\<lbrakk>split_relation as (ls,rs) i; rs = r#rrs\<rbrakk> \<Longrightarrow> as!i = r"
  by (simp add: split_relation_alt)

lemma index_to_elem_all: "(\<forall>j<length xs. P (xs!j)) = (\<forall>x \<in> set xs. P x)"
  by (simp add: all_set_conv_nth)

lemma index_to_elem: "n < length xs \<Longrightarrow> (\<forall>j<n. P (xs!j)) = (\<forall>x \<in> set (take n xs). P x)"
  by (simp add: all_set_conv_nth)
    (* ----------------- *)

definition split_half :: "('a::heap \<times> 'b::{heap}) pfarray \<Rightarrow> nat Heap"
  where
    "split_half a \<equiv> do {
  l \<leftarrow> pfa_length a;
  return (l div 2)
}"

lemma split_half_rule[sep_heap_rules]: "<
    is_pfa c tsi a
  * list_assn R ts tsi>
    split_half a
  <\<lambda>i.
      is_pfa c tsi a
    * list_assn R ts tsi
    * \<up>(i = length ts div 2 \<and>  split_relation ts (BTree_Set.split_half ts) i)>"
  unfolding split_half_def split_relation_def
  apply(rule hoare_triple_preI)
  apply(sep_auto dest!: list_assn_len mod_starD)
  done

subsection "The imperative split locale"

text "This locale extends the abstract split locale,
assuming that we are provided with an imperative program
that refines the abstract split function."

locale imp_split = abs_split: BTree_Set.split split
  for split::
    "('a btree \<times> 'a::{heap,default,linorder}) list \<Rightarrow> 'a
       \<Rightarrow> ('a btree \<times> 'a) list \<times> ('a btree \<times> 'a) list" +
  fixes imp_split:: "('a btnode ref option \<times> 'a::{heap,default,linorder}) pfarray \<Rightarrow> 'a \<Rightarrow> nat Heap"
  assumes imp_split_rule [sep_heap_rules]:"sorted_less (separators ts) \<Longrightarrow>
   <is_pfa c tsi (a,n)
  * blist_assn k ts tsi>
    imp_split (a,n) p
  <\<lambda>i.
    is_pfa c tsi (a,n)
    * blist_assn k ts tsi
    * \<up>(split_relation ts (split ts p) i)>\<^sub>t"
begin

subsection "Membership"

partial_function (heap) isin :: "'a btnode ref option \<Rightarrow> 'a \<Rightarrow>  bool Heap"
  where
    "isin p x =
  (case p of
     None \<Rightarrow> return False |
     (Some a) \<Rightarrow> do {
       node \<leftarrow> !a;
       i \<leftarrow> imp_split (kvs node) x;
       tsl \<leftarrow> pfa_length (kvs node);
       if i < tsl then do {
         s \<leftarrow> pfa_get (kvs node) i;
         let (sub,sep) = s in
         if x = sep then
           return True
         else
           isin sub x
       } else
           isin (last node) x
    }
)"

subsection "Insertion"

datatype 'b btupi =
  T\<^sub>i "'b btnode ref option" |
  Up\<^sub>i "'b btnode ref option" "'b" "'b btnode ref option"

fun btupi_assn where
  "btupi_assn k (abs_split.T\<^sub>i l) (T\<^sub>i li) =
   btree_assn k l li" |
  "btupi_assn k (abs_split.Up\<^sub>i l a r) (Up\<^sub>i li ai ri) =
   btree_assn k l li * id_assn a ai * btree_assn k r ri" |
  "btupi_assn _ _ _ = false"

definition node\<^sub>i :: "nat \<Rightarrow> ('a btnode ref option \<times> 'a) pfarray \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btupi Heap" where
  "node\<^sub>i k a ti \<equiv> do {
    n \<leftarrow> pfa_length a;
    if n \<le> 2*k then do {
      a' \<leftarrow> pfa_shrink_cap (2*k) a;
      l \<leftarrow> ref (Btnode a' ti);
      return (T\<^sub>i (Some l))
    }
    else do {
      b \<leftarrow> (pfa_empty (2*k) :: ('a btnode ref option \<times> 'a) pfarray Heap);
      i \<leftarrow> split_half a;
      m \<leftarrow> pfa_get a i;
      b' \<leftarrow> pfa_drop a (i+1) b;
      a' \<leftarrow> pfa_shrink i a;
      a'' \<leftarrow> pfa_shrink_cap (2*k) a';
      let (sub,sep) = m in do {
        l \<leftarrow> ref (Btnode a'' sub);
        r \<leftarrow> ref (Btnode b' ti);
        return (Up\<^sub>i (Some l) sep (Some r))
      }
    }
}"

partial_function (heap) ins :: "nat \<Rightarrow> 'a \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btupi Heap"
  where
    "ins k x apo = (case apo of
  None \<Rightarrow>
    return (Up\<^sub>i None x None) |
  (Some ap) \<Rightarrow> do {
    a \<leftarrow> !ap;
    i \<leftarrow> imp_split (kvs a) x;
    tsl \<leftarrow> pfa_length (kvs a);
    if i < tsl then do {
      s \<leftarrow> pfa_get (kvs a) i;
      let (sub,sep) = s in
      if sep = x then
        return (T\<^sub>i apo)
      else do {
        r \<leftarrow> ins k x sub;
        case r of
          (T\<^sub>i lp) \<Rightarrow> do {
            pfa_set (kvs a) i (lp,sep);
            return (T\<^sub>i apo)
          } |
          (Up\<^sub>i lp x' rp) \<Rightarrow> do {
            pfa_set (kvs a) i (rp,sep);
            if tsl < 2*k then do {
                kvs' \<leftarrow> pfa_insert (kvs a) i (lp,x');
                ap := (Btnode kvs' (last a));
                return (T\<^sub>i apo)
            } else do {
              kvs' \<leftarrow> pfa_insert_grow (kvs a) i (lp,x');
              node\<^sub>i k kvs' (last a)
            }
          }
        }
      }
    else do {
      r \<leftarrow> ins k x (last a);
      case r of
        (T\<^sub>i lp) \<Rightarrow> do {
          ap := (Btnode (kvs a) lp);
          return (T\<^sub>i apo)
        } |
        (Up\<^sub>i lp x' rp) \<Rightarrow>
          if tsl < 2*k then do {
            kvs' \<leftarrow> pfa_append (kvs a) (lp,x');
            ap := (Btnode kvs' rp);
            return (T\<^sub>i apo)
          } else do {
            kvs' \<leftarrow> pfa_append_grow' (kvs a) (lp,x');
            node\<^sub>i k kvs' rp
        }
    }
  }
)"

(*fun tree\<^sub>i::"'a up\<^sub>i \<Rightarrow> 'a btree" where
  "tree\<^sub>i (T\<^sub>i sub) = sub" |
  "tree\<^sub>i (Up\<^sub>i l a r) = (Node [(l,a)] r)"

fun insert::"nat \<Rightarrow> 'a \<Rightarrow> 'a btree \<Rightarrow> 'a btree" where
  "insert k x t = tree\<^sub>i (ins k x t)"
*)

definition insert :: "nat \<Rightarrow> ('a::{heap,default,linorder}) \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btnode ref option Heap" where
  "insert \<equiv> \<lambda>k x ti. do {
  ti' \<leftarrow> ins k x ti;
  case ti' of
     T\<^sub>i sub \<Rightarrow> return sub |
     Up\<^sub>i l a r \<Rightarrow> do {
        kvs \<leftarrow> pfa_init (2*k) (l,a) 1;
        t' \<leftarrow> ref (Btnode kvs r);
        return (Some t')
      }
}"

subsection "Deletion"

(* rebalance middle tree gets a list of trees, an index pointing to
the position of sub/sep and a last tree *)
definition rebalance_middle_tree:: "nat \<Rightarrow> (('a::{default,heap,linorder}) btnode ref option \<times> 'a) pfarray \<Rightarrow> nat \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btnode Heap"
  where
    "rebalance_middle_tree \<equiv> \<lambda> k tsi i r_ti. (
  case r_ti of
  None \<Rightarrow> do {
      (r_sub,sep) \<leftarrow> pfa_get tsi i;
      case r_sub of None \<Rightarrow>  return (Btnode tsi r_ti)
  } |
  Some p_t \<Rightarrow> do {
      (r_sub,sep) \<leftarrow> pfa_get tsi i;
      case r_sub of (Some p_sub) \<Rightarrow>  do {
      ti \<leftarrow> !p_t;
      sub \<leftarrow> !p_sub;
      l_sub \<leftarrow> pfa_length (kvs sub);
      l_tts \<leftarrow> pfa_length (kvs ti);
      if l_sub \<ge> k \<and> l_tts \<ge> k then do {
        return (Btnode tsi r_ti)
      } else do {
        l_tsi \<leftarrow> pfa_length tsi;
        if i+1 = l_tsi then do {
          mts' \<leftarrow> pfa_append_extend_grow (kvs sub) (last sub,sep) (kvs ti);
          res_node\<^sub>i \<leftarrow> node\<^sub>i k mts' (last ti);
          case res_node\<^sub>i of
            T\<^sub>i u \<Rightarrow> do {
              tsi' \<leftarrow> pfa_shrink i tsi;
              return (Btnode tsi' u)
            } |
            Up\<^sub>i l a r \<Rightarrow> do {
              tsi' \<leftarrow> pfa_set tsi i (l,a);
              return (Btnode tsi' r)
            }
        } else do {
          (r_rsub,rsep) \<leftarrow> pfa_get tsi (i+1);
          case r_rsub of Some p_rsub \<Rightarrow> do {
            rsub \<leftarrow> !p_rsub;
            mts' \<leftarrow> pfa_append_extend_grow (kvs sub) (last sub,sep) (kvs rsub);
            res_node\<^sub>i \<leftarrow> node\<^sub>i k mts' (last rsub);
            case res_node\<^sub>i of
             T\<^sub>i u \<Rightarrow> do {
              tsi' \<leftarrow> pfa_set tsi i (u,rsep);
              tsi'' \<leftarrow> pfa_delete tsi' (i+1);
              return (Btnode tsi'' r_ti)
            } |
             Up\<^sub>i l a r \<Rightarrow> do {
              tsi' \<leftarrow> pfa_set tsi i (l,a);
              tsi'' \<leftarrow> pfa_set tsi' (i+1) (r,rsep);
              return (Btnode tsi'' r_ti)
            }
          }
        }
      }
  }
})
"

definition rebalance_last_tree:: "nat \<Rightarrow> (('a::{default,heap,linorder}) btnode ref option \<times> 'a) pfarray \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btnode Heap"
  where
    "rebalance_last_tree \<equiv> \<lambda>k tsi ti. do {
   l_tsi \<leftarrow> pfa_length tsi;
   rebalance_middle_tree k tsi (l_tsi-1) ti
}"

subsection "Refinement of the abstract B-tree operations"

definition empty ::"('a::{default,heap,linorder}) btnode ref option Heap"
  where "empty = return None"

lemma P_imp_Q_implies_P: "P \<Longrightarrow> (Q \<longrightarrow> P)"
  by simp

lemma  "sorted_less (inorder t) \<Longrightarrow>
   <btree_assn k t ti>
     isin ti x
   <\<lambda>r. btree_assn k t ti * \<up>(abs_split.isin t x = r)>\<^sub>t"
proof(induction t x arbitrary: ti rule: abs_split.isin.induct)
  case (1 x)
  then show ?case
    apply(subst isin.simps)
    apply (cases ti)
     apply (auto simp add: return_cons_rule)
    done
next
  case (2 ts t x)
  then obtain ls rs where list_split[simp]: "split ts x = (ls,rs)"
    by (cases "split ts x")
  then show ?case
  proof (cases rs)
    (* NOTE: induction condition trivial here *)
    case [simp]: Nil
    show ?thesis
      apply(subst isin.simps)
      apply(sep_auto)
      using "2.prems" sorted_inorder_separators apply blast
      apply(auto simp add: split_relation_def dest!: sym[of "[]"] mod_starD list_assn_len)[]
      apply(rule hoare_triple_preI)
      apply(auto simp add: split_relation_def dest!: sym[of "[]"] mod_starD list_assn_len)[]
      using 2(3) apply(sep_auto heap: "2.IH"(1)[of ls "[]"] simp add: sorted_wrt_append)
      done
  next
    case [simp]: (Cons h rrs)
    obtain sub sep where h_split[simp]: "h = (sub,sep)"
      by (cases h)
    show ?thesis
    proof (cases "sep = x")
      (* NOTE: no induction required here, only vacuous counter cases generated *)
      case [simp]: True
      then show ?thesis
        apply(simp split: list.splits prod.splits)
        apply(subst isin.simps)
        using "2.prems" sorted_inorder_separators apply(sep_auto)
         apply(rule hoare_triple_preI)
         apply(auto simp add: split_relation_alt list_assn_append_Cons_left dest!: mod_starD list_assn_len)[]
        apply(rule hoare_triple_preI)
        apply(auto simp add: split_relation_def dest!: sym[of "[]"] mod_starD list_assn_len)[]
        done
    next
      case [simp]: False
      show ?thesis
        apply(simp split: list.splits prod.splits)
        apply safe
        using False apply simp
        apply(subst isin.simps)
        using "2.prems" sorted_inorder_separators
        apply(sep_auto)
          (*eliminate vacuous case*)
          apply(auto simp add: split_relation_alt list_assn_append_Cons_left dest!:  mod_starD list_assn_len)[]
          (* simplify towards induction step *)
         apply(auto simp add: split_relation_alt list_assn_append_Cons_left dest!: mod_starD list_assn_len)[]

(* NOTE show that z = (suba, sepa) *)
         apply(rule norm_pre_ex_rule)+
         apply(rule hoare_triple_preI)
        subgoal for p tsi n ti xsi suba sepa zs1 z zs2 _
          apply(subgoal_tac "z = (suba, sepa)", simp)
          using 2(3) apply(sep_auto
              heap:"2.IH"(2)[of ls rs h rrs sub sep]
              simp add: sorted_wrt_append)
          using list_split Cons h_split apply simp_all
            (* proof that previous assumptions hold later *)
           apply(rule P_imp_Q_implies_P)
           apply(rule ent_ex_postI[where x="(tsi,n)"])
           apply(rule ent_ex_postI[where x="ti"])
           apply(rule ent_ex_postI[where x="(zs1 @ (suba, sepa) # zs2)"])
           apply(rule ent_ex_postI[where x="zs1"])
           apply(rule ent_ex_postI[where x="z"])
           apply(rule ent_ex_postI[where x="zs2"])
           apply sep_auto
            (* prove subgoal_tac assumption *)
          apply (metis (no_types, lifting) list_assn_aux_ineq_len list_assn_len nth_append_length star_false_left star_false_right)
          done
            (* eliminate last vacuous case *)
        apply(rule hoare_triple_preI)
        apply(auto simp add: split_relation_def dest!: mod_starD list_assn_len)[]
        done
    qed
  qed
qed

declare abs_split.node\<^sub>i.simps [simp add]

lemma node\<^sub>i_rule: assumes c_cap: "2*k \<le> c" "c \<le> 4*k+1"
  shows "<is_pfa c tsi (a,n) * list_assn ((btree_assn k) \<times>\<^sub>a id_assn) ts tsi * btree_assn k t ti>
  node\<^sub>i k (a,n) ti
  <\<lambda>r. btupi_assn k (abs_split.node\<^sub>i k ts t) r >\<^sub>t"
proof (cases "length ts \<le> 2 * k")
  case [simp]: True
  then show ?thesis
    apply(subst node\<^sub>i_def)
    apply(rule hoare_triple_preI)
    apply(sep_auto dest!: mod_starD list_assn_len)
       apply(sep_auto simp add: is_pfa_def)[]
    using c_cap apply(sep_auto simp add: is_pfa_def)[]
     apply(sep_auto  dest!: mod_starD list_assn_len)[]
    using True apply(sep_auto dest!: mod_starD list_assn_len)
    done
next
  note max.absorb1 [simp del] max.absorb2 [simp del] max.absorb3 [simp del] max.absorb4 [simp del]
  note min.absorb1 [simp del] min.absorb2 [simp del] min.absorb3 [simp del] min.absorb4 [simp del]
  case [simp]: False
  then obtain ls sub sep rs where
    split_half_eq: "BTree_Set.split_half ts = (ls,(sub,sep)#rs)"
    using abs_split.node\<^sub>i_cases by blast
  then show ?thesis
    apply(subst node\<^sub>i_def)
    apply(rule hoare_triple_preI)
    apply(sep_auto dest!: mod_starD list_assn_len)
       apply(sep_auto simp add:  split_relation_alt split_relation_length is_pfa_def dest!: mod_starD list_assn_len)
    using False apply(sep_auto simp add: split_relation_alt )
    using False  apply(sep_auto simp add: is_pfa_def)[]
    apply(sep_auto)[]
      apply(sep_auto simp add: is_pfa_def split_relation_alt)[]
    using c_cap apply(sep_auto simp add: is_pfa_def)[]
     apply(sep_auto)[]
    using c_cap apply(sep_auto simp add: is_pfa_def)[]
    using c_cap apply(simp)
    apply(vcg)
    apply(simp)
    apply(rule impI)
    subgoal for  _ _ _ _ rsa subi ba rn lsi al ar _
      thm ent_ex_postI
      thm ent_ex_postI[where x="take (length tsi div 2) tsi"]
        (* instantiate right hand side *)
      apply(rule ent_ex_postI[where x="(rsa,rn)"])
      apply(rule ent_ex_postI[where x="ti"])
      apply(rule ent_ex_postI[where x="(drop (Suc (length tsi div 2)) tsi)"])
      apply(rule ent_ex_postI[where x="lsi"])
      apply(rule ent_ex_postI[where x="subi"])
      apply(rule ent_ex_postI[where x="take (length tsi div 2) tsi"])
        (* introduce equality between equality of split tsi/ts and original lists *)
      apply(simp add: split_relation_alt)
      apply(subgoal_tac "tsi =
            take (length tsi div 2) tsi @ (subi, ba) # drop (Suc (length tsi div 2)) tsi")
       apply(rule back_subst[where a="blist_assn k ts (take (length tsi div 2) tsi @ (subi, ba) # (drop (Suc (length tsi div 2)) tsi))" and b="blist_assn k ts tsi"])
        apply(rule back_subst[where a="blist_assn k (take (length tsi div 2) ts @ (sub, sep) # rs)" and b="blist_assn k ts"])
         apply(subst list_assn_aux_append_Cons)
          apply sep_auto
         apply sep_auto
        apply simp
       apply simp
      apply(rule back_subst[where a="tsi ! (length tsi div 2)" and b="(subi, ba)"])
       apply(rule id_take_nth_drop)
       apply simp
      apply simp
      done
    done
qed
declare abs_split.node\<^sub>i.simps [simp del]

lemma node\<^sub>i_no_split: "length ts \<le> 2*k \<Longrightarrow> abs_split.node\<^sub>i k ts t = abs_split.T\<^sub>i (Node ts t)"
  by (simp add: abs_split.node\<^sub>i.simps)

lemma node\<^sub>i_rule_app: "\<lbrakk>2*k \<le> c; c \<le> 4*k+1\<rbrakk> \<Longrightarrow>
<is_pfa c (tsi' @ [(li, ai)]) (aa, al) *
   blist_assn k ls tsi' *
   btree_assn k l li *
   id_assn a ai *
   btree_assn k r ri> node\<^sub>i k (aa, al) ri
 <btupi_assn k (abs_split.node\<^sub>i k (ls @ [(l, a)]) r)>\<^sub>t"
proof -
  note node\<^sub>i_rule[of k c "(tsi' @ [(li, ai)])" aa al "(ls @ [(l, a)])" r ri]
  moreover assume "2*k \<le> c" "c \<le> 4*k+1"
  ultimately show ?thesis
    by (simp add: mult.left_assoc)
qed

lemma node\<^sub>i_rule_ins2: "\<lbrakk>2*k \<le> c; c \<le> 4*k+1; length ls = length lsi\<rbrakk> \<Longrightarrow>
 <is_pfa c (lsi @ (li, ai) # (ri,a'i) # rsi) (aa, al) *
   blist_assn k ls lsi *
   btree_assn k l li *
   id_assn a ai *
   btree_assn k r ri *
   id_assn a' a'i *
   blist_assn k rs rsi *
   btree_assn k t ti> node\<^sub>i k (aa, al)
          ti <btupi_assn k (abs_split.node\<^sub>i k (ls @ (l, a) # (r,a') # rs) t)>\<^sub>t"
proof -
  assume [simp]: "2*k \<le> c" "c \<le> 4*k+1" "length ls = length lsi"
  moreover note node\<^sub>i_rule[of k c "(lsi @ (li, ai) # (ri,a'i) # rsi)" aa al "(ls @ (l, a) # (r,a') # rs)" t ti]
  ultimately show ?thesis
    by (simp add: mult.left_assoc list_assn_aux_append_Cons)
qed

lemma ins_rule:
  "sorted_less (inorder t) \<Longrightarrow> <btree_assn k t ti>
  ins k x ti
  <\<lambda>r. btupi_assn k (abs_split.ins k x t) r>\<^sub>t"
proof (induction k x t arbitrary: ti rule: abs_split.ins.induct)
  case (1 k x)
  then show ?case
    apply(subst ins.simps)
    apply (sep_auto simp add: pure_app_eq)
    done
next
  case (2 k x ts t)
  obtain ls rrs where list_split: "split ts x = (ls,rrs)"
    by (cases "split ts x")
  have [simp]: "sorted_less (separators ts)"
    using "2.prems" sorted_inorder_separators by simp
  have [simp]: "sorted_less (inorder t)"
    using "2.prems" sorted_inorder_induct_last by simp
  show ?case
  proof (cases rrs)
    case Nil
    then show ?thesis
    proof (cases "abs_split.ins k x t")
      case (T\<^sub>i a)
      then show ?thesis
        apply(subst ins.simps)
        apply(sep_auto)
        subgoal for p tsil tsin tti
          using Nil list_split
          by (simp add: list_assn_aux_ineq_len split_relation_alt)
        subgoal for p tsil tsin tti tsi' i tsin' _ sub sep
          apply(rule hoare_triple_preI)
          using Nil list_split
          by (simp add: list_assn_aux_ineq_len split_relation_alt)
        subgoal for p tsil tsin tti tsi'
          thm "2.IH"(1)[of ls rrs tti]
          using Nil list_split T\<^sub>i apply(sep_auto split!: list.splits simp add: split_relation_alt
              heap add: "2.IH"(1)[of ls rrs tti])
          subgoal for ai
            apply(cases ai)
             apply sep_auto
            apply sep_auto
            done
          done
        done
    next
      case (Up\<^sub>i l a r)
      then show ?thesis
        apply(subst ins.simps)
        apply(sep_auto)
        subgoal for p tsil tsin tti
          using Nil list_split
          by (simp add: list_assn_aux_ineq_len split_relation_alt)
        subgoal for p tsil tsin tti tsi' i tsin' _ sub sep
          using Nil list_split
          by (simp add: list_assn_aux_ineq_len split_relation_alt)
        subgoal for p tsil tsin tti tsi' i tsin'
          thm "2.IH"(1)[of ls rrs tti]
          using Nil list_split Up\<^sub>i apply(sep_auto split!: list.splits
              simp add: split_relation_alt
              heap add: "2.IH"(1)[of ls rrs tti])
          subgoal for ai
            apply(cases ai)
             apply sep_auto
            apply(rule hoare_triple_preI)
            apply(sep_auto)
              apply(auto dest!: mod_starD simp add: is_pfa_def)[]
             apply (sep_auto)
            subgoal for li ai ri (* no split case *)
              apply(subgoal_tac "length (ls @ [(l,a)]) \<le> 2*k")
               apply(simp add: node\<^sub>i_no_split)
               apply(rule ent_ex_postI[where x="(tsil,Suc tsin)"])
               apply(rule ent_ex_postI[where x="ri"])
               apply(rule ent_ex_postI[where x="tsi' @ [(li, ai)]"])
               apply(sep_auto)
              apply (sep_auto dest!: mod_starD list_assn_len simp add: is_pfa_def)
              done
                (* split case*)
            apply(sep_auto heap add: node\<^sub>i_rule_app)
            done
          done
        done
    qed
  next
    case (Cons a rs)
    obtain sub sep where a_split: "a = (sub,sep)"
      by (cases a)
    then have [simp]: "sorted_less (inorder sub)"
      using "2.prems" abs_split.split_axioms list_split Cons sorted_inorder_induct_subtree split_def
      by fastforce
    then show ?thesis
    proof(cases "x = sep")
      case True
      show ?thesis
        apply(subst ins.simps)
        apply(sep_auto)
        subgoal for p tsil tsin tti tsi j subi
          using Cons list_split a_split True
          by sep_auto
        subgoal for p tsil tsin tti tsi j _ _ subi sepi
          apply(rule hoare_triple_preI)
          using Cons list_split a_split True
          apply(subgoal_tac "sepi = sep")
           apply (sep_auto simp add: split_relation_alt)
          apply(sep_auto simp add: list_assn_prod_map dest!: mod_starD id_assn_list)
          by (metis length_map snd_conv snd_map_help(2) split_relation_access)
        subgoal for p tsil tsin tti tsi j
          apply(rule hoare_triple_preI)
          using Cons list_split
          by (sep_auto simp add: split_relation_alt dest!: mod_starD list_assn_len)
        done
    next
      case False
      then show ?thesis
      proof (cases "abs_split.ins k x sub")
        case (T\<^sub>i a')
        then show ?thesis
          apply(auto simp add: Cons list_split a_split False)
          using False apply simp
          apply(subst ins.simps)
          apply vcg
           apply auto
          apply(rule norm_pre_ex_rule)+
            (* at this point, we want to introduce the split, and after that tease the
  hoare triple assumptions out of the bracket, s.t. we don't split twice *)
          apply vcg
           apply sep_auto
          using list_split Cons
          apply(simp add: split_relation_alt list_assn_append_Cons_left)
          apply (rule impI)
          apply(rule norm_pre_ex_rule)+
          apply(rule hoare_triple_preI)
          apply sep_auto
            (* discard wrong branch *)
          subgoal for p tsil tsin ti zs1 subi sepi zs2 _ _ suba
            apply(subgoal_tac "sepi  = x")
            using list_split Cons a_split
             apply(auto  dest!:  mod_starD )[]
            apply(auto dest!:  mod_starD list_assn_len)[]
            done
              (* actual induction branch *)
          subgoal for p tsil tsin ti zs1 subi sepi zs2 _ _ n z suba sepa
            apply (cases a, simp)
            apply(subgoal_tac "subi = suba", simp)
            using list_split a_split T\<^sub>i False
             apply (vcg heap: 2)
               apply(auto split!: btupi.splits)
              (* careful progression for manual value insertion *)
             apply vcg
              apply simp
             apply vcg
             apply simp
            subgoal for a'i q r
              apply(rule impI)
              apply(simp add: list_assn_append_Cons_left)
              apply(rule ent_ex_postI[where x="(tsil,tsin)"])
              apply(rule ent_ex_postI[where x="ti"])
              apply(rule ent_ex_postI[where x="(zs1 @ (a'i, sepi) # zs2)"])
              apply(rule ent_ex_postI[where x="zs1"])
              apply(rule ent_ex_postI[where x="(a'i,sep)"])
              apply(rule ent_ex_postI[where x="zs2"])
              apply sep_auto
               apply (simp add: pure_app_eq)
              apply(sep_auto dest!:  mod_starD list_assn_len)[]
              done
            apply (metis list_assn_aux_ineq_len Pair_inject list_assn_len nth_append_length star_false_left star_false_right)
            done
          subgoal for p tsil tsin ti zs1 subi sepi zs2 _ _ suba
            apply(auto dest!:  mod_starD list_assn_len)[]
            done
          done
      next
        case (Up\<^sub>i l w r)
        then show ?thesis
          apply(auto simp add: Cons list_split a_split False)
          using False apply simp
          apply(subst ins.simps)
          apply vcg
           apply auto
          apply(rule norm_pre_ex_rule)+
            (* at this point, we want to introduce the split, and after that tease the
  hoare triple assumptions out of the bracket, s.t. we don't split twice *)
          apply vcg
           apply sep_auto
          using list_split Cons
          apply(simp add: split_relation_alt list_assn_append_Cons_left)
          apply (rule impI)
          apply(rule norm_pre_ex_rule)+
          apply(rule hoare_triple_preI)
          apply sep_auto
            (* discard wrong branch *)
          subgoal for p tsil tsin ti zs1 subi sepi zs2 _ _ suba
            apply(subgoal_tac "sepi  = x")
            using list_split Cons a_split
             apply(auto  dest!:  mod_starD )[]
            apply(auto dest!:  mod_starD list_assn_len)[]
            done
              (* actual induction branch *)
          subgoal for p tsil tsin ti zs1 subi sepi zs2 _ _ n z suba sepa
            apply(subgoal_tac "subi = suba", simp)
            thm 2(2)[of ls rrs a rs sub sep]
            using list_split a_split Cons Up\<^sub>i False
             apply (sep_auto heap: 2(2))
             apply(auto split!: btupi.splits)
              (* careful progression for manual value insertion *)
              apply vcg
               apply simp
            subgoal for li wi ri u (* no split case *)
              apply (cases u,simp)
              apply (sep_auto dest!: mod_starD list_assn_len heap: pfa_insert_grow_rule)
                apply (simp add: is_pfa_def)[]
                apply (metis le_less_linear length_append length_take less_not_refl min.absorb2 trans_less_add1)
               apply(simp add: is_pfa_def)
               apply (metis add_Suc_right length_Cons length_append length_take min.absorb2)
              apply(sep_auto split: prod.splits  dest!: mod_starD list_assn_len)[]
                (* no split case *)
              apply(subgoal_tac "length (ls @ [(l,w)]) \<le> 2*k")
               apply(simp add: node\<^sub>i_no_split)
               apply(rule ent_ex_postI[where x="(tsil,Suc tsin)"])
               apply(rule ent_ex_postI[where x="ti"])
               apply(rule ent_ex_postI[where x="(zs1 @ (li, wi) # (ri, sep) # zs2)"])
               apply(sep_auto dest!: mod_starD list_assn_len)
              apply (sep_auto dest!: mod_starD list_assn_len simp add: is_pfa_def)
              done
             apply vcg
              apply simp
            subgoal for x21 x22 x23 u (* split case *)
              apply (cases u,simp)
              thm pfa_insert_grow_rule[where ?l="((zs1 @ (suba, sepi) # zs2)[length ls := (x23, sepa)])"]
              apply (sep_auto dest!: mod_starD list_assn_len heap: pfa_insert_grow_rule)
               apply (simp add: is_pfa_def)[]
               apply (metis le_less_linear length_append length_take less_not_refl min.absorb2 trans_less_add1)
              apply(auto split: prod.splits  dest!: mod_starD list_assn_len)[]

              apply (vcg heap: node\<^sub>i_rule_ins2)
                 apply simp
                apply simp
               apply simp
              apply sep_auto
              done
            apply(auto dest!:  mod_starD list_assn_len)[]
            done
          subgoal for p tsil tsin ti zs1 subi sepi zs2 _ _ suba
            apply(auto dest!:  mod_starD list_assn_len)[]
            done
          done
      qed
    qed
  qed
qed

text "The imperative insert refines the abstract insert."

lemma insert_rule:
  assumes "k > 0" "sorted_less (inorder t)"
  shows "<btree_assn k t ti>
  insert k x ti
  <\<lambda>r. btree_assn k (abs_split.insert k x t) r>\<^sub>t"
  unfolding insert_def
  apply(cases "abs_split.ins k x t")
   apply(sep_auto split!: btupi.splits heap: ins_rule[OF assms(2)])
  using assms
  apply(vcg heap: ins_rule[OF assms(2)])
  apply(simp split!: btupi.splits)
  apply(vcg)
   apply auto[]
  apply vcg
  apply auto[]
  subgoal for l a r li ai ri tsa tsn ti
    apply(rule ent_ex_postI[where x="(tsa,tsn)"])
    apply(rule ent_ex_postI[where x="ri"])
    apply(rule ent_ex_postI[where x="[(li, ai)]"])
    apply sep_auto
    done
  done

text "The \"pure\" resulting rule follows automatically."
lemma insert_rule':
  shows "<btree_assn (Suc k) t ti * \<up>(abs_split.invar_inorder (Suc k) t \<and> sorted_less (inorder t))>
  insert (Suc k) x ti
  <\<lambda>ri.\<exists>\<^sub>Ar. btree_assn (Suc k) r ri * \<up>(abs_split.invar_inorder (Suc k) r \<and> sorted_less (inorder r) \<and> inorder r = (ins_list x (inorder t)))>\<^sub>t"
  using abs_split.insert_bal abs_split.insert_order abs_split.insert_inorder
  by (sep_auto heap: insert_rule simp add: sorted_ins_list)

lemma list_update_length2 [simp]:
  "(xs @ x # y # ys)[Suc (length xs) := z] = (xs @ x # z # ys)"
  by (induct xs, auto)

lemma node\<^sub>i_rule_ins: "\<lbrakk>2*k \<le> c; c \<le> 4*k+1; length ls = length lsi\<rbrakk> \<Longrightarrow>
 <is_pfa c (lsi @ (li, ai) # rsi) (aa, al) *
   blist_assn k ls lsi *
   btree_assn k l li *
   id_assn a ai *
   blist_assn k rs rsi *
   btree_assn k t ti>
     node\<^sub>i k (aa, al) ti
 <btupi_assn k (abs_split.node\<^sub>i k (ls @ (l, a) # rs) t)>\<^sub>t"
proof -
  assume [simp]: "2*k \<le> c" "c \<le> 4*k+1" "length ls = length lsi"
  moreover note node\<^sub>i_rule[of k c "(lsi @ (li, ai) # rsi)" aa al "(ls @ (l, a) # rs)" t ti]
  ultimately show ?thesis
    by (simp add: mult.left_assoc list_assn_aux_append_Cons)
qed

lemma btupi_assn_T: "h \<Turnstile> btupi_assn k (abs_split.node\<^sub>i k ts t) (T\<^sub>i x) \<Longrightarrow> abs_split.node\<^sub>i k ts t = abs_split.T\<^sub>i (Node ts t)"
  apply(auto simp add: abs_split.node\<^sub>i.simps dest!: mod_starD split!: list.splits)
  done

lemma btupi_assn_Up: "h \<Turnstile> btupi_assn k (abs_split.node\<^sub>i k ts t) (Up\<^sub>i l a r) \<Longrightarrow>
  abs_split.node\<^sub>i k ts t = (
    case BTree_Set.split_half ts of (ls, (sub,sep)#rs) \<Rightarrow>
      abs_split.Up\<^sub>i (Node ls sub) sep (Node rs t))"
  apply(auto simp add: abs_split.node\<^sub>i.simps dest!: mod_starD split!: list.splits)
  done

lemma second_last_access:"(xs@a#b#ys) ! Suc(length xs) = b"
  by (simp add: nth_via_drop)

lemma pfa_assn_len:"h \<Turnstile> is_pfa k ls (a,n) \<Longrightarrow> n \<le> k \<and> length ls = n"
  by (auto simp add: is_pfa_def)

(*declare "impCE"[rule del]*)
lemma rebalance_middle_tree_rule:
  assumes "height t = height sub"
    and "case rs of (rsub,rsep) # list \<Rightarrow> height rsub = height t | [] \<Rightarrow> True"
    and "i = length ls"
  shows "<is_pfa (2*k) tsi (a,n) * blist_assn k (ls@(sub,sep)#rs) tsi * btree_assn k t ti>
  rebalance_middle_tree k (a,n) i ti
  <\<lambda>r. btnode_assn k (abs_split.rebalance_middle_tree k ls sub sep rs t) r >\<^sub>t"
  apply(simp add: list_assn_append_Cons_left)
  apply(rule norm_pre_ex_rule)+
proof(goal_cases)
  case (1 lsi z rsi)
  then show ?case
  proof(cases z)
    case z_split: (Pair subi sepi)
    then show ?thesis
    proof(cases sub)
      case sub_leaf[simp]: Leaf
      then have t_leaf[simp]: "t = Leaf" using assms
        by (cases t) auto
      show ?thesis
        apply (subst rebalance_middle_tree_def)
        apply (rule hoare_triple_preI)
        apply (vcg)
        using assms apply (auto dest!: mod_starD list_assn_len split!: option.splits)
        apply (vcg)
        apply (auto dest!: mod_starD list_assn_len split!: option.splits)
        apply (rule ent_ex_postI[where x=tsi])
        apply sep_auto
        done
    next
      case sub_node[simp]: (Node mts mt)
      then obtain tts tt where t_node[simp]: "t = Node tts tt" using assms
        by (cases t) auto
      then show ?thesis
      proof(cases "length mts \<ge> k \<and> length tts \<ge> k")
        case True
        then show ?thesis
          apply(subst rebalance_middle_tree_def)
          apply(rule hoare_triple_preI)
          apply(sep_auto dest!: mod_starD)
          using assms apply (auto  dest!: list_assn_len)[]

          using assms apply(sep_auto  split!: prod.splits)
          using assms apply (auto simp del: height_btree.simps dest!: mod_starD list_assn_len)[]
          using z_split apply(auto)[]
          subgoal for _ _ _ _ _ _ _ _ tp tsia' tsin' _ _  _ _ _ _ _ _ _ _ tsia tsin tti ttsi sepi subp
            apply(auto dest!: mod_starD list_assn_len simp: prod_assn_def)[]
            apply(vcg)
             apply(auto)[]
             apply(rule ent_ex_postI[where x="lsi@(Some subp, sepi)#rsi"])
             apply(rule ent_ex_postI[where x="(tsia, tsin)"])
             apply(rule ent_ex_postI[where x="tti"])
             apply(rule ent_ex_postI[where x=ttsi])
             apply(sep_auto)[]
            apply(rule hoare_triple_preI)
            using True apply(auto dest!: mod_starD list_assn_len)
            done
          done
      next
        case False
        then show ?thesis
        proof(cases rs)
          case Nil
          then show ?thesis
            apply(subst rebalance_middle_tree_def)
            apply(rule hoare_triple_preI)
            apply(sep_auto dest!: mod_starD)
            using assms apply (auto  dest!: list_assn_len)[]

             apply(sep_auto  split!: prod.splits)
            using assms apply (auto simp del: height_btree.simps dest!: mod_starD list_assn_len)[]
            using z_split apply(auto)[]
            subgoal for _ _ _ _ _ _ _ _ tp tsia' tsin' _ _  _ _ _ _ _ _ _ _ tsia tsin tti ttsi
              apply(auto dest!: mod_starD list_assn_len simp: prod_assn_def)[]
              apply(vcg)
              using False apply(auto dest!: mod_starD list_assn_len)
              done
            apply(sep_auto dest!: mod_starD)
            using assms apply (auto dest!: list_assn_len)[]
            using assms apply (auto dest!: list_assn_len)[]
            apply(sep_auto)
            using assms apply (auto dest!: list_assn_len mod_starD)[]
            using assms apply (auto dest!: list_assn_len mod_starD)[]
              (* Issue: we do not know yet what  'subp is pointing at *)
            subgoal for _ _ _ _ _ _ tp tsia tsin tti ttsi _ _ _ _ _ _ _ _ tsia' tsin' tti' tsi' subi sepi subp
              apply(subgoal_tac "z = (subi, sepi)")
               prefer 2
               apply (metis assms(3) list_assn_len nth_append_length)
              apply simp
              apply(vcg)
              subgoal
                (* still the "IF" branch *)
                apply(rule entailsI)
                  (* solves impossible case*)
                using False apply (auto dest!: list_assn_len mod_starD)[]
                done
              apply (auto del: impCE)
              apply(thin_tac "_ \<Turnstile> _")+
              apply(rule hoare_triple_preI)
                (* for each possible combination of \<le> and \<not>\<le>, a subgoal is created *)
              apply(sep_auto heap add: node\<^sub>i_rule_ins dest!: mod_starD del: impCE)
                 apply (auto dest!: pfa_assn_len)[]
                apply (auto dest!: pfa_assn_len list_assn_len)[]
              subgoal
                apply(thin_tac "_ \<Turnstile> _")+
                apply(rule hoare_triple_preI)
                apply(sep_auto split!: btupi.splits del: impCE)
                 apply(auto dest!: btupi_assn_T mod_starD del: impCE)[]
                 apply(rule ent_ex_postI[where x="lsi"])
                 apply sep_auto
                apply (sep_auto del: impCE)
                apply(auto dest!: btupi_assn_Up mod_starD split!: list.splits del: impCE)[]
                subgoal for li ai ri
                  apply(rule ent_ex_postI[where x="lsi @ [(li, ai)]"])
                  apply sep_auto
                  done
                done
              apply (sep_auto del: impCE)
              using assms apply(auto dest!: pfa_assn_len list_assn_len mod_starD)[]
              using assms apply(auto dest!: pfa_assn_len list_assn_len mod_starD)[]
              done
            done
        next
          case (Cons rss rrs)
          then show ?thesis
            apply(subst rebalance_middle_tree_def)
            apply(rule hoare_triple_preI)
            apply(sep_auto dest!: mod_starD)
            using assms apply (auto  dest!: list_assn_len)[]

             apply(sep_auto  split!: prod.splits)
            using assms apply (auto simp del: height_btree.simps dest!: mod_starD list_assn_len)[]
             apply(auto)[]
            subgoal for _ _ _ _ _ _ _ _ tp tsia' tsin' _ _  _ _ _ _ _ _ _ _ tsia tsin tti ttsi
              apply(auto dest!: mod_starD list_assn_len simp: prod_assn_def)[]
              apply(vcg)
              using False apply(auto dest!: mod_starD list_assn_len)
              done
            apply(sep_auto dest!: mod_starD del: impCE)
            using assms apply (auto dest!: list_assn_len)[]
            apply(sep_auto del: impCE)
            using assms apply (auto dest!: list_assn_len mod_starD)[]
              (* Issue: we do not know yet what  'xa' is pointing at *)
            subgoal for list_heap1 list_heap2 _ _ _ _ _ _ tp ttsia' ttsin' tti' ttsi' _ _ _ _ _ _ _ _ ttsia ttsin tti ttsi subi sepi subp
              apply(subgoal_tac "z = (subi, sepi)")
               prefer 2
               apply (metis assms(3) list_assn_len nth_append_length)
              apply simp
              apply(vcg)
              subgoal
                (* still the "IF" branch *)
                apply(rule entailsI)
                  (* solves impossible case*)
                using False apply (auto dest!: list_assn_len mod_starD)[]
                done
              apply simp
              subgoal for subtsi subti subts ti subi subtsl ttsl
                (* TODO different nodei rule here *)
                supply R = node\<^sub>i_rule_ins[where k=k and c="(max (2 * k) (Suc (_ + ttsin)))" and lsi=subts]
                thm R
                apply(cases subtsi)
                apply(sep_auto heap add: R pfa_append_extend_grow_rule dest!: mod_starD del: impCE)
                  (* all of these cases are vacuous *)
                using assms apply (auto dest!: list_assn_len pfa_assn_len)[]
                using assms apply (auto dest!: list_assn_len pfa_assn_len)[]
                using assms apply (auto dest!: list_assn_len pfa_assn_len)[]
                apply(sep_auto split!: btupi.splits del: impCE)
                using assms apply (auto dest!: list_assn_len pfa_assn_len)[]
                apply(thin_tac "_ \<Turnstile> _")+
                apply(rule hoare_triple_preI)
                apply (cases rsi)
                 apply(auto dest!: list_assn_len mod_starD)[]
                  (* TODO avoid creating subgoals here but still split the heap? do we need to do that anyways *)
                subgoal for subtsa subtsn mtsa mtsn mtt mtsi _ _ _ _ _ _ _ _ rsubsep _ rrsi rssi
                  (* ensuring that the tree to the right is not none *)
                  apply (cases rsubsep)
                  apply(subgoal_tac "rsubsep = rrsi")
                   prefer 2
                  using assms apply(auto dest!: list_assn_len mod_starD del: impCE simp add: second_last_access)[]
                  apply (simp add: prod_assn_def)
                  apply(cases rss)
                  apply simp
                  subgoal for rsubi rsepi rsub rsep
                    apply(subgoal_tac "height rsub \<noteq> 0")
                     prefer 2
                    using assms apply(auto)[]
                    apply(cases rsubi; cases rsub)
                       apply simp+
                      (* now we may proceed *)
                    apply (vcg (ss))
                    apply (vcg (ss))
                    apply (vcg (ss))
                     apply (vcg (ss))
                    apply (vcg (ss))
                    subgoal for rsubi rsubts rsubt rsubtsi' rsubti rsubtsi subnode
                      apply(cases "kvs subnode")
                      apply (vcg (ss))
                      apply (vcg (ss))
                      apply (vcg (ss))
                      apply (vcg (ss))
                       apply (vcg (ss))
                      subgoal for _ rsubtsn subtsmergedi
                        apply (cases subtsmergedi)
                        apply simp
                        apply (vcg (ss))
                        subgoal for subtsmergeda _
                          supply R = node\<^sub>i_rule_ins[where
                              k=k and
                              c="max (2*k) (Suc (subtsn + rsubtsn))" and
                              ls="mts" and
                              al="Suc (subtsn+rsubtsn)" and
                              aa=subtsmergeda and
                              ti=rsubti and
                              rsi=rsubtsi and
                              li=subti and a=sep and ai=sep
                              ]
                          thm R
                          apply(rule P_imp_Q_implies_P)
                          apply(auto del: impCE dest!: mod_starD list_assn_len)[]
                          apply(rule hoare_triple_preI)
                          apply(subgoal_tac "subtsn \<le> 2*k \<and> rsubtsn \<le> 2*k")
                           prefer 2
                           apply (auto simp add: is_pfa_def)[]
                          apply (sep_auto heap add: R del: impCE)
                          apply(sep_auto split!: btupi.splits del: impCE)
                          using assms apply(auto  dest!: mod_starD list_assn_len)[]
                           apply(sep_auto del: impCE)
                          using assms apply(auto  dest!: mod_starD list_assn_len pfa_assn_len del: impCE)[]
                           apply(thin_tac "_ \<Turnstile> _")+
                           apply(rule hoare_triple_preI)
                           apply (drule btupi_assn_T mod_starD | erule conjE exE)+
                           apply vcg
                           apply simp
                          subgoal for rsubtsi ai tsian
                            apply(cases tsian)
                            apply simp
                            apply(rule P_imp_Q_implies_P)
                            apply(rule ent_ex_postI[where x="lsi @ (ai, rsep) # rssi"])
                            apply(rule ent_ex_postI[where x="(ttsia, ttsin)"])
                            apply(rule ent_ex_postI[where x="tti"])
                            apply(rule ent_ex_postI[where x="ttsi"])
                            using assms apply (sep_auto dest!: list_assn_len)
                            done
                          subgoal for _ _ rsubp rsubtsa _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _  li ai ri
                            apply(sep_auto del: impCE)
                            using assms apply(auto dest!: list_assn_len)[]
                            apply(sep_auto del: impCE)
                            using assms apply(auto dest!: list_assn_len)[]
                            apply(thin_tac "_ \<Turnstile> _")+
                            apply(rule hoare_triple_preI)
                            apply (drule btupi_assn_Up mod_starD | erule conjE exE)+
                            apply vcg
                              (* generates two identical subgoals ? *)
                            apply(simp split!: list.split)
                             apply(rule ent_ex_postI[where x="(lsi @ (li, ai) # (ri, rsepi) # rssi)"])
                             apply(rule ent_ex_postI[where x="(ttsia, ttsin)"])
                             apply(rule ent_ex_postI[where x="tti"])
                             apply(rule ent_ex_postI[where x="ttsi"])
                            using assms apply (sep_auto dest!: list_assn_len)
                            apply(rule ent_ex_postI[where x="(lsi @ (li, ai) # (ri, rsepi) # rssi)"])
                            apply(rule ent_ex_postI[where x="(ttsia, ttsin)"])
                            apply(rule ent_ex_postI[where x="tti"])
                            apply(rule ent_ex_postI[where x="ttsi"])
                            using assms apply (sep_auto dest!: list_assn_len)
                            done
                          done
                        done
                      done
                    done
                  done
                done
              done
            done
        qed
      qed
    qed
  qed
qed

lemma rebalance_last_tree_rule:
  assumes "height t = height sub"
    and "ts = list@[(sub,sep)]"
  shows "<is_pfa (2*k) tsi tsia * blist_assn k ts tsi * btree_assn k t ti>
  rebalance_last_tree k tsia ti
  <\<lambda>r. btnode_assn k (abs_split.rebalance_last_tree k ts  t) r >\<^sub>t"
  apply(subst rebalance_last_tree_def)
  apply(rule hoare_triple_preI)
  using assms apply(auto dest!: mod_starD)
  apply(subgoal_tac "length tsi - Suc 0 = length list")
   prefer 2
   apply(auto dest!: list_assn_len)[]
  using assms apply(sep_auto)
  supply R = rebalance_middle_tree_rule[where
      ls="list" and
      rs="[]" and
      i="length tsi - 1", simplified]
  apply(cases tsia)
  using R by blast

partial_function (heap) split_max ::"nat \<Rightarrow> ('a::{default,heap,linorder}) btnode ref option \<Rightarrow> ('a btnode ref option \<times> 'a) Heap"
  where
    "split_max k r_t = (case r_t of Some p_t \<Rightarrow> do {
   t \<leftarrow> !p_t;
   (case (last t) of None \<Rightarrow> do {
      (sub,sep) \<leftarrow> pfa_last (kvs t);
      tsi' \<leftarrow> pfa_butlast (kvs t);
      p_t := Btnode tsi' sub;
      return (Some p_t, sep)
  } |
    Some x \<Rightarrow> do {
      (sub,sep) \<leftarrow> split_max k (Some x);
      p_t' \<leftarrow> rebalance_last_tree k (kvs t) sub;
      p_t := p_t';
      return (Some p_t, sep)
  })
})
"

declare  abs_split.split_max.simps [simp del] abs_split.rebalance_last_tree.simps [simp del] height_btree.simps [simp del]

lemma split_max_rule:
  assumes "abs_split.nonempty_lasttreebal t"
    and "t \<noteq> Leaf"
  shows "<btree_assn k t ti>
  split_max k ti
  <((btree_assn k) \<times>\<^sub>a id_assn) (abs_split.split_max k t)>\<^sub>t"
  using assms
proof(induction k t arbitrary: ti rule: abs_split.split_max.induct)
  case (2 Leaf)
  then show ?case by auto
next
  case (1 k ts tt)
  then show ?case
  proof(cases tt)
    case Leaf
    then show ?thesis
      apply(subst split_max.simps)
      apply (vcg)
      using assms apply auto[]
      apply (vcg (ss))
      apply simp
      apply (vcg (ss))
      apply (vcg (ss))
       apply (vcg (ss))
      apply (vcg (ss))
      apply (vcg (ss))
      apply (vcg (ss))
      apply (vcg (ss))
       apply (vcg (ss))
       apply (vcg (ss))
        apply (vcg (ss))
        apply(rule hoare_triple_preI)
        apply (vcg (ss))
      using 1 apply(auto dest!: mod_starD)[]
       apply (vcg (ss))
       apply (vcg (ss))
       apply (vcg (ss))
       apply (vcg (ss))
       apply (vcg (ss))
      subgoal for tp tsi tti tsi' tnode subsep sub sep
        apply(cases tsi)
        apply(rule hoare_triple_preI)
        apply (vcg)
        apply(auto simp add: prod_assn_def abs_split.split_max.simps split!: prod.splits)
        subgoal for tsia tsin _ _ tsin' lastsep lastsub
          apply(rule ent_ex_postI[where x="(tsia, tsin')"])
          apply(rule ent_ex_postI[where x="sub"])
          apply(rule ent_ex_postI[where x="(butlast tsi')"])
          using 1 apply (auto dest!: mod_starD simp add: list_assn_append_Cons_left)
          apply sep_auto
          done
        done
      apply(sep_auto)
      done
  next
    case (Node tts ttt)
    have IH_help: "abs_split.nonempty_lasttreebal tt \<Longrightarrow>
tt \<noteq> Leaf \<Longrightarrow>
<btree_assn k (Node tts ttt) (Some ttp)> split_max k (Some ttp) <(btree_assn k \<times>\<^sub>a id_assn) (abs_split.split_max k tt)>\<^sub>t"
      for ttp
      using "1.IH" Node by blast
    obtain butlasttts l_sub l_sep where ts_split:"tts = butlasttts@[(l_sub, l_sep)]"
      using 1 Node by auto
    from Node show ?thesis
      apply(subst split_max.simps)
      apply (vcg)
      using 1 apply auto[]
      apply (vcg (ss))
      apply simp
      apply (vcg (ss))
      apply (vcg (ss))
       apply (vcg (ss))
      apply (vcg (ss))
      apply (vcg (ss))
      apply (vcg (ss))
      apply (vcg (ss))
       apply (vcg (ss))
      using 1 apply(auto dest!: mod_starD)[]
      apply (vcg (ss))
      subgoal for tp tsi tti tsi' tnode ttp
        using "1.prems" apply (vcg heap add: IH_help)
          apply simp
         apply simp
        apply(subst prod_assn_def)
        apply(cases "abs_split.split_max k tt")
        apply (auto simp del: abs_split.split_max.simps abs_split.rebalance_last_tree.simps height_btree.simps)[]
        subgoal for ttsubi ttmaxi ttsub ttmax butlasttsi' lasttssubi butlastts lasttssub lasttssepi lasttssep
          apply(rule hoare_triple_preI)
          supply R = rebalance_last_tree_rule[where k=k and tsia=tsi and ti=ttsubi and t=ttsub and tsi=tsi' and ts=" (butlasttsi' @ [(lasttssubi, lasttssepi)])"
              and list=butlasttsi' and sub=lasttssubi and sep=lasttssepi]
          thm R
          using ts_split
            (*TODO weird post conditions... *)
          apply (sep_auto heap add: R
              simp del: abs_split.split_max.simps abs_split.rebalance_last_tree.simps height_btree.simps
              dest!: mod_starD)
            apply (metis abs_split.nonempty_lasttreebal.simps(2) abs_split.split_max_height btree.distinct(1))
           apply simp
          apply(rule hoare_triple_preI)
          apply (simp add: prod_assn_def)
          apply vcg
          apply(subst abs_split.split_max.simps)
          using "1.prems" apply(auto dest!: mod_starD split!: prod.splits btree.splits)
          subgoal for _ _ _ _ _ _ _ _ _ _ tp'
            apply(cases "abs_split.rebalance_last_tree k (butlasttsi' @ [(lasttssubi, lasttssepi)]) ttsub"; cases tp')
             apply auto
            apply(rule ent_ex_preI)
            subgoal for _ _ tsia' tsin' tt' _ tsi'
              apply(rule ent_ex_postI[where x="(tsia', tsin')"])
              apply(rule ent_ex_postI[where x="tt'"])
              apply(rule ent_ex_postI[where x="tsi'"])
              apply sep_auto
              done
            done
          done
        done
      done
  qed
qed

partial_function (heap) del ::"nat \<Rightarrow> 'a \<Rightarrow> ('a::{default,heap,linorder}) btnode ref option \<Rightarrow> 'a btnode ref option Heap"
  where
    "del k x ti = (case ti of None \<Rightarrow> return None |
   Some p \<Rightarrow> do {
   node \<leftarrow> !p;
   i \<leftarrow> imp_split (kvs node) x;
   tsl \<leftarrow> pfa_length (kvs node);
   if i < tsl then do {
     (sub,sep) \<leftarrow> pfa_get (kvs node) i;
     if sep \<noteq> x then do {
       sub' \<leftarrow> del k x sub;
       kvs' \<leftarrow> pfa_set (kvs node) i (sub',sep);
       node' \<leftarrow> rebalance_middle_tree k kvs' i (last node);
       p := node';
       return (Some p)
      }
     else if sub = None then do{
       kvs' \<leftarrow> pfa_delete (kvs node) i;
       p := (Btnode kvs' (last node));
       return (Some p)
     }
     else do {
        sm \<leftarrow> split_max k sub;
        kvs' \<leftarrow> pfa_set (kvs node) i sm;
        node' \<leftarrow> rebalance_middle_tree k kvs' i (last node);
        p := node';
        return (Some p)
     }
   } else do {
       t' \<leftarrow> del k x (last node);
       node' \<leftarrow> rebalance_last_tree k (kvs node) t';
       p := node';
       return (Some p)
    }
})"

lemma rebalance_middle_tree_update_rule:
  assumes "height tt = height sub"
    and "case rs of (rsub,rsep) # list \<Rightarrow> height rsub = height tt | [] \<Rightarrow> True"
    and "i = length ls"
  shows "<is_pfa (2 * k) (zs1 @ (x', sep) # zs2) a * btree_assn k sub x' *
     blist_assn k ls zs1 *
     id_assn sep sep *
     blist_assn k rs zs2 *
     btree_assn k tt ti>
  rebalance_middle_tree k a i ti
   <btnode_assn k (abs_split.rebalance_middle_tree k ls sub sep rs tt)>\<^sub>t"
proof (cases a)
  case [simp]: (Pair a n)
  note R=rebalance_middle_tree_rule[of tt sub rs i ls k "zs1@(x', sep)#zs2" a n sep ti]
  show ?thesis
    apply(rule hoare_triple_preI)
    using R assms apply (sep_auto dest!: mod_starD list_assn_len simp add: prod_assn_def)
    using assn_times_assoc star_aci(3) by auto
qed

lemma del_rule:
  assumes "bal t" and "sorted (inorder t)" and "root_order k t" and "k > 0"
  shows "<btree_assn k t ti>
  del k x ti
  <btree_assn k (abs_split.del k x t)>\<^sub>t"
  using assms
proof (induction k x t arbitrary: ti rule: abs_split.del.induct)
  case (1 k x)
  then show ?case
    apply(subst del.simps)
    apply sep_auto
    done
next
  case (2 k x ts tt ti)
  obtain ls rs where split_ts[simp]: "split ts x = (ls, rs)"
    by (cases "split ts x")
  obtain tss lastts_sub lastts_sep where last_ts: "ts = tss@[(lastts_sub, lastts_sep)]"
    using "2.prems"  apply auto
    by (metis abs_split.isin.cases neq_Nil_rev_conv)
  show ?case
  proof(cases "rs")
    case Nil
    then show ?thesis
      apply(subst del.simps)
      apply sep_auto
      using "2.prems"(2) sorted_inorder_separators apply blast
      apply(rule hoare_triple_preI)
      apply (sep_auto)
      using Nil  apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
      using Nil  apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
      using Nil  apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
      apply (sep_auto heap add: "2.IH"(1))
      using "2.prems" apply (auto dest!: mod_starD)[]
      using "2.prems" apply (auto dest!: mod_starD simp add: sorted_wrt_append)[]
      using "2.prems" order_impl_root_order apply (auto dest!: mod_starD)[]
      using "2.prems" apply (auto)[]
      subgoal for tp tsia tsin tti tsi i _ _ tti'
        apply(rule hoare_triple_preI)
        supply R = rebalance_last_tree_rule[where t="(abs_split.del k x tt)" and ti=tti' and ts=ts and sub=lastts_sub
            and list=tss and sep=lastts_sep]
        thm R
        using last_ts apply(sep_auto heap add: R)
        using "2.prems" abs_split.del_height[of k tt x] order_impl_root_order[of k tt] apply (auto dest!: mod_starD)[]
         apply simp
        apply(rule hoare_triple_preI)
        apply (sep_auto)
        apply(cases "abs_split.rebalance_last_tree k ts (abs_split.del k x tt)")
         apply(auto simp add: split_relation_alt dest!: mod_starD list_assn_len)
        subgoal for tnode
          apply (cases tnode; sep_auto)
          done
        done
      done
  next
    case [simp]: (Cons rrs rss)
    then obtain sub sep where [simp]: "rrs = (sub, sep)"
      by (cases rrs)
    consider (sep_n_x) "sep \<noteq> x" |
      (sep_x_Leaf) "sep = x \<and> sub = Leaf" |
      (sep_x_Node) "sep = x \<and> (\<exists>ts t. sub = Node ts t)"
      using btree.exhaust by blast
    then show ?thesis
    proof(cases)
      case sep_n_x
      then show ?thesis
        apply(subst del.simps)
        apply sep_auto
        using "2.prems"(2) sorted_inorder_separators apply blast
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
         apply(vcg (ss))
         apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
         apply(vcg (ss))
          apply(vcg (ss))
          apply(vcg (ss))
          apply simp
         apply(vcg (ss))
         apply(vcg (ss))
         apply(vcg (ss))
        subgoal for tp tsi ti' tsi' tnode i tsi'l subsep subi sepi
          (* TODO this causes 4 subgoals *)
          apply(auto simp add: split_relation_alt list_assn_append_Cons_left;
              rule norm_pre_ex_rule; rule norm_pre_ex_rule; rule norm_pre_ex_rule;
              rule hoare_triple_preI;
              auto dest!: mod_starD)[]
             apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
          subgoal for lsi subi rsi
            apply(subgoal_tac "subi = None")
             prefer 2
             apply(auto dest!: list_assn_len)[]
            supply R = "2.IH"(2)[of ls rs rrs rss sub sep]
            thm R
            using split_ts apply(sep_auto heap add: R)
            using "2.prems" apply auto[]
               apply (metis "2.prems"(2) sorted_inorder_induct_subtree)
            using "2.prems" apply auto[]
              apply (meson "2.prems"(4) order_impl_root_order)
            using "2.prems"(4) apply fastforce
            apply(vcg (ss))
            apply(vcg (ss))
             apply(vcg (ss))
             apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
            apply(vcg (ss))
            apply(vcg (ss); simp)
            apply(cases tsi; simp)
            subgoal for subi' _ tsia' tsin'
              supply R = rebalance_middle_tree_update_rule
              thm R
                (* TODO create a new heap rule, in the node_i style *)
              apply(auto dest!: list_assn_len)[]
              apply(rule hoare_triple_preI)
              apply (sep_auto heap add: R dest!: mod_starD)
              using "2.prems" abs_split.del_height[of k sub x] order_impl_root_order[of k sub] apply (auto)[]
              using "2.prems" apply (auto split!: list.splits)[]
               apply auto[]
              apply sep_auto
              subgoal for _ _ _ _ _ _ _ _ _ _ _ _ _ _ tnode''
                apply (cases "(abs_split.rebalance_middle_tree k ls (abs_split.del k x sub) sepi rss tt)"; cases tnode'')
                 apply sep_auto
                apply sep_auto
                done
              done
            done
           apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
            (* copy pasta of "none" branch *)
          subgoal for subnode lsi subi rsi
            apply(subgoal_tac "subi = Some subnode")
             prefer 2
             apply(auto dest!: list_assn_len)[]
            supply R = "2.IH"(2)[of ls rs rrs rss sub sep]
            thm R
            using split_ts apply(sep_auto heap add: R)
            using "2.prems" apply auto[]
               apply (metis "2.prems"(2) sorted_inorder_induct_subtree)
            using "2.prems" apply auto[]
              apply (meson "2.prems"(4) order_impl_root_order)
            using "2.prems"(4) apply fastforce
            apply(vcg (ss))
            apply(vcg (ss))
             apply(vcg (ss))
             apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
            apply(vcg (ss))
            apply(vcg (ss); simp)
            apply(cases tsi; simp)
            subgoal for x' xab a n
              supply R = rebalance_middle_tree_update_rule
              thm R
                (* TODO create a new heap rule, in the node_i style *)
              apply(auto dest!: list_assn_len)[]
              apply(rule hoare_triple_preI)
              apply (sep_auto heap add: R dest!: mod_starD)
              using "2.prems" abs_split.del_height[of k sub x] order_impl_root_order[of k sub] apply (auto)[]
              using "2.prems" apply (auto split!: list.splits)[]
               apply auto[]
              apply sep_auto
              subgoal for _ _ _ _ _ _ _ _ _ _ _ _ _  _  tnode'
                apply (cases "(abs_split.rebalance_middle_tree k ls (abs_split.del k x sub) sepi rss tt)"; cases tnode')
                 apply sep_auto
                apply sep_auto
                done
              done
            done
          done
        apply(rule hoare_triple_preI)
        using Cons  apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
        done
    next
      case sep_x_Leaf
      then show ?thesis
        apply(subst del.simps)
        apply sep_auto
        using "2.prems"(2) sorted_inorder_separators apply blast
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
         apply(vcg (ss))
         apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
         apply(vcg (ss))
          apply(vcg (ss))
          apply(vcg (ss))
          apply simp
         apply(vcg (ss))
         apply(vcg (ss))
         apply(vcg (ss))
        subgoal for tp tsi ti' tsi' tnode i tsi'l subsep subi sepi
          (* TODO this causes 4 subgoals *)
          apply(auto simp add: split_relation_alt list_assn_append_Cons_left;
              rule norm_pre_ex_rule; rule norm_pre_ex_rule; rule norm_pre_ex_rule;
              rule hoare_triple_preI;
              auto dest!: mod_starD)[]
            (* the correct subbranch *)
          subgoal for lsi subi rsi
            apply(cases tsi)
            apply (sep_auto)
             apply(auto simp add: is_pfa_def dest!: list_assn_len)[]
             apply (metis add_Suc_right le_imp_less_Suc length_append length_take less_add_Suc1 less_trans_Suc list.size(4) min.cobounded2 not_less_eq)
            apply vcg
            apply auto
            subgoal for tsin tsia
              apply(rule ent_ex_postI[where x="(tsia, tsin-1)"])
              apply(rule ent_ex_postI[where x="ti'"])
              apply(rule ent_ex_postI[where x="lsi@rsi"])
              apply (sep_auto dest!: list_assn_len)
              done
            done
            apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
           apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
          apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
          done
        apply(rule hoare_triple_preI)
        using Cons  apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
        done
    next
      case sep_x_Node
      then show ?thesis
        apply(subst del.simps)
        apply sep_auto
        using "2.prems"(2) sorted_inorder_separators apply blast
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
         apply(vcg (ss))
         apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
        apply(vcg (ss))
         apply(vcg (ss))
          apply(vcg (ss))
          apply(vcg (ss))
          apply simp
         apply(vcg (ss))
         apply(vcg (ss))
         apply(vcg (ss))
        subgoal for subts subt tp tsi ti tsi' tnode i tsi'l subsep subi sepi
          (* TODO this causes 4 subgoals *)
          apply(auto simp add: split_relation_alt list_assn_append_Cons_left;
              rule norm_pre_ex_rule; rule norm_pre_ex_rule; rule norm_pre_ex_rule;
              rule hoare_triple_preI;
              auto dest!: mod_starD)[]
             apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
            apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
            (* the correct sub branch *)
          subgoal for subnode lsi subi rsi
            apply(subgoal_tac "subi = Some subnode")
             apply (simp del: btree_assn.simps)
             supply R = split_max_rule[of "Node subts subt" k "Some subnode"]
            thm R
             apply(sep_auto heap add: R simp del: btree_assn.simps)
            using "2.prems" apply(auto dest!: list_assn_len mod_starD simp del: bal.simps order.simps)[]
            subgoal
            proof(goal_cases)
              case 1
              then have "order k (Node subts subt)"
                by blast
              moreover have "k > 0"
                by (simp add: "2.prems"(4))
              ultimately obtain sub_ls lsub lsep where sub_ts_split: "subts = sub_ls@[(lsub,lsep)]"
                by (metis abs_split.isin.cases le_0_eq list.size(3) order.simps(2) rev_exhaust zero_less_iff_neq_zero)
              from 1 have "bal (Node subts subt)"
                by auto
              then have "height lsub = height subt"
                by (simp add: sub_ts_split)
              then show ?thesis using sub_ts_split by blast
            qed
            using "2.prems" abs_split.order_bal_nonempty_lasttreebal[of k subt] order_impl_root_order[of k subt]
               apply(auto)[]
              apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
             apply vcg
              apply auto[]
             apply(cases "abs_split.split_max k (Node subts subt)"; simp)
            subgoal for split_res _ split_sub split_sep
              apply(cases split_res; simp)
              subgoal for split_subi split_sepi
                supply R = rebalance_middle_tree_update_rule[
                    of tt split_sub rss "length lsi" ls k lsi split_subi split_sep rsi tsi ti
                    ]
                thm R
                  (* id_assn split_sepi doesnt match yet... *)
                apply(auto simp add: prod_assn_def dest!: list_assn_len)
                apply (sep_auto)
                 apply(rule hoare_triple_preI)
                 apply(auto dest!: mod_starD)[]
                 apply (sep_auto heap add: R)
                using "2.prems" abs_split.split_max_height[of k sub] order_impl_root_order[of k sub]
                  abs_split.order_bal_nonempty_lasttreebal[of k sub] apply (auto)[]
                using "2.prems" abs_split.split_max_bal[of sub k] order_impl_root_order[of k sub]
                  apply (auto split!: list.splits)[]
                 apply auto[]
                apply(rule hoare_triple_preI)
                apply(auto dest!: mod_starD)[]
                subgoal for subtsi''a subtsi''n ti subtsi'' tnode'
                  apply(cases "(abs_split.rebalance_middle_tree k ls split_sub split_sep rss tt)"; cases "tnode'")
                   apply auto
                  apply sep_auto
                  done
                done
              done
            apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
            done
          apply (auto simp add: split_relation_alt dest!: list_assn_len)[]
          done
        apply(rule hoare_triple_preI)
        using Cons  apply (auto simp add: split_relation_alt dest!: mod_starD list_assn_len)[]
        done
    qed
  qed
qed

definition reduce_root ::"('a::{default,heap,linorder}) btnode ref option \<Rightarrow> 'a btnode ref option Heap"
  where
    "reduce_root ti = (case ti of
  None \<Rightarrow> return None |
  Some p_t \<Rightarrow> do {
    node \<leftarrow> !p_t;
    tsl \<leftarrow> pfa_length (kvs node);
    case tsl of 0 \<Rightarrow> return (last node) |
    _ \<Rightarrow> return ti
})"

lemma reduce_root_rule:
  "<btree_assn k t ti> reduce_root ti <btree_assn k (abs_split.reduce_root t)>\<^sub>t"
  apply(subst reduce_root_def)
  apply(cases t; cases ti)
     apply (sep_auto split!: nat.splits list.splits)+
  done

definition delete ::"nat \<Rightarrow> 'a \<Rightarrow> ('a::{default,heap,linorder}) btnode ref option \<Rightarrow> 'a btnode ref option Heap"
  where
    "delete k x ti = do {
  ti' \<leftarrow> del k x ti;
  reduce_root ti'
}"

lemma delete_rule:
  assumes "bal t" and "root_order k t" and "k > 0" and "sorted (inorder t)"
  shows "<btree_assn k t ti> delete k x ti <btree_assn k (abs_split.delete k x t)>\<^sub>t"
  apply(subst delete_def)
  using assms apply (sep_auto heap add: del_rule reduce_root_rule)
  done

lemma empty_rule:
  shows "<emp>
  empty
  <\<lambda>r. btree_assn k (abs_split.empty_btree) r>"
  apply(subst empty_def)
  apply(sep_auto simp add: abs_split.empty_btree_def)
  done

end

end


(*  Title:      Smartphone.thy
    Author:     Felipe Rodopoulos, University of Brasilia
    Copyright   2018 University of Brasilia

Theory for offline and out-of-band channels. These are defined by the
communications means created by the usage of a smartphone camera for
decoding QR codes displayed others devices screens.

Definitions for keys, initial state of agents and smartphone's usability.

An agent is bad if her smartphone is compromised.

*)

theory Smartphone imports "./EventSP" "~~/src/HOL/Auth/All_Symmetric" begin

(* Theory only reasons over pre-shared keys between agents smartphones and Servers *)
axiomatization
  shrK  ::  "agent \<Rightarrow> key"

where
  inj_shrK : "inj shrK"

section\<open>Smartphone Usage\<close>
(* Legal agents use their smartphone if they hold it *)
definition legalUse :: "smartphone \<Rightarrow> bool" ("legalUse (_)") where
  "legalUse P == P \<notin> stolen"

(* Smartphones are prone to theft. The Spy may use it if she have stole it.
   If devices can be compromised, the Spy can remotely obtain its inputs and outputs *)
primrec illegalUse :: "smartphone \<Rightarrow> bool" where
  illegalUse_def: "illegalUse (Smartphone A) = (
    (insecureP \<and> (Smartphone A \<in> stolen) \<or> (Smartphone A \<in> badP)) \<or>
    (secureP   \<and> (Smartphone A \<in> stolen)))"

section\<open>Agents' Initial State\<close>
overloading initState \<equiv> initState
  begin
  primrec initState where
    initState_Server : "initState Server = (Key` (range shrK))" |
    initState_Friend : "initState (Friend i) = {}" |
    initState_Spy : "initState Spy = (Key` (shrK` {A. Smartphone A \<in> badP}))"
end

axiomatization where
  Key_supply_ax: "finite KK \<Longrightarrow> \<exists> K. K \<notin> KK & Key K \<notin> used evs " and

  (*Needed because of Spy's knowledge of Pairkeys*)
  Nonce_supply_ax: "finite NN \<Longrightarrow> \<exists> N. N \<notin> NN & Nonce N \<notin> used evs"

section\<open>Shared Key Properties\<close>
declare inj_shrK [THEN inj_eq, iff]

(* Shared key encryption is symmetric *)
lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

(* An agent who has a cipher and its correspondet key, can retrieve the message from the cipher's
   body. Trivial, given two facts:
    1. invKey K = K, so K decrypts anything encryted with K
    2. Given that, this lemma follow the structure of the last fact that defines the analz operator
*)
lemma analz_Decrypt' [dest]:
  "\<lbrakk> Crypt K X \<in> analz H; Key K \<in> analz H \<rbrakk> \<Longrightarrow> X \<in> analz H"
apply (erule analz.Decrypt)
apply (simp)
done

(* Removing the <dest> atribute of <analz.Decrypt> in the analz declaration *)
declare analz.Decrypt [rule del]

(* parts predicate idempotency on nonces *)
lemma parts_image_Nonce [simp] :
  "parts (Nonce` N) = Nonce` N"
by auto

(* *)
lemma keysFor_parts_initState [simp] :
  "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C", auto)
done

(* Specific for shared keys: a key used for encrypt a message must coexist in the same message
set of that message or came from some other message set *)
lemma keysFor_parts_insert :
  "\<lbrakk> K \<in> keysFor (parts (insert X G)); X \<in> synth (analz H) \<rbrakk>
    \<Longrightarrow> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (force dest: EventSP.keysFor_parts_insert)

(* The key for an encryption must coexist in the same set where the encryption was created *)
lemma Crypt_imp_keysFor :
  "Crypt K X \<in> H \<Longrightarrow> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

(* Server does know all shared keys! *)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState Server"
apply (induct_tac "A")
apply simp_all
done

(* Previous to any session, legal agents only know their keys *)
lemma shrK_not_in_other [iff]: "Key (shrK (Friend x)) \<in> initState (Friend y) \<Longrightarrow> (x = y)"
apply simp
done

(* Long term keys are not fresh *)
lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

(* Following lemmas are used in parts_induct_tac and analz_Fake_tac to distinguish session keys
   from long-term shared keys *)
text\<open>If a key is fresh, then it must not a long-term key\<close>
lemma Key_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> shrK B \<noteq> K"
by blast

declare shrK_neq [THEN not_sym, simp]

section\<open>Function \<^term>\<open>knows\<close>\<close>
(* An agent's compromised Smartphone disclose hers shared keys *)
lemma Spy_knows_bad_phones [intro!] :
  "Smartphone A \<in> badP \<Longrightarrow> Key (shrK A) \<in> knows Spy evs"

  apply (induct_tac "evs")
  apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(* As a consequence, if the Smartphone is robbed, it also disclose the agents secrets to the Spy *)
lemma Spy_knows_stolen_phones [intro!] :
  "Smartphone A \<in> stolen \<Longrightarrow> Key (shrK A) \<in> knows Spy evs"

  apply (induct_tac "evs")
  apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
using Stolen_in_badP by blast

(* Case analysis on whether or not an agent is compromised *)
lemma Crypt_Spy_analz_bad :
  "\<lbrakk> Crypt (shrK A) X \<in> analz (knows Spy evs); Smartphone A \<in> badP \<rbrakk>
    \<Longrightarrow> X \<in> analz (knows Spy evs)"

  apply (erule analz.Decrypt)
  apply (simp add: Spy_knows_bad_phones)
done

lemma Crypt_Spy_analz_stolen :
  "\<lbrakk> Crypt (shrK A) X \<in> analz (knows Spy evs); Smartphone A \<in> stolen \<rbrakk>
    \<Longrightarrow> X \<in> analz (knows Spy evs)"

  apply (erule analz.Decrypt)
  apply (simp add: Spy_knows_stolen_phones)
done

section\<open>Nonce Lemmas\<close>
(* Nonces must be fresh! So no nonces in initial state of agents knowledge *)
lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState (Friend i))"
by auto

lemma subset_Compl_range_shrK: "A \<subseteq> - (range shrK) \<Longrightarrow> shrK x \<notin> A"
by blast

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

lemma Nonce_supply :
  "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE])
apply (rule someI, blast)
done

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment>\<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range_shrK
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  \<Longrightarrow>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

section\<open>Tactics for possibility theorems\<close>
ML
\<open>
structure Smartphone =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
      delsimps @{thms used_Cons_simps}
      setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
               delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
               addsimps @{thms analz_image_freshK_simps})
end
\<close>

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)
method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Smartphone.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

method_setup possibility = \<open>
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartphone.possibility_tac ctxt))\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartphone.basic_possibility_tac ctxt))\<close>
    "for proving possibility theorems"

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

(*Needed for actual protocols that will follow*)
declare legalUse_def [iff] illegalUse_def [iff]

end