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

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

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

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

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

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

section "Example: Quicksort on Heap Lists"

theory Quicksort
imports "../Vcg" "../HeapList" "HOL-Library.Permutation"
begin

record globals_heap =
  next_' :: "ref \<Rightarrow> ref"
  cont_' :: "ref \<Rightarrow> nat"

record 'g vars = "'g state" +
  p_'    :: "ref"
  q_'    :: "ref"
  le_'   :: "ref"
  gt_'   :: "ref"
  hd_'   :: "ref"
  tl_'   :: "ref"

procedures
  append(p,q|p) =
    "IF \<acute>p=Null THEN \<acute>p :== \<acute>q ELSE \<acute>p\<rightarrow>\<acute>next :== CALL append(\<acute>p\<rightarrow>\<acute>next,\<acute>q) FI"

  append_spec:
   "\<forall>\<sigma> Ps Qs.
     \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
           \<acute>p :== PROC append(\<acute>p,\<acute>q)
         \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  append_modifies:
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"

lemma (in append_impl) append_modifies:
  shows
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma (in append_impl) append_spec:
  shows "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>
            \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
                \<acute>p :== PROC append(\<acute>p,\<acute>q)
            \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg
  apply fastforce
  done

primrec sorted:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list  \<Rightarrow> bool"
where
"sorted le [] = True" |
"sorted le (x#xs) = ((\<forall>y\<in>set xs. le x y) \<and> sorted le xs)"

lemma perm_set_eq:
  assumes perm: "xs <~~> ys"
  shows "set xs = set ys"
  using perm
  by induct auto

lemma perm_Cons_eq [iff]: "x#xs <~~> x#ys = (xs <~~> ys)"
  by auto

lemma perm_app_Cons_eq1 : "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
proof -
  have app_Cons: "xs@y#ys <~~> y#xs@ys"
    by (rule perm_sym, rule perm_append_Cons)
  show ?thesis
  proof
    assume "xs@y#ys <~~> zs"
    with app_Cons [THEN perm_sym]
    show "y#xs@ys <~~> zs"
      by (rule perm.trans)
  next
    assume " y#xs@ys <~~> zs"
    with app_Cons
    show "xs@y#ys <~~> zs"
      by (rule perm.trans)
  qed
qed

lemma perm_app_Cons_eq2 : "zs <~~> xs@y#ys = (zs <~~> y#xs@ys)"
proof -
  have "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
    by (rule perm_app_Cons_eq1)
  thus ?thesis
    by (iprover intro: perm_sym)
qed

lemmas perm_app_Cons_simps = perm_app_Cons_eq1 [THEN sym]
                             perm_app_Cons_eq2 [THEN sym]

lemma sorted_append[simp]:
 "sorted le (xs@ys) = (sorted le xs \<and> sorted le ys \<and>
                       (\<forall>x \<in> set xs. \<forall>y \<in> set ys. le x y))"
by (induct xs, auto)

lemma perm_append_blocks:
  assumes ws_ys: "ws <~~> ys"
  assumes xs_zs: "xs <~~> zs"
  shows "ws@xs <~~> ys@zs"
using ws_ys
proof (induct)
  case (swap l x y)
  from xs_zs
  show "(l # x # y) @ xs <~~> (x # l # y) @ zs"
  by (induct) auto
qed (insert xs_zs , auto)

