text \<open>General definition of procedure for inverting certain functions f :: nat \<Rightarrow> nat TODO: Better description

  Also some locale to structure refinement process to IMP_Minus.
\<close>

(* Clean up *)
theory Inversion
  imports Primitives "Poly_Reductions_Lib.Landau_Auxiliaries"
    "HOL-Library.Rewrite" "HOL-Library.Sublist" "HOL-Eisbach.Eisbach"

    "HOL-Library.Nat_Bijection" IMP_Minus.Call_By_Prefixes
    "Poly_Reductions_Lib.Triangle_Extensions"
    "Poly_Reductions_Lib.Discrete_Extensions"
begin

lemma "\<not> surj (power2 :: nat \<Rightarrow> nat)"
  by (metis (full_types) One_nat_def lessI less_exp mult.right_neutral nat_less_le numerals(2) power2_eq_square sqrt_inverse_power2 sqrt_unique surj_def)
(*
  Could probably generalize from nat
  assumptions in no collections so I see exactly where I need them
*)
locale inversion =
  fixes f :: "nat \<Rightarrow> nat"
  assumes inj: "inj f"
  assumes mono: "mono f"
  assumes 0: "f 0 = 0" (* I would like to get rid of this, but then the inverse is only defined *)
begin

lemma strict_mono: "strict_mono f"
  using inj mono
  by (metis injD monoD nat_less_le strict_mono_def)

lemma inc: "n \<le> f n"
  using strict_mono strict_mono_imp_increasing by blast

definition "f_inv n \<equiv> Max {m. f m \<le> n}"

lemma f_inv_aux:
  fixes n :: nat
  shows "finite {m. f m \<le> n}" and "{m. f m \<le> n} \<noteq> {}"
proof -
  { fix m
    assume "f m \<le> n"
    then have "m \<le> n"
      apply (cases m) apply simp_all
      using inc order_trans by blast
  } note ** = this
  then have "{m. f m \<le> n} \<subseteq> {m. m \<le> n}" by auto
  then show "finite {m. f m \<le> n}" by (rule finite_subset) rule
  have "f 0 \<le> n" using 0 by simp
  then show *: "{m. f m \<le> n} \<noteq> {}" by blast
qed

lemma f_inv_unique:
  assumes "f m \<le> n" "n < f (Suc m)"
  shows   "f_inv n = m"
proof -
  have "m' \<le> m" if "f m' \<le> n" for m'
  proof -
    note that
    also note assms(2)
    finally have "m' < Suc m"
      using strict_mono strict_mono_less by blast
    thus "m' \<le> m" by simp
  qed
  with \<open>f m \<le> n\<close> f_inv_aux[of n] show ?thesis unfolding f_inv_def
    by (intro antisym Max.boundedI Max.coboundedI) simp_all
qed

lemma f_nat_le_imp_le:
  fixes m n :: nat
  assumes "f m \<le> n"
  shows "m \<le> n"
proof (cases m)
  case 0
  then show ?thesis
    by simp
next
  case (Suc nat)
  then show ?thesis
    using assms inc
    using order_trans by blast
qed

(* Real proof *)
lemma f_nat_le_eq_le: "f m \<le> f n \<longleftrightarrow> m \<le> n"
  for m n :: nat
  using strict_mono by (simp add: mono strict_mono_less_eq)

(* basically linear search, delete this code equation once you have a better one *)
lemma f_inv_code_1 [code]: "f_inv n = Max (Set.filter (\<lambda>m. f m \<le> n) {0..n})"
proof -
  from f_nat_le_imp_le [of _ n] have "{m. m \<le> n \<and> f m \<le> n} = {m. f m \<le> n}" by auto
  then show ?thesis by (simp add: f_inv_def Set.filter_def)
qed

lemma f_inv_inverse_f [simp]: "f_inv (f n) = n"
proof -
  have "{m. m \<le> n} \<noteq> {}" by auto
  then have "Max {m. m \<le> n} \<le> n" by auto
  then show ?thesis
    by (auto simp add: f_inv_def f_nat_le_eq_le intro: antisym)
qed

lemma f_inv_zero [simp]: "f_inv 0 = 0"
  using f_inv_inverse_f [of 0]
  by (simp add: "0")

(* Might no longer hold
(* Now this is gettingout of hand :) *)
lemma f_inv_one [simp]: "f_inv 1 = 1"
  using f_inv_inverse_f [of 1]  sledgehammer
  by (metis "0" One_nat_def bij bij_inv_eq_iff inversion.f_inv_inverse inversion.f_inv_unique inversion.inc
      inversion_axioms linordered_nonzero_semiring_class.zero_le_one order_le_less)
*)

lemma f_gt_0: "f 1 > 0"
  by (metis inc not_one_le_zero zero_less_iff_neq_zero)

lemma "f_inv 1 \<le> f_inv 2"
  by (metis "0" Suc_0_to_numeral Suc_1 f_inv_inverse_f f_inv_unique gr0I inc less_Suc0 nat_less_le one_le_numeral)

lemma mono_f_inv: "mono f_inv"
proof
  fix m n :: nat
  have *: "0 * 0 \<le> m" by simp
  assume "m \<le> n"
  then show "f_inv m \<le> f_inv n"
    using 0 apply (auto intro!: Max_mono \<open>0 * 0 \<le> m\<close> finite_less_ub simp add: f_inv_def f_nat_le_imp_le)
    by (metis "0" le0)
qed

lemma mono_f_inv_': "m \<le> n \<Longrightarrow> f_inv m \<le> f_inv n"
  using mono_f_inv unfolding mono_def by auto

(* No longer holds :(
lemma f_inv_greater_zero_iff [simp]: "f_inv n > 0 \<longleftrightarrow> n > 0"
proof -
  have *: "0 < Max {m. f m \<le> n} \<longleftrightarrow> (\<exists>a\<in>{m. f m \<le> n}. 0 < a)"
    by (rule Max_gr_iff) (fact f_inv_aux)+
  show ?thesis
  proof
    assume "0 < f_inv n"
    then have "0 < Max {m. f m \<le> n}" by (simp add: f_inv_def)
    with * show "0 < n" by (auto dest: f_nat_le_imp_le)
  next
    assume "0 < n"
    hence "f 1 \<le> n"
    then have "f 1 \<le> n \<and> 0 < (1::nat)"
      by (metis "0" One_nat_def Suc_leI f_inv_one f_inv_unique linorder_not_le linordered_nonzero_semiring_class.zero_le_one
          order_trans zero_less_one)
    then have "\<exists>q. f q \<le> n \<and> 0 < q" ..
    with * have "0 < Max {m. f m \<le> n}" by blast
    then show "0 < f_inv n" by (simp add: f_inv_def)
  qed
qed
*)

(* No idea what this proof does, find out sometime :) *)
lemma f_inv_f_le [simp]: "f (f_inv n) \<le> n" (* FIXME tune proof *)
proof (cases "n > 0")
  case False then show ?thesis
    using mono inc 0
    by (metis f_inv_inverse_f gr0I)
next
  case True (*then have "f_inv n > 0"
    using f_inv_greater_zero_iff by blast*)
  then have "mono (times (Max {m. f m \<le> n}))"
    using Rings.mono_mult by blast
  then have *: "Max {m. f m \<le> n} * Max {m. f m \<le> n} = Max (times (Max {m. f m \<le> n}) ` {m. f m \<le> n})"
    using f_inv_aux [of n] by (rule mono_Max_commute)
  have "\<And>a. a * a \<le> n \<Longrightarrow> Max {m. m * m \<le> n} * a \<le> n"
  proof -
    fix q
    assume "q * q \<le> n"
    show "Max {m. m * m \<le> n} * q \<le> n"
    proof (cases "q > 0")
      case False then show ?thesis by simp
    next
      case True then have "mono (times q)" by (rule mono_times_nat)
      then have "q * Max {m. m * m \<le> n} = Max (times q ` {m. m * m \<le> n})"
        using sqrt_aux [of n] by (auto simp add: power2_eq_square intro: mono_Max_commute)
      then have "Max {m. m * m \<le> n} * q = Max (times q ` {m. m * m \<le> n})" by (simp add: ac_simps)
      moreover have "finite ((*) q ` {m. m * m \<le> n})"
        by (metis (mono_tags) finite_imageI finite_less_ub le_square)
      moreover have "\<exists>x. x * x \<le> n"
        by (metis \<open>q * q \<le> n\<close>)
      ultimately show ?thesis
        by simp (metis \<open>q * q \<le> n\<close> le_cases mult_le_mono1 mult_le_mono2 order_trans)
    qed
  qed
  then have "Max ((*) (Max {m. m * m \<le> n}) ` {m. m * m \<le> n}) \<le> n"
    apply (subst Max_le_iff)
      apply (metis (mono_tags) finite_imageI finite_less_ub le_square)
     apply auto
    apply (metis le0 mult_0_right)
    done
  with * show ?thesis
    using f_inv_aux Max_in by (auto simp add: f_inv_def)
qed

lemma f_inv_le: "f_inv n \<le> n"
  using f_inv_aux [of n] by (auto simp add: f_inv_def intro: f_nat_le_imp_le)

lemma Suc_f_inv_f_gt: "n < f (Suc (f_inv n))"
  using Max_ge[OF f_inv_aux(1), of "f_inv n + 1" n]
  by (cases "n < f (Suc (f_inv n))") (simp_all add: f_inv_def)

lemma le_f_inv_iff: "x \<le> f_inv y \<longleftrightarrow> f x \<le> y"
proof -
  have "x \<le> f_inv y \<longleftrightarrow> (\<exists>z. f z \<le> y \<and> x \<le> z)"
    using Max_ge_iff[OF f_inv_aux, of x y] by (simp add: f_inv_def)
  also have "\<dots> \<longleftrightarrow> f x \<le> y"
  proof safe
    fix z assume "x \<le> z" "f z \<le> y"
    thus "f x \<le> y" by (intro le_trans[of "f x" "f z" y]) (simp_all add: f_nat_le_eq_le)
  qed auto
  finally show ?thesis .
qed

lemma le_f_invI: "f x \<le> y \<Longrightarrow> x \<le> f_inv y"
  by (simp add: le_f_inv_iff)

lemma f_inv_le_iff: "f_inv y \<le> x \<longleftrightarrow> (\<forall>z. f z \<le> y \<longrightarrow> z \<le> x)"
  using Max.bounded_iff[OF f_inv_aux] by (simp add: f_inv_def)

lemma sqrt_leI:
  "(\<And>z. f z \<le> y \<Longrightarrow> z \<le> x) \<Longrightarrow> f_inv y \<le> x"
  by simp

lemma f_less_imp_less: "f x < f y \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
  by (simp add: less_le_not_le f_nat_le_eq_le)
lemma f_inv_Suc:
  "f_inv (Suc n) = (if \<exists>m. Suc n = f m then Suc (f_inv n) else f_inv n)"
proof cases
  assume "\<exists> m. Suc n = f m"
  then obtain m where m_def: "Suc n = f m" by blast
  then have lhs: "f_inv (Suc n) = m" by simp
  from m_def f_inv_f_le[of n]
    have "f (f_inv n) < f m" by linarith
  with f_less_imp_less have lt_m: "f_inv n < m" by blast
  from m_def Suc_f_inv_f_gt[of "n"]
    have "f m \<le> f (Suc(f_inv n))"
      by linarith
  with f_nat_le_eq_le have "m \<le> Suc (f_inv n)" by blast
  with lt_m have "m = Suc (f_inv n)" by simp
  with lhs m_def show ?thesis by metis
next
  assume asm: "\<not> (\<exists> m. Suc n = f m)"
  hence "Suc n \<noteq> f (f_inv (Suc n))" by simp
  with f_inv_f_le[of "Suc n"]
    have "f_inv (Suc n) \<le> f_inv n" by (intro le_f_invI) linarith
  moreover have "f_inv (Suc n) \<ge> f_inv n"
    by (intro monoD[OF mono_f_inv]) simp_all
  ultimately show ?thesis using asm by simp
qed

function f_inv_bisection' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "Suc L \<ge> R \<Longrightarrow> f_inv_bisection' y L R = L"
| "Suc L < R \<Longrightarrow> f ((L+R) div 2) \<le> y \<Longrightarrow> f_inv_bisection' y L R = f_inv_bisection' y ((L + R) div 2) R"
| "Suc L < R \<Longrightarrow> f ((L+R) div 2) > y \<Longrightarrow> f_inv_bisection' y L R = f_inv_bisection' y L ((L + R) div 2)"
  by force+
termination by (relation "Wellfounded.measure (\<lambda>(y,L,R) . R-L)") auto