procedures quickSort(p|p) =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI"

  quickSort_spec:
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC quickSort(\<acute>p)
       \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
        sorted (\<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
        Ps <~~> sortedPs) \<and>
        (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  quickSort_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"

lemma (in quickSort_impl) quickSort_modifies:
  shows
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

lemma (in quickSort_impl) quickSort_spec:
shows
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace>
                  \<acute>p :== PROC quickSort(\<acute>p)
                \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
                 sorted (\<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
                 Ps <~~> sortedPs) \<and>
                 (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply (hoare_rule anno =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null
       INV \<lbrace> (\<exists>les grs tls. List \<acute>le \<acute>next les \<and> List \<acute>gt \<acute>next grs \<and>
               List \<acute>tl \<acute>next tls \<and>
               Ps <~~> \<acute>p#tls@les@grs \<and>
               distinct(\<acute>p#tls@les@grs) \<and>
               (\<forall>x\<in>set les. x\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont) \<and>
               (\<forall>x\<in>set grs. \<acute>p\<rightarrow>\<acute>cont < x\<rightarrow>\<acute>cont)) \<and>
               \<acute>p=\<^bsup>\<sigma>\<^esup>p \<and>
               \<acute>cont=\<^bsup>\<sigma>\<^esup>cont \<and>
               List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>
               (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>
       DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI" in HoarePartial.annotateI)
apply vcg
apply   fastforce
apply  clarsimp
apply  (rule conjI)
apply   clarify
apply   (rule conjI)
apply    (rule_tac x="tl#les" in exI)
apply    simp
apply    (rule_tac x="grs" in exI)
apply    simp
apply    (rule_tac x="ps" in exI)
apply    simp
apply    (erule perm.trans)
apply    simp
apply    (simp add: perm_app_Cons_simps)
apply   (simp add: perm_set_eq)
apply  clarify
apply  (rule conjI)
apply   (rule_tac x="les" in exI)
apply   simp
apply   (rule_tac x="tl#grs" in exI)
apply   simp
apply   (rule_tac x="ps" in exI)
apply   simp
apply   (erule perm.trans)
apply   simp
apply   (simp add: perm_app_Cons_simps)
apply  (simp add: perm_set_eq)
apply clarsimp
apply (rule_tac ?x=grs in exI)
apply (rule conjI)
apply  (erule heap_eq_ListI1)
apply  clarify
apply  (erule_tac x=x in allE)back
apply  blast
apply clarsimp
apply (rule_tac x="sortedPs" in exI)
apply (rule conjI)
apply  (erule heap_eq_ListI1)
apply  (clarsimp)
apply  (erule_tac x=x in allE) back back
apply  (fast dest!: perm_set_eq)
apply (rule_tac x="p#sortedPsa" in exI)
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (force dest!: perm_set_eq)
apply clarsimp
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (erule perm.trans)
apply  (simp add:  perm_app_Cons_simps list_all_iff)
apply  (fastforce intro!: perm_append_blocks)
apply clarsimp
apply (erule_tac x=x in allE)+
apply (force dest!: perm_set_eq)
done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
Hoare reasoning and WP (weakest-precondition) generator rules for the option monad.

This list is almost certainly incomplete; add rules here as they are needed.
*)

theory OptionMonadWP
imports
  OptionMonadND
  "wp/WP"
begin

declare K_def [simp]

(* Hoare triples.
   TODO: design a sensible syntax for them. *)

(* Partial correctness. *)
definition ovalid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" where
  "ovalid P f Q \<equiv> \<forall>s r. P s \<and> f s = Some r \<longrightarrow> Q r s"
(* Total correctness. *)
definition ovalidNF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" where
  "ovalidNF P f Q \<equiv> \<forall>s. P s \<longrightarrow> (f s \<noteq> None \<and> (\<forall>r. f s = Some r \<longrightarrow> Q r s))"
(* Termination. *)
definition no_ofail where "no_ofail P f \<equiv> \<forall>s. P s \<longrightarrow> f s \<noteq> None"

(*
This rule lets us apply ovalidNF machinery for proving no_ofail.
However, we ought to eventually write working wp rules for no_ofail (see below).
*)
lemma no_ofail_is_ovalidNF: "no_ofail P f \<equiv> ovalidNF P f (\<lambda>_ _. True)"
  by (simp add: no_ofail_def ovalidNF_def)
lemma ovalidNF_combine: "\<lbrakk> ovalid P f Q; no_ofail P f \<rbrakk> \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def ovalid_def no_ofail_def)

(* Annotating programs with loop invariant and measure. *)
definition owhile_inv ::
  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'a option) \<Rightarrow> 'a
   \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> 's \<Rightarrow> 'a option"
  where "owhile_inv C B x I M = owhile C B x"

lemmas owhile_add_inv = owhile_inv_def[symmetric]

(* WP rules for ovalid. *)
lemma obind_wp [wp]:
  "\<lbrakk> \<And>r. ovalid (R r) (g r) Q; ovalid P f R \<rbrakk> \<Longrightarrow> ovalid P (obind f g) Q"
  by (simp add: ovalid_def obind_def split: option.splits, fast)

lemma oreturn_wp [wp]:
  "ovalid (P x) (oreturn x) P"
  by (simp add: ovalid_def oreturn_def K_def)

lemma ocondition_wp [wp]:
  "\<lbrakk> ovalid L l Q; ovalid R r Q \<rbrakk>
   \<Longrightarrow> ovalid (\<lambda>s. if C s then L s else R s) (ocondition C l r) Q"
  by (auto simp: ovalid_def ocondition_def)

lemma ofail_wp [wp]:
  "ovalid (\<lambda>_. True) ofail Q"
  by (simp add: ovalid_def ofail_def)

lemma ovalid_K_bind_wp [wp]:
  "ovalid P f Q \<Longrightarrow> ovalid P (K_bind f x) Q"
  by simp

lemma ogets_wp [wp]: "ovalid (\<lambda>s. P (f s) s) (ogets f) P"
  by (simp add: ovalid_def ogets_def)

lemma oguard_wp [wp]: "ovalid (\<lambda>s. f s \<longrightarrow> P () s) (oguard f) P"
  by (simp add: ovalid_def oguard_def)

lemma oskip_wp [wp]:
  "ovalid (\<lambda>s. P () s) oskip P"
  by (simp add: ovalid_def oskip_def)

lemma ovalid_case_prod [wp]:
  assumes "(\<And>x y. ovalid (P x y) (B x y) Q)"
  shows "ovalid (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q"
  using assms unfolding ovalid_def by auto

lemma owhile_ovalid [wp]:
"\<lbrakk>\<And>a. ovalid (\<lambda>s. I a s \<and> C a s) (B a) I;
   \<And>a s. \<lbrakk>I a s; \<not> C a s\<rbrakk> \<Longrightarrow> Q a s\<rbrakk>
  \<Longrightarrow> ovalid (I a) (owhile_inv C B a I M) Q"
  unfolding owhile_inv_def owhile_def ovalid_def
  apply clarify
  apply (frule_tac I = "\<lambda>a. I a s" in option_while_rule)
  apply auto
  done

definition ovalid_property where "ovalid_property P x = (\<lambda>s f. (\<forall>r. Some r = x s f \<longrightarrow> P r s))"
lemma ovalid_is_triple [wp_trip]:
  "ovalid P f Q = triple_judgement P f (ovalid_property Q (\<lambda>s f. f s))"
  by (auto simp: triple_judgement_def ovalid_def ovalid_property_def)

lemma ovalid_wp_comb1 [wp_comb]:
  "\<lbrakk> ovalid P' f Q; ovalid P f Q'; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> ovalid P f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalid_def)

lemma ovalid_wp_comb2 [wp_comb]:
  "\<lbrakk> ovalid P f Q; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> ovalid P' f Q"
  by (auto simp: ovalid_def)

lemma ovalid_wp_comb3 [wp_comb]:
  "\<lbrakk> ovalid P f Q; ovalid P' f Q' \<rbrakk> \<Longrightarrow> ovalid (\<lambda>s. P s \<and> P' s) f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (auto simp: ovalid_def)

(* WP rules for ovalidNF. *)
lemma obind_NF_wp [wp]:
  "\<lbrakk> \<And>r. ovalidNF (R r) (g r) Q; ovalidNF P f R \<rbrakk> \<Longrightarrow> ovalidNF P (obind f g) Q"
  by (auto simp: ovalidNF_def obind_def split: option.splits)

lemma oreturn_NF_wp [wp]:
  "ovalidNF (P x) (oreturn x) P"
  by (simp add: ovalidNF_def oreturn_def)

lemma ocondition_NF_wp [wp]:
  "\<lbrakk> ovalidNF L l Q; ovalidNF R r Q \<rbrakk>
   \<Longrightarrow> ovalidNF (\<lambda>s. if C s then L s else R s) (ocondition C l r) Q"
  by (simp add: ovalidNF_def ocondition_def)

lemma ofail_NF_wp [wp]:
  "ovalidNF (\<lambda>_. False) ofail Q"
  by (simp add: ovalidNF_def ofail_def)

lemma ovalidNF_K_bind_wp [wp]:
  "ovalidNF P f Q \<Longrightarrow> ovalidNF P (K_bind f x) Q"
  by simp

lemma ogets_NF_wp [wp]:
  "ovalidNF (\<lambda>s. P (f s) s) (ogets f) P"
  by (simp add: ovalidNF_def ogets_def)

lemma oguard_NF_wp [wp]:
  "ovalidNF (\<lambda>s. f s \<and> P () s) (oguard f) P"
  by (simp add: ovalidNF_def oguard_def)

lemma oskip_NF_wp [wp]:
  "ovalidNF (\<lambda>s. P () s) oskip P"
  by (simp add: ovalidNF_def oskip_def)

lemma ovalid_NF_case_prod [wp]:
  assumes "(\<And>x y. ovalidNF (P x y) (B x y) Q)"
  shows "ovalidNF (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q"
  using assms unfolding ovalidNF_def by auto

lemma owhile_NF [wp]:
"\<lbrakk>\<And>a. ovalidNF (\<lambda>s. I a s \<and> C a s) (B a) I;
   \<And>a m. ovalid (\<lambda>s. I a s \<and> C a s \<and> M a s = m) (B a) (\<lambda>r s. M r s < m);
   \<And>a s. \<lbrakk>I a s; \<not> C a s\<rbrakk> \<Longrightarrow> Q a s\<rbrakk>
  \<Longrightarrow> ovalidNF (I a) (owhile_inv C B a I M) Q"
  unfolding owhile_inv_def ovalidNF_def ovalid_def
  apply clarify
  apply (rename_tac s, rule_tac I = I and M = "measure (\<lambda>r. M r s)" in owhile_rule)
       apply fastforce
      apply fastforce
     apply fastforce
    apply blast+
  done

definition ovalidNF_property where "ovalidNF_property P x = (\<lambda>s f. (x s f \<noteq> None \<and> (\<forall>r. Some r = x s f \<longrightarrow> P r s)))"
lemma ovalidNF_is_triple [wp_trip]:
  "ovalidNF P f Q = triple_judgement P f (ovalidNF_property Q (\<lambda>s f. f s))"
  by (auto simp: triple_judgement_def ovalidNF_def ovalidNF_property_def)

lemma ovalidNF_wp_comb1 [wp_comb]:
  "\<lbrakk> ovalidNF P' f Q; ovalidNF P f Q'; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> ovalidNF P f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalidNF_def)

lemma ovalidNF_wp_comb2 [wp_comb]:
  "\<lbrakk> ovalidNF P f Q; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> ovalidNF P' f Q"
  by (simp add: ovalidNF_def)

lemma ovalidNF_wp_comb3 [wp_comb]:
  "\<lbrakk> ovalidNF P f Q; ovalidNF P' f Q' \<rbrakk> \<Longrightarrow> ovalidNF (\<lambda>s. P s \<and> P' s) f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalidNF_def)

(* FIXME: WP rules for no_ofail, which might not be correct. *)
lemma no_ofail_ofail [wp]: "no_ofail (\<lambda>_. False) ofail"
  by (simp add: no_ofail_def ofail_def)

lemma no_ofail_ogets [wp]: "no_ofail (\<lambda>_. True) (ogets f)"
  by (simp add: no_ofail_def ogets_def)

lemma no_ofail_obind [wp]:
  "\<lbrakk> \<And>r. no_ofail (P r) (g r); no_ofail Q f; ovalid Q f P \<rbrakk> \<Longrightarrow> no_ofail Q (obind f g)"
  by (auto simp: no_ofail_def obind_def ovalid_def)

lemma no_ofail_K_bind [wp]:
  "no_ofail P f \<Longrightarrow> no_ofail P (K_bind f x)"
  by simp

lemma no_ofail_oguard [wp]:
  "no_ofail (\<lambda>s. f s) (oguard f)"
  by (auto simp: no_ofail_def oguard_def)

lemma no_ofail_ocondition [wp]:
  "\<lbrakk> no_ofail L l; no_ofail R r \<rbrakk>
     \<Longrightarrow> no_ofail (\<lambda>s. if C s then L s else R s) (ocondition C l r)"
  by (simp add: no_ofail_def ocondition_def)

lemma no_ofail_oreturn [wp]:
  "no_ofail (\<lambda>_. True) (oreturn x)"
  by (simp add: no_ofail_def oreturn_def)

lemma no_ofail_oskip [wp]:
  "no_ofail (\<lambda>_. True) oskip"
  by (simp add: no_ofail_def oskip_def)

lemma no_ofail_is_triple [wp_trip]:
  "no_ofail P f = triple_judgement P f (\<lambda>s f. f s \<noteq> None)"
  by (auto simp: triple_judgement_def no_ofail_def)

lemma no_ofail_wp_comb1 [wp_comb]:
  "\<lbrakk> no_ofail P f; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> no_ofail P' f"
  by (simp add: no_ofail_def)

lemma no_ofail_wp_comb2 [wp_comb]:
  "\<lbrakk> no_ofail P f; no_ofail P' f \<rbrakk> \<Longrightarrow> no_ofail (\<lambda>s. P s \<and> P' s) f"
  by (simp add: no_ofail_def)

(* Some extra lemmas for our predicates. *)
lemma ovalid_grab_asm:
  "(G \<Longrightarrow> ovalid P f Q) \<Longrightarrow> ovalid (\<lambda>s. G \<and> P s) f Q"
  by (simp add: ovalid_def)
lemma ovalidNF_grab_asm:
  "(G \<Longrightarrow> ovalidNF P f Q) \<Longrightarrow> ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (simp add: ovalidNF_def)
lemma no_ofail_grab_asm:
  "(G \<Longrightarrow> no_ofail P f) \<Longrightarrow> no_ofail (\<lambda>s. G \<and> P s) f"
  by (simp add: no_ofail_def)

lemma ovalid_assume_pre:
  "(\<And>s. P s \<Longrightarrow> ovalid P f Q) \<Longrightarrow> ovalid P f Q"
  by (auto simp: ovalid_def)
lemma ovalidNF_assume_pre:
  "(\<And>s. P s \<Longrightarrow> ovalidNF P f Q) \<Longrightarrow> ovalidNF P f Q"
  by (simp add: ovalidNF_def)
lemma no_ofail_assume_pre:
  "(\<And>s. P s \<Longrightarrow> no_ofail P f) \<Longrightarrow> no_ofail P f"
  by (simp add: no_ofail_def)

lemma ovalid_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P' f Q"
  by (simp add: ovalid_def)
lemma ovalidNF_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P' f Q"
  by (simp add: ovalidNF_def)
lemma no_ofail_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; no_ofail P f \<rbrakk> \<Longrightarrow> no_ofail P' f"
  by (simp add: no_ofail_def)

lemma ovalid_post_imp:
  "\<lbrakk> \<And>r s. Q r s \<Longrightarrow> Q' r s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P f Q'"
  by (simp add: ovalid_def)
lemma ovalidNF_post_imp:
  "\<lbrakk> \<And>r s. Q r s \<Longrightarrow> Q' r s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P f Q'"
  by (simp add: ovalidNF_def)

lemma ovalid_post_imp_assuming_pre:
  "\<lbrakk> \<And>r s. \<lbrakk> P s; Q r s \<rbrakk> \<Longrightarrow> Q' r s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P f Q'"
  by (simp add: ovalid_def)
lemma ovalidNF_post_imp_assuming_pre:
  "\<lbrakk> \<And>r s. \<lbrakk> P s; Q r s \<rbrakk> \<Longrightarrow> Q' r s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P f Q'"
  by (simp add: ovalidNF_def)

end


subsection \<open>Executable version\<close>
theory Multiset_Extension2_Impl
imports
  "HOL-Library.DAList_Multiset"
  List_Order
  Multiset_Extension2
  Multiset_Extension_Pair_Impl
begin

(**
We use the lifting when it is sufficient to prove the non-strict
domination to also prove the strict one. For example if [a > x] then
it is sufficient to prove that [A \<ge> X] to get [A + {#a#} > X + {#x#}]
**)

lemma mul_ext_list_ext: "\<exists> s ns. list_order_extension_impl s ns mul_ext"
proof(intro exI)
  let ?s = "\<lambda> s ns. {(as,bs). (mset as, mset bs) \<in> s_mul_ext ns s}"
  let ?ns = "\<lambda> s ns. {(as,bs). (mset as, mset bs) \<in> ns_mul_ext ns s}"
  let ?m = mset
  show "list_order_extension_impl ?s ?ns mul_ext"
  proof
    fix s ns
    show "?s {(a,b). s a b} {(a,b). ns a b} = {(as,bs). fst (mul_ext (\<lambda> a b. (s a b, ns a b)) as bs)}"
      unfolding mul_ext_def Let_def by auto
  next
    fix s ns
    show "?ns {(a,b). s a b} {(a,b). ns a b} = {(as,bs). snd (mul_ext (\<lambda> a b. (s a b, ns a b)) as bs)}"
      unfolding mul_ext_def Let_def by auto
  next
    fix s ns s' ns' as bs
    assume "set as \<times> set bs \<inter> ns \<subseteq> ns'"
           "set as \<times> set bs \<inter> s \<subseteq> s'"
           "(as,bs) \<in> ?s s ns"
    then show "(as,bs) \<in> ?s s' ns'"
      using s_mul_ext_local_mono[of "?m as" "?m bs" ns ns' s s']
      unfolding set_mset_mset by auto
  next
    fix s ns s' ns' as bs
    assume "set as \<times> set bs \<inter> ns \<subseteq> ns'"
           "set as \<times> set bs \<inter> s \<subseteq> s'"
           "(as,bs) \<in> ?ns s ns"
    then show "(as,bs) \<in> ?ns s' ns'"
      using ns_mul_ext_local_mono[of "?m as" "?m bs" ns ns' s s']
      unfolding set_mset_mset by auto
  qed
qed

context fixes sns :: "'a \<Rightarrow> 'a \<Rightarrow> bool \<times> bool"
begin

fun mul_ext_impl :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
and mul_ex_dom :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
where
  "mul_ext_impl [] []       = (False, True)"
| "mul_ext_impl [] ys       = (False, False)"
| "mul_ext_impl xs []       = (True, True)"
| "mul_ext_impl xs (y # ys) = mul_ex_dom xs [] y ys"

| "mul_ex_dom []       xs' y ys = (False, False)"
| "mul_ex_dom (x # xs) xs' y ys =
    (case sns x y of
      (True, _) \<Rightarrow> if snd (mul_ext_impl (xs @ xs') (filter (\<lambda>y. \<not> fst (sns x y)) ys)) then (True, True)
                   else mul_ex_dom xs (x # xs') y ys
    | (False, True) \<Rightarrow> or2 (mul_ext_impl (xs @ xs') ys) (mul_ex_dom xs (x # xs') y ys)
    | _ \<Rightarrow> mul_ex_dom xs (x # xs') y ys)"

end

context
begin
lemma mul_ext_impl_sound0:
  "mul_ext_impl sns xs ys = mult2_impl (\<lambda>x y. sns y x) ys xs"
  "mul_ex_dom sns xs xs' y ys = mult2_ex_dom (\<lambda>x y. sns y x) y ys xs xs'"
by (induct xs ys and xs xs' y ys taking: sns rule: mul_ext_impl_mul_ex_dom.induct)
  (auto split: prod.splits bool.splits)

private definition cond1 where
  "cond1 f bs y xs ys \<equiv>
  ((\<exists>b. b \<in> set bs \<and> fst (f b y) \<and> snd (mul_ext f (remove1 b xs) [y\<leftarrow>ys . \<not> fst (f b y)]))
  \<or> (\<exists>b. b \<in> set bs \<and> snd (f b y) \<and> fst (mul_ext f (remove1 b xs) ys)))"

private lemma cond1_propagate:
  assumes "cond1 f bs y xs ys"
  shows "cond1 f (b # bs) y xs ys"
using assms unfolding cond1_def by auto

private definition cond2 where
  "cond2 f bs y xs ys \<equiv> (cond1 f bs y xs ys
  \<or> (\<exists>b. b \<in> set bs \<and> snd (f b y) \<and> snd (mul_ext f (remove1 b xs) ys)))"

private lemma cond2_propagate:
  assumes "cond2 f bs y xs ys"
  shows "cond2 f (b # bs) y xs ys"
using assms and cond1_propagate[of f bs y xs ys]
unfolding cond2_def by auto

private lemma cond1_cond2:
  assumes "cond1 f bs y xs ys"
  shows "cond2 f bs y xs ys"
using assms unfolding cond2_def by simp

lemma mul_ext_impl_sound:
  shows "mul_ext_impl f xs ys = mul_ext f xs ys"
unfolding mul_ext_def s_mul_ext_def ns_mul_ext_def
by (auto simp: Let_def converse_def mul_ext_impl_sound0 mult2_impl_sound)

lemma mul_ext_code [code]: "mul_ext = mul_ext_impl"
  by (intro ext, unfold mul_ext_impl_sound, auto)

lemma mul_ext_impl_cong[fundef_cong]:
  assumes "\<And>x x'. x \<in> set xs \<Longrightarrow> x' \<in> set ys \<Longrightarrow> f x x' = g x x'"
  shows "mul_ext_impl f xs ys = mul_ext_impl g xs ys"
using assms
 stri_mul_ext_map[of xs ys g f id] nstri_mul_ext_map[of xs ys g f id]
 stri_mul_ext_map[of xs ys f g id] nstri_mul_ext_map[of xs ys f g id]
  by (auto simp: mul_ext_impl_sound mul_ext_def Let_def)
end

fun ass_list_to_single_list :: "('a \<times> nat) list \<Rightarrow> 'a list"
  where
    "ass_list_to_single_list [] = []"
  | "ass_list_to_single_list ((x, n) # xs) = replicate n x @ ass_list_to_single_list xs"

lemma set_ass_list_to_single_list [simp]:
  "set (ass_list_to_single_list xs) = {x. \<exists>n. (x, n) \<in> set xs \<and> n > 0}"
  by (induct xs rule: ass_list_to_single_list.induct) auto

lemma count_mset_replicate [simp]:
  "count (mset (replicate n x)) x = n"
  by (induct n) (auto)

lemma count_mset_lal_ge:
  "(x, n) \<in> set xs \<Longrightarrow> count (mset (ass_list_to_single_list xs)) x \<ge> n"
  by (induct xs) auto

lemma count_of_count_mset_lal [simp]:
  "distinct (map fst y) \<Longrightarrow> count_of y x = count (mset (ass_list_to_single_list y)) x"
  by (induct y) (auto simp: count_mset_lal_ge count_of_empty)

lemma Bag_mset: "Bag xs = mset (ass_list_to_single_list (DAList.impl_of xs))"
  by (intro multiset_eqI, induct xs) (auto simp: Alist_inverse)

lemma Bag_Alist_Cons:
  "x \<notin> fst ` set xs \<Longrightarrow> distinct (map fst xs) \<Longrightarrow>
    Bag (Alist ((x, n) # xs)) = mset (replicate n x) + Bag (Alist xs)"
  by (induct xs) (auto simp: Bag_mset Alist_inverse)

lemma mset_lal [simp]:
  "distinct (map fst xs) \<Longrightarrow> mset (ass_list_to_single_list xs) = Bag (Alist xs)"
  apply (induct xs) apply (auto simp: Bag_Alist_Cons)
  apply (simp add: Mempty_Bag empty.abs_eq)
  done

lemma Bag_s_mul_ext:
  "(Bag xs, Bag ys) \<in> s_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)} \<longleftrightarrow>
    fst (mul_ext f (ass_list_to_single_list (DAList.impl_of xs)) (ass_list_to_single_list (DAList.impl_of ys)))"
  by (auto simp: mul_ext_def Let_def Alist_impl_of)

lemma Bag_ns_mul_ext:
  "(Bag xs, Bag ys) \<in> ns_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)} \<longleftrightarrow>
    snd (mul_ext f (ass_list_to_single_list (DAList.impl_of xs)) (ass_list_to_single_list (DAList.impl_of ys)))"
  by (auto simp: mul_ext_def Let_def Alist_impl_of)

lemma smulextp_code[code]:
  "smulextp f (Bag xs) (Bag ys) \<longleftrightarrow> fst (mul_ext f (ass_list_to_single_list (DAList.impl_of xs)) (ass_list_to_single_list (DAList.impl_of ys)))"
  unfolding smulextp_def Bag_s_mul_ext ..

lemma nsmulextp_code[code]:
  "nsmulextp f (Bag xs) (Bag ys) \<longleftrightarrow> snd (mul_ext f (ass_list_to_single_list (DAList.impl_of xs)) (ass_list_to_single_list (DAList.impl_of ys)))"
  unfolding nsmulextp_def Bag_ns_mul_ext ..

lemma mulextp_code[code]:
  "mulextp f (Bag xs) (Bag ys) = mul_ext f (ass_list_to_single_list (DAList.impl_of xs)) (ass_list_to_single_list (DAList.impl_of ys))"
  unfolding mulextp_def by (simp add: nsmulextp_code smulextp_code)

end


section "No Invariant Checks"
theory no_failing_invchecks
imports packed_traces ignore_fails
begin

text "In this section we show that we can remove invariant checks from a trace
without changing the behaviour of the system."

definition openTransactions :: "('proc, 'op, 'any) trace \<Rightarrow> (invocId \<times> txId) set" where
"openTransactions tr \<equiv> {(i, tx) | i j tx txns. j<length tr \<and> tr!j = (i, ABeginAtomic tx txns) \<and> (\<forall>k. k>j \<and> k<length tr \<longrightarrow> tr!k \<noteq> (i, AEndAtomic))}"

lemma open_transactions_empty:
  shows "openTransactions [] = {}"
  by (auto simp add: openTransactions_def)

lemma open_transactions_append_one:
  shows "openTransactions (tr@[a]) =
(case a of
    (i, AEndAtomic) \<Rightarrow> openTransactions tr - ({i} \<times> UNIV)
  | (i, ABeginAtomic tx txns) \<Rightarrow> openTransactions tr \<union> {(i, tx)}
  | _ \<Rightarrow> openTransactions tr
)"
proof -
  obtain invoc action where a_def[simp]: "a = (invoc, action)"
    using prod.exhaust_sel by blast
  show ?thesis
  proof (cases action)
    case ALocal
    then show ?thesis
      by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  next
    case (ANewId x2)
    then show ?thesis by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  next
    case (ABeginAtomic x31 x32)
    then show ?thesis
      by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits,
          blast, blast, fastforce)
  next
    case AEndAtomic
    then show ?thesis
      by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast+)
  next
    case (ADbOp )
    then show ?thesis by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  next
    case (AInvoc )
    then show ?thesis by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  next
    case (AReturn x7)
    then show ?thesis by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  next
    case ACrash
    then show ?thesis by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  next
    case (AInvcheck r)
    then show ?thesis by (auto simp add: openTransactions_def nth_append split: prod.splits action.splits, blast)
  qed
qed

text \<open>
If only the local states in invocId i differ,
we can transfer an execution to the different state,
when the execution trace contains no action in i.
\<close>

lemma show_state_transfer:
  assumes steps: "S_start ~~ tr \<leadsto>* S_end"
    and step_simulate: "\<And>a tr' S S'. \<lbrakk>a\<in>set tr; S ~~ a \<leadsto> S'; P tr' S\<rbrakk> \<Longrightarrow> T S ~~ a \<leadsto> T S'"
    and step_preserves: "\<And>a tr' S S'. \<lbrakk>a\<in>set tr; S ~~ a \<leadsto> S'; P tr' S\<rbrakk> \<Longrightarrow> P (tr'@[a]) S'"
    and prop_initial: "P [] S_start"
  shows "(T S_start ~~ tr \<leadsto>* T S_end) \<and> P tr S_end"
  using steps step_simulate step_preserves prop_initial proof (induct rule: steps_induct)
  case initial
  show "(T S_start ~~ [] \<leadsto>* T S_start) \<and> P [] S_start"
    using \<open>P [] S_start\<close>
    by (auto simp add: steps_empty)
next
  case (step S' tr a S'')
  show "(T S_start ~~ tr @ [a] \<leadsto>* T S'') \<and> P (tr @ [a]) S''"
  proof (intro conjI)
    show "P (tr @ [a]) S''"
      by (metis append_is_Nil_conv butlast_snoc in_set_butlastD last_in_set last_snoc list.simps(3) prop_initial step.IH step.prems(1) step.prems(2) step.step)
    show " T S_start ~~ tr @ [a] \<leadsto>* T S''"
      by (metis UnI2 butlast_snoc in_set_butlastD list.set_intros(1) prop_initial set_append step.IH step.prems(1) step.prems(2) step.step steps_step)
  qed
qed

lemma show_state_transfer2_noP:
  assumes steps: "S_start ~~ tr \<leadsto>* S_end"
    and step_simulate: "\<And>i a S S'. \<lbrakk>(i,a)\<in>set tr; S ~~ (i,a) \<leadsto> S'\<rbrakk> \<Longrightarrow> T S ~~ (i,a) \<leadsto> T S'"
  shows "T S_start ~~ tr \<leadsto>* T S_end"
proof -
  from steps
  have "(T S_start ~~ tr \<leadsto>* T S_end) \<and> True"
    by (rule show_state_transfer; auto simp add: assms)
  then show ?thesis by simp
qed

lemma remove_local_step:
  fixes S_start S_end :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
  assumes step_a: "S_start ~~ a \<leadsto> S_mid"
    and steps: "S_start ~~ (a#tr) \<leadsto>* S_end"
    and steps_tr: "S_mid ~~ tr \<leadsto>* S_end"
    and a_def: "a = (i, ALocal ok)"
    and no_i: "\<And>a. a\<in>set tr \<Longrightarrow> get_invoc a \<noteq> i"
    and S_end'_def: "S_end' = S_end\<lparr>localState := (localState S_end)(i := localState S_start i)\<rparr>"
  shows "S_start ~~ tr \<leadsto>* S_end'"
proof -
  define T where
    "T \<equiv> \<lambda>S::('proc::valueType, 'ls, 'op, 'any::valueType) state. S\<lparr>localState := (localState S)(i := localState S_start i)\<rparr>"

  have "T S_mid = S_start"
    using step_a by (auto simp add: a_def step_simps T_def state_ext)

  from steps_tr
  have "T S_mid ~~ tr \<leadsto>* T S_end"
  proof (rule show_state_transfer2_noP)
    show "T S ~~ (i',a) \<leadsto> T S'" if "(i',a) \<in> set tr" and  "S ~~ (i',a) \<leadsto> S'" for i' a S S'
    proof -

      have [simp]: "i' \<noteq> i" using \<open>(i',a) \<in> set tr\<close> no_i by force
      then have [simp]: "i \<noteq> i'" by blast

      from \<open>S ~~ (i',a) \<leadsto> S'\<close>
      show "T S ~~ (i',a) \<leadsto> T S'"
        by (induct rule: step.cases, auto simp add: step_simps T_def state_ext elim: chooseSnapshot_unchanged_precise)
    qed
  qed

  then show "S_start ~~ tr \<leadsto>* S_end'"
    using S_end'_def T_def \<open>T S_mid = S_start\<close> by auto
qed

lemma remove_newId_step:
  fixes S_start S_end :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
  assumes steps: "S_start ~~ (a#tr) \<leadsto>* S_end"
    and step_a: "S_start ~~ a \<leadsto> S_mid"
    and steps_tr: "S_mid ~~ tr \<leadsto>* S_end"
    and a_def: "a = (i, ANewId uid)"
    and no_i: "\<And>a. a\<in>set tr \<Longrightarrow> get_invoc a \<noteq> i"
    and wf: "state_wellFormed S_start"
    and S_end'_def: "S_end' = S_end\<lparr>generatedIds := (generatedIds S_end)(to_nat uid := None), localState := (localState S_end)(i := localState S_start i)\<rparr>"
  shows "S_start ~~ tr \<leadsto>* S_end'"
proof -
  define T where
    "T \<equiv> \<lambda>S::('proc, 'ls, 'op, 'any) state. S\<lparr>generatedIds := (generatedIds S)(to_nat uid := None), localState := (localState S)(i := localState S_start i)\<rparr>"

  have "T S_mid = S_start"
    using step_a by (auto simp add: a_def step_simps T_def state_ext)

  have uid_fresh: "generatedIds S_start (to_nat uid) = None"
    using step_a a_def by (auto simp add: step_simps)

  obtain uid_i where "generatedIds S_mid (to_nat uid) \<triangleq> uid_i"
    using step_a by (auto simp add: a_def step_simps T_def state_ext)

  from \<open>S_mid ~~ tr \<leadsto>* S_end\<close> \<open>generatedIds S_mid (to_nat uid) \<triangleq> uid_i\<close>
  have uid_not_used: "(i, ANewId uid) \<notin> set tr" for i
    by (rule uid_used_only_once)

  from steps_tr
  have "T S_mid ~~ tr \<leadsto>* T S_end"
  proof (rule show_state_transfer2_noP)
    show "T S ~~ (i',a) \<leadsto> T S'" if in_trace: "(i',a) \<in> set tr" and  "S ~~ (i',a) \<leadsto> S'" for i' a S S'
    proof -

      have [simp]: "i' \<noteq> i" using \<open>(i',a) \<in> set tr\<close> no_i by force
      then have [simp]: "i \<noteq> i'" by blast

      from \<open>S ~~ (i',a) \<leadsto> S'\<close>
      show "T S ~~ (i',a) \<leadsto> T S'"
      proof (induct rule: step.cases)
        case (local C s ls f ls')
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (newId C s ls f ls' uid)
        then show ?case
          using in_trace uid_not_used by (auto simp add: step_simps T_def state_ext)
      next
        case (beginAtomic C s ls f ls' t vis snapshot)
        then show ?case by (auto simp add: step_simps T_def state_ext elim: chooseSnapshot_unchanged_precise)
      next
        case (endAtomic C s ls f ls' t)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (dbop C s ls f Op  ls' t c res vis)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (invocation C s proc initialState impl)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (return C s ls f res)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (crash C s ls)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (invCheck C res s)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      qed
    qed
  qed

  then show "S_start ~~ tr \<leadsto>* S_end'"
    using S_end'_def T_def \<open>T S_mid = S_start\<close> by (auto simp add: )

qed

lemma remove_beginAtomic_step:
  fixes S_start S_end :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
  assumes steps: "S_start ~~ (a#tr) \<leadsto>* S_end"
    and step_a: "S_start ~~ a \<leadsto> S_mid"
    and steps_tr: "S_mid ~~ tr \<leadsto>* S_end"
    and a_def: "a = (i, ABeginAtomic t txns)"
    and no_i: "\<And>a. a\<in>set tr \<Longrightarrow> get_invoc a \<noteq> i"
    and wf: "state_wellFormed S_start"
    and newCalls_def: "newCalls = callsInTransaction C newTxns \<down> happensBefore C"
    and snapshot_def: "snapshot = vis \<union> newCalls"
    and S_end'_def: "S_end' = S_end\<lparr>
                localState := (localState S_end)(i := localState S_start i),
                currentTx := (currentTx S_end)(i := None),
                txStatus := (txStatus S_end)(t := None),
                txOrigin := (txOrigin S_end)(t := None),
                visibleCalls := (visibleCalls S_end)(i := visibleCalls S_start i)
      \<rparr>"
  shows "S_start ~~ tr \<leadsto>* S_end'"
proof -
  define T where
    "T \<equiv> \<lambda>S::('proc, 'ls, 'op, 'any) state. S\<lparr>
                localState := (localState S)(i := localState S_start i),
                currentTx := (currentTx S)(i := None),
                txStatus := (txStatus S)(t := None),
                txOrigin := (txOrigin S)(t := None),
                visibleCalls := (visibleCalls S)(i := visibleCalls S_start i) \<rparr>"

  have noOrig: "txOrigin S_start t = None"
    using step_a local.wf wf_transaction_status_iff_origin by (auto simp add: a_def step_simps)

  then have "T S_mid = S_start"
    using step_a by (auto simp add: a_def step_simps T_def state_ext)

  define P where
    p_def: "P \<equiv> \<lambda>S::('proc, 'ls, 'op, 'any) state. t \<notin> committedTransactions S \<and> (\<forall>i'. i' \<noteq> i \<longrightarrow>  currentTx S i' \<noteq> Some t)"

  have "currentTx S_start i \<noteq> Some t" for i
    by (metis local.wf noOrig option.simps(3) wellFormed_currentTxUncommitted wf_transaction_status_iff_origin)

  then have "P S_mid"
    using step_a
    by (auto simp add: p_def step.simps  a_def  split: if_splits)

  from \<open>S_mid ~~ tr \<leadsto>* S_end\<close>
  have t_not_used1: "(i, ABeginAtomic t txns) \<notin> set tr" for i txns
    using a_def no_i steps transactionIdsUnique2 by fastforce

  from steps_tr
  have "(T S_mid ~~ tr \<leadsto>* T S_end) \<and> P S_end"
  proof (rule show_state_transfer)

    show "P S_mid"
      using \<open>P S_mid\<close> .

    show "\<And>a S S'. \<lbrakk>a \<in> set tr; S ~~ a \<leadsto> S'; P S\<rbrakk> \<Longrightarrow> P S'"
      using no_i by (auto simp add: step.simps p_def t_not_used1  split: if_splits)

    have "T S ~~ (i',a) \<leadsto> T S'" if in_trace: "(i',a) \<in> set tr" and  a_step: "S ~~ (i',a) \<leadsto> S'" and P_S: "P S" for i' a S S'
    proof -

      have [simp]: "i' \<noteq> i" using \<open>(i',a) \<in> set tr\<close> no_i by force
      then have [simp]: "i \<noteq> i'" by blast

      from \<open>S ~~ (i',a) \<leadsto> S'\<close>
      show "T S ~~ (i',a) \<leadsto> T S'"
      proof (induct rule: step.cases)
        case (local C s ls f ls')
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (newId C s ls f ls' uid)
        then show ?case
          using in_trace t_not_used1 by (auto simp add: step_simps T_def state_ext)
      next
        case (beginAtomic C s ls f ls' t vis snapshot)
        then show ?case
          using in_trace t_not_used1 p_def \<open>P S\<close> by (auto simp add: step_simps T_def state_ext elim!: chooseSnapshot_unchanged_precise)
      next
        case (endAtomic C s ls f ls' t)
        then show ?case
          using t_not_used1 \<open>P S\<close>
          by (auto simp add: step_simps T_def state_ext p_def, fastforce)
      next
        case (dbop C s ls f Op ls' t c res vis)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (invocation C s proc initialState impl)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (return C s ls f res)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (crash C s ls)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (invCheck C res s)
        have  "invContextH (callOrigin C) ((txOrigin C)(t := None)) ((txStatus C)(t := None)) (happensBefore C) (calls C) (knownIds C) (invocOp C)
               (invocRes C)
          = invContext C "
          using P_S \<open>S = C\<close>
          by (auto simp add: invContextH_def restrict_map_def p_def committedCallsH_def  isCommittedH_def restrict_relation_def intro!: ext split: if_splits)

        with invCheck
        show ?case
          using t_not_used1 P_S p_def by (auto simp add: step_simps T_def )
      qed
    qed
    then show "\<And>a S S'. \<lbrakk>a \<in> set tr; S ~~ a \<leadsto> S'; P S\<rbrakk> \<Longrightarrow> T S ~~ a \<leadsto> T S'"
      by force
  qed

  then show "S_start ~~ tr \<leadsto>* S_end'"
    using S_end'_def T_def \<open>T S_mid = S_start\<close> by (auto simp add: )

qed

lemma remove_DBOp_step:
  fixes S_start S_end :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
  assumes steps: "S_start ~~ (a#tr) \<leadsto>* S_end"
    and step_a: "S_start ~~ a \<leadsto> S_mid"
    and steps_tr: "S_mid ~~ tr \<leadsto>* S_end"
    and a_def: "a = (i, ADbOp cId operation res)"
    and no_i: "\<And>a. a\<in>set tr \<Longrightarrow> get_invoc a \<noteq> i"
    and wf: "state_wellFormed S_start"
    and S_end'_def: "S_end' = S_end\<lparr>
                localState := (localState S_end)(i := localState S_start i),
                calls := (calls S_end)(cId := None),
                callOrigin := (callOrigin S_end)(cId := None),
                visibleCalls := (visibleCalls S_end)(i := visibleCalls S_start i),
                happensBefore := happensBefore S_end - {cId} \<times> UNIV - UNIV \<times> {cId}
      \<rparr>"
  shows "S_start ~~ tr \<leadsto>* S_end'"
proof -

  obtain start_txn where "currentTx S_start i \<triangleq> start_txn"
    using step_a a_def by (auto simp add: step_simps)

  have calls_S_start_cId: "calls S_start cId = None"
    using a_def callIds_unique(1) steps by fastforce

  with wellFormed_visibleCallsSubsetCalls_h(1)[OF wf]
  have hb1: "(c, cId) \<notin> happensBefore S_start" for c
    by blast

  from calls_S_start_cId wellFormed_visibleCallsSubsetCalls_h(1)[OF wf]
  have hb2: "(cId, c) \<notin> happensBefore S_start" for c
    by blast

  from calls_S_start_cId
  have callOrigin_S_start_cId: "callOrigin S_start cId = None"
    using local.wf wellFormed_callOrigin_dom3 by blast

  define T where
    "T \<equiv> \<lambda>S::('proc, 'ls, 'op, 'any) state. S\<lparr>
                localState := (localState S)(i := localState S_start i),
                calls := (calls S)(cId := None),
                callOrigin := (callOrigin S)(cId := None),
                visibleCalls := (visibleCalls S)(i := visibleCalls S_start i),
                happensBefore := happensBefore S - {cId} \<times> UNIV - UNIV \<times> {cId}
    \<rparr>"

  then have "T S_mid = S_start"
    using step_a  by (auto simp add: a_def step_simps T_def,
        subst state_ext,
        intro conjI,
        insert hb1 hb2 callOrigin_S_start_cId,
        auto)

  define P where
    p_def: "P \<equiv> \<lambda>S::('proc, 'ls, 'op, 'any) state.
                     callOrigin S cId \<triangleq> start_txn
                   \<and> txStatus S start_txn \<triangleq> Uncommitted
                   \<and> (\<forall>i'. i\<noteq>i' \<longrightarrow> currentTx S i' \<noteq> Some start_txn)
                   \<and> (\<forall>x. (cId, x) \<notin> happensBefore S)
                   \<and> (\<forall>i' vis. i\<noteq>i' \<and> visibleCalls S i' \<triangleq> vis \<longrightarrow> cId \<notin> vis)"

  have cId_not_used_again: "(s, ADbOp cId Op res) \<notin> set tr" for s Op res
    using callIds_unique2[OF steps, where i=0] by (simp add: a_def,
        metis One_nat_def Suc_mono diff_Suc_1 in_set_conv_nth zero_less_Suc)

  from steps_tr
  have "(T S_mid ~~ tr \<leadsto>* T S_end) \<and> P S_end"
  proof (rule show_state_transfer)

    from step_a
    show "P S_mid"
      using \<open>currentTx S_start i \<triangleq> start_txn\<close> local.wf wellFormed_currentTxUncommitted
      by (auto simp add: p_def step_simps a_def,
          (insert wellFormed_currentTx_unique_h hb2 wellFormed_visibleCallsSubsetCalls2, blast)+)

    have cId_not_in_calls: "cId \<notin> callsInTransaction S newTxns \<down> happensBefore S" if "newTxns \<subseteq> committedTransactions S" and "P S" for S newTxns
      using that  by (auto simp add: p_def callsInTransactionH_contains downwardsClosure_in)

    show "\<And>a S S'. \<lbrakk>a \<in> set tr; S ~~ a \<leadsto> S'; P S\<rbrakk> \<Longrightarrow> P S'"
      using no_i cId_not_used_again
      by (auto simp add: step.simps p_def cId_not_in_calls chooseSnapshot_committed  split: if_splits, fastforce+)

    have "T S ~~ (i',a) \<leadsto> T S'" if in_trace: "(i',a) \<in> set tr" and  a_step: "S ~~ (i',a) \<leadsto> S'" and P_S: "P S" for i' a S S'
    proof -

      have [simp]: "i' \<noteq> i" using \<open>(i',a) \<in> set tr\<close> no_i by force
      then have [simp]: "i \<noteq> i'" by blast

      from \<open>S ~~ (i',a) \<leadsto> S'\<close>
      show "T S ~~ (i',a) \<leadsto> T S'"
      proof (induct rule: step.cases)
        case (local C s ls f ls')
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (newId C s ls f ls' uid)
        then show ?case
          using in_trace  by (auto simp add: step_simps T_def state_ext)
      next
        case (beginAtomic C s ls f ls' t vis snapshot)
        define C' where "C' \<equiv> C\<lparr>
            calls := (calls C)(cId := None),
            happensBefore := happensBefore C - {cId} \<times> UNIV - UNIV \<times> {cId},
            localState := (localState C)(i := localState S_start i),
            visibleCalls := (visibleCalls C)(i := visibleCalls S_start i),
            callOrigin := (callOrigin C)(cId := None)\<rparr>"

        from beginAtomic show ?case
        proof (auto simp add: step.simps T_def state_ext intro!: ext,
            auto simp add: intro!: exI[where x=C'],
            auto simp add: C'_def )

          show "chooseSnapshot_h snapshot vis (txStatus C) ((callOrigin C)(cId := None)) (happensBefore C - {cId} \<times> UNIV - UNIV \<times> {cId})"
            if c0: "i' = s"
              and c1: "a = ABeginAtomic t snapshot"
              and c2: "S = C"
              and c3: "S' = C \<lparr>localState := localState C(s \<mapsto> ls'), currentTx := currentTx C(s \<mapsto> t), txStatus := txStatus C(t \<mapsto> Uncommitted), txOrigin := txOrigin C(t \<mapsto> s), visibleCalls := visibleCalls C(s \<mapsto> snapshot)\<rparr>"
              and c4: "localState C s \<triangleq> ls"
              and c5: "currentProc C s \<triangleq> f"
              and c6: "f ls = BeginAtomic ls'"
              and c7: "currentTx C s = None"
              and c8: "txStatus C t = None"
              and c9: "visibleCalls C s \<triangleq> vis"
              and c10: "chooseSnapshot snapshot vis C"
              and c11: "s \<noteq> i"
            using `chooseSnapshot snapshot vis C`
            by (rule chooseSnapshot_unchanged_precise, insert P_S   c2 p_def, auto)
        qed

      next
        case (endAtomic C s ls f ls' t)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (dbop C s ls f Op ls' t c res vis)

        have [simp]: "cId \<notin> vis "
          using P_S \<open>i' \<noteq> i\<close> dbop.hyps(1) dbop.hyps(10) dbop.hyps(2) p_def by fastforce

        have sameContext:
             "(getContextH (calls C) (happensBefore C) (Some vis))
            = (getContextH ((calls C)(cId := None)) (happensBefore C - {cId} \<times> UNIV - UNIV \<times> {cId}) (Some vis))"
          by (auto simp add: getContextH_def restrict_map_def restrict_relation_def)

        from dbop
        show ?case using cId_not_used_again in_trace by (auto simp add: step_simps T_def state_ext sameContext)

      next
        case (invocation C s procName initialState impl)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (return C s ls f res)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (crash C s ls)
        then show ?case by (auto simp add: step_simps T_def state_ext)
      next
        case (invCheck C res s)
        have [simp]: "\<not>isCommitted C cId"
          using P_S committedCalls_uncommittedNotIn invCheck.hyps(1) p_def
          by (simp add: isCommittedH_def)
        have [simp]: "cId \<notin> committedCalls C"
          using P_S committedCalls_uncommittedNotIn invCheck.hyps(1) p_def by blast

        have [simp]: "isCommittedH ((callOrigin C)(cId := None)) (txStatus C) x
                  \<longleftrightarrow> isCommittedH (callOrigin C) (txStatus C) x"  for x
          by (auto simp add: isCommittedH_def,
           meson \<open>\<not> isCommitted C cId\<close> isCommittedH_def)

        have  "(invContextH ((callOrigin C)(cId := None)) (txOrigin C) (txStatus C) (happensBefore C - {cId} \<times> UNIV - UNIV \<times> {cId}) ((calls C)(cId := None))
           (knownIds C) (invocOp C) (invocRes C)
           )
          = invContext C"
          using P_S \<open>S = C\<close>
          by (auto simp add: p_def invContextH_def restrict_map_def committedCallsH_def restrict_relation_def downwardsClosure_def callsInTransactionH_def intro!: ext)

        with invCheck
        show ?case
          using P_S p_def by (auto simp add: step_simps T_def )
      qed
    qed
    then show "\<And>a S S'. \<lbrakk>a \<in> set tr; S ~~ a \<leadsto> S'; P S\<rbrakk> \<Longrightarrow> T S ~~ a \<leadsto> T S'"
      by force
  qed

  then show "S_start ~~ tr \<leadsto>* S_end'"
    using S_end'_def T_def \<open>T S_mid = S_start\<close> by (auto simp add: )

qed

lemma transfer_execution_local_difference:
  assumes steps: "S1 ~~ tr \<leadsto>* S1'"
    and no_i: "\<And>a. a\<in>set tr \<Longrightarrow> get_invoc a \<noteq> i"
    and S2_def: "S2 = S1\<lparr>localState := (localState S1)(i := ls),
      currentTx := (currentTx S1)(i := tx)\<rparr>"
    and S2'_def: "S2' = S1'\<lparr>localState := (localState S1')(i := ls),
      currentTx := (currentTx S1')(i := tx)\<rparr>"
  shows "S2 ~~ tr \<leadsto>* S2'"
  using steps no_i S2'_def proof (induct arbitrary: S2' rule: steps_induct)
  case initial
  then show ?case
    using steps_refl S2_def by blast
next
  case (step S' tr a S'')

  define S_mid where "S_mid \<equiv> S'\<lparr>localState := (localState S')(i := ls), currentTx := (currentTx S')(i := tx)\<rparr>"

  have "S2 ~~ tr \<leadsto>* S_mid"
  proof (rule step.IH)
    show "\<And>a. a \<in> set tr \<Longrightarrow> get_invoc a \<noteq> i"
      using step.prems(1) by auto
    show " S_mid = S'\<lparr>localState := (localState S')(i := ls), currentTx := (currentTx S')(i := tx)\<rparr>"
      by (simp add: S_mid_def)
  qed

  have [simp]: "get_invoc a \<noteq> i"
    by (auto simp add: step.prems(1))
  then have [simp]: "i\<noteq>get_invoc a"
    by blast

  from \<open>S' ~~ a \<leadsto> S''\<close>
  have "S_mid ~~ a \<leadsto> S2'"
  proof (induct rule: step.cases)
    case (local C s ls f ls')
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (newId C s ls f ls' uid)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (beginAtomic C s ls f ls' t vis snapshot)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close>
      by (auto simp add: step step_simps S_mid_def intro!: stateEqI elim: chooseSnapshot_unchanged)
  next
    case (endAtomic C s ls f ls' t)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (dbop C s ls f Op ls' t c res vis)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (invocation C s procName initialState impl)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (return C s ls f res)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (crash C s ls)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  next
    case (invCheck C res s)
    then show ?case
      using \<open>get_invoc a \<noteq> i\<close> by (auto simp add: step step_simps S_mid_def intro!: stateEqI)
  qed
  then show "S2 ~~ tr @ [a] \<leadsto>* S2'"
    using \<open>S2 ~~ tr \<leadsto>* S_mid\<close> steps_step by blast

qed

lemma transfer_execution_local_difference':
  assumes steps: "S1 ~~ tr \<leadsto>* S1'"
    and no_i: "\<And>a. a\<in>set tr \<Longrightarrow> get_invoc a \<noteq> i"
    and S2_def: "\<exists>ls tx. S2 = S1\<lparr>localState := (localState S1)(i := ls),
      currentTx := (currentTx S1)(i := tx)\<rparr>"
  shows "\<exists>S2'. S2 ~~ tr \<leadsto>* S2'"
  using transfer_execution_local_difference[OF steps no_i]
  using S2_def by blast

definition no_invariant_checks_in_transaction where
"no_invariant_checks_in_transaction tr \<equiv> \<forall>ib i s c tx txns.
    tr!ib = (s, ABeginAtomic tx txns)
  \<and> ib < i
  \<and> i < length tr
  \<and> (\<forall>j. ib<j \<and> j<i \<longrightarrow> tr!j \<noteq> (s, AEndAtomic))
  \<longrightarrow> tr!i \<noteq> (s, AInvcheck c) "

lemma show_no_invariant_checks_in_transaction[case_names hasEndatomic[invcheck beginatomic beginBefore lessLength]]:
  assumes "\<And>i s tx txns c ib. \<lbrakk>tr!i = (s, AInvcheck c); tr!ib = (s, ABeginAtomic tx txns); ib < i; i<length tr\<rbrakk>
            \<Longrightarrow> \<exists>j. ib<j \<and> j<i \<and> tr!j = (s, AEndAtomic)"
  shows "no_invariant_checks_in_transaction tr"
  using assms by (auto simp add: no_invariant_checks_in_transaction_def, blast)

lemma use_no_invariant_checks_in_transaction:
  assumes "no_invariant_checks_in_transaction tr"
    and "tr!i = (s, AInvcheck c)"
    and "tr!ib = (s, ABeginAtomic tx txns)"
    and "ib < i"
    and "i < length tr"
  shows "\<exists>j. ib<j \<and> j<i \<and> tr!j = (s, AEndAtomic)"
  using assms by (auto simp add: no_invariant_checks_in_transaction_def, blast)

lemma maintain_no_invariant_checks_in_transaction:
  assumes "no_invariant_checks_in_transaction tr"
    and "get_action (tr!pos) \<noteq> AEndAtomic"
    and "pos < length tr"
  shows "no_invariant_checks_in_transaction (take pos tr @ drop (Suc pos) tr)"
proof (rule show_no_invariant_checks_in_transaction)
  fix i s tx txns c ib
  assume a1: "(take pos tr @ drop (Suc pos) tr) ! i = (s, AInvcheck c)"
    and  a2: "(take pos tr @ drop (Suc pos) tr) ! ib = (s, ABeginAtomic tx txns)"
    and a3: "ib < i"
    and a4: "i < length (take pos tr @ drop (Suc pos) tr)"

  define i' where "i' \<equiv> if i < pos then i else Suc i"
  define ib' where "ib' \<equiv> if ib < pos then ib else Suc ib"

  have a1': "tr!i' = (s, AInvcheck c)"
    using a1 i'_def \<open>pos < length tr\<close> a4 by (auto simp add: nth_append min_def split: if_splits)

  have a2': "tr!ib' = (s, ABeginAtomic tx txns)"
    using a2 ib'_def \<open>pos < length tr\<close> a3 a4 by (auto simp add: nth_append min_def split: if_splits)
  have a3':"ib'<i'"
    using a3 i'_def ib'_def by auto
  have a4':"i'<length tr"
    using a4 i'_def by auto

  with use_no_invariant_checks_in_transaction[OF \<open>no_invariant_checks_in_transaction tr\<close> a1' a2' a3' a4']
  obtain j where "j>ib'" and "j < i'" and  "tr ! j = (s, AEndAtomic)"
    by auto

  have h1: "ib < j"  by (metis Suc_lessD \<open>ib' < j\<close> ib'_def)
  have h2: "j < i" if "j < pos"
    using \<open>j < i'\<close> i'_def less_antisym that by fastforce

  then show  "\<exists>j>ib. j < i \<and> (take pos tr @ drop (Suc pos) tr) ! j = (s, AEndAtomic)"
  proof (cases "j < pos")
    case True
    show ?thesis
      by (rule exI[where x=j], auto simp add: True \<open>tr ! j = (s, AEndAtomic)\<close> assms(3) h1 h2 less_imp_le min.absorb2 nth_append_first)
  next
    case False
    show ?thesis
    proof (rule exI[where x="j - 1"], auto)
      from  \<open>j>ib'\<close> \<open>j < i'\<close> False
      have
         "j \<le> i" and cases:"(ib < pos \<and> j \<ge> pos) \<or> ( ib \<ge> pos \<and> Suc ib < j )"
        by (auto simp add: ib'_def i'_def split: if_splits)

      have h3: "Suc ib < j"
        if c0: "ib < pos"
          and c1: "pos \<le> j"
          and c2: "j > 0"
        using Suc_lessI \<open>tr ! j = (s, AEndAtomic)\<close> assms(2) local.cases by fastforce

(*
        by (metis \<open>tr ! j = (s, AEndAtomic)\<close> assms(2) c0 c1 c2 h1 le_SucE less_antisym not_less snd_conv)
*)

      show "ib < j - Suc 0"
        using cases h3 by auto
      show "j - Suc 0 < i"
        using \<open>ib < j - Suc 0\<close> \<open>j \<le> i\<close> by linarith

      have "pos \<noteq> j"
        using \<open>tr ! j = (s, AEndAtomic)\<close> assms(2) by auto

      show " (take pos tr @ drop (Suc pos) tr) ! (j - Suc 0) = (s, AEndAtomic)"
        using \<open>tr ! j = (s, AEndAtomic)\<close>  False \<open>pos \<noteq> j\<close> \<open>j < i'\<close> a4' less_imp_diff_less less_trans
        by (auto simp add: nth_append nth_drop_if Suc_lessI min.absorb2)
    qed
  qed
qed

lemma maintain_no_invariant_checks_in_transaction2a:
  assumes "no_invariant_checks_in_transaction tr"
    and "pos < length tr"
    and "0 < pos"
    and pos_no_endAtomic:
    "\<And>i invoc tx txns. \<lbrakk>
        i<pos;
        tr!i = (invoc, ABeginAtomic tx txns);
      \<And>j. \<lbrakk>i<j; j<pos\<rbrakk> \<Longrightarrow> tr!j \<noteq> (invoc, AEndAtomic)
      \<rbrakk> \<Longrightarrow> tr!pos \<noteq> (invoc, AEndAtomic)"
  shows "no_invariant_checks_in_transaction (take pos tr @ drop (Suc pos) tr)"
proof (rule show_no_invariant_checks_in_transaction)
  fix i s tx txns c ib
  assume a0: "(take pos tr @ drop (Suc pos) tr) ! i = (s, AInvcheck c)"
    and a1: "(take pos tr @ drop (Suc pos) tr) ! ib = (s, ABeginAtomic tx txns)"
    and a2: "ib < i"
    and a3: "i < length (take pos tr @ drop (Suc pos) tr)"

  text "Function f converts position to position in original trace tr."
  define f where "f  \<equiv> \<lambda>i. if i < pos then i else Suc i"

  have [simp]: " min (length tr) pos = pos"
    using assms(2) by auto
  have [simp]: "pos + (length tr - Suc pos) = length tr - 1"
    by (simp add: Suc_leI assms(2))
  have [simp]: "Suc pos \<le> length tr"
    using assms(2) by auto

  have "i < length tr - 1"
    using a3 by auto

  have h1: "tr ! f i = (s, AInvcheck c)"
    using a0 by (auto simp add: f_def nth_append  split: if_splits)

  have h2: "tr ! f ib = (s, ABeginAtomic tx txns)"
    using a1 by (auto simp add: f_def nth_append  split: if_splits)

  from `no_invariant_checks_in_transaction tr`
  have "\<exists>j>f ib. j < f i \<and> tr ! j = (s, AEndAtomic)"
    using h1 h2
  proof (rule use_no_invariant_checks_in_transaction)
    show "f ib < f i"
      using a2 f_def by auto
    show "f i < length tr"
      using \<open>i < length tr - 1\<close> dual_order.strict_trans f_def by auto
  qed
  from this
  obtain j where "j > f ib" and " j < f i" and "tr!j = (s, AEndAtomic)"
    by blast

  show "\<exists>j>ib. j < i \<and> (take pos tr @ drop (Suc pos) tr) ! j = (s, AEndAtomic)"
  proof (rule classical)
    assume neg: "\<not> (\<exists>j>ib. j < i \<and> (take pos tr @ drop (Suc pos) tr) ! j = (s, AEndAtomic))"

    have "tr ! pos \<noteq> (s, AEndAtomic)" if "f ib < pos"
    proof (rule pos_no_endAtomic)
      show "tr ! f ib = (s, ABeginAtomic tx txns)"
        using h2 by auto
      show "f ib < pos" using that .
      show " \<And>j. \<lbrakk>f ib < j; j < pos\<rbrakk> \<Longrightarrow> tr ! j \<noteq> (s, AEndAtomic)"
        using neg apply (auto simp add: nth_append split: if_splits)
        apply (drule_tac x=j in spec)
        apply auto
         apply (metis dual_order.asym f_def not_less_eq)
        by (smt Suc_lessI \<open>f ib < j\<close> \<open>j < f i\<close> \<open>min (length tr) pos = pos\<close> \<open>tr ! j = (s, AEndAtomic)\<close> dual_order.strict_trans f_def isPrefix_appendI isPrefix_same length_take neg not_less_eq nth_take)
    qed

    hence  "j \<noteq> pos" if "f ib < pos"
      using \<open>tr ! j = (s, AEndAtomic)\<close> that by blast
    hence "j \<noteq> pos"
      using \<open>f ib < j\<close> by blast

(*
    thm pos_no_endAtomic
    have "j \<noteq> pos"
      using \<open>f ib < j\<close> \<open>tr ! j = (s, AEndAtomic)\<close> pos_no_endAtomic h2 by blast
*)

    show "\<exists>j>ib. j < i \<and> (take pos tr @ drop (Suc pos) tr) ! j = (s, AEndAtomic)"
    proof (intro exI conjI)
      show "ib < (if j \<le> pos then j else j - 1)"
        using \<open>f ib < j\<close> by (auto simp add: f_def split: if_splits)
      show "(if j \<le> pos then j else j - 1) < i"
        using \<open>j < f i\<close> \<open>j \<noteq> pos\<close> by (auto simp add: f_def split: if_splits)
      show "(take pos tr @ drop (Suc pos) tr) ! (if j \<le> pos then j else j - 1) = (s, AEndAtomic)"
        using \<open>tr ! j = (s, AEndAtomic)\<close>  \<open>j \<noteq> pos\<close> by (auto simp add: nth_append)
    qed
  qed
qed

lemma no_invariant_checks_in_transaction_tail:
  assumes "no_invariant_checks_in_transaction tr"
  shows "no_invariant_checks_in_transaction (drop 1 tr)"
proof (rule show_no_invariant_checks_in_transaction)

fix i s tx txns c ib
assume a0: "drop 1 tr ! i = (s, AInvcheck c)"
   and a1: "drop 1 tr ! ib = (s, ABeginAtomic tx txns)"
   and a2: "ib < i"
   and a3: "i < length (drop 1 tr)"

  from  `no_invariant_checks_in_transaction tr`
  have "\<exists>j>Suc ib. j < Suc i \<and> tr ! j = (s, AEndAtomic)"
  proof (rule  use_no_invariant_checks_in_transaction)
    show "tr ! Suc i = (s, AInvcheck c)"
      using a0 a3 by auto
    show "tr ! Suc ib = (s, ABeginAtomic tx txns)"
      using a1 a3 by auto
    show "Suc ib < Suc i"
      by (simp add: a2)
    show "Suc i < length tr"
      using a3 by auto
  qed
  then

  show "\<exists>j>ib. j < i \<and> drop 1 tr ! j = (s, AEndAtomic)"
    using Suc_less_eq2 a3 by auto
qed

lemma maintain_no_invariant_checks_in_transaction2:
  assumes "no_invariant_checks_in_transaction tr"
    and "pos < length tr"
    and pos_no_endAtomic:
    "\<And>i invoc tx txns. \<lbrakk>
        i<pos;
        tr!i = (invoc, ABeginAtomic tx txns);
      \<And>j. \<lbrakk>i<j; j<pos\<rbrakk> \<Longrightarrow> tr!j \<noteq> (invoc, AEndAtomic)
      \<rbrakk> \<Longrightarrow> tr!pos \<noteq> (invoc, AEndAtomic)"
  shows "no_invariant_checks_in_transaction (take pos tr @ drop (Suc pos) tr)"
proof (cases "0 < pos")
  case True
  then show ?thesis
    using assms maintain_no_invariant_checks_in_transaction2a pos_no_endAtomic by blast
next
  case False
  hence [simp]: "pos = 0"
    by simp

  then show ?thesis
    using assms(1) no_invariant_checks_in_transaction_tail by auto
qed

definition
"isNoInvCheck a \<equiv> case a of (s, AInvcheck txns) \<Rightarrow> False | _ \<Rightarrow> True"

definition
"removeInvChecks \<equiv> filter isNoInvCheck"

lemma removeInvChecks_same:
  assumes "S ~~ trace \<leadsto>* S'"
shows "S ~~ removeInvChecks trace \<leadsto>* S'"
using assms proof (induct rule: steps_induct)
  case initial
  then show ?case  by (auto simp add: removeInvChecks_def steps_empty)
next
  case (step S' tr a S'')
  then show ?case
    by (auto simp add: removeInvChecks_def isNoInvCheck_def steps_append step_simps steps_empty steps_single split: action.splits)

qed

lemma removeInvChecks_no_invcheck:
  assumes "ia < length (removeInvChecks trace)"
  shows "removeInvChecks trace ! ia \<noteq> (s, AInvcheck c)"
proof
  assume "removeInvChecks trace ! ia = (s, AInvcheck c)"
  then have " (s, AInvcheck c) \<in> set (removeInvChecks trace)"
    using assms
    using nth_mem by force
  then show False
    by (auto simp add: removeInvChecks_def  isNoInvCheck_def)
qed

end


(*  Title:      Containers/RBT_ext.thy
    Author:     Andreas Lochbihler, KIT *)

theory RBT_ext
imports
  "~~/src/HOL/Library/RBT_Impl"
  Containers_Auxiliary
  List_Fusion
begin

section {* More on red-black trees *}

subsection {* More lemmas *}

context linorder begin

lemma is_rbt_fold_rbt_insert:
  "is_rbt t \<Longrightarrow> is_rbt (RBT_Impl.fold rbt_insert t' t)"
by(simp add: rbt_insert_def is_rbt_fold_rbt_insertwk)

lemma rbt_sorted_fold_insert: "rbt_sorted t \<Longrightarrow> rbt_sorted (RBT_Impl.fold rbt_insert t' t)"
by(induct t' arbitrary: t)(simp_all add: rbt_insert_rbt_sorted)

lemma rbt_lookup_rbt_insert': "rbt_sorted t \<Longrightarrow> rbt_lookup (rbt_insert k v t) = rbt_lookup t(k \<mapsto> v)"
by(simp add: rbt_insert_def rbt_lookup_rbt_insertwk fun_eq_iff split: option.split)

lemma rbt_lookup_fold_rbt_insert:
  "rbt_sorted t2 \<Longrightarrow>
  rbt_lookup (RBT_Impl.fold rbt_insert t1 t2) = rbt_lookup t2 ++ map_of (rev (RBT_Impl.entries t1))"
proof(induction t1 arbitrary: t2)
  case Empty thus ?case by simp
next
  case (Branch c l x k r)
  show ?case using Branch.prems
    by(simp add: map_add_def Branch.IH rbt_insert_rbt_sorted rbt_sorted_fold_insert rbt_lookup_rbt_insert' fun_eq_iff split: option.split)
qed

end

subsection {* Build the cross product of two RBTs *}

context fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e" begin

definition alist_product :: "('a \<times> 'b) list \<Rightarrow> ('c \<times> 'd) list \<Rightarrow> (('a \<times> 'c) \<times> 'e) list"
where "alist_product xs ys = concat (map (\<lambda>(a, b). map (\<lambda>(c, d). ((a, c), f a b c d)) ys) xs)"

lemma alist_product_simps [simp]:
  "alist_product [] ys = []"
  "alist_product xs [] = []"
  "alist_product ((a, b) # xs) ys = map (\<lambda>(c, d). ((a, c), f a b c d)) ys @ alist_product xs ys"
by(simp_all add: alist_product_def)

lemma append_alist_product_conv_fold:
  "zs @ alist_product xs ys = rev (fold (\<lambda>(a, b). fold (\<lambda>(c, d) rest. ((a, c), f a b c d) # rest) ys) xs (rev zs))"
proof(induction xs arbitrary: zs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by(cases x)
  have "\<And>zs. fold (\<lambda>(c, d). op # ((a, c), f a b c d)) ys zs =
    rev (map (\<lambda>(c, d). ((a, c), f a b c d)) ys) @ zs"
    by(induct ys) auto
  with Cons.IH[of "zs @ map (\<lambda>(c, d). ((a, c), f a b c d)) ys"] x
  show ?case by simp
qed

lemma set_alist_product:
  "set (alist_product xs ys) =
  (\<lambda>((a, b), (c, d)). ((a, c), f a b c d)) ` (set xs \<times> set ys)"
by(auto 4 3 simp add: alist_product_def intro: rev_image_eqI rev_bexI)

lemma distinct_alist_product:
  "\<lbrakk> distinct (map fst xs); distinct (map fst ys) \<rbrakk>
  \<Longrightarrow> distinct (map fst (alist_product xs ys))"
proof(induct xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by(cases x)
  have "distinct (map (fst \<circ> (\<lambda>(c, d). ((a, c), f a b c d))) ys)"
    using `distinct (map fst ys)` by(induct ys)(auto intro: rev_image_eqI)
  thus ?case using Cons x by(auto simp add: set_alist_product intro: rev_image_eqI)
qed

lemma map_of_alist_product:
  "map_of (alist_product xs ys) (a, c) =
  (case map_of xs a of None \<Rightarrow> None
   | Some b \<Rightarrow> map_option (f a b c) (map_of ys c))"
proof(induction xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by (cases x)
  let ?map = "map (\<lambda>(c, d). ((a, c), f a b c d)) ys"
  have "map_of ?map (a, c) = map_option (f a b c) (map_of ys c)"
    by(induct ys) auto
  moreover {
    fix a' assume "a' \<noteq> a"
    hence "map_of ?map (a', c) = None"
      by(induct ys) auto }
  ultimately show ?case using x Cons.IH
    by(auto simp add: map_add_def split: option.split)
qed

definition rbt_product :: "('a, 'b) rbt \<Rightarrow> ('c, 'd) rbt \<Rightarrow> ('a \<times> 'c, 'e) rbt"
where
  "rbt_product rbt1 rbt2 = rbtreeify (alist_product (RBT_Impl.entries rbt1) (RBT_Impl.entries rbt2))"

lemma rbt_product_code [code]:
  "rbt_product rbt1 rbt2 =
   rbtreeify (rev (RBT_Impl.fold (\<lambda>a b. RBT_Impl.fold (\<lambda>c d rest. ((a, c), f a b c d) # rest) rbt2) rbt1 []))"
unfolding rbt_product_def alist_product_code RBT_Impl.fold_def ..

end

context
  fixes leq_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>a" 50)
  and less_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>a" 50)
  and leq_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>b" 50)
  and less_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>b" 50)
  assumes lin_a: "class.linorder leq_a less_a"
  and lin_b: "class.linorder leq_b less_b"
begin

abbreviation (input) less_eq_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where "less_eq_prod' \<equiv> less_eq_prod leq_a less_a leq_b"

abbreviation (input) less_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where "less_prod' \<equiv> less_prod leq_a less_a less_b"

lemmas linorder_prod = linorder_prod[OF lin_a lin_b]

lemma sorted_alist_product:
  assumes xs: "linorder.sorted leq_a (map fst xs)" "distinct (map fst xs)"
  and ys: "linorder.sorted op \<sqsubseteq>\<^sub>b (map fst ys)"
  shows "linorder.sorted op \<sqsubseteq> (map fst (alist_product f xs ys))"
proof -
  interpret a!: linorder "op \<sqsubseteq>\<^sub>a" "op \<sqsubset>\<^sub>a" by(fact lin_a)

  note [simp] =
    linorder.sorted.Nil[OF linorder_prod] linorder.sorted_Cons[OF linorder_prod]
    linorder.sorted_append[OF linorder_prod]
    linorder.sorted_Cons[OF lin_b]
    linorder.sorted_Cons[OF lin_a]

  show ?thesis using xs
  proof(induction xs)
    case Nil show ?case by simp
  next
    case (Cons x xs)
    obtain a b where x: "x = (a, b)" by(cases x)
    have "linorder.sorted op \<sqsubseteq> (map fst (map (\<lambda>(c, d). ((a, c), f a b c d)) ys))"
      using ys by(induct ys) auto
    thus ?case using x Cons
      by(fastforce simp add: set_alist_product a.not_less dest: bspec a.antisym intro: rev_image_eqI)
  qed
qed

lemma is_rbt_rbt_product:
  "\<lbrakk> ord.is_rbt op \<sqsubset>\<^sub>a rbt1; ord.is_rbt op \<sqsubset>\<^sub>b rbt2 \<rbrakk>
  \<Longrightarrow> ord.is_rbt op \<sqsubset> (rbt_product f rbt1 rbt2)"
unfolding rbt_product_def
by(blast intro: linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b])

lemma rbt_lookup_rbt_product:
  "\<lbrakk> ord.is_rbt op \<sqsubset>\<^sub>a rbt1; ord.is_rbt op \<sqsubset>\<^sub>b rbt2 \<rbrakk>
  \<Longrightarrow> ord.rbt_lookup op \<sqsubset> (rbt_product f rbt1 rbt2) (a, c) =
     (case ord.rbt_lookup op \<sqsubset>\<^sub>a rbt1 a of None \<Rightarrow> None
      | Some b \<Rightarrow> map_option (f a b c) (ord.rbt_lookup op \<sqsubset>\<^sub>b rbt2 c))"
by(simp add: rbt_product_def linorder.rbt_lookup_rbtreeify[OF linorder_prod] linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b] map_of_alist_product linorder.map_of_entries[OF lin_a] linorder.map_of_entries[OF lin_b] cong: option.case_cong)

end

hide_const less_eq_prod' less_prod'

subsection {* Build an RBT where keys are paired with themselves *}

primrec RBT_Impl_diag :: "('a, 'b) rbt \<Rightarrow> ('a \<times> 'a, 'b) rbt"
where
  "RBT_Impl_diag rbt.Empty = rbt.Empty"
| "RBT_Impl_diag (rbt.Branch c l k v r) = rbt.Branch c (RBT_Impl_diag l) (k, k) v (RBT_Impl_diag r)"

lemma entries_RBT_Impl_diag:
  "RBT_Impl.entries (RBT_Impl_diag t) = map (\<lambda>(k, v). ((k, k), v)) (RBT_Impl.entries t)"
by(induct t) simp_all

lemma keys_RBT_Impl_diag:
  "RBT_Impl.keys (RBT_Impl_diag t) = map (\<lambda>k. (k, k)) (RBT_Impl.keys t)"
by(simp add: RBT_Impl.keys_def entries_RBT_Impl_diag split_beta)

lemma rbt_sorted_RBT_Impl_diag:
  "ord.rbt_sorted lt t \<Longrightarrow> ord.rbt_sorted (less_prod leq lt lt) (RBT_Impl_diag t)"
by(induct t)(auto simp add: ord.rbt_sorted.simps ord.rbt_less_prop ord.rbt_greater_prop keys_RBT_Impl_diag)

lemma bheight_RBT_Impl_diag:
  "bheight (RBT_Impl_diag t) = bheight t"
by(induct t) simp_all

lemma inv_RBT_Impl_diag:
  assumes "inv1 t" "inv2 t"
  shows "inv1 (RBT_Impl_diag t)" "inv2 (RBT_Impl_diag t)"
  and "color_of t = color.B \<Longrightarrow> color_of (RBT_Impl_diag t) = color.B"
using assms by(induct t)(auto simp add: bheight_RBT_Impl_diag)

lemma is_rbt_RBT_Impl_diag:
  "ord.is_rbt lt t \<Longrightarrow> ord.is_rbt (less_prod leq lt lt) (RBT_Impl_diag t)"
by(simp add: ord.is_rbt_def rbt_sorted_RBT_Impl_diag inv_RBT_Impl_diag)

lemma (in linorder) rbt_lookup_RBT_Impl_diag:
  "ord.rbt_lookup (less_prod op \<le> op < op <) (RBT_Impl_diag t) =
  (\<lambda>(k, k'). if k = k' then ord.rbt_lookup op < t k else None)"
by(induct t)(auto simp add: ord.rbt_lookup.simps fun_eq_iff)

subsection {* Folding and quantifiers over RBTs *}

definition RBT_Impl_fold1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a, unit) RBT_Impl.rbt \<Rightarrow> 'a"
where "RBT_Impl_fold1 f rbt = fold f (tl (RBT_Impl.keys rbt)) (hd (RBT_Impl.keys rbt))"

lemma RBT_Impl_fold1_simps [simp, code]:
  "RBT_Impl_fold1 f rbt.Empty = undefined"
  "RBT_Impl_fold1 f (Branch c rbt.Empty k v r) = RBT_Impl.fold (\<lambda>k v. f k) r k"
  "RBT_Impl_fold1 f (Branch c (Branch c' l' k' v' r') k v r) =
   RBT_Impl.fold (\<lambda>k v. f k) r (f k (RBT_Impl_fold1 f (Branch c' l' k' v' r')))"
by(simp_all add: RBT_Impl_fold1_def RBT_Impl.keys_def fold_map RBT_Impl.fold_def split_def o_def tl_append hd_def split: list.split)

definition RBT_Impl_rbt_all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where [code del]: "RBT_Impl_rbt_all P rbt = (\<forall>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"

lemma RBT_Impl_rbt_all_simps [simp, code]:
  "RBT_Impl_rbt_all P rbt.Empty \<longleftrightarrow> True"
  "RBT_Impl_rbt_all P (Branch c l k v r) \<longleftrightarrow> P k v \<and> RBT_Impl_rbt_all P l \<and> RBT_Impl_rbt_all P r"
by(auto simp add: RBT_Impl_rbt_all_def)

definition RBT_Impl_rbt_ex :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where [code del]: "RBT_Impl_rbt_ex P rbt = (\<exists>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"

lemma RBT_Impl_rbt_ex_simps [simp, code]:
  "RBT_Impl_rbt_ex P rbt.Empty \<longleftrightarrow> False"
  "RBT_Impl_rbt_ex P (Branch c l k v r) \<longleftrightarrow> P k v \<or> RBT_Impl_rbt_ex P l \<or> RBT_Impl_rbt_ex P r"
by(auto simp add: RBT_Impl_rbt_ex_def)

subsection {* List fusion for RBTs *}

type_synonym ('a, 'b, 'c) rbt_generator_state = "('c \<times> ('a, 'b) RBT_Impl.rbt) list \<times> ('a, 'b) RBT_Impl.rbt"

fun rbt_has_next :: "('a, 'b, 'c) rbt_generator_state \<Rightarrow> bool"
where
  "rbt_has_next ([], rbt.Empty) = False"
| "rbt_has_next _ = True"

fun rbt_keys_next :: "('a, 'b, 'a) rbt_generator_state \<Rightarrow> 'a \<times> ('a, 'b, 'a) rbt_generator_state"
where
  "rbt_keys_next ((k, t) # kts, rbt.Empty) = (k, kts, t)"
| "rbt_keys_next (kts, rbt.Branch c l k v r) = rbt_keys_next ((k, r) # kts, l)"

lemma rbt_generator_induct [case_names empty split shuffle]:
  assumes "P ([], rbt.Empty)"
  and "\<And>k t kts. P (kts, t) \<Longrightarrow> P ((k, t) # kts, rbt.Empty)"
  and "\<And>kts c l k v r. P ((f k v, r) # kts, l) \<Longrightarrow> P (kts, Branch c l k v r)"
  shows "P ktst"
using assms
apply(induction_schema)
apply pat_completeness
apply(relation "measure (\<lambda>(kts, t). size_list (\<lambda>(k, t). size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t) kts + size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t)")
apply simp_all
done

lemma terminates_rbt_keys_generator:
  "terminates (rbt_has_next, rbt_keys_next)"
proof
  fix ktst :: "('a \<times> ('a, 'b) rbt) list \<times> ('a, 'b) rbt"
  show "ktst \<in> terminates_on (rbt_has_next, rbt_keys_next)"
    by(induct ktst taking: "\<lambda>k _. k" rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
qed

lift_definition rbt_keys_generator :: "('a, ('a, 'b, 'a) rbt_generator_state) generator"
  is "(rbt_has_next, rbt_keys_next)"
by(rule terminates_rbt_keys_generator)

definition rbt_init :: "('a, 'b) rbt \<Rightarrow> ('a, 'b, 'c) rbt_generator_state"
where "rbt_init = Pair []"

lemma has_next_rbt_keys_generator [simp]:
  "list.has_next rbt_keys_generator = rbt_has_next"
by transfer simp

lemma next_rbt_keys_generator [simp]:
  "list.next rbt_keys_generator = rbt_keys_next"
by transfer simp

lemma unfoldr_rbt_keys_generator_aux:
  "list.unfoldr rbt_keys_generator (kts, t) =
  RBT_Impl.keys t @ concat (map (\<lambda>(k, t). k # RBT_Impl.keys t) kts)"
proof(induct "(kts, t)" arbitrary: kts t taking: "\<lambda>k _. k" rule: rbt_generator_induct)
  case empty thus ?case
    by(simp add: list.unfoldr.simps)
next
  case split thus ?case
    by(subst list.unfoldr.simps) simp
next
  case shuffle thus ?case
    by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
qed

corollary unfoldr_rbt_keys_generator:
  "list.unfoldr rbt_keys_generator (rbt_init t) = RBT_Impl.keys t"
by(simp add: unfoldr_rbt_keys_generator_aux rbt_init_def)

fun rbt_entries_next ::
  "('a, 'b, 'a \<times> 'b) rbt_generator_state \<Rightarrow> ('a \<times> 'b) \<times> ('a, 'b, 'a \<times> 'b) rbt_generator_state"
where
  "rbt_entries_next ((kv, t) # kts, rbt.Empty) = (kv, kts, t)"
| "rbt_entries_next (kts, rbt.Branch c l k v r) = rbt_entries_next (((k, v), r) # kts, l)"

lemma terminates_rbt_entries_generator:
  "terminates (rbt_has_next, rbt_entries_next)"
proof(rule terminatesI)
  fix ktst :: "('a, 'b, 'a \<times> 'b) rbt_generator_state"
  show "ktst \<in> terminates_on (rbt_has_next, rbt_entries_next)"
    by(induct ktst taking: Pair rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
qed

lift_definition rbt_entries_generator :: "('a \<times> 'b, ('a, 'b, 'a \<times> 'b) rbt_generator_state) generator"
  is "(rbt_has_next, rbt_entries_next)"
by(rule terminates_rbt_entries_generator)

lemma has_next_rbt_entries_generator [simp]:
  "list.has_next rbt_entries_generator = rbt_has_next"
by transfer simp

lemma next_rbt_entries_generator [simp]:
  "list.next rbt_entries_generator = rbt_entries_next"
by transfer simp

lemma unfoldr_rbt_entries_generator_aux:
  "list.unfoldr rbt_entries_generator (kts, t) =
  RBT_Impl.entries t @ concat (map (\<lambda>(k, t). k # RBT_Impl.entries t) kts)"
proof(induct "(kts, t)" arbitrary: kts t taking: Pair rule: rbt_generator_induct)
  case empty thus ?case
    by(simp add: list.unfoldr.simps)
next
  case split thus ?case
    by(subst list.unfoldr.simps) simp
next
  case shuffle thus ?case
    by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
qed

corollary unfoldr_rbt_entries_generator:
  "list.unfoldr rbt_entries_generator (rbt_init t) = RBT_Impl.entries t"
by(simp add: unfoldr_rbt_entries_generator_aux rbt_init_def)

end