lemma f_inv_bisection'_correct':
  "(0::nat) \<le> L \<Longrightarrow> L < R \<Longrightarrow> f L \<le> y \<Longrightarrow> y < f R \<Longrightarrow> f (f_inv_bisection' y L R) \<le> y \<and> y < f (Suc (f_inv_bisection' y L R))"
  by (induction y L R rule: f_inv_bisection'.induct) (simp_all add: le_Suc_eq)

(* This is what I would like *)
lemma f_inv_bisection'_correct'':
  assumes "(0::nat) \<le> L" "L < R" "f L \<le> y" "y < f R"
  shows "f (f_inv_bisection' y L R) \<le> y" "y < f (Suc (f_inv_bisection' y L R))"
  using assms f_inv_bisection'_correct'  by blast+

definition "f_inv_bisection y \<equiv> f_inv_bisection' y 0 (Suc y)"

lemma f_inv_bisection_correct':
  "f (f_inv_bisection y) \<le> y" "y < f (Suc (f_inv_bisection y))"
  unfolding f_inv_bisection_def apply (all \<open>rule f_inv_bisection'_correct''\<close>)
     apply (simp_all add: "0")
  using mono Suc_le_eq inc by blast+

corollary f_inv_bisection_correct: "f_inv_bisection y = f_inv y"
  by (intro f_inv_unique[symmetric] f_inv_bisection_correct')

lemmas f_inv_bisection_code[code] = f_inv_bisection_correct[symmetric]

(* Now, I can probably do refinement as well here generally *)

(* Even the timing function should be defineable without ML *)

unbundle IMP_Minus_Minus_Com.no_com_syntax

end
(* I wondered a bit how much we can do with just locales, but for timing we definitely need ML,
  so that goes to students. Locale below shows what should be generated by ML code
*)
term big_step_t

locale inversion_imp = inversion +
  (* state, in this case simple, in general more difficult, find needed variables in record by analysis of tl-rec f *)
  fixes f_imp_state_in :: "'a \<Rightarrow> nat"
  fixes f_imp_state_out :: "'a \<Rightarrow> nat"
  fixes f_imp_state :: "nat \<Rightarrow> nat \<Rightarrow> 'a"

  (* Properties of state, usually provided by record/datatype package *)
  assumes f_imp_state_in[simp]: "f_imp_state_in (f_imp_state in' out) = in'"
  assumes f_imp_state_out[simp]: "f_imp_state_out (f_imp_state in' out) = out"
  assumes f_imp_state[simp]: "f_imp_state (f_imp_state_in s) (f_imp_state_in s) = s"

  (* Program on HOL level, should be translated from tl-rec f. Probably follow the _state_upd approach though *)
  fixes f_imp :: "'a \<Rightarrow> 'a"
  (* Timing function, generated from f_imp *)
  fixes f_imp_time :: "nat \<Rightarrow> 'a \<Rightarrow> nat"

  (* Correctness of f, more complicated in general, proof hopefully fairly automatic *)
  assumes f_imp_correct: "f_imp_state_out (f_imp s) = f (f_imp_state_in s)"

  (* Pull out accumulator, maybe define without directly? Provable from from f_imp_time definition, nothing special *)
  assumes f_imp_time_acc: "f_imp_time (Suc t) s = Suc (f_imp_time t s)"

  (* Variable names occuring in IMP_Minus program, of course more general for others,
    note that there might be internal vars not in the record(Which are not relevant, input/output)
    Should be generateable from f_imp
    prefix str without . for now
  *)
  fixes f_pref_str :: string
  fixes f_in_str :: string
  fixes f_out_str :: string
  assumes f_in_str_f_out_str[simp]: "f_in_str \<noteq> f_out_str"

  (* IMP_MINUS version of f_imp, translate from f_imp *)
  fixes f_IMP_Minus :: "Com.com"
  (* Extract record from IMP_Minus state, generate from record *)
  fixes f_imp_to_HOL_state :: "string \<Rightarrow> AExp.state \<Rightarrow> 'a"

  (* Provable from from f_imp_to_HOL_state definition, nothing special *)
  assumes f_imp_to_HOL_state_add_prefix:
    "f_imp_to_HOL_state (add_prefix p1 p2) S = f_imp_to_HOL_state p2 (S o (add_prefix p1))"

  (* f_imp_to_HOL_state translates correctly, probably given by definition of f_imp_to_HOL_state *)
  assumes f_imp_state_in_f_imp_to_HOL_state[simp]: "f_imp_state_in (f_imp_to_HOL_state p S) = S (add_prefix p f_in_str)"
  assumes f_imp_state_out_f_imp_to_HOL_state[simp]: "f_imp_state_out (f_imp_to_HOL_state p S) = S (add_prefix p f_out_str)"

  (* Final desired correctness result, for the proof we probably need functional/timing correctness lemmas in between
    Also should be fairly automatic, correctness part of statement is of course more general in other cases,

    proof should again be hopefully fairly automatic, problem is runtime
  *)
  assumes f_IMP_Minus_correct:
  "\<lbrakk>(invoke_subprogram (p1 @ p2) f_IMP_Minus, S) \<Rightarrow>\<^bsup>t\<^esup> s';
    \<And>v. v \<in> vars \<Longrightarrow> \<not> (prefix p2 v);
     \<lbrakk>t = f_imp_time 0 (f_imp_to_HOL_state (p1 @ p2) S);
      s' (add_prefix (p1 @ p2) f_out_str) =
        f_imp_state_out (f_imp (f_imp_to_HOL_state (p1 @ p2) S));
      \<And>v. v \<in> vars \<Longrightarrow> S (add_prefix p1 v) = s' (add_prefix p1 v)\<rbrakk>
     \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
begin

(* If I create a general locale struture for this, I can get theorems like this directly on the user level *)
lemma f_imp_time_acc': "f_imp_time t s = t + f_imp_time 0 s"
  by (induction t arbitrary: s) (simp_all add: f_imp_time_acc)

(* Record package not localized :( In this case I can just use a datatype instead,
  why still records btw? is there any reason? *)
datatype f_inv_bisection'_state = f_inv_bisection'_state (f_inv_bisection'_state_y: nat)
  (f_inv_bisection'_state_L: nat) (f_inv_bisection'_state_R: nat)

definition "f_inv_bisection'_imp_state_upd s = (let
    M = f_inv_bisection'_state_L s + f_inv_bisection'_state_R s;
    M = M div 2;

    f_in = M;
    f_out = 0; \<comment> \<open>For general version, just use one var\<close>
    f_inv_bisection'_f_state = f_imp_state f_in f_out;
    f_ret = f_imp f_inv_bisection'_f_state;
    M2 = f_imp_state_out f_ret;

    \<comment> \<open>Canonical way to do general (i.e. not just one assignment) branching?\<close>
    cond = M2 - f_inv_bisection'_state_y s;
    L = if cond \<noteq> 0 then f_inv_bisection'_state_L s else M;
    R = if cond \<noteq> 0 then M else f_inv_bisection'_state_R s;

    ret = f_inv_bisection'_state (f_inv_bisection'_state_y s) L R
  in
    ret)
"

(* Names in program, note that I need to differentiate different instance *)
abbreviation "f_inv_bisection'_pref \<equiv> f_pref_str @ ''inv_bisection'.''"
abbreviation "f_inv_bisection'_y_str \<equiv> ''y''"
abbreviation "f_inv_bisection'_L_str \<equiv> ''L''"
abbreviation "f_inv_bisection'_R_str \<equiv> ''R''"

function f_inv_bisection'_imp :: "f_inv_bisection'_state \<Rightarrow> f_inv_bisection'_state" where
  "f_inv_bisection'_imp s =
  (if f_inv_bisection'_state_R s - (f_inv_bisection'_state_L s + 1) \<noteq> 0 then \<comment> \<open>While L+1 < R\<close>
    (
      let
        next_iteration = f_inv_bisection'_imp (f_inv_bisection'_imp_state_upd s)
      in
        next_iteration
    )
  else
    (
      let
        ret = s
      in
        ret
    )
  )"
  by pat_completeness auto
termination (* Same termination proof as recursive version, just some additional decoration *)
  by (relation "Wellfounded.measure (\<lambda>s. f_inv_bisection'_state_R s - f_inv_bisection'_state_L s)")
    (auto simp: f_inv_bisection'_imp_state_upd_def Let_def split: if_splits)

declare f_inv_bisection'_imp.simps[simp del]

lemma f_inv_bisection'_imp_correct: "f_inv_bisection'_state_L (f_inv_bisection'_imp s)
  = f_inv_bisection' (f_inv_bisection'_state_y s) (f_inv_bisection'_state_L s) (f_inv_bisection'_state_R s)"
proof (induction s rule: f_inv_bisection'_imp.induct)
  case (1 s)
  then show ?case
    apply(subst f_inv_bisection'_imp.simps)
    apply (auto simp: f_inv_bisection'_imp_state_upd_def Let_def f_imp_correct
         split: if_splits) (* Slow, very slow, do better*)
    done
qed

function f_inv_bisection'_imp_time :: "nat \<Rightarrow> f_inv_bisection'_state \<Rightarrow> nat" where
  "f_inv_bisection'_imp_time t s =
  (if f_inv_bisection'_state_R s - (f_inv_bisection'_state_L s + 1) \<noteq> 0 then \<comment> \<open>While L+1 < R\<close>
    (
      let
        t = t + 5; \<comment> \<open>To account for while loop condition checking and difference computation\<close>
         \<comment> \<open>Computation of M\<close>

        M = f_inv_bisection'_state_L s + f_inv_bisection'_state_R s;
        t = t + 2;
        M = M div 2;
        t = t + 2;

        f_in = M;
        t = t + 2;
        f_out = 0; \<comment> \<open>For general version, just use one var\<close>
        t = t + 2;
        f_inv_bisection'_f_state = f_imp_state f_in f_out;
        f_ret = f_imp f_inv_bisection'_f_state;
        t = t + f_imp_time 0 f_inv_bisection'_f_state;
        M2 = f_imp_state_out f_ret;
        t = t + 2;

        \<comment> \<open>Canonical way to do general (i.e. not just one assignment) branching?\<close>
        cond = M2 - f_inv_bisection'_state_y s;
        t = t + 2;
        L = if cond \<noteq> 0 then f_inv_bisection'_state_L s else M;
        t = t + 3;
        R = if cond \<noteq> 0 then M else f_inv_bisection'_state_R s;
        t = t + 3;

        next_iteration = f_inv_bisection'_imp_time t (f_inv_bisection'_imp_state_upd s)
      in
        next_iteration
    )
  else
    (
      let
        t = t + 7;
        ret = t
      in
        ret
    )
  )"
  by pat_completeness auto
termination (* Same termination proof as recursive version, just some additional decoration *)
  by (relation "Wellfounded.measure (\<lambda>(t,s). f_inv_bisection'_state_R s - f_inv_bisection'_state_L s)")
    (auto simp: f_inv_bisection'_imp_state_upd_def Let_def split: if_splits)

declare f_inv_bisection'_imp_time.simps[simp del]

lemma f_inv_bisection'_imp_time_acc: "(f_inv_bisection'_imp_time (Suc t) s) = Suc (f_inv_bisection'_imp_time t s)"
proof (induction t s arbitrary: rule: f_inv_bisection'_imp_time.induct)
  case (1 t s)
  then show ?case
  proof(cases "f_inv_bisection'_state_R s - (f_inv_bisection'_state_L s + 1) \<noteq> 0")
    case True
    hence "(Suc (f_inv_bisection'_state_L s)) < f_inv_bisection'_state_R s"
      by simp
    with True show ?thesis
      apply (subst (2) f_inv_bisection'_imp_time.simps)
      apply (subst f_inv_bisection'_imp_time.simps)
      using 1 by (simp add: f_inv_bisection'_imp_state_upd_def Let_def split: if_splits)
  next
    case False
    then show ?thesis
      by (auto simp add: f_inv_bisection'_imp_time.simps split: if_splits)
  qed
qed

lemma f_inv_bisection'_imp_time_acc': "(f_inv_bisection'_imp_time t s) = t + (f_inv_bisection'_imp_time 0 s)"
  by (induction t) (auto simp add: f_inv_bisection'_imp_time_acc)
lemma f_inv_bisection'_imp_time_acc'': "NO_MATCH 0 t \<Longrightarrow> (f_inv_bisection'_imp_time t s) = t + (f_inv_bisection'_imp_time 0 s)"
  using f_inv_bisection'_imp_time_acc' .

definition f_inv_bisection'_IMP_Minus_while_condition where
  "f_inv_bisection'_IMP_Minus_while_condition \<equiv>
  ''inc'' ::= ((V f_inv_bisection'_L_str) \<oplus> (N 1));;
   ''diff'' ::= ((V f_inv_bisection'_R_str) \<ominus> (V ''inc''))"

(* Dangerous*)
abbreviation "f_prefix_str \<equiv> f_pref_str @ ''.''"

definition f_inv_bisection'_IMP_Minus_loop_body where
  "f_inv_bisection'_IMP_Minus_loop_body =
    \<comment> \<open>M = (L+R) / 2;\<close>
    ''M'' ::= ((V f_inv_bisection'_L_str) \<oplus> (V f_inv_bisection'_R_str));;
    ''M'' ::= ((V ''M'')\<then>);;

    \<comment> \<open>M*M,\<close>
    (f_prefix_str @ f_in_str) ::= A (V ''M'');;
    (f_prefix_str @ f_out_str) ::= A (N 0);;
    invoke_subprogram f_prefix_str f_IMP_Minus;;
    ''M2'' ::= A (V (f_prefix_str @ f_out_str));;

    \<comment> \<open>New left bound\<close>
    ''cond'' ::= ((V ''M2'') \<ominus> (V f_inv_bisection'_y_str));;
    (IF ''cond''\<noteq>0 THEN f_inv_bisection'_L_str ::= A (V f_inv_bisection'_L_str) ELSE f_inv_bisection'_L_str ::= A (V ''M''));;
    \<comment> \<open>New right bound\<close>
    (IF ''cond''\<noteq>0 THEN f_inv_bisection'_R_str ::= A (V ''M'') ELSE f_inv_bisection'_R_str ::= A (V f_inv_bisection'_R_str))"

definition f_inv_bisection'_IMP_Minus_after_loop where
  "f_inv_bisection'_IMP_Minus_after_loop = Com.SKIP"

definition f_inv_bisection'_IMP_Minus where
"f_inv_bisection'_IMP_Minus \<equiv>
  \<comment> \<open>if L+1 < R\<close>
  f_inv_bisection'_IMP_Minus_while_condition;;
  WHILE ''diff''\<noteq>0 DO (
    f_inv_bisection'_IMP_Minus_loop_body;;
    f_inv_bisection'_IMP_Minus_while_condition
  );;
  f_inv_bisection'_IMP_Minus_after_loop"

lemmas f_inv_bisection'_IMP_Minus_subprogram_simps =
  f_inv_bisection'_IMP_Minus_while_condition_def f_inv_bisection'_IMP_Minus_loop_body_def f_inv_bisection'_IMP_Minus_after_loop_def

definition "f_inv_bisection'_imp_to_HOL_state p s = f_inv_bisection'_state
  (s (add_prefix p f_inv_bisection'_y_str))
  (s (add_prefix p f_inv_bisection'_L_str))
  (s (add_prefix p f_inv_bisection'_R_str))"

abbreviation
  "f_inv_bisection'_IMP_vars \<equiv> {f_inv_bisection'_y_str, f_inv_bisection'_L_str, f_inv_bisection'_R_str,
  ''inc'', ''diff'', ''cond'', ''M'', ''M2''}"

lemma why_is_this_not_happening: "f_inv_bisection'_state_y
     (f_inv_bisection'_state (s (add_prefix p ''y'')) (s (add_prefix p ''L''))
       (s (add_prefix p ''R''))) = (s (add_prefix p ''y''))"
  by simp

lemma do_not_want_to_search: "n+1 = Suc n"
  by simp

lemma cond_elim: "(\<And>v . v \<in> insert w W \<Longrightarrow> s (add_prefix p v) = s' (add_prefix p v))
  \<Longrightarrow> (s (add_prefix p w) = s' (add_prefix p w) \<Longrightarrow> (\<And>v . v \<in> W \<Longrightarrow> s (add_prefix p v) = s' (add_prefix p v)) \<Longrightarrow> P)
  \<Longrightarrow> P"
  by auto

lemma simp_cond1: "(\<And>v . v \<in> W \<Longrightarrow> s (add_prefix p v) = s' (add_prefix p v)) \<equiv> Trueprop (\<forall>v\<in>W . s (add_prefix p v) = s' (add_prefix p v))"
  by (rule atomize_ball)

lemma simp_cond2: "(\<forall>v\<in>insert w W . s (add_prefix p v) = s' (add_prefix p v))
  = (s (add_prefix p w) = s' (add_prefix p w) \<and> (\<forall>v\<in>W . s (add_prefix p v) = s' (add_prefix p v)))"
  by auto

lemma simp_cond3: "(\<forall>v\<in>{} . P v) = True"
  by auto

lemma "set xs \<noteq> set ys \<Longrightarrow> xs \<noteq> ys"
  by blast

(* YEAAAH! *)
lemma f_inv_bisection'_IMP_Minus_correct_function_1:
  "(invoke_subprogram p f_inv_bisection'_IMP_Minus, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow>
     s' (add_prefix p f_inv_bisection'_L_str) =
       f_inv_bisection'_state_L (f_inv_bisection'_imp (f_inv_bisection'_imp_to_HOL_state p s))"
proof (induction "f_inv_bisection'_imp_to_HOL_state p s" arbitrary: s s' t rule: f_inv_bisection'_imp.induct)
  case 1
  then show ?case
  apply (subst f_inv_bisection'_imp.simps)
  apply (simp only: f_inv_bisection'_IMP_Minus_def prefix_simps)
  apply (erule Seq_tE)+
  apply (erule While_tE)
     apply (auto simp add: f_inv_bisection'_imp_state_upd_def prefix_simps Let_def
        f_inv_bisection'_imp_to_HOL_state_def f_inv_bisection'_IMP_Minus_subprogram_simps split: if_splits)[]
    apply (erule Seq_tE)+
    apply dest_com_gen

    subgoal (* This seems unproblematic *)
    apply (simp only: f_inv_bisection'_IMP_Minus_while_condition_def prefix_simps)
    apply (erule Seq_tE)+
      by (auto simp add: f_inv_bisection'_imp_to_HOL_state_def)

    subgoal premises p for x s2 y xa s2a ya xb s2b yb xc s2c yc
      thm p
      using p(4,5,8,9) apply -
      apply (simp only: f_inv_bisection'_IMP_Minus_while_condition_def f_inv_bisection'_IMP_Minus_loop_body_def prefix_simps)
      apply(erule Seq_tE)+
      apply(all \<open>erule f_IMP_Minus_correct[where vars = "f_inv_bisection'_IMP_vars"]\<close>)
      subgoal premises p  using p(24) by (auto simp add: prefix_Cons) (* Here we already see how auto gets confused by all the crap in p,
        also a free prefix made it more difficult, abuse . *)
      apply(elim If_tE)
      apply (all \<open>drule AssignD\<close>)+
         apply (all \<open>erule conjE\<close>)+
          (* All proofs the same now, instantiations maybe with simprocs *)
          subgoal premises p
          using p(1,13,15-) using p(14) apply (elim cond_elim) (* Seems to work, still need to filter garbage out *)
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
        done

      subgoal premises p for x s2 y xa s2a ya xb s2b yb xc s2c yc
      thm p
      using p(4,5,8,9) apply -
      apply (simp only: f_inv_bisection'_IMP_Minus_while_condition_def f_inv_bisection'_IMP_Minus_loop_body_def prefix_simps)
      apply(erule Seq_tE)+
      apply(all \<open>erule f_IMP_Minus_correct[where vars = "f_inv_bisection'_IMP_vars"]\<close>)
      subgoal premises p  using p(24) by (auto simp add: prefix_Cons) (* Here we already see how auto gets confused by all the crap in p,
        also a free prefix made it more difficult, abuse . *)
      apply(elim If_tE)
      apply (all \<open>drule AssignD\<close>)+
         apply (all \<open>erule conjE\<close>)+
          (* All proofs the same now, instantiations maybe with simprocs *)
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
        done
      done
  qed

lemma f_inv_bisection'_IMP_Minus_correct_time:
  "(invoke_subprogram p f_inv_bisection'_IMP_Minus, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow> t = f_inv_bisection'_imp_time 0 (f_inv_bisection'_imp_to_HOL_state p s)"
proof (induction "f_inv_bisection'_imp_to_HOL_state p s" arbitrary: s s' t rule: f_inv_bisection'_imp.induct)
  case 1
  from "1.prems" show ?case
  apply (subst f_inv_bisection'_imp_time.simps)
  apply (simp only: f_inv_bisection'_IMP_Minus_def prefix_simps)
  apply (erule Seq_tE)+
  apply (erule While_tE_time)
     apply (auto simp add: f_inv_bisection'_imp_state_upd_def prefix_simps Let_def
        f_inv_bisection'_imp_to_HOL_state_def f_inv_bisection'_IMP_Minus_subprogram_simps f_inv_bisection'_imp_time_acc split: if_splits)[]
    apply (erule Seq_tE)+
    using "1.hyps"[unfolded f_inv_bisection'_IMP_Minus_def] apply -
    apply (simp add: add.assoc)
    apply dest_com_gen_time

    subgoal (* This seems unproblematic *)
    apply (simp only: f_inv_bisection'_IMP_Minus_while_condition_def prefix_simps)
    apply (erule Seq_tE)+
      by (auto simp add: f_inv_bisection'_imp_to_HOL_state_def)

    subgoal premises p for x s2 y xa s2a ya xb s2b yb xc s2c yc
      thm p
      using p(4,5,8,9) apply -
      apply (simp only: f_inv_bisection'_IMP_Minus_while_condition_def f_inv_bisection'_IMP_Minus_loop_body_def prefix_simps)
      apply(erule Seq_tE)+
      apply(all \<open>erule f_IMP_Minus_correct[where vars = "f_inv_bisection'_IMP_vars"]\<close>)
      subgoal premises p  using p(24) by (auto simp add: prefix_Cons) (* Here we already see how auto gets confused by all the crap in p,
        also a free prefix made it more difficult, abuse . *)
      apply(elim If_tE)
      apply (all \<open>drule AssignD\<close>)+
         apply (all \<open>erule conjE\<close>)+
          (* All proofs the same now, instantiations maybe with simprocs *)
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
        done

      subgoal premises p for x s2 y xa s2a ya xb s2b yb xc s2c yc
      thm p
      using p(4,5,8,9) apply -
      apply (simp only: f_inv_bisection'_IMP_Minus_while_condition_def f_inv_bisection'_IMP_Minus_loop_body_def prefix_simps)
      apply(erule Seq_tE)+
      apply(all \<open>erule f_IMP_Minus_correct[where vars = "f_inv_bisection'_IMP_vars"]\<close>)
      subgoal premises p  using p(24) by (auto simp add: prefix_Cons) (* Here we already see how auto gets confused by all the crap in p,
        also a free prefix made it more difficult, abuse . *)
      apply(elim If_tE)
      apply (all \<open>drule AssignD\<close>)+
         apply (all \<open>erule conjE\<close>)+
          (* All proofs the same now, instantiations maybe with simprocs *)
          subgoal premises p thm p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          by (metis f_imp_state f_imp_state_in f_imp_state_out) (* ? *)
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)

          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          done
          subgoal premises p
          using p(1,13,15-)
          (* Full hammer, but it won't work without instantiations *)
          using p(14)[of "''M2''"] p(14)[of "''M''"] p(14)[of "''inc''"] p(14)[of "''diff''"] p(14)[of "''cond''"] p(14)[of "''y''"] p(14)[of "''L''"] p(14)[of "''R''"]
          apply (auto simp add: f_inv_bisection'_imp_state_upd_def f_inv_bisection'_imp_to_HOL_state_def Let_def f_imp_correct split: if_splits simp add: p(14)[of "''y''"] Cons_eq_append_conv)
          by (metis f_imp_state f_imp_state_in f_imp_state_out) (* ? *)
          done
        done
  qed

lemma IMP_Minus_correct_effects:
  "(invoke_subprogram (p1 @ p2) prog, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow>  v \<in> vars \<Longrightarrow> \<not> (prefix p2 v)
  \<Longrightarrow> s (add_prefix p1 v) = s' (add_prefix p1 v)"
  using com_add_prefix_valid'' com_only_vars
  by (metis prefix_def)

lemma f_inv_bisection'_IMP_Minus_correct:
  "\<lbrakk>(invoke_subprogram (p1 @ p2) f_inv_bisection'_IMP_Minus, s) \<Rightarrow>\<^bsup>t\<^esup> s';
    \<And>v. v \<in> vars \<Longrightarrow> \<not> (prefix p2 v);
     \<lbrakk>t = (f_inv_bisection'_imp_time 0 (f_inv_bisection'_imp_to_HOL_state (p1 @ p2) s));
      s' (add_prefix (p1 @ p2) f_inv_bisection'_L_str) =
        f_inv_bisection'_state_L (f_inv_bisection'_imp (f_inv_bisection'_imp_to_HOL_state (p1 @ p2) s));
      \<And>v. v \<in> vars \<Longrightarrow> s (add_prefix p1 v) = s' (add_prefix p1 v)\<rbrakk>
     \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  using f_inv_bisection'_IMP_Minus_correct_time f_inv_bisection'_IMP_Minus_correct_function_1
        IMP_Minus_correct_effects
  by auto

datatype f_inv_bisection_state = f_inv_bisection_state (f_inv_bisection_state_y: nat) (f_inv_bisection_state_ret: nat)

abbreviation "f_inv_bisection_prefix \<equiv> f_pref_str @ ''inv_bisection.''"
abbreviation "f_inv_bisection_y_str \<equiv> ''y''"
abbreviation "f_inv_bisection_ret_str \<equiv> ''ret''"

abbreviation
  "f_inv_bisection_IMP_vars \<equiv> {f_inv_bisection_y_str, f_inv_bisection_ret_str}"

definition "f_inv_bisection_imp_state_upd s = (let
    f_inv_bisection'_y = f_inv_bisection_state_y s;
    f_inv_bisection'_L = 0;
    f_inv_bisection'_R = Suc (f_inv_bisection_state_y s);

    f_inv_bisection_f_inv_bisection'_state = f_inv_bisection'_state f_inv_bisection'_y f_inv_bisection'_L f_inv_bisection'_R;
    f_inv_bisection'_ret = f_inv_bisection'_imp f_inv_bisection_f_inv_bisection'_state;

    f_inv_bisection_ret = f_inv_bisection'_state_L f_inv_bisection'_ret;
    ret = f_inv_bisection_state (f_inv_bisection_state_y s) f_inv_bisection_ret
  in
    ret)
"

fun f_inv_bisection_imp :: "f_inv_bisection_state \<Rightarrow> f_inv_bisection_state" where
  "f_inv_bisection_imp s =
  (let
    ret = f_inv_bisection_imp_state_upd s
  in
    ret
  )"

declare f_inv_bisection_imp.simps [simp del]

lemma f_inv_bisection_imp_correct:
   "f_inv_bisection_state_ret (f_inv_bisection_imp s) = f_inv_bisection (f_inv_bisection_state_y s)"
  by (subst f_inv_bisection_imp.simps) (auto simp: f_inv_bisection'_imp_correct f_inv_bisection_def f_inv_bisection_imp_state_upd_def
      Let_def f_inv_bisection_correct[symmetric] split: if_splits)

fun f_inv_bisection_imp_time:: "nat \<Rightarrow> f_inv_bisection_state\<Rightarrow> nat" where
  "f_inv_bisection_imp_time t s =
    (
      let
        f_inv_bisection'_y = f_inv_bisection_state_y s;
        t = t+2;
        f_inv_bisection'_L = 0;
        t = t+2;
        f_inv_bisection'_R = Suc (f_inv_bisection_state_y s);
        t = t+2;

        f_inv_bisection_f_inv_bisection'_state = f_inv_bisection'_state f_inv_bisection'_y f_inv_bisection'_L f_inv_bisection'_R;
        f_inv_bisection'_ret = f_inv_bisection'_imp f_inv_bisection_f_inv_bisection'_state;
        t = t + f_inv_bisection'_imp_time 0 f_inv_bisection_f_inv_bisection'_state;

        f_inv_bisection_ret = f_inv_bisection'_state_L f_inv_bisection'_ret;
        t = t+2;
        ret = t
      in
        ret
    )
"

lemmas [simp del] = f_inv_bisection_imp_time.simps

lemma f_inv_bisection_imp_time_acc: "(f_inv_bisection_imp_time (Suc t) s) = Suc (f_inv_bisection_imp_time t s)"
  apply(subst f_inv_bisection_imp_time.simps)
  apply(subst f_inv_bisection_imp_time.simps)
  apply (auto simp add: f_inv_bisection_imp_state_upd_def Let_def eval_nat_numeral split: if_splits)
  done

lemma f_inv_bisection_imp_time_acc_2: "(f_inv_bisection_imp_time x s) = x + (f_inv_bisection_imp_time 0 s)"
  by (induction x arbitrary: s)
     (auto simp add: f_inv_bisection_imp_time_acc f_inv_bisection_imp_state_upd_def Let_def eval_nat_numeral split: if_splits)

definition f_inv_bisection_IMP_Minus where
"f_inv_bisection_IMP_Minus \<equiv>
  (
    (f_inv_bisection'_pref @ f_inv_bisection'_y_str) ::= A (V f_inv_bisection_y_str);;
    (f_inv_bisection'_pref @ f_inv_bisection'_L_str) ::= A (N 0);;
    (f_inv_bisection'_pref @ f_inv_bisection'_R_str) ::= (V f_inv_bisection_y_str \<oplus> N 1);;

    invoke_subprogram f_inv_bisection'_pref f_inv_bisection'_IMP_Minus;;

    f_inv_bisection_ret_str ::= A (V (f_inv_bisection'_pref @ f_inv_bisection'_L_str))
  )"

definition "f_inv_bisection_imp_to_HOL_state p s = f_inv_bisection_state
  (s (add_prefix p f_inv_bisection_y_str)) (s (add_prefix p f_inv_bisection_ret_str))"

lemma f_inv_bisection_IMP_Minus_correct_function:
  "(invoke_subprogram p f_inv_bisection_IMP_Minus, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow>
     s' (add_prefix p f_inv_bisection_ret_str) = f_inv_bisection_state_ret (f_inv_bisection_imp (f_inv_bisection_imp_to_HOL_state p s))"
  apply(subst f_inv_bisection_imp.simps)
  apply(simp only: f_inv_bisection_IMP_Minus_def com_add_prefix.simps aexp_add_prefix.simps atomExp_add_prefix.simps invoke_subprogram_append)
  apply (erule Seq_tE)+
  apply(all \<open>erule f_inv_bisection'_IMP_Minus_correct[where vars = "f_inv_bisection_IMP_vars"]\<close>) (* Probably do not need this here *)
   apply simp
    (* ? *)
   apply auto[]
   apply (metis bot_nat_0.not_eq_extremum f_imp_state f_imp_state_in f_imp_state_out lessI)
   apply (metis bot_nat_0.not_eq_extremum f_imp_state f_imp_state_in f_imp_state_out lessI)
  apply (drule AssignD)+
  apply (auto simp add: f_inv_bisection_imp_state_upd_def f_inv_bisection_imp_to_HOL_state_def f_inv_bisection'_imp_to_HOL_state_def)
  done

lemma f_inv_bisection_IMP_Minus_correct_time:
  "(invoke_subprogram p f_inv_bisection_IMP_Minus, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow>
     t = f_inv_bisection_imp_time 0 (f_inv_bisection_imp_to_HOL_state p s)"
  apply(subst f_inv_bisection_imp_time.simps)
  apply(simp only: f_inv_bisection_IMP_Minus_def com_add_prefix.simps aexp_add_prefix.simps atomExp_add_prefix.simps invoke_subprogram_append)
  apply (erule Seq_tE)+
  apply(all \<open>erule f_inv_bisection'_IMP_Minus_correct[where vars = "f_inv_bisection_IMP_vars"]\<close>) (* Probably do not need this here *)
   apply simp
    (* ? *)
   apply auto[]
   apply (metis bot_nat_0.not_eq_extremum f_imp_state f_imp_state_in f_imp_state_out lessI)
   apply (metis bot_nat_0.not_eq_extremum f_imp_state f_imp_state_in f_imp_state_out lessI)
  apply (drule AssignD)+
  apply (auto simp add: f_inv_bisection_imp_state_upd_def f_inv_bisection_imp_to_HOL_state_def f_inv_bisection'_imp_to_HOL_state_def)
  done

lemma f_inv_bisection_IMP_Minus_correct:
  "\<lbrakk>(invoke_subprogram (p1 @ p2) f_inv_bisection_IMP_Minus, s) \<Rightarrow>\<^bsup>t\<^esup> s';
    \<And>v. v \<in> vars \<Longrightarrow> \<not> (prefix p2 v);
     \<lbrakk>t = (f_inv_bisection_imp_time 0 (f_inv_bisection_imp_to_HOL_state (p1 @ p2) s));
      s' (add_prefix (p1 @ p2) f_inv_bisection_ret_str) =
        f_inv_bisection_state_ret (f_inv_bisection_imp (f_inv_bisection_imp_to_HOL_state (p1 @ p2) s));
      \<And>v. v \<in> vars \<Longrightarrow> s (add_prefix p1 v) = s' (add_prefix p1 v)\<rbrakk>
     \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  using f_inv_bisection_IMP_Minus_correct_time f_inv_bisection_IMP_Minus_correct_function
        IMP_Minus_correct_effects
  by auto

end

end


(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section \<open>\isaheader{Set Implementation by non-distinct Lists}\<close>
theory ListSetImpl_NotDist
imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  (*"../common/ListAdd"*)
begin
text_raw \<open>\label{thy:ListSetImpl_NotDist}\<close>

(*@impl Set
  @type 'a lsnd
  @abbrv lsnd
  Sets implemented by lists that may contain duplicate elements.
  Insertion is quick, but other operations are less performant than on
  lists with distinct elements.
*)

type_synonym
  'a lsnd = "'a list"

subsection "Definitions"

definition lsnd_\<alpha> :: "'a lsnd \<Rightarrow> 'a set" where "lsnd_\<alpha> == set"
abbreviation (input) lsnd_invar
  :: "'a lsnd \<Rightarrow> bool" where "lsnd_invar == (\<lambda>_. True)"
definition lsnd_empty :: "unit \<Rightarrow> 'a lsnd" where "lsnd_empty == (\<lambda>_::unit. [])"
definition lsnd_memb :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> bool" where "lsnd_memb x l == List.member l x"
definition lsnd_ins :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_ins x l == x#l"
definition lsnd_ins_dj :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_ins_dj x l == x#l"

definition lsnd_delete :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_delete x l == remove_rev x l"

definition lsnd_iteratei :: "'a lsnd \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lsnd_iteratei l = foldli (remdups l)"

definition lsnd_isEmpty :: "'a lsnd \<Rightarrow> bool" where "lsnd_isEmpty s == s=[]"

definition lsnd_union :: "'a lsnd \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd"
  where "lsnd_union s1 s2 == revg s1 s2"
definition lsnd_union_dj :: "'a lsnd \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd"
  where "lsnd_union_dj s1 s2 == revg s1 s2" \<comment> \<open>Union of disjoint sets\<close>

definition lsnd_to_list :: "'a lsnd \<Rightarrow> 'a list" where "lsnd_to_list == remdups"
definition list_to_lsnd :: "'a list \<Rightarrow> 'a lsnd" where "list_to_lsnd == id"

subsection "Correctness"
lemmas lsnd_defs =
  lsnd_\<alpha>_def
  lsnd_empty_def
  lsnd_memb_def
  lsnd_ins_def
  lsnd_ins_dj_def
  lsnd_delete_def
  lsnd_iteratei_def
  lsnd_isEmpty_def
  lsnd_union_def
  lsnd_union_dj_def
  lsnd_to_list_def
  list_to_lsnd_def

lemma lsnd_empty_impl: "set_empty lsnd_\<alpha> lsnd_invar lsnd_empty"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_memb_impl: "set_memb lsnd_\<alpha> lsnd_invar lsnd_memb"
by (unfold_locales)(auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_impl: "set_ins lsnd_\<alpha> lsnd_invar lsnd_ins"
by (unfold_locales) (auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_dj_impl: "set_ins_dj lsnd_\<alpha> lsnd_invar lsnd_ins_dj"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_delete_impl: "set_delete lsnd_\<alpha> lsnd_invar lsnd_delete"
by (unfold_locales) (auto simp add: lsnd_delete_def lsnd_\<alpha>_def remove_rev_alt_def)

lemma lsnd_\<alpha>_finite[simp, intro!]: "finite (lsnd_\<alpha> l)"
  by (auto simp add: lsnd_defs)

lemma lsnd_is_finite_set: "finite_set lsnd_\<alpha> lsnd_invar"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_iteratei_impl: "poly_set_iteratei lsnd_\<alpha> lsnd_invar lsnd_iteratei"
proof
  fix l :: "'a list"
  show "finite (lsnd_\<alpha> l)"
    unfolding lsnd_\<alpha>_def by simp

  show "set_iterator (lsnd_iteratei l) (lsnd_\<alpha> l)"
    apply (rule set_iterator_I [of "remdups l"])
    apply (simp_all add: lsnd_\<alpha>_def lsnd_iteratei_def)
  done
qed

lemma lsnd_isEmpty_impl: "set_isEmpty lsnd_\<alpha> lsnd_invar lsnd_isEmpty"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_impl: "set_union lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_union"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_dj_impl: "set_union_dj lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_union_dj"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_to_list_impl: "set_to_list lsnd_\<alpha> lsnd_invar lsnd_to_list"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma list_to_lsnd_impl: "list_to_set lsnd_\<alpha> lsnd_invar list_to_lsnd"
by(unfold_locales)(auto simp add: lsnd_defs)

definition lsnd_basic_ops :: "('x,'x lsnd) set_basic_ops"
  where [icf_rec_def]: "lsnd_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = lsnd_\<alpha>,
    bset_op_invar = lsnd_invar,
    bset_op_empty = lsnd_empty,
    bset_op_memb = lsnd_memb,
    bset_op_ins = lsnd_ins,
    bset_op_ins_dj = lsnd_ins_dj,
    bset_op_delete = lsnd_delete,
    bset_op_list_it = lsnd_iteratei
  \<rparr>"

setup Locale_Code.open_block
interpretation lsnd_basic: StdBasicSet lsnd_basic_ops
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lsnd_empty_impl lsnd_memb_impl lsnd_ins_impl lsnd_ins_dj_impl
    lsnd_delete_impl lsnd_iteratei_impl)+
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsnd_ops \<equiv> lsnd_basic.dflt_ops \<lparr>
  set_op_isEmpty := lsnd_isEmpty,
  set_op_union := lsnd_union,
  set_op_union_dj := lsnd_union_dj,
  set_op_to_list := lsnd_to_list,
  set_op_from_list := list_to_lsnd
  \<rparr>"

setup Locale_Code.open_block
interpretation lsnd: StdSetDefs lsnd_ops .
interpretation lsnd: StdSet lsnd_ops
proof -
  interpret aux: StdSet lsnd_basic.dflt_ops
    by (rule lsnd_basic.dflt_ops_impl)

  show "StdSet lsnd_ops"
    unfolding lsnd_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lsnd_isEmpty_impl lsnd_union_impl lsnd_union_dj_impl lsnd_to_list_impl
      list_to_lsnd_impl
    )
    done
qed
interpretation lsnd: StdSet_no_invar lsnd_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

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

lemma pi_lsnd[proper_it]:
  "proper_it' lsnd_iteratei lsnd_iteratei"
  apply (rule proper_it'I)
  unfolding lsnd_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lsnd: proper_it_loc lsnd_iteratei lsnd_iteratei
  apply unfold_locales by (rule pi_lsnd)

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

export_code test_codegen checking SML

end


subsection \<open>Pair Memory\<close>

theory Pair_Memory
  imports "../state_monad/Memory"
begin

(* XXX Move *)
lemma map_add_mono:
  "(m1 ++ m2) \<subseteq>\<^sub>m (m1' ++ m2')" if "m1 \<subseteq>\<^sub>m m1'" "m2 \<subseteq>\<^sub>m m2'" "dom m1 \<inter> dom m2' = {}"
  using that unfolding map_le_def map_add_def dom_def by (auto split: option.splits)

lemma map_add_upd2:
  "f(x \<mapsto> y) ++ g = (f ++ g)(x \<mapsto> y)" if "dom f \<inter> dom g = {}" "x \<notin> dom g"
  apply (subst map_add_comm)
   defer
   apply simp
   apply (subst map_add_comm)
  using that
  by auto

locale pair_mem_defs =
  fixes lookup1 lookup2 :: "'a \<Rightarrow> ('mem, 'v option) state"
    and update1 update2 :: "'a \<Rightarrow> 'v \<Rightarrow> ('mem, unit) state"
    and move12 :: "'k1 \<Rightarrow> ('mem, unit) state"
    and get_k1 get_k2 :: "('mem, 'k1) state"
    and P :: "'mem \<Rightarrow> bool"
  fixes key1 :: "'k \<Rightarrow> 'k1" and key2 :: "'k \<Rightarrow> 'a"
begin

text \<open>We assume that look-ups happen on the older row, so it is biased towards the second entry.\<close>
definition
  "lookup_pair k = do {
     let k' = key1 k;
     k2 \<leftarrow> get_k2;
     if k' = k2
     then lookup2 (key2 k)
     else do {
       k1 \<leftarrow> get_k1;
       if k' = k1
       then lookup1 (key2 k)
       else State_Monad.return None
     }
   }
   "

text \<open>We assume that updates happen on the newer row, so it is biased towards the first entry.\<close>
definition
  "update_pair k v = do {
    let k' = key1 k;
    k1 \<leftarrow> get_k1;
    if k' = k1
    then update1 (key2 k) v
    else do {
      k2 \<leftarrow> get_k2;
      if k' = k2
      then update2 (key2 k) v
      else (move12 k' \<then> update1 (key2 k) v)
    }
  }
  "

sublocale pair: state_mem_defs lookup_pair update_pair .

sublocale mem1: state_mem_defs lookup1 update1 .

sublocale mem2: state_mem_defs lookup2 update2 .

definition
  "inv_pair heap \<equiv>
    let
      k1 = fst (State_Monad.run_state get_k1 heap);
      k2 = fst (State_Monad.run_state get_k2 heap)
    in
    (\<forall> k \<in> dom (mem1.map_of heap). \<exists> k'. key1 k' = k1 \<and> key2 k' = k) \<and>
    (\<forall> k \<in> dom (mem2.map_of heap). \<exists> k'. key1 k' = k2 \<and> key2 k' = k) \<and>
    k1 \<noteq> k2 \<and> P heap
  "

definition
  "map_of1 m k = (if key1 k = fst (State_Monad.run_state get_k1 m) then mem1.map_of m (key2 k) else None)"

definition
  "map_of2 m k = (if key1 k = fst (State_Monad.run_state get_k2 m) then mem2.map_of m (key2 k) else None)"

end (* Pair Mem Defs *)

locale pair_mem = pair_mem_defs +
  assumes get_state:
    "State_Monad.run_state get_k1 m = (k, m') \<Longrightarrow> m' = m"
    "State_Monad.run_state get_k2 m = (k, m') \<Longrightarrow> m' = m"
  assumes move12_correct:
    "P m \<Longrightarrow> State_Monad.run_state (move12 k1) m = (x, m') \<Longrightarrow> mem1.map_of m' \<subseteq>\<^sub>m Map.empty"
    "P m \<Longrightarrow> State_Monad.run_state (move12 k1) m = (x, m') \<Longrightarrow> mem2.map_of m' \<subseteq>\<^sub>m mem1.map_of m"
  assumes move12_keys:
    "State_Monad.run_state (move12 k1) m = (x, m') \<Longrightarrow> fst (State_Monad.run_state get_k1 m') = k1"
    "State_Monad.run_state (move12 k1) m = (x, m') \<Longrightarrow> fst (State_Monad.run_state get_k2 m') = fst (State_Monad.run_state get_k1 m)"
  assumes move12_inv:
    "lift_p P (move12 k1)"
  assumes lookup_inv:
    "lift_p P (lookup1 k')" "lift_p P (lookup2 k')"
  assumes update_inv:
    "lift_p P (update1 k' v)" "lift_p P (update2 k' v)"
  assumes lookup_keys:
    "P m \<Longrightarrow> State_Monad.run_state (lookup1 k') m = (v', m') \<Longrightarrow>
     fst (State_Monad.run_state get_k1 m') = fst (State_Monad.run_state get_k1 m)"
    "P m \<Longrightarrow> State_Monad.run_state (lookup1 k') m = (v', m') \<Longrightarrow>
     fst (State_Monad.run_state get_k2 m') = fst (State_Monad.run_state get_k2 m)"
    "P m \<Longrightarrow> State_Monad.run_state (lookup2 k') m = (v', m') \<Longrightarrow>
     fst (State_Monad.run_state get_k1 m') = fst (State_Monad.run_state get_k1 m)"
    "P m \<Longrightarrow> State_Monad.run_state (lookup2 k') m = (v', m') \<Longrightarrow>
     fst (State_Monad.run_state get_k2 m') = fst (State_Monad.run_state get_k2 m)"
  assumes update_keys:
    "P m \<Longrightarrow> State_Monad.run_state (update1 k' v) m = (x, m') \<Longrightarrow>
     fst (State_Monad.run_state get_k1 m') = fst (State_Monad.run_state get_k1 m)"
    "P m \<Longrightarrow> State_Monad.run_state (update1 k' v) m = (x, m') \<Longrightarrow>
     fst (State_Monad.run_state get_k2 m') = fst (State_Monad.run_state get_k2 m)"
    "P m \<Longrightarrow> State_Monad.run_state (update2 k' v) m = (x, m') \<Longrightarrow>
     fst (State_Monad.run_state get_k1 m') = fst (State_Monad.run_state get_k1 m)"
    "P m \<Longrightarrow> State_Monad.run_state (update2 k' v) m = (x, m') \<Longrightarrow>
     fst (State_Monad.run_state get_k2 m') = fst (State_Monad.run_state get_k2 m)"
  assumes
    lookup_correct:
      "P m \<Longrightarrow> mem1.map_of (snd (State_Monad.run_state (lookup1 k') m)) \<subseteq>\<^sub>m (mem1.map_of m)"
      "P m \<Longrightarrow> mem2.map_of (snd (State_Monad.run_state (lookup1 k') m)) \<subseteq>\<^sub>m (mem2.map_of m)"
      "P m \<Longrightarrow> mem1.map_of (snd (State_Monad.run_state (lookup2 k') m)) \<subseteq>\<^sub>m (mem1.map_of m)"
      "P m \<Longrightarrow> mem2.map_of (snd (State_Monad.run_state (lookup2 k') m)) \<subseteq>\<^sub>m (mem2.map_of m)"
  assumes
    update_correct:
      "P m \<Longrightarrow> mem1.map_of (snd (State_Monad.run_state (update1 k' v) m)) \<subseteq>\<^sub>m (mem1.map_of m)(k' \<mapsto> v)"
      "P m \<Longrightarrow> mem2.map_of (snd (State_Monad.run_state (update2 k' v) m)) \<subseteq>\<^sub>m (mem2.map_of m)(k' \<mapsto> v)"
      "P m \<Longrightarrow> mem2.map_of (snd (State_Monad.run_state (update1 k' v) m)) \<subseteq>\<^sub>m mem2.map_of m"
      "P m \<Longrightarrow> mem1.map_of (snd (State_Monad.run_state (update2 k' v) m)) \<subseteq>\<^sub>m mem1.map_of m"
begin

lemma map_of_le_pair:
  "pair.map_of m \<subseteq>\<^sub>m map_of1 m ++ map_of2 m"
  if "inv_pair m"
  using that
  unfolding pair.map_of_def map_of1_def map_of2_def
  unfolding lookup_pair_def inv_pair_def map_of_def map_le_def dom_def map_add_def
  unfolding State_Monad.bind_def
  by (auto 4 4
        simp: mem2.map_of_def mem1.map_of_def Let_def
        dest: get_state split: prod.split_asm if_split_asm
     )

lemma pair_le_map_of:
  "map_of1 m ++ map_of2 m \<subseteq>\<^sub>m pair.map_of m"
  if "inv_pair m"
  using that
  unfolding pair.map_of_def map_of1_def map_of2_def
  unfolding lookup_pair_def inv_pair_def map_of_def map_le_def dom_def map_add_def
  unfolding State_Monad.bind_def
  by (auto
        simp: mem2.map_of_def mem1.map_of_def State_Monad.run_state_return Let_def
        dest: get_state split: prod.splits if_split_asm option.split
     )

lemma map_of_eq_pair:
  "map_of1 m ++ map_of2 m = pair.map_of m"
  if "inv_pair m"
  using that
  unfolding pair.map_of_def map_of1_def map_of2_def
  unfolding lookup_pair_def inv_pair_def map_of_def map_le_def dom_def map_add_def
  unfolding State_Monad.bind_def
  by (auto 4 4
        simp: mem2.map_of_def mem1.map_of_def State_Monad.run_state_return Let_def
        dest: get_state split: prod.splits option.split
     )

lemma inv_pair_neq[simp]:
  False if "inv_pair m" "fst (State_Monad.run_state get_k1 m) = fst (State_Monad.run_state get_k2 m)"
  using that unfolding inv_pair_def by auto

lemma inv_pair_P_D:
  "P m" if "inv_pair m"
  using that unfolding inv_pair_def by (auto simp: Let_def)

lemma inv_pair_domD[intro]:
  "dom (map_of1 m) \<inter> dom (map_of2 m) = {}" if "inv_pair m"
  using that unfolding inv_pair_def map_of1_def map_of2_def by (auto split: if_split_asm)

lemma move12_correct2:
  "map_of2 heap' \<subseteq>\<^sub>m map_of1 heap" if "State_Monad.run_state (move12 k1) heap = (x, heap')" "P heap"
  using move12_correct(2)[OF that(2,1)] that unfolding map_of1_def map_of2_def
  by (auto simp: move12_keys map_le_def)

lemma dom_empty[simp]:
  "dom (map_of1 heap') = {}" if "State_Monad.run_state (move12 k1) heap = (x, heap')" "P heap"
  using move12_correct1[OF that] by (auto dest: map_le_implies_dom_le)

lemma inv_pair_lookup1:
  "inv_pair m'" if "State_Monad.run_state (lookup1 k) m = (v, m')" "inv_pair m"
  using that lookup_inv[of k] inv_pair_P_D[OF \<open>inv_pair m\<close>] unfolding inv_pair_def
  by (auto 4 4
        simp: Let_def lookup_keys
        dest: lift_p_P lookup_correct[of _ k, THEN map_le_implies_dom_le]
     )

lemma inv_pair_lookup2:
  "inv_pair m'" if "State_Monad.run_state (lookup2 k) m = (v, m')" "inv_pair m"
  using that lookup_inv[of k] inv_pair_P_D[OF \<open>inv_pair m\<close>] unfolding inv_pair_def
  by (auto 4 4
        simp: Let_def lookup_keys
        dest: lift_p_P lookup_correct[of _ k, THEN map_le_implies_dom_le]
     )

lemma inv_pair_update1:
  "inv_pair m'"
  if "State_Monad.run_state (update1 (key2 k) v) m = (v', m')" "inv_pair m" "fst (State_Monad.run_state get_k1 m) = key1 k"
  using that update_inv[of "key2 k" v] inv_pair_P_D[OF \<open>inv_pair m\<close>] unfolding inv_pair_def
  apply (auto
        simp: Let_def update_keys
        dest: lift_p_P update_correct[of _ "key2 k" v, THEN map_le_implies_dom_le]
     )
   apply (frule update_correct[of _ "key2 k" v, THEN map_le_implies_dom_le]; auto 13 2; fail)
  apply (frule update_correct[of _ "key2 k" v, THEN map_le_implies_dom_le]; auto 13 2; fail)
  done

lemma inv_pair_update2:
  "inv_pair m'"
  if "State_Monad.run_state (update2 (key2 k) v) m = (v', m')" "inv_pair m" "fst (State_Monad.run_state get_k2 m) = key1 k"
  using that update_inv[of "key2 k" v] inv_pair_P_D[OF \<open>inv_pair m\<close>] unfolding inv_pair_def
  apply (auto
        simp: Let_def update_keys
        dest: lift_p_P update_correct[of _ "key2 k" v, THEN map_le_implies_dom_le]
     )
   apply (frule update_correct[of _ "key2 k" v, THEN map_le_implies_dom_le]; auto 13 2; fail)
  apply (frule update_correct[of _ "key2 k" v, THEN map_le_implies_dom_le]; auto 13 2; fail)
  done

lemma inv_pair_move12:
  "inv_pair m'"
  if "State_Monad.run_state (move12 k) m = (v', m')" "inv_pair m" "fst (State_Monad.run_state get_k1 m) \<noteq> k"
  using that move12_inv[of "k"] inv_pair_P_D[OF \<open>inv_pair m\<close>] unfolding inv_pair_def
  apply (auto
        simp: Let_def move12_keys
        dest: lift_p_P move12_correct[of _ "k", THEN map_le_implies_dom_le]
     )
  apply (blast dest: move12_correct[of _ "k", THEN map_le_implies_dom_le])
  done

lemma mem_correct_pair:
  "mem_correct lookup_pair update_pair inv_pair"
  if injective: "\<forall> k k'. key1 k = key1 k' \<and> key2 k = key2 k' \<longrightarrow> k = k'"
proof (standard, goal_cases)
  case (1 k) \<comment> \<open>Lookup invariant\<close>
  show ?case
    unfolding lookup_pair_def Let_def
    by (auto 4 4
        intro!: lift_pI
        dest: get_state inv_pair_lookup1 inv_pair_lookup2
        simp: State_Monad.bind_def State_Monad.run_state_return
        split: if_split_asm prod.split_asm
        )
next
  case (2 k v) \<comment> \<open>Update invariant\<close>
  show ?case
    unfolding update_pair_def Let_def
    apply (auto 4 4
        intro!: lift_pI intro: inv_pair_update1 inv_pair_update2
        dest: get_state
        simp: State_Monad.bind_def get_state State_Monad.run_state_return
        split: if_split_asm prod.split_asm
        )+
    apply (elim inv_pair_update1 inv_pair_move12)
      apply (((subst get_state, assumption)+)?, auto intro: move12_keys dest: get_state; fail)+
    done
next
  case (3 m k)
  {
    let ?m = "snd (State_Monad.run_state (lookup2 (key2 k)) m)"
    have "map_of1 ?m \<subseteq>\<^sub>m map_of1 m"
      by (smt 3 domIff inv_pair_P_D local.lookup_keys lookup_correct map_le_def map_of1_def surjective_pairing)
    moreover have "map_of2 ?m \<subseteq>\<^sub>m map_of2 m"
      by (smt 3 domIff inv_pair_P_D local.lookup_keys lookup_correct map_le_def map_of2_def surjective_pairing)
    moreover have "dom (map_of1 ?m) \<inter> dom (map_of2 m) = {}"
      using 3 \<open>map_of1 ?m \<subseteq>\<^sub>m map_of1 m\<close> inv_pair_domD map_le_implies_dom_le by fastforce
    moreover have "inv_pair ?m"
      using 3 inv_pair_lookup2 surjective_pairing by metis
    ultimately have "pair.map_of ?m \<subseteq>\<^sub>m pair.map_of m"
      apply (subst map_of_eq_pair[symmetric])
       defer
       apply (subst map_of_eq_pair[symmetric])
      by (auto intro: 3 map_add_mono)
  }
  moreover
  {
    let ?m = "snd (State_Monad.run_state (lookup1 (key2 k)) m)"
    have "map_of1 ?m \<subseteq>\<^sub>m map_of1 m"
      by (smt 3 domIff inv_pair_P_D local.lookup_keys lookup_correct map_le_def map_of1_def surjective_pairing)
    moreover have "map_of2 ?m \<subseteq>\<^sub>m map_of2 m"
      by (smt 3 domIff inv_pair_P_D local.lookup_keys lookup_correct map_le_def map_of2_def surjective_pairing)
    moreover have "dom (map_of1 ?m) \<inter> dom (map_of2 m) = {}"
      using 3 \<open>map_of1 ?m \<subseteq>\<^sub>m map_of1 m\<close> inv_pair_domD map_le_implies_dom_le by fastforce
    moreover have "inv_pair ?m"
      using 3 inv_pair_lookup1 surjective_pairing by metis
    ultimately have "pair.map_of ?m \<subseteq>\<^sub>m pair.map_of m"
      apply (subst map_of_eq_pair[symmetric])
       defer
       apply (subst map_of_eq_pair[symmetric])
      by (auto intro: 3 map_add_mono)
  }
  ultimately show ?case
    by (auto
        split:if_split prod.split
        simp: Let_def lookup_pair_def State_Monad.bind_def State_Monad.run_state_return dest: get_state intro: map_le_refl
        )
next
  case prems: (4 m k v)
  let ?m1 = "snd (State_Monad.run_state (update1 (key2 k) v) m)"
  let ?m2 = "snd (State_Monad.run_state (update2 (key2 k) v) m)"
  from prems have disjoint: "dom (map_of1 m) \<inter> dom (map_of2 m) = {}"
    by (simp add: inv_pair_domD)
  show ?case
    apply (auto
        intro: map_le_refl dest: get_state
        split: prod.split
        simp: Let_def update_pair_def State_Monad.bind_def State_Monad.run_state_return
        )
  proof goal_cases
    case (1 m')
    then have "m' = m"
      by (rule get_state)
    from 1 prems have "map_of1 ?m1 \<subseteq>\<^sub>m map_of1 m(k \<mapsto> v)"
      by (smt inv_pair_P_D map_le_def map_of1_def surjective_pairing domIff
          fst_conv fun_upd_apply injective update_correct update_keys
          )
    moreover from prems have "map_of2 ?m1 \<subseteq>\<^sub>m map_of2 m"
      by (smt domIff inv_pair_P_D update_correct update_keys map_le_def map_of2_def surjective_pairing)
    moreover from prems have "dom (map_of1 ?m1) \<inter> dom (map_of2 m) = {}"
      by (smt inv_pair_P_D[OF \<open>inv_pair m\<close>] domIff Int_emptyI eq_snd_iff inv_pair_neq
          map_of1_def map_of2_def update_keys(1)
          )
    moreover from 1 prems have "k \<notin> dom (map_of2 m)"
      using inv_pair_neq map_of2_def by fastforce
    moreover from 1 prems have "inv_pair ?m1"
      using inv_pair_update1 fst_conv surjective_pairing by metis
    ultimately show "pair.map_of (snd (State_Monad.run_state (update1 (key2 k) v) m')) \<subseteq>\<^sub>m pair.map_of m(k \<mapsto> v)"
      unfolding \<open>m' = m\<close> using disjoint
      apply (subst map_of_eq_pair[symmetric])
       defer
       apply (subst map_of_eq_pair[symmetric], rule prems)
       apply (subst map_add_upd2[symmetric])
      by (auto intro: map_add_mono)
  next
    case (2 k1 m' m'')
    then have "m' = m" "m'' = m"
      by (auto dest: get_state)
    from 2 prems have "map_of2 ?m2 \<subseteq>\<^sub>m map_of2 m(k \<mapsto> v)"
      unfolding \<open>m' = m\<close> \<open>m'' = m\<close>
      by (smt inv_pair_P_D map_le_def map_of2_def surjective_pairing domIff
          fst_conv fun_upd_apply injective update_correct update_keys
          )
    moreover from prems have "map_of1 ?m2 \<subseteq>\<^sub>m map_of1 m"
      by (smt domIff inv_pair_P_D update_correct update_keys map_le_def map_of1_def surjective_pairing)
    moreover from 2 have "dom (map_of1 ?m2) \<inter> dom (map_of2 m(k \<mapsto> v)) = {}"
      unfolding \<open>m' = m\<close>
      by (smt domIff \<open>map_of1 ?m2 \<subseteq>\<^sub>m map_of1 m\<close> disjoint_iff_not_equal fst_conv fun_upd_apply
          map_le_def map_of1_def map_of2_def
          )
    moreover from 2 prems have "inv_pair ?m2"
      unfolding \<open>m' = m\<close>
      using inv_pair_update2 fst_conv surjective_pairing by metis
    ultimately show "pair.map_of (snd (State_Monad.run_state (update2 (key2 k) v) m'')) \<subseteq>\<^sub>m pair.map_of m(k \<mapsto> v)"
      unfolding \<open>m' = m\<close> \<open>m'' = m\<close>
      apply (subst map_of_eq_pair[symmetric])
       defer
       apply (subst map_of_eq_pair[symmetric], rule prems)
       apply (subst map_add_upd[symmetric])
      by (rule map_add_mono)
  next
    case (3 k1 m1 k2 m2 m3)
    then have "m1 = m" "m2 = m"
      by (auto dest: get_state)
    let ?m3 = "snd (State_Monad.run_state (update1 (key2 k) v) m3)"
    from 3 prems have "map_of1 ?m3 \<subseteq>\<^sub>m map_of2 m(k \<mapsto> v)"
      unfolding \<open>m2 = m\<close>
      by (smt inv_pair_P_D map_le_def map_of1_def surjective_pairing domIff
          fst_conv fun_upd_apply injective
          inv_pair_move12 move12_correct move12_keys update_correct update_keys
          )
    moreover have "map_of2 ?m3 \<subseteq>\<^sub>m map_of1 m"
    proof -
      from prems 3 have "P m" "P m3"
        unfolding \<open>m1 = m\<close> \<open>m2 = m\<close>
        using inv_pair_P_D[OF prems] by (auto elim: lift_p_P[OF move12_inv])
      from 3(3)[unfolded \<open>m2 = m\<close>] have "mem2.map_of ?m3 \<subseteq>\<^sub>m mem1.map_of m"
        by - (erule map_le_trans[OF update_correct(3)[OF \<open>P m3\<close>] move12_correct(2)[OF \<open>P m\<close>]])
      with 3 prems show ?thesis
        unfolding \<open>m1 = m\<close> \<open>m2 = m\<close> map_le_def map_of2_def
        apply auto
        apply (frule move12_keys(2), simp)
        by (metis
            domI inv_pair_def map_of1_def surjective_pairing
            inv_pair_move12 move12_keys(2) update_keys(2)
            )
    qed
    moreover from prems 3 have "dom (map_of1 ?m3) \<inter> dom (map_of1 m) = {}"
      unfolding \<open>m1 = m\<close> \<open>m2 = m\<close>
      by (smt inv_pair_P_D disjoint_iff_not_equal map_of1_def surjective_pairing domIff
          fst_conv inv_pair_move12 move12_keys update_keys
          )
    moreover from 3 have "k \<notin> dom (map_of1 m)"
      by (simp add: domIff map_of1_def)
    moreover from 3 prems have "inv_pair ?m3"
      unfolding \<open>m2 = m\<close>
      by (metis inv_pair_move12 inv_pair_update1 move12_keys(1) fst_conv surjective_pairing)
    ultimately show ?case
      unfolding \<open>m1 = m\<close> \<open>m2 = m\<close> using disjoint
      apply (subst map_of_eq_pair[symmetric])
       defer
       apply (subst map_of_eq_pair[symmetric])
        apply (rule prems)
       apply (subst (2) map_add_comm)
        defer
        apply (subst map_add_upd2[symmetric])
          apply (auto intro: map_add_mono)
      done
  qed
qed

lemma emptyI:
  assumes "inv_pair m" "mem1.map_of m \<subseteq>\<^sub>m Map.empty" "mem2.map_of m \<subseteq>\<^sub>m Map.empty"
  shows "pair.map_of m \<subseteq>\<^sub>m Map.empty"
  using assms by (auto simp: map_of1_def map_of2_def map_le_def map_of_eq_pair[symmetric])

end (* Pair Mem *)

datatype ('k, 'v) pair_storage = Pair_Storage 'k 'k 'v 'v

context mem_correct_empty
begin

context
  fixes key :: "'a \<Rightarrow> 'k"
begin

text \<open>We assume that look-ups happen on the older row, so it is biased towards the second entry.\<close>
definition
  "lookup_pair k =
    State (\<lambda> mem.
    (
      case mem of Pair_Storage k1 k2 m1 m2 \<Rightarrow> let k' = key k in
        if k' = k2 then case State_Monad.run_state (lookup k) m2 of (v, m) \<Rightarrow> (v, Pair_Storage k1 k2 m1 m)
        else if k' = k1 then case State_Monad.run_state (lookup k) m1 of (v, m) \<Rightarrow> (v, Pair_Storage k1 k2 m m2)
        else (None, mem)
    )
    )
  "

text \<open>We assume that updates happen on the newer row, so it is biased towards the first entry.\<close>
definition
  "update_pair k v =
    State (\<lambda> mem.
    (
      case mem of Pair_Storage k1 k2 m1 m2 \<Rightarrow> let k' = key k in
        if k' = k1 then case State_Monad.run_state (update k v) m1 of (_, m) \<Rightarrow> ((), Pair_Storage k1 k2 m m2)
        else if k' = k2 then case State_Monad.run_state (update k v) m2 of (_, m) \<Rightarrow> ((),Pair_Storage k1 k2 m1 m)
        else case State_Monad.run_state (update k v) empty of (_, m) \<Rightarrow> ((), Pair_Storage k' k1 m m1)
    )
    )
  "

interpretation pair: state_mem_defs lookup_pair update_pair .

definition
  "inv_pair p = (case p of Pair_Storage k1 k2 m1 m2 \<Rightarrow>
    key ` dom (map_of m1) \<subseteq> {k1} \<and> key ` dom (map_of m2) \<subseteq> {k2} \<and> k1 \<noteq> k2 \<and> P m1 \<and> P m2
  )"

lemma map_of_le_pair:
  "pair.map_of (Pair_Storage k1 k2 m1 m2) \<subseteq>\<^sub>m (map_of m1 ++ map_of m2)"
  if "inv_pair (Pair_Storage k1 k2 m1 m2)"
  using that
  unfolding pair.map_of_def
  unfolding lookup_pair_def inv_pair_def map_of_def map_le_def dom_def map_add_def
  by (auto 4 6 split: prod.split_asm if_split_asm option.split simp: Let_def)

lemma pair_le_map_of:
  "map_of m1 ++ map_of m2 \<subseteq>\<^sub>m pair.map_of (Pair_Storage k1 k2 m1 m2)"
  if "inv_pair (Pair_Storage k1 k2 m1 m2)"
  using that
  unfolding pair.map_of_def
  unfolding lookup_pair_def inv_pair_def map_of_def map_le_def dom_def map_add_def
  by (auto 4 5 split: prod.split_asm if_split_asm option.split simp: Let_def)

lemma map_of_eq_pair:
  "map_of m1 ++ map_of m2 = pair.map_of (Pair_Storage k1 k2 m1 m2)"
  if "inv_pair (Pair_Storage k1 k2 m1 m2)"
  using that
  unfolding pair.map_of_def
  unfolding lookup_pair_def inv_pair_def map_of_def map_le_def dom_def map_add_def
  by (auto 4 7 split: prod.split_asm if_split_asm option.split simp: Let_def)

lemma inv_pair_neq[simp, dest]:
  False if "inv_pair (Pair_Storage k k x y)"
  using that unfolding inv_pair_def by auto

lemma inv_pair_P_D1:
  "P m1" if "inv_pair (Pair_Storage k1 k2 m1 m2)"
  using that unfolding inv_pair_def by auto

lemma inv_pair_P_D2:
  "P m2" if "inv_pair (Pair_Storage k1 k2 m1 m2)"
  using that unfolding inv_pair_def by auto

lemma inv_pair_domD[intro]:
  "dom (map_of m1) \<inter> dom (map_of m2) = {}" if "inv_pair (Pair_Storage k1 k2 m1 m2)"
  using that unfolding inv_pair_def by fastforce

lemma mem_correct_pair:
  "mem_correct lookup_pair update_pair inv_pair"
proof (standard, goal_cases)
  case (1 k) \<comment> \<open>Lookup invariant\<close>
  with lookup_inv[of k] show ?case
    unfolding lookup_pair_def Let_def
    by (auto intro!: lift_pI split: pair_storage.split_asm if_split_asm prod.split_asm)
       (auto dest: lift_p_P simp: inv_pair_def,
         (force dest!: lookup_correct[of _ k] map_le_implies_dom_le)+
       )
next
  case (2 k v) \<comment> \<open>Update invariant\<close>
  with update_inv[of k v] update_correct[OF P_empty, of k v] P_empty show ?case
    unfolding update_pair_def Let_def
    by (auto intro!: lift_pI split: pair_storage.split_asm if_split_asm prod.split_asm)
       (auto dest: lift_p_P simp: inv_pair_def,
         (force dest: lift_p_P dest!: update_correct[of _ k v] map_le_implies_dom_le)+
       )
next
  case (3 m k)
  {
    fix m1 v1 m1' m2 v2 m2' k1 k2
    assume assms:
      "State_Monad.run_state (lookup k) m1 = (v1, m1')" "State_Monad.run_state (lookup k) m2 = (v2, m2')"
      "inv_pair (Pair_Storage k1 k2 m1 m2)"
    from assms have "P m1" "P m2"
      by (auto intro: inv_pair_P_D1 inv_pair_P_D2)
    have [intro]: "map_of m1' \<subseteq>\<^sub>m map_of m1" "map_of m2' \<subseteq>\<^sub>m map_of m2"
      using lookup_correct[OF \<open>P m1\<close>, of k] lookup_correct[OF \<open>P m2\<close>, of k] assms by auto
    from inv_pair_domD[OF assms(3)] have 1: "dom (map_of m1') \<inter> dom (map_of m2) = {}"
      by (metis (no_types) \<open>map_of m1' \<subseteq>\<^sub>m map_of m1\<close> disjoint_iff_not_equal domIff map_le_def)
    have inv1: "inv_pair (Pair_Storage (key k) k2 m1' m2)" if "k2 \<noteq> key k" "k1 = key k"
      using that \<open>P m1\<close> \<open>P m2\<close> unfolding inv_pair_def
      apply clarsimp
      apply safe
      subgoal for x' y
        using assms(1,3) lookup_correct[OF \<open>P m1\<close>, of k, THEN map_le_implies_dom_le]
        unfolding inv_pair_def by auto
      subgoal for x' y
        using assms(3) unfolding inv_pair_def by fastforce
      using lookup_inv[of k] assms unfolding lift_p_def by force
    have inv2: "inv_pair (Pair_Storage k1 (key k) m1 m2')" if "k2 = key k" "k1 \<noteq> key k"
      using that \<open>P m1\<close> \<open>P m2\<close> unfolding inv_pair_def
      apply clarsimp
      apply safe
      subgoal for x' y
        using assms(3) unfolding inv_pair_def by fastforce
      subgoal for x x' y
        using assms(2,3) lookup_correct[OF \<open>P m2\<close>, of k, THEN map_le_implies_dom_le]
        unfolding inv_pair_def by fastforce
      using lookup_inv[of k] assms unfolding lift_p_def by force
    have A:
      "pair.map_of (Pair_Storage (key k) k2 m1' m2) \<subseteq>\<^sub>m pair.map_of (Pair_Storage (key k) k2 m1 m2)"
      if "k2 \<noteq> key k" "k1 = key k"
      using inv1 assms(3) 1
      by (auto intro: map_add_mono map_le_refl simp: that map_of_eq_pair[symmetric])
    have B:
      "pair.map_of (Pair_Storage k1 (key k) m1 m2') \<subseteq>\<^sub>m pair.map_of (Pair_Storage k1 (key k) m1 m2)"
      if "k2 = key k" "k1 \<noteq> key k"
      using inv2 assms(3) that
      by (auto intro: map_add_mono map_le_refl simp: map_of_eq_pair[symmetric] dest: inv_pair_domD)
    note A B
  }
  with \<open>inv_pair m\<close> show ?case
    by (auto split: pair_storage.split if_split prod.split simp: Let_def lookup_pair_def)
next
  case (4 m k v)
  {
    fix m1 v1 m1' m2 v2 m2' m3 k1 k2
    assume assms:
      "State_Monad.run_state (update k v) m1 = ((), m1')" "State_Monad.run_state (update k v) m2 = ((), m2')"
      "State_Monad.run_state (update k v) empty = ((), m3)"
      "inv_pair (Pair_Storage k1 k2 m1 m2)"
    from assms have "P m1" "P m2"
      by (auto intro: inv_pair_P_D1 inv_pair_P_D2)
    from assms(3) P_empty update_inv[of k v] have "P m3"
      unfolding lift_p_def by auto
    have [intro]: "map_of m1' \<subseteq>\<^sub>m map_of m1(k \<mapsto> v)" "map_of m2' \<subseteq>\<^sub>m map_of m2(k \<mapsto> v)"
      using update_correct[OF \<open>P m1\<close>, of k v] update_correct[OF \<open>P m2\<close>, of k v] assms by auto
    have "map_of m3 \<subseteq>\<^sub>m map_of empty(k \<mapsto> v)"
      using assms(3) update_correct[OF P_empty, of k v] by auto
    also have "\<dots> \<subseteq>\<^sub>m map_of m2(k \<mapsto> v)"
      using empty_correct by (auto elim: map_le_trans intro!: map_le_upd)
    finally have "map_of m3 \<subseteq>\<^sub>m map_of m2(k \<mapsto> v)" .
    have 1: "dom (map_of m1) \<inter> dom (map_of m2(k \<mapsto> v)) = {}" if "k1 \<noteq> key k"
      using assms(4) that by (force simp: inv_pair_def)
    have 2: "dom (map_of m3) \<inter> dom (map_of m1) = {}" if "k1 \<noteq> key k"
      using \<open>local.map_of m3 \<subseteq>\<^sub>m local.map_of empty(k \<mapsto> v)\<close> assms(4) that
      by (fastforce dest!: map_le_implies_dom_le simp: inv_pair_def)
    have inv: "inv_pair (Pair_Storage (key k) k1 m3 m1)" if "k2 \<noteq> key k" "k1 \<noteq> key k"
      using that \<open>P m1\<close> \<open>P m2\<close> \<open>P m3\<close> unfolding inv_pair_def
      apply clarsimp
      apply safe
      subgoal for x x' y
        using assms(3) update_correct[OF P_empty, of k v, THEN map_le_implies_dom_le]
          empty_correct
        by (auto dest: map_le_implies_dom_le)
      subgoal for x x' y
        using assms(4) unfolding inv_pair_def by fastforce
      done
    have A:
      "pair.map_of (Pair_Storage (key k) k1 m3 m1) \<subseteq>\<^sub>m pair.map_of (Pair_Storage k1 k2 m1 m2)(k \<mapsto> v)"
      if "k2 \<noteq> key k" "k1 \<noteq> key k"
      using inv assms(4) \<open>map_of m3 \<subseteq>\<^sub>m map_of m2(k \<mapsto> v)\<close> 1
      apply (simp add: that map_of_eq_pair[symmetric])
      apply (subst map_add_upd[symmetric], subst Map.map_add_comm, rule 2, rule that)
      by (rule map_add_mono; auto)
    have inv1: "inv_pair (Pair_Storage (key k) k2 m1' m2)" if "k2 \<noteq> key k" "k1 = key k"
      using that \<open>P m1\<close> \<open>P m2\<close> unfolding inv_pair_def
      apply clarsimp
      apply safe
      subgoal for x' y
        using assms(1,4) update_correct[OF \<open>P m1\<close>, of k v, THEN map_le_implies_dom_le]
        unfolding inv_pair_def by auto
      subgoal for x' y
        using assms(4) unfolding inv_pair_def by fastforce
      using update_inv[of k v] assms unfolding lift_p_def by force
    have inv2: "inv_pair (Pair_Storage k1 (key k) m1 m2')" if "k2 = key k" "k1 \<noteq> key k"
      using that \<open>P m1\<close> \<open>P m2\<close> unfolding inv_pair_def
      apply clarsimp
      apply safe
      subgoal for x' y
        using assms(4) unfolding inv_pair_def by fastforce
      subgoal for x x' y
        using assms(2,4) update_correct[OF \<open>P m2\<close>, of k v, THEN map_le_implies_dom_le]
        unfolding inv_pair_def by fastforce
      using update_inv[of k v] assms unfolding lift_p_def by force
    have C:
      "pair.map_of (Pair_Storage (key k) k2 m1' m2) \<subseteq>\<^sub>m
       pair.map_of (Pair_Storage (key k) k2 m1 m2)(k \<mapsto> v)"
      if "k2 \<noteq> key k" "k1 = key k"
      using inv1[OF that] assms(4) \<open>inv_pair m\<close>
      by (simp add: that map_of_eq_pair[symmetric])
         (subst map_add_upd2[symmetric]; force simp: inv_pair_def intro: map_add_mono map_le_refl)
    have B:
      "pair.map_of (Pair_Storage k1 (key k) m1 m2') \<subseteq>\<^sub>m
       pair.map_of (Pair_Storage k1 (key k) m1 m2)(k \<mapsto> v)"
      if "k2 = key k" "k1 \<noteq> key k"
      using inv2[OF that] assms(4)
      by (simp add: that map_of_eq_pair[symmetric])
         (subst map_add_upd[symmetric]; rule map_add_mono; force simp: inv_pair_def)
    note A B C
  }
  with \<open>inv_pair m\<close> show ?case
    by (auto split: pair_storage.split if_split prod.split simp: Let_def update_pair_def)
qed

end (* Key function *)

end (* Lookup & Update w/ Empty *)

end (* Theory *)


theory Transition_Rules
  imports Rules
begin

context rules
begin

text \<open>
A series of lemmas that demonstrate the logic's rules are preserved across the semantic steps and
ensure any executed behaviours conform to the desired specification.
\<close>

section \<open>Reordering Rules\<close>

text \<open>
  Reorder the judgements of a reorderable instruction \<alpha> and program c, given a suitable
  interference property.
\<close>
lemma reorder_prog:
  assumes "R,G \<turnstile> P {c} M" "R,G \<turnstile>\<^sub>A M {\<alpha>} Q" "inter\<^sub>c w R G c \<alpha>" "\<alpha>' < c <\<^sub>w \<alpha>"
  obtains M' where "R,G \<turnstile>\<^sub>A stabilise R P {\<alpha>'} M'" "R,G \<turnstile> M' {c} Q"
  using assms
proof (induct c arbitrary: R G P M Q \<alpha> \<alpha>')
  case Nil
  hence "stabilise R P \<subseteq> M" using stable_preE'[OF Nil(2)] by blast
  then show ?case using Nil atomic_rule_def unfolding reorder_com.simps
    by (metis atomic_pre nil stable_stabilise)
next
  case (Basic \<beta>)
  obtain N' where \<beta>: "R,G \<turnstile>\<^sub>A stabilise R P {\<beta>} N'" "N' \<subseteq> M" using Basic by auto
  have m': "R,G \<turnstile>\<^sub>A N' {\<alpha>} Q"
    using atomic_pre[OF Basic(3)] \<beta>(1,2) Basic(3) by (auto simp: atomic_rule_def)
  obtain M' where m'': "R,G \<turnstile>\<^sub>A stabilise R P {\<alpha>'} M'" "R,G \<turnstile>\<^sub>A M' {\<beta>} Q"
    using \<beta>(1) m'(1) Basic
    unfolding inter\<^sub>\<alpha>_def inter\<^sub>c.simps reorder_com.simps by metis
  have "R,G \<turnstile> M' {Basic \<beta>} Q" by (rule rules.basic[OF m''(2)])
  then show ?case using Basic(1) \<beta>(1) m''(1) by auto
next
  case (Seq c\<^sub>1 w' c\<^sub>2)
  obtain M' where m: "R,G \<turnstile> P {c\<^sub>1} M'" "R,G \<turnstile> M' {c\<^sub>2} M" using Seq(4) by fast
  obtain \<alpha>'' where r: "\<alpha>'' < c\<^sub>2 <\<^sub>w \<alpha>" "\<alpha>' < c\<^sub>1 <\<^sub>w \<alpha>''" using Seq(7) by auto
  hence i: "inter\<^sub>c w R G c\<^sub>1 \<alpha>''" "inter\<^sub>c w R G c\<^sub>2 \<alpha>" using Seq(6) unfolding inter\<^sub>c.simps by blast+
  show ?case
  proof (rule Seq(2)[OF _ m(2) Seq(5) i(2) r(1)], goal_cases outer)
    case (outer N')
    hence c1: "R,G \<turnstile> P {c\<^sub>1} stabilise R M'" using m(1) conseq stabilise_supset[of M'] by fast
    show ?case
    proof (rule Seq(1)[OF _ c1 outer(1) i(1) r(2)], goal_cases inner)
      case (inner M'')
      then show ?case using Seq(3) outer by auto
    qed
  qed
qed auto

section \<open>Transition Rules\<close>

text \<open>Judgements are preserved across thread-local execution steps\<close>
lemma lexecute_ruleI [intro]:
  assumes "R,G \<turnstile> P {c} Q" "c \<mapsto>[\<alpha>',r] c'" "inter R G r"
  shows "\<exists>M. R,G \<turnstile>\<^sub>A stabilise R P {\<alpha>'} M \<and> R,G \<turnstile> M {c'} Q"
  using assms(2,1,3)
proof (induct arbitrary: P R G Q)
  case (act \<alpha>)
  then show ?case by clarsimp (meson atomic_rule_def nil rules.conseq order_refl)
next
  case (ino c\<^sub>1 \<alpha>' r c\<^sub>1' w c\<^sub>2)
  then obtain M' where m: "R,G \<turnstile> P {c\<^sub>1} M'" "R,G \<turnstile> M' {c\<^sub>2} Q" by auto
  then show ?case using ino(2)[OF m(1) ino(4)] m(2) by blast
next
  case (ooo c\<^sub>1 \<alpha>' r c\<^sub>1' \<alpha>'' c\<^sub>2 w)
  obtain M' where m: "R,G \<turnstile> P {c\<^sub>2} M'" "R,G \<turnstile> M' {c\<^sub>1} Q" using ooo(4) by (rule seqE)
  have i: "inter\<^sub>c w R G c\<^sub>2 \<alpha>'" "inter R G r" using ooo(5) by auto
  obtain M where m': "R,G \<turnstile>\<^sub>A stabilise R M' {\<alpha>'} M" "R,G \<turnstile> M {c\<^sub>1'} Q"
    using ooo(2)[OF m(2) i(2)] by auto
  have m'': "R,G \<turnstile> P {c\<^sub>2} stabilise R M'" using m(1) stabilise_supset[of M' R] by auto
  show ?case using reorder_prog[OF m'' m'(1)] i(1) m'(2) ooo(3) by (metis rules.seq)
next
  case (cap c \<alpha>' r c' s s')
  let ?R="uncapRely R" and ?G="uncapGuar G" and ?P="uncapPred s P" and ?Q="pushpredAll Q"
  have "?R,?G \<turnstile> ?P {c} ?Q" using cap(3) by (rule captureE)
  moreover have "inter ?R ?G r" using cap(4) by simp
  ultimately obtain M where m: "?R,?G \<turnstile>\<^sub>A stabilise ?R ?P {\<alpha>'} M" "?R,?G \<turnstile> M {c'} ?Q"
    using cap(2) by force
  have "R,G \<turnstile>\<^sub>A stabilise R P {popbasic s s' \<alpha>'} poppred' s' M"
    using helpa[OF m(1)[simplified stabilise_pushrel]] by simp
  moreover have "R,G \<turnstile> (poppred' s' M) {Capture s' c'} Q"
    using m(2) push_poppred_subset by blast
  ultimately show ?case by blast
qed

lemma test:
  assumes "pushpred s (stabilise R P) \<subseteq> pushpredAll Q" "x \<in> stabilise R P"
  shows "x \<in> Q"
proof -
  have "push x s \<in> pushpred s (stabilise R P)" using assms by auto
  hence "push x s \<in> pushpredAll Q" using assms by auto
  then obtain x' s' where e: "push x s = push x' s'" "x' \<in> Q" unfolding pushpredAll_def by auto
  hence "x' = x" using push_inj by auto
  thus ?thesis using e by auto
qed

text \<open>Judgements are preserved across silent steps\<close>
lemma rewrite_ruleI [intro]:
  assumes "R,G \<turnstile> P {c} Q"
  assumes "c \<leadsto> c'"
  shows "R,G \<turnstile> P {c'} Q"
  using assms
proof (induct arbitrary: c' rule: rules.induct)
  case (seq R G P c\<^sub>1 Q c\<^sub>2 M)
  thus ?case by (cases rule: silentE, auto) (blast)+
next
  case (capture R G s P c Q)
  show ?case using capture
  proof (cases "Capture s c" c' rule: silentE)
    case 1
    then show ?case using capture by auto
  next
    case (15 k)
    hence "uncapRely R,uncapGuar G \<turnstile> uncapPred s P {Nil} pushpredAll Q"
      using capture(1) by simp
    hence t: "stabilise (uncapRely R) (uncapPred s P) \<subseteq> pushpredAll Q"
      using nilE2 by simp
    have "R,G \<turnstile> stabilise R P {Nil} stabilise R P"
      by (simp add: rules.rules.nil stable_stabilise)
    moreover have "P \<subseteq> stabilise R P"
      by (simp add: stabilise_supset)
    moreover have "stabilise R P \<subseteq> Q"
      using t test unfolding stabilise_pushrel by blast
    ultimately show ?thesis using 15(2) by blast
  next
    case (16 c'' c''' k)
    then show ?thesis using capture by auto
  qed auto
qed (cases rule: silentE, auto)+

text \<open>Judgements are preserved across global execution steps\<close>
lemma gexecute_ruleI [intro]:
  assumes "R,G \<turnstile> P {c} Q"
  assumes "c \<mapsto>[g] c'"
  shows "\<exists>M v. P \<subseteq> wp v g M \<and> guar v g G \<and> R,G \<turnstile> M {c'} Q"
  using assms
proof (induct arbitrary: g c' rule: rules.induct)
  case (par R\<^sub>1 G\<^sub>1 P\<^sub>1 c\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 c\<^sub>2 Q\<^sub>2)
  show ?case using par(7)
  proof cases
    case (par1 c\<^sub>1')
    obtain M\<^sub>2 where m2: "P\<^sub>2 \<subseteq> M\<^sub>2" "stable R\<^sub>2 M\<^sub>2" "R\<^sub>2,G\<^sub>2 \<turnstile> M\<^sub>2 {c\<^sub>2} Q\<^sub>2" using par
      by (meson stable_preE)
    obtain M\<^sub>1 v where m1: "P\<^sub>1 \<subseteq> wp v g M\<^sub>1" "guar v g G\<^sub>1" "R\<^sub>1,G\<^sub>1 \<turnstile> M\<^sub>1 {c\<^sub>1'} Q\<^sub>1"
      using par1 par(2)[OF par1(2)] by blast
    hence "R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile> M\<^sub>1 \<inter> M\<^sub>2 {c'} Q\<^sub>1 \<inter> Q\<^sub>2" using par1 m2 par by blast
    moreover have "P\<^sub>1 \<inter> P\<^sub>2 \<subseteq> wp v g (M\<^sub>1 \<inter> M\<^sub>2)"
      using m1(1,2) m2(1,2) par.hyps(6) unfolding guar_def wp_def stable_def
      by auto blast
    ultimately show ?thesis using m1(2) unfolding guar_def by blast
  next
    case (par2 c\<^sub>2')
    obtain M\<^sub>1 where m1: "P\<^sub>1 \<subseteq> M\<^sub>1" "stable R\<^sub>1 M\<^sub>1" "R\<^sub>1,G\<^sub>1 \<turnstile> M\<^sub>1 {c\<^sub>1} Q\<^sub>1" using par
      by (meson stable_preE)
    obtain M\<^sub>2 v where m2: "P\<^sub>2 \<subseteq> wp v g M\<^sub>2" "guar v g G\<^sub>2" "R\<^sub>2,G\<^sub>2 \<turnstile> M\<^sub>2 {c\<^sub>2'} Q\<^sub>2"
      using par2 par(4)[OF par2(2)] by blast
    hence "R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile> M\<^sub>1 \<inter> M\<^sub>2 {c'} Q\<^sub>1 \<inter> Q\<^sub>2" using par2 m1 par by blast
    moreover have "P\<^sub>1 \<inter> P\<^sub>2 \<subseteq> wp v g (M\<^sub>1 \<inter> M\<^sub>2)"
      using m1(1,2) m2(1,2) par.hyps(5) unfolding guar_def wp_def stable_def
      by auto blast
    ultimately show ?thesis using m2(2) unfolding guar_def by blast
  qed
next
  case (conseq R G P c Q P' R' G' Q')
  thus ?case by (smt Un_iff guar_def rules.conseq subset_iff)
next
  case (inv R G P c Q R' M')
  then obtain M v where p: "P \<subseteq> wp v g M" "guar v g G" "R,G \<turnstile> M {c'} Q" by metis
  hence "P \<inter> M' \<subseteq> wp v g (M \<inter> M')" using inv(3,4) by (auto simp: stable_def guar_def wp_def) blast
  thus ?case using rules.inv p(2,3) inv(3,4) by blast
next
  case (thread R G P c Q)
  then obtain r \<alpha>' c'' where e: "g = beh \<alpha>'" "c \<mapsto>[\<alpha>',r] c''" "c' = Thread c''" by auto
  then obtain M where "R,G \<turnstile>\<^sub>A stabilise R P {\<alpha>'} M" "R,G \<turnstile> M {c''} Q" "rif R G c''"
    using thread lexecute_ruleI[OF thread(1) e(2)] indep_stepI[OF thread(3) e(2)] by metis
  thus ?case using stabilise_supset[of P R] e unfolding atomic_rule_def by auto
qed auto

end

end