           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2012         |
            |               November 2012  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2013         |
            |                   June 2013  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Set_F
imports Trace
begin

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(***********************************************************
                 type def (Failure Part)
 ***********************************************************)

(* types 'a failure = "'a trace * 'a event set"       (* synonym *)   Isabelle 2011 *)
type_synonym 'a failure = "'a trace * 'a event set"       (* synonym *)

definition
  HC_F2    :: "'a failure set => bool"
  where
  HC_F2_def : "HC_F2 F == (ALL s X Y. ((s,X) : F & Y <= X) --> (s,Y) : F)"

definition "setF  = {F::('a failure set). HC_F2(F)}"
typedef 'a setF = "setF :: 'a failure set set"
apply (rule_tac x ="{}" in exI)
apply (simp add: setF_def)
by (simp add: HC_F2_def)

declare Rep_setF         [simp]

(***********************************************************
                   operators on setF
 ***********************************************************)

definition
  memF     :: "'a failure => 'a setF => bool"  ("(_/ :f _)" [50, 51] 50)
  where
  memF_def     : "x :f F     == x : (Rep_setF F)"

definition
  CollectF :: "('a failure => bool) => 'a setF"("CollectF")
  where
  CollectF_def : "CollectF P == Abs_setF (Collect P)"

definition
  UnionF   :: "'a setF set => 'a setF"         ("UnionF _" [90] 90)
  where
  UnionF_def   : "UnionF Fs  == Abs_setF (Union (Rep_setF ` Fs))"

definition
  InterF   :: "'a setF set => 'a setF"         ("InterF _" [90] 90)
  where
  InterF_def   : "InterF Fs  == Abs_setF (Inter (Rep_setF ` Fs))"

definition
  empF     :: "'a setF"                        ("{}f")
  where
  empF_def     : "{}f        == Abs_setF {}"

definition
  UNIVF    :: "'a setF"                        ("UNIVf")
  where
  UNIVF_def    : "UNIVf      == Abs_setF UNIV"

(******** X-symbols ********)
(*
notation (xsymbols) memF ("(_/ \<in>f _)" [50, 51] 50)
notation (xsymbols) UnionF ("\<Union>f _" [90] 90)
notation (xsymbols) InterF ("\<Inter>f _" [90] 90)
*)

(******** syntactic sugar ********)

abbreviation
 nonmemF :: "'a failure => 'a setF => bool"   ("(_/ ~:f _)" [50, 51] 50)
 where "x ~:f F == ~ x :f F"

abbreviation
 UnF :: "'a setF => 'a setF => 'a setF"   ("_ UnF _" [65,66] 65)
 where "F UnF E == UnionF {F,E}"

abbreviation
 IntF :: "'a setF => 'a setF => 'a setF"   ("_ IntF _" [70,71] 70)
 where "F IntF E == InterF {F,E}"

syntax
  "@CollF"    :: "pttrn => bool => 'a setF"        ("(1{_./ _}f)" [1000,10] 1000)
  "@FinsetF"  :: "args => 'a setF"                 ("{(_)}f" [1000] 1000)

translations
  "{x. P}f"    == "CONST Abs_setF {x. P}" (* "CONST" for isabelle2009-2 *)
  "{X}f"       == "CONST Abs_setF {X}"    (* "CONST" for isabelle2009-2 *)

(******** X-symbols ********)
(*
notation (xsymbols) nonmemF  ("(_/ \<notin>f _)" [50, 51] 50)
notation (xsymbols) UnF      ("_ \<union>f _" [65,66] 65)
notation (xsymbols) IntF     ("_ \<inter>f _" [70,71] 70)
*)
(*********************************************************
          The relation (<=) is defined over setF
 *********************************************************)

instantiation setF :: (type) ord
begin
definition
  subsetF_def:
    "F <= E  ==  (Rep_setF F) <= (Rep_setF E)"
definition
  psubsetF_def:
    "F <  E  ==  (Rep_setF F) <  (Rep_setF E)"

instance
by (intro_classes)
end

(*********************************************************
          The relation (<=) is a partial order
 *********************************************************)

instance setF :: (type) order
apply (intro_classes)
apply (unfold subsetF_def psubsetF_def)
(* apply (simp add: less_fun_def)                (* isabelle 2009-2011 !! *)*)
apply (simp only: order_less_le Rep_setF_inject)
apply (auto simp add: Rep_setF_inject)
done

(***********************************************************
                          lemmas
 ***********************************************************)

(*******************************
             basic
 *******************************)

lemma setF_F2:
  "[| F : setF ; (s,X) : F ; Y <= X |] ==> (s,Y) : F"
apply (simp add: setF_def)
apply (unfold HC_F2_def)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
apply (drule_tac x="Y" in spec)
by (simp)

(*** {} in setF ***)

lemma emptyset_in_setF[simp]: "{} : setF"
by (simp add: setF_def HC_F2_def)

(*******************************
         check in setF
 *******************************)

(*** [] (for STOP) ***)

lemma nilt_in_setF[simp]: "{(<>, X) |X. X <= EvsetTick} : setF"
by (auto simp add: setF_def HC_F2_def)

(*** [Tick] (for SKIP) ***)
lemma nilt_Tick_in_setF[simp]: "{(<>, X) |X. X <= Evset} Un
                                {(<Tick>, X) |X. X <= EvsetTick} : setF"
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)
apply (elim conjE disjE)
by (simp_all)

(*** Union ***)

lemma setF_Union_in_setF: "(Union (Rep_setF ` Fs)) : setF"
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)

apply (erule conjE)
apply (erule bexE)
apply (rename_tac s X Y F)
apply (rule_tac x="F" in bexI)
apply (rule setF_F2)
by (simp_all)

(*** Un ***)

lemma setF_Un_in_setF:
  "(Rep_setF F Un Rep_setF E) : setF"
apply (insert setF_Union_in_setF[of "{F,E}"])
by (simp)

(*** Inter ***)

lemma setF_Inter_in_setF: "(Inter (Rep_setF ` Fs)) : setF"
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)

apply (rule ballI)
apply (rename_tac s X Y F)
apply (erule conjE)
apply (drule_tac x="F" in bspec, simp)
apply (rule setF_F2)
by (simp_all)

(*** Int ***)

lemma setF_Int_in_setF:
  "(Rep_setF F Int Rep_setF E) : setF"
apply (insert setF_Inter_in_setF[of "{F,E}"])
by (simp)

lemmas in_setF = setF_Union_in_setF setF_Un_in_setF
                 setF_Inter_in_setF setF_Int_in_setF

(*******************************
     setF type --> set type
 *******************************)

(*** UnionF ***)

lemma setF_UnionF_Rep:
  "Rep_setF (UnionF Fs) = Union (Rep_setF ` Fs)"
by (simp add: UnionF_def Abs_setF_inverse in_setF)

(*** UnF ***)

lemma setF_UnF_Rep:
  "Rep_setF (F UnF E) = (Rep_setF F) Un (Rep_setF E)"
by (simp add: setF_UnionF_Rep)

(*** InterF ***)

lemma setF_InterF_Rep:
  "Rep_setF (InterF Fs) = Inter (Rep_setF ` Fs)"
by (simp add: InterF_def Abs_setF_inverse in_setF)

(*** IntF ***)

lemma setF_IntF_Rep:
  "Rep_setF (F IntF E) = (Rep_setF F) Int (Rep_setF E)"
by (simp add: setF_InterF_Rep)

(*********************************************************
                       memF
 *********************************************************)

(* memF_F2 *)

lemma memF_F2:
  "[| (s,X) :f F ; Y <= X |] ==> (s,Y) :f F"
apply (simp add: memF_def)
apply (rule setF_F2)
by (simp_all)

(* UnionF *)

lemma memF_UnionF_only_if:
  "sX :f UnionF Fs ==> EX F:Fs. sX :f F"
by (simp add: memF_def setF_UnionF_Rep)

lemma memF_UnionF_if:
  "[| F:Fs ; sX :f F |] ==> sX :f UnionF Fs"
apply (subgoal_tac "Fs ~= {}")
apply (simp add: memF_def setF_UnionF_Rep)
apply (rule_tac x="F" in bexI)
by (auto)

lemma memF_UnionF[simp]:
  "sX :f UnionF Fs = (EX F:Fs. sX :f F)"
apply (rule iffI)
apply (simp add: memF_UnionF_only_if)
by (auto simp add: memF_UnionF_if)

(* InterF *)

lemma memF_InterF_only_if:
  "sX :f InterF Fs ==> ALL F:Fs. sX :f F"
by (simp add: memF_def setF_InterF_Rep)

lemma memF_InterF_if:
  "ALL F:Fs. sX :f F ==> sX :f InterF Fs"
by (simp add: memF_def setF_InterF_Rep)

lemma memF_InterF[simp]:
  "sX :f InterF Fs = (ALL F:Fs. sX :f F)"
apply (rule iffI)
apply (rule memF_InterF_only_if, simp_all)
by (simp add: memF_InterF_if)

(* empty *)

lemma memF_empF[simp]: "sX ~:f {}f"
apply (simp add: memF_def empF_def)
by (simp add: Abs_setF_inverse)

(* pair *)

lemma memF_pair_iff: "(f :f F) = (EX s X. f = (s,X) & (s,X) :f F)"
apply (rule)
apply (rule_tac x="fst f" in exI)
apply (rule_tac x="snd f" in exI)
by (auto)

lemma memF_pairI: "(EX s X. f = (s,X) & (s,X) :f F) ==> (f :f F)"
by (auto)

lemma memF_pairE_lm: "[| f :f F ; (EX s X. f = (s,X) & (s,X) :f F) --> R |] ==> R"
apply (drule mp)
apply (rule_tac x="fst f" in exI)
apply (rule_tac x="snd f" in exI)
by (auto)

lemma memF_pairE: "[| f :f F ; !! s X. [| f = (s,X) ; (s,X) :f F |] ==> R |] ==> R"
apply (erule memF_pairE_lm)
by (auto)

(*********************************************************
                       subsetF
 *********************************************************)

lemma subsetFI [intro!]: "(!! s X. (s, X) :f E ==> (s, X) :f F) ==> E <= F"
by (auto simp add: subsetF_def memF_def)

lemma subsetFE [elim!]:
  "[| E <= F ; (!!s X. (s, X) :f E ==> (s, X) :f F) ==> R |] ==> R"
by (auto simp add: subsetF_def memF_def)

lemma subsetFE_ALL:
  "[| E <= F ; (ALL s X. (s, X) :f E --> (s, X) :f F) ==> R |] ==> R"
by (auto simp add: subsetF_def memF_def)

lemma subsetF_iff: "((E::'a setF) <= F)
                  = (ALL s X. (s, X) :f E --> (s, X) :f F)"
by (auto)

(*** {}f is bottom ***)

lemma BOT_is_bottom_setF[simp]: "{}f <= F"
by (simp add: subsetF_iff)

lemma memF_subsetF: "[| (s,X) :f E ; E <= F |] ==> (s,X) :f F"
by (simp add: subsetF_iff)

(*********************************************************
                         UnF
 *********************************************************)

lemma UnF_commut: "E UnF F = F UnF E"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma UnF_assoc: "(E UnF F) UnF R = E UnF (F UnF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma UnF_left_commut: "E UnF (F UnF R) = F UnF (E UnF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemmas UnF_rules = UnF_commut UnF_assoc UnF_left_commut

(*********************************************************
                         IntF
 *********************************************************)

lemma IntF_commut: "E IntF F = F IntF E"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma IntF_assoc: "(E IntF F) IntF R = E IntF (F IntF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma IntF_left_commut: "E IntF (F IntF R) = F IntF (E IntF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemmas IntF_rules = IntF_commut IntF_assoc IntF_left_commut

(*********************************************************
                         CollectT
 *********************************************************)

(*** open ***)

lemma CollectF_open[simp]: "{u. u :f F}f = F"
apply (subgoal_tac "{f. f :f F} : setF")
apply (auto simp add: memF_def Abs_setF_inverse)
by (simp add: Rep_setF_inverse)

lemma CollectF_open_memF: "{f. P f} : setF ==> f :f {f. P f}f = P f"
by (simp add: memF_def Abs_setF_inverse)

(*** implies {  }f ***)

lemma set_CollectF_eq:
  "{f. Pr1 f} = {f. Pr2 f} ==>{f. Pr1 f}f = {f. Pr2 f}f"
by (simp)

lemma CollectF_eq:
  "[| !! f. Pr1 f = Pr2 f |] ==>{f. Pr1 f}f = {f. Pr2 f}f"
by (simp)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
end


section\<open>Enum toString Functions\<close>
theory Lib_Enum_toString
imports Main IP_Addresses.Lib_List_toString
begin

fun bool_toString :: "bool \<Rightarrow> string" where
  "bool_toString True = ''True''" |
  "bool_toString False = ''False''"

subsection\<open>Enum set to string\<close>
  fun enum_set_get_one :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a option" where
    "enum_set_get_one []     S = None" |
    "enum_set_get_one (s#ss) S = (if s \<in> S then Some s else enum_set_get_one ss S)"

  lemma enum_set_get_one_empty: "enum_set_get_one ss {} = None"
    by(induction ss) simp_all

  lemma enum_set_get_one_None: "S \<subseteq> set ss \<Longrightarrow> enum_set_get_one ss S = None \<longleftrightarrow> S = {}"
    apply(induction ss)
     apply(simp; fail)
    apply(simp)
    apply(intro conjI)
     apply blast
    by fast

  lemma enum_set_get_one_Some: "S \<subseteq> set ss \<Longrightarrow> enum_set_get_one ss S = Some x \<Longrightarrow> x \<in> S"
    apply(induction ss)
     apply(simp; fail)
    apply(simp split: if_split_asm)
    apply(blast)
    done
  corollary enum_set_get_one_enum_Some: "enum_set_get_one enum_class.enum S = Some x \<Longrightarrow> x \<in> S"
    using enum_set_get_one_Some[where ss=enum_class.enum, simplified enum_UNIV] by auto

  lemma enum_set_get_one_Ex_Some: "S \<subseteq> set ss \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>x. enum_set_get_one ss S = Some x"
    apply(induction ss)
     apply(simp; fail)
    apply(simp split: if_split_asm)
    apply(blast)
    done
  corollary enum_set_get_one_enum_Ex_Some:
    "S \<noteq> {} \<Longrightarrow> \<exists>x. enum_set_get_one enum_class.enum S = Some x"
    using enum_set_get_one_Ex_Some[where ss=enum_class.enum, simplified enum_UNIV] by auto

  function enum_set_to_list :: "('a::enum) set \<Rightarrow> 'a list" where
    "enum_set_to_list S = (if S = {} then [] else
      case enum_set_get_one Enum.enum S of None \<Rightarrow> []
                                        |  Some a \<Rightarrow> a#enum_set_to_list (S - {a}))"
  by(pat_completeness) auto

  termination enum_set_to_list
    apply(relation "measure (\<lambda>(S). card S)")
     apply(simp_all add: card_gt_0_iff)
    apply(drule enum_set_get_one_enum_Some)
    apply(subgoal_tac "finite S")
     prefer 2
     apply force
    apply (meson card_Diff1_less)
    done

  (*this definition is simpler*)
  lemma enum_set_to_list_simps: "enum_set_to_list S =
      (case enum_set_get_one (Enum.enum) S of None \<Rightarrow> []
                                           |  Some a \<Rightarrow> a#enum_set_to_list (S - {a}))"
   by(simp add: enum_set_get_one_empty)
  declare enum_set_to_list.simps[simp del]

  lemma enum_set_to_list: "set (enum_set_to_list A) = A"
    apply(induction A rule: enum_set_to_list.induct)
    apply(case_tac "S = {}")
     apply(simp add: enum_set_to_list.simps; fail)
    apply(simp)
    apply(subst enum_set_to_list_simps)
    apply(simp)
    apply(drule enum_set_get_one_enum_Ex_Some)
    apply(clarify)
    apply(simp)
    apply(drule enum_set_get_one_enum_Some)
    by blast

lemma "list_toString bool_toString (enum_set_to_list {True, False}) = ''[False, True]''" by eval

end


section \<open> Up Part \<close>

theory Up
imports UpDown_Scheme Triangular_Function
begin

lemma up'_inplace:
  assumes p'_in: "p' \<notin> grid p ds" and "d \<in> ds"
  shows "snd (up' d l p \<alpha>) p' = \<alpha> p'"
  using p'_in
proof (induct l arbitrary: p \<alpha>)
  case (Suc l)
  let "?ch dir" = "child p dir d"
  let "?up dir \<alpha>" = "up' d l (?ch dir) \<alpha>"
  let "?upl" = "snd (?up left \<alpha>)"

  from contrapos_nn[OF \<open>p' \<notin> grid p ds\<close> grid_child[OF \<open>d \<in> ds\<close>]]
  have left: "p' \<notin> grid (?ch left) ds" and
       right: "p' \<notin> grid (?ch right) ds" by auto

  have "p \<noteq> p'" using grid.Start Suc.prems by auto
  with Suc.hyps[OF left, of \<alpha>] Suc.hyps[OF right, of ?upl]
  show ?case
    by (cases "?up left \<alpha>", cases "?up right ?upl", auto simp add: Let_def)
qed auto

lemma up'_fl_fr:
      "\<lbrakk> d < length p ; p = (child p_r right d) ; p = (child p_l left d) \<rbrakk>
       \<Longrightarrow> fst (up' d lm p \<alpha>) =
              (\<Sum> p' \<in> lgrid p {d} (lm + level p). (\<alpha> p') * l2_\<phi> (p' ! d) (p_r ! d),
               \<Sum> p' \<in> lgrid p {d} (lm + level p). (\<alpha> p') * l2_\<phi> (p' ! d) (p_l ! d))"
proof (induct lm arbitrary: p p_l p_r \<alpha>)
  case (Suc lm)
  note \<open>d < length p\<close>[simp]

  from child_ex_neighbour
  obtain pc_r pc_l
    where pc_r_def: "child p right d = child pc_r (inv right) d"
    and pc_l_def: "child p left d = child pc_l (inv left) d" by blast

  define pc where "pc dir = (case dir of right \<Rightarrow> pc_r | left \<Rightarrow> pc_l)" for dir
  { fix dir have "child p (inv dir) d = child (pc (inv dir)) dir d"
      by (cases dir, auto simp add: pc_def pc_r_def pc_l_def) } note pc_child = this
  { fix dir have "child p dir d = child (pc dir) (inv dir) d"
      by (cases dir, auto simp add: pc_def pc_r_def pc_l_def) } note pc_child_inv = this
  hence "!! dir. length (child p dir d) = length (child (pc dir) (inv dir) d)" by auto
  hence "!! dir. length p = length (pc dir)" by auto
  hence [simp]: "!! dir. d < length (pc dir)" by auto

  let ?l = "\<lambda>s. lm + level s"
  let ?C = "\<lambda>p p'. (\<alpha> p) * l2_\<phi> (p ! d) (p' ! d)"
  let ?sum' = "\<lambda>s p''. \<Sum> p' \<in> lgrid s {d} (Suc lm + level p). ?C p' p''"
  let ?sum = "\<lambda>s dir p. \<Sum> p' \<in> lgrid (child s dir d) {d} (?l (child s dir d)). ?C p' p"
  let ?ch = "\<lambda>dir. child p dir d"
  let ?f = "\<lambda>dir. ?sum p dir (pc dir)"
  let ?fm = "\<lambda>dir. ?sum p dir p"
  let ?result = "(?fm left + ?fm right + (\<alpha> p) / 2 ^ (lv p d) / 2) / 2"
  let ?up = "\<lambda>lm p \<alpha>. up' d lm p \<alpha>"

  define \<beta>l where "\<beta>l = snd (?up lm (?ch left) \<alpha>)"
  define \<beta>r where "\<beta>r = snd (?up lm (?ch right) \<beta>l)"

  define p_d where "p_d dir = (case dir of right \<Rightarrow> p_r | left \<Rightarrow> p_l)" for dir
  have p_d_child: "p = child (p_d dir) dir d" for dir
    using Suc.prems p_d_def by (cases dir) auto
  hence "\<And> dir. length p = length (child (p_d dir) dir d)" by auto
  hence "\<And> dir. d < length (p_d dir)" by auto

  { fix dir

    { fix p' assume "p' \<in> lgrid (?ch (inv dir)) {d} (?l (?ch (inv dir))) "
      hence "?C p' (pc (inv dir)) + (?C p' p) / 2 = ?C p' (p_d dir)"
        using l2_zigzag[OF _ p_d_child[of dir] _ pc_child[of dir]]
        by (cases dir) (auto simp add: algebra_simps) }
    hence inv_dir_sum: "?sum p (inv dir) (pc (inv dir)) + (?sum p (inv dir) p) / 2
      = ?sum p (inv dir) (p_d dir)"
      by (auto simp add: sum.distrib[symmetric] sum_divide_distrib)

    have "?sum p dir p / 2 = ?sum p dir (p_d dir)"
      using l2_down2[OF _ _ \<open>p = child (p_d dir) dir d\<close>]
      by (force intro!: sum.cong simp add: sum_divide_distrib)
    moreover
    have "?C p (p_d dir) = (\<alpha> p) / 2 ^ (lv p d) / 4"
      using l2_child[OF \<open>d < length (p_d dir)\<close>, of p dir "{d}"] p_d_child[of dir]
      \<open>d < length (p_d dir)\<close> child_lv child_ix grid.Start[of p "{d}"]
      by (cases dir) (auto simp add: add_divide_distrib field_simps)
    ultimately
    have "?sum' p (p_d dir) =
      ?sum p (inv dir) (pc (inv dir)) +
      (?sum p (inv dir) p) / 2 + ?sum p dir p / 2 + (\<alpha> p) / 2 ^ (lv p d) / 4"
      using lgrid_sum[where b=p] and child_level and inv_dir_sum
      by (cases dir) auto
    hence "?sum p (inv dir) (pc (inv dir)) + ?result = ?sum' p (p_d dir)"
      by (cases dir) auto }
  note this[of left] this[of right]
  moreover
  note eq = up'_inplace[OF grid_not_child[OF \<open>d < length p\<close>], of d "{d}" lm]
  { fix p' assume "p' \<in> lgrid (?ch right) {d} (lm + level (?ch right))"
    with grid_disjunct[of d p] up'_inplace[of p' "?ch left" "{d}" d lm \<alpha>] \<beta>l_def
    have "\<beta>l p' = \<alpha> p'" by auto }
  hence "fst (?up (Suc lm) p \<alpha>) = (?f left + ?result, ?f right + ?result)"
    using \<beta>l_def pc_child_inv[of left] pc_child_inv[of right]
      Suc.hyps[of "?ch left" "pc left" p \<alpha>] eq[of left \<alpha>]
      Suc.hyps[of "?ch right" p "pc right" \<beta>l] eq[of right \<beta>l]
    by (cases "?up lm (?ch left) \<alpha>", cases "?up lm (?ch right) \<beta>l") (simp add: Let_def)
  ultimately show ?case by (auto simp add: p_d_def)
next
  case 0
  show ?case by simp
qed

lemma up'_\<beta>:
  "\<lbrakk> d < length b ; l + level b = lm ; b \<in> sparsegrid' dm ; p \<in> sparsegrid' dm \<rbrakk>
   \<Longrightarrow>
   (snd (up' d l b \<alpha>)) p =
     (if p \<in> lgrid b {d} lm
      then \<Sum> p' \<in> (lgrid p {d} lm) - {p}. \<alpha> p' * l2_\<phi> (p' ! d) (p ! d)
      else \<alpha> p)"
  (is "\<lbrakk> _ ; _ ; _ ; _ \<rbrakk> \<Longrightarrow> (?goal l b p \<alpha>)")
proof (induct l arbitrary: b p \<alpha>)
  case (Suc l)

  let ?l = "child b left d" and ?r = "child b right d"
  obtain p_l where p_l_def: "?r = child p_l left d" using child_ex_neighbour[where dir=right] by auto
  obtain p_r where p_r_def: "?l = child p_r right d" using child_ex_neighbour[where dir=left] by auto

  let ?ul = "up' d l ?l \<alpha>"
  let ?ur = "up' d l ?r (snd ?ul)"

  let "?C p'" = "\<alpha> p' * l2_\<phi> (p' ! d) (p ! d)"
  let "?s s" = "\<Sum> p' \<in> (lgrid s {d} lm). ?C p'"

  from \<open>b \<in> sparsegrid' dm\<close> have "length b = dm" unfolding sparsegrid'_def start_def
    by auto
  hence "d < dm" using \<open>d < length b\<close> by auto

  { fix p' assume "p' \<in> grid ?r {d}"
    hence "p' \<notin> grid ?l {d}"
      using grid_disjunct[OF \<open>d < length b\<close>] by auto
    hence "snd ?ul p' = \<alpha> p'" using up'_inplace by auto
  } note eq = this

  show "?goal (Suc l) b p \<alpha>"
  proof (cases "p = b")
    case True

    let "?C p'" = "\<alpha> p' * l2_\<phi> (p' ! d) (b ! d)"
    let "?s s" = "\<Sum> p' \<in> (lgrid s {d} lm). ?C p'"

    have "d < length ?l" using \<open>d < length b\<close> by auto
    from up'_fl_fr[OF this p_r_def]
    have fml: "snd (fst ?ul) = (\<Sum> p' \<in> lgrid ?l {d} (l + level ?l). ?C p')" by simp

    have "d < length ?r" using \<open>d < length b\<close> by auto
    from up'_fl_fr[OF this _ p_l_def, where \<alpha>="snd ?ul"]
    have fmr: "fst (fst ?ur) = (\<Sum> p' \<in> lgrid ?r {d} (l + level ?r).
                                ((snd ?ul) p') * l2_\<phi> (p' ! d) (b ! d))" by simp

    have "level b < lm" using \<open>Suc l + level b = lm\<close> by auto
    hence "{ b } \<subseteq> lgrid b {d} lm" unfolding lgrid_def by auto
    from sum_diff[OF lgrid_finite this]
    have "(\<Sum> p' \<in> (lgrid b {d} lm) - {b}. ?C p') = ?s b - ?C b" by simp
    also have "\<dots> = ?s ?l + ?s ?r"
      using lgrid_sum and \<open>level b < lm\<close> and \<open>d < length b\<close> by auto
    also have "\<dots> = snd (fst ?ul) + fst (fst ?ur)" using fml and fmr
      and \<open>Suc l + level b = lm\<close> and child_level[OF \<open>d < length b\<close>]
      using eq unfolding True lgrid_def by auto

    finally show ?thesis unfolding up'.simps Let_def and fun_upd_def lgrid_def
      using \<open>p = b\<close> and \<open>level b < lm\<close>
      by (cases ?ul, cases ?ur, auto)
  next
    case False

    have "?r \<in> sparsegrid' dm" and "?l \<in> sparsegrid' dm"
      using \<open>b \<in> sparsegrid' dm\<close> and \<open>d < dm\<close> unfolding sparsegrid'_def by auto
    from Suc.hyps[OF _ _ this(1)] Suc.hyps[OF _ _ this(2)]
    have "?goal l ?l p \<alpha>" and "?goal l ?r p (snd ?ul)"
      using \<open>d < length b\<close> and \<open>Suc l + level b = lm\<close> and \<open>p \<in> sparsegrid' dm\<close> by auto

    show ?thesis
    proof (cases "p \<in> lgrid b {d} lm")
      case True
      hence "level p < lm" and "p \<in> grid b {d}" unfolding lgrid_def by auto
      hence "p \<in> grid ?l {d} \<or> p \<in> grid ?r {d}"
        unfolding grid_partition[of b] using \<open>p \<noteq> b\<close> by auto
      thus ?thesis
      proof (rule disjE)
        assume "p \<in> grid (child b left d) {d}"
        hence "p \<notin> grid (child b right d) {d}"
          using grid_disjunct[OF \<open>d < length b\<close>] by auto
        thus ?thesis
          using \<open>?goal l ?l p \<alpha>\<close> and \<open>?goal l ?r p (snd ?ul)\<close>
          using \<open>p \<noteq> b\<close> \<open>p \<in> lgrid b {d} lm\<close>
          unfolding lgrid_def grid_partition[of b]
          by (cases ?ul, cases ?ur, auto simp add: Let_def)
      next
        assume *: "p \<in> grid (child b right d) {d}"
        hence "p \<notin> grid (child b left d) {d}"
          using grid_disjunct[OF \<open>d < length b\<close>] by auto
        moreover
        { fix p' assume "p' \<in> grid p {d}"
          from grid_transitive[OF this *] eq[of p']
          have "snd ?ul p' = \<alpha> p'" by simp
        }
        ultimately show ?thesis
          using \<open>?goal l ?l p \<alpha>\<close> and \<open>?goal l ?r p (snd ?ul)\<close>
          using \<open>p \<noteq> b\<close> \<open>p \<in> lgrid b {d} lm\<close> *
          unfolding lgrid_def
          by (cases ?ul, cases ?ur, auto simp add: Let_def)
  qed
next
      case False
      then have "p \<notin> lgrid ?l {d} lm" and "p \<notin> lgrid ?r {d} lm"
        unfolding lgrid_def and grid_partition[where p=b] by auto
      with False show ?thesis using \<open>?goal l ?l p \<alpha>\<close> and \<open>?goal l ?r p (snd ?ul)\<close>
        using \<open>p \<noteq> b\<close> \<open>p \<notin> lgrid b {d} lm\<close>
        unfolding lgrid_def
        by (cases ?ul, cases ?ur, auto simp add: Let_def)
    qed
  qed
next
  case 0
  then have "lgrid b {d} lm = {}"
    using lgrid_empty'[where p=b and lm=lm and ds="{d}"] by auto
  with 0 show ?case unfolding up'.simps by auto
qed

lemma up:
  assumes "d < dm" and "p \<in> sparsegrid dm lm"
  shows "(up dm lm d \<alpha>) p = (\<Sum> p' \<in> (lgrid p {d} lm) - {p}. \<alpha> p' * l2_\<phi> (p' ! d) (p ! d))"
proof -
  let ?S = "\<lambda> x p p'. if p' \<in> grid p {d} - {p} then x * l2_\<phi> (p'!d) (p!d) else 0"
  let ?F = "\<lambda> d lm p \<alpha>. snd (up' d lm p \<alpha>)"

  { fix p b assume "p \<in> grid b {d}"
    from grid_transitive[OF _ this subset_refl subset_refl]
    have "lgrid b {d} lm \<inter> (grid p {d} - {p}) = lgrid p {d} lm - {p}"
      unfolding lgrid_def by auto
  } note lgrid_eq = this

  { fix l b p \<alpha>
    assume b: "b \<in> lgrid (start dm) ({0..<dm} - {d}) lm"
    hence "b \<in> sparsegrid' dm" and "d < length b" using sparsegrid'_start \<open>d < dm\<close> by auto
    assume l: "l + level b = lm" and p: "p \<in> sparsegrid dm lm"
    note sparsegridE[OF p]

    note up' = up'_\<beta>[OF \<open>d < length b\<close> l \<open>b \<in> sparsegrid' dm\<close> \<open>p \<in> sparsegrid' dm\<close>]

    have "?F d l b \<alpha> p =
          (if b = base {d} p then (\<Sum>p'\<in>lgrid b {d} lm. ?S (\<alpha> p') p p') else \<alpha> p)"
    proof (cases "b = base {d} p")
      case True with baseE(2)[OF \<open>p \<in> sparsegrid' dm\<close>] \<open>level p < lm\<close>
      have "p \<in> lgrid b {d} lm" and "p \<in> grid b {d}" by auto
      show ?thesis
        using lgrid_eq[OF \<open>p \<in> grid b {d}\<close>]
        unfolding up' if_P[OF True] if_P[OF \<open>p \<in> lgrid b {d} lm\<close>]
        by (intro sum.mono_neutral_cong_left lgrid_finite) auto
    next
      case False
      moreover have "p \<notin> lgrid b {d} lm"
      proof (rule ccontr)
        assume "\<not> ?thesis"
        hence "base {d} p = b" using b by (auto intro!: baseI)
        thus False using False by auto
      qed
      ultimately show ?thesis unfolding up' by auto
    qed }
  with lift[where F = ?F, OF \<open>d < dm\<close> \<open>p \<in> sparsegrid dm lm\<close>]
  have lift_eq: "lift ?F dm lm d \<alpha> p =
         (\<Sum>p'\<in>lgrid (base {d} p) {d} lm. ?S (\<alpha> p') p p')" by auto
  from lgrid_eq[OF baseE(2)[OF sparsegrid_subset[OF \<open>p \<in> sparsegrid dm lm\<close>]]]
  show ?thesis
    unfolding up_def lift_eq by (intro sum.mono_neutral_cong_right lgrid_finite) auto
qed

end


(*  Title:      Imperative_Insertion_Sort
    Author:     Christian Sternagel
*)

header \<open>Insertion Sort\<close>

theory Imperative_Insertion_Sort
imports
  Imperative_Loops
  "~~/src/HOL/Library/Multiset"
begin

subsection \<open>The Algorithm\<close>

abbreviation
  array_update :: "'a\<Colon>heap array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array Heap" ("(_.'(_') \<leftarrow>/ _)" [1000, 0, 13] 14)
where
  "a.(i) \<leftarrow> x \<equiv> Array.upd i x a"

abbreviation array_nth :: "'a\<Colon>heap array \<Rightarrow> nat \<Rightarrow> 'a Heap" ("_.'(_')" [1000, 0] 14)
where
  "a.(i) \<equiv> Array.nth a i"

text \<open>
  A definition of insertion sort as given by Cormen et al.\ in \emph{Introduction to Algorithms}.
  Compared to the informal textbook version the variant below is a bit unwieldy due to explicit
  dereferencing of variables on the heap.

  To avoid ambiguities with existing syntax we use OCaml's notation for accessing (@{term "a.(i)"})
  and updating (@{term "a.(i) \<leftarrow> x"}) an array @{term a} at position @{term i}.
\<close>
definition
  "insertion_sort a = do {
    l \<leftarrow> Array.len a;
    for [1 ..< l] (\<lambda>j. do {
      (*Insert a[j] into the sorted subarray a[1 .. j - 1].*)
      key \<leftarrow> a.(j);
      i \<leftarrow> ref j;
      while (do {
        i' \<leftarrow> ! i;
        if i' > 0 then do {x \<leftarrow> a.(i' - 1); return (x > key)}
        else return False})
      (do {
        i' \<leftarrow> ! i;
        x \<leftarrow> a.(i' - 1);
        a.(i') \<leftarrow> x;
        i := i' - 1
      });
      i' \<leftarrow> ! i;
      a.(i') \<leftarrow> key
    })
  }"

text \<open>
  The following definitions decompose the nested loops of the algorithm into more manageable chunks.
\<close>
definition "shiftr_p a (key\<Colon>'a\<Colon>{heap, linorder}) i =
  (do {i' \<leftarrow> ! i; if i' > 0 then do {x \<leftarrow> a.(i' - 1); return (x > key)} else return False})"

definition "shiftr_f a i = do {
  i' \<leftarrow> ! i;
  x \<leftarrow> a.(i' - 1);
  a.(i') \<leftarrow> x;
  i := i' - 1
}"

definition "shiftr a key i = while (shiftr_p a key i) (shiftr_f a i)"

definition "insert_elt a = (\<lambda>j. do {
  key \<leftarrow> a.(j);
  i \<leftarrow> ref j;
  shiftr a key i;
  i' \<leftarrow> ! i;
  a.(i') \<leftarrow> key
})"

definition "sort_upto a = (\<lambda>l. for [1 ..< l] (insert_elt a))"

lemma insertion_sort_alt_def:
  "insertion_sort a = (Array.len a \<guillemotright>= sort_upto a)"
  by (simp add: insertion_sort_def sort_upto_def shiftr_def shiftr_p_def shiftr_f_def insert_elt_def)

subsection \<open>Partial Correctness\<close>

lemma effect_shiftr_f:
  assumes "effect (shiftr_f a i) h h' u"
  shows "Ref.get h' i = Ref.get h i - 1 \<and>
    Array.get h' a = list_update (Array.get h a) (Ref.get h i) (Array.get h a ! (Ref.get h i - 1))"
  using assms by (auto simp: shiftr_f_def elim!: effect_elims)

lemma success_shiftr_p:
  "Ref.get h i < Array.length h a \<Longrightarrow> success (shiftr_p a key i) h"
  by (auto simp: success_def shiftr_p_def execute_simps)

interpretation ro_shiftr_p!: ro_cond "shiftr_p a key i" for a key i
  by (unfold_locales)
     (auto simp: shiftr_p_def success_def execute_simps execute_bind_case split: option.split, metis effectI effect_nthE)

(*[0 .. j - 1]*)
definition [simp]: "ini h a j = take j (Array.get h a)"
(*[0 .. i - 1]*)
definition [simp]: "left h a i = take (Ref.get h i) (Array.get h a)"
(*[i+1 .. j]*)
definition [simp]: "right h a j i = take (j - Ref.get h i) (drop (Ref.get h i + 1) (Array.get h a))"
(*[0 .. i - 1, i + 1 .. j]*)
definition [simp]: "both h a j i = left h a i @ right h a j i"

lemma effect_shiftr:
  assumes "Ref.get h i = j" (is "?i h = _")
    and "j < Array.length h a"
    and "sorted (take j (Array.get h a))"
    and "effect (while (shiftr_p a key i) (shiftr_f a i)) h h' u"
  shows "Array.length h a = Array.length h' a \<and>
    ?i h' \<le> j \<and>
    multiset_of (list_update (Array.get h a) j key) =
      multiset_of (list_update (Array.get h' a) (?i h') key) \<and>
    ini h a j = both h' a j i \<and>
    sorted (both h' a j i) \<and>
    (\<forall>x \<in> set (right h' a j i). x > key)"
using assms(4, 2)
proof (induction rule: ro_shiftr_p.effect_while_induct)
  case base
  show ?case using assms by auto
next
  case (step h' h'' u)
  from \<open>success (shiftr_p a key i) h'\<close> and \<open>cond (shiftr_p a key i) h'\<close>
    have "?i h' > 0" and
    key: "Array.get h' a ! (?i h' - 1) > key"
    by (auto dest!: ro_shiftr_p.success_cond_effect)
       (auto simp: shiftr_p_def elim!: effect_elims effect_ifE)
  from effect_shiftr_f [OF \<open>effect (shiftr_f a i) h' h'' u\<close>]
    have [simp]: "?i h'' = ?i h' - 1"
    "Array.get h'' a = list_update (Array.get h' a) (?i h') (Array.get h' a ! (?i h' - 1))"
    by auto
  from step have *: "?i h' < length (Array.get h' a)"
    and **: "?i h' - (Suc 0) \<le> ?i h'" "?i h' \<le> length (Array.get h' a)"
    and "?i h' \<le> j"
    and "?i h' < Suc j"
    and IH: "ini h a j = both h' a j i"
    by (auto simp add: Array.length_def)
  have "Array.length h a = Array.length h'' a" using step by (simp add: Array.length_def)
  moreover
  have "?i h'' \<le> j" using step by auto
  moreover
  have "multiset_of (list_update (Array.get h a) j key) =
    multiset_of (list_update (Array.get h'' a) (?i h'') key)"
  proof -
    have "?i h' < length (Array.get h' a)"
      and "?i h' - 1 < length (Array.get h' a)" using * by auto
    then show ?thesis
      using step by (simp add: multiset_of_update ac_simps nth_list_update)
  qed
  moreover
  have "ini h a j = both h'' a j i"
    using \<open>0 < ?i h'\<close> and \<open>?i h' \<le> j\<close> and \<open>?i h' < length (Array.get h' a)\<close> and ** and IH
    by (auto simp: upd_conv_take_nth_drop Suc_diff_le min_absorb1)
       (metis Suc_lessD Suc_pred take_Suc_conv_app_nth)

  moreover
  have "sorted (both h'' a j i)"
    using step and \<open>0 < ?i h'\<close> and \<open>?i h' \<le> j\<close> and \<open>?i h' < length (Array.get h' a)\<close> and **
    by (auto simp: IH upd_conv_take_nth_drop Suc_diff_le min_absorb1)
       (metis Suc_lessD Suc_pred append.simps append_assoc take_Suc_conv_app_nth)
  moreover
  have "\<forall>x \<in> set (right h'' a j i). x > key"
    using step and \<open>0 < ?i h'\<close> and \<open>?i h' < length (Array.get h' a)\<close> and key
    by (auto simp: upd_conv_take_nth_drop Suc_diff_le)
  ultimately show ?case by blast
qed

lemma sorted_take_nth:
  assumes "0 < i" and "i < length xs" and "xs ! (i - 1) \<le> y"
    and "sorted (take i xs)"
  shows "\<forall>x \<in> set (take i xs). x \<le> y"
proof -
  have "take i xs = take (i - 1) xs @ [xs ! (i - 1)]"
    using \<open>0 < i\<close> and \<open>i < length xs\<close>
    by (metis Suc_diff_1 less_imp_diff_less take_Suc_conv_app_nth)
  then show ?thesis
    using \<open>sorted (take i xs)\<close> and \<open>xs ! (i - 1) \<le>y\<close>
    by (auto simp: sorted_append)
qed

lemma effect_for_insert_elt:
  assumes "l \<le> Array.length h a"
    and "1 \<le> l"
    and "effect (for [1 ..< l] (insert_elt a)) h h' u"
  shows "Array.length h a = Array.length h' a \<and>
    sorted (take l (Array.get h' a)) \<and>
    multiset_of (Array.get h a) = multiset_of (Array.get h' a)"
using assms(2-)
proof (induction l h' rule: effect_for_induct)
  case base
  show ?case by (cases "Array.get h a") simp_all
next
  case (step j h' h'' u)
  with assms(1) have "j < Array.length h' a" by auto
  from step have sorted: "sorted (take j (Array.get h' a))" by blast
  from step(3) [unfolded insert_elt_def]
    obtain key and h\<^sub>1 and i and h\<^sub>2 and i'
    where key: "key = Array.get h' a ! j"
      and "effect (ref j) h' h\<^sub>1 i"
      and ref\<^sub>1: "Ref.get h\<^sub>1 i = j"
      and shiftr': "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
      and [simp]: "Ref.get h\<^sub>2 i = i'"
      and [simp]: "h'' = Array.update a i' key h\<^sub>2"
      and "i' < Array.length h\<^sub>2 a"
      by (elim effect_bindE effect_nthE effect_lookupE effect_updE)
         (auto intro: effect_intros, metis effect_refE)

  from \<open>effect (ref j) h' h\<^sub>1 i\<close> have [simp]: "Array.get h\<^sub>1 a = Array.get h' a"
    by (metis array_get_alloc effectE execute_ref option.sel)

  have [simp]: "Array.length h\<^sub>1 a = Array.length h' a" by (simp add: Array.length_def)

  from step and assms(1)
    have "j < Array.length h\<^sub>1 a" "sorted (take j (Array.get h\<^sub>1 a))" by auto
  note shiftr = effect_shiftr [OF ref\<^sub>1 this shiftr' [unfolded shiftr_def], simplified]
  have "i' \<le> j" using shiftr by simp

  have "i' < length (Array.get h\<^sub>2 a)"
    by (metis `i' < Array.length h\<^sub>2 a` length_def)
  have [simp]: "min (Suc j) i' = i'" using \<open>i' \<le> j\<close> by simp
  have [simp]: "min (length (Array.get h\<^sub>2 a)) i' = i'"
    using \<open>i' < length (Array.get h\<^sub>2 a)\<close> by (simp)
  have take_Suc_j: "take (Suc j) (list_update (Array.get h\<^sub>2 a) i' key) =
    take i' (Array.get h\<^sub>2 a) @ key # take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))"
    unfolding upd_conv_take_nth_drop [OF \<open>i' < length (Array.get h\<^sub>2 a)\<close>]
    by (auto) (metis Suc_diff_le `i' \<le> j` take_Suc_Cons)

  have "Array.length h a = Array.length h'' a"
    using shiftr by (auto) (metis step.IH)
  moreover
  have "multiset_of (Array.get h a) = multiset_of (Array.get h'' a)"
    using shiftr and step by (simp add: key)
  moreover
  have "sorted (take (Suc j) (Array.get h'' a))"
  proof -
    from ro_shiftr_p.effect_while_post [OF shiftr' [unfolded shiftr_def]]
      have "i' = 0 \<or> (0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1))"
      by (auto dest!: ro_shiftr_p.success_not_cond_effect)
         (auto elim!: effect_elims simp: shiftr_p_def)
    then show ?thesis
    proof
      assume [simp]: "i' = 0"
      have *: "take (Suc j) (list_update (Array.get h\<^sub>2 a) 0 key) =
        key # take j (drop 1 (Array.get h\<^sub>2 a))"
        by (simp) (metis `i' = 0` append_Nil take_Suc_j semiring_numeral_div_class.diff_zero take_0)
      from sorted and shiftr
        have "sorted (take j (drop 1 (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take j (drop 1 (Array.get h\<^sub>2 a))). key < x" by simp_all
      then have "sorted (key # take j (drop 1 (Array.get h\<^sub>2 a)))"
        by (metis less_imp_le sorted_Cons)
      then show ?thesis by (simp add: *)
    next
      assume "0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1)"
      moreover
      have "sorted (take i' (Array.get h\<^sub>2 a) @ take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))). key < x"
        using shiftr by auto
      ultimately have "\<forall>x \<in> set (take i' (Array.get h\<^sub>2 a)). x \<le> key"
        using sorted_take_nth [OF _ \<open>i' < length (Array.get h\<^sub>2 a)\<close>, of key]
        by (simp add: sorted_append)
      then show ?thesis
        using shiftr by (auto simp: take_Suc_j sorted_append) (metis less_imp_le sorted.Cons)
    qed
  qed
  ultimately
  show ?case by blast
qed

lemma effect_insertion_sort:
  assumes "effect (insertion_sort a) h h' u"
  shows "multiset_of (Array.get h a) = multiset_of (Array.get h' a) \<and> sorted (Array.get h' a)"
  using assms
  apply (cases "Array.length h a")
  apply (auto elim!: effect_elims simp: insertion_sort_def Array.length_def)[1]
  unfolding insertion_sort_def
  unfolding shiftr_p_def [symmetric] shiftr_f_def [symmetric]
  unfolding shiftr_def [symmetric] insert_elt_def [symmetric]
  apply (elim effect_elims)
  apply (simp only:)
  apply (subgoal_tac "Suc nat \<le> Array.length h a")
  apply (drule effect_for_insert_elt)
  apply (auto simp: Array.length_def)
done

subsection \<open>Total Correctness\<close>

lemma success_shiftr_f:
  assumes "Ref.get h i < Array.length h a"
  shows "success (shiftr_f a i) h"
  using assms by (auto simp: success_def shiftr_f_def execute_simps)

lemma success_shiftr:
  assumes "Ref.get h i < Array.length h a"
  shows "success (while (shiftr_p a key i) (shiftr_f a i)) h"
proof -
  have "wf (measure (\<lambda>h. Ref.get h i))" by (metis wf_measure)
  then show ?thesis
  proof (induct taking: "\<lambda>h. Ref.get h i < Array.length h a" rule: ro_shiftr_p.success_while_induct)
    case (success_cond h)
    then show ?case by (metis success_shiftr_p)
  next
    case (success_body h)
    then show ?case by (blast intro: success_shiftr_f)
  next
    case (step h h' r)
    then show ?case
      by (auto dest!: effect_shiftr_f ro_shiftr_p.success_cond_effect simp: length_def)
         (auto simp: shiftr_p_def elim!: effect_elims effect_ifE)
  qed fact
qed

lemma effect_shiftr_index:
  assumes "effect (shiftr a key i) h h' u"
  shows "Ref.get h' i \<le> Ref.get h i"
  using assms unfolding shiftr_def
  by (induct h' rule: ro_shiftr_p.effect_while_induct) (auto dest: effect_shiftr_f)

lemma effect_shiftr_length:
  assumes "effect (shiftr a key i) h h' u"
  shows "Array.length h' a = Array.length h a"
  using assms unfolding shiftr_def
  by (induct h' rule: ro_shiftr_p.effect_while_induct) (auto simp: length_def dest: effect_shiftr_f)

lemma success_insert_elt:
  assumes "k < Array.length h a"
  shows "success (insert_elt a k) h"
proof -
  obtain key where "effect (a.(k)) h h key"
    using assms by (auto intro: effect_intros)
  moreover
  obtain i and h\<^sub>1 where "effect (ref k) h h\<^sub>1 i"
    and [simp]: "Ref.get h\<^sub>1 i = k"
    and [simp]: "Array.length h\<^sub>1 a = Array.length h a"
    by (auto simp: ref_def length_def) (metis Ref.get_alloc array_get_alloc effect_heapI)
  moreover
  obtain h\<^sub>2 where *: "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
    using success_shiftr [of h\<^sub>1 i a key] and assms
    by (auto simp: success_def effect_def shiftr_def)
  moreover
  have "effect (! i) h\<^sub>2 h\<^sub>2 (Ref.get h\<^sub>2 i)"
    and "Ref.get h\<^sub>2 i \<le> Ref.get h\<^sub>1 i"
    and "Ref.get h\<^sub>2 i < Array.length h\<^sub>2 a"
    using effect_shiftr_index [OF *] and effect_shiftr_length [OF *] and assms
    by (auto intro!: effect_intros)
  moreover
  then obtain h\<^sub>3 and r where "effect (a.(Ref.get h\<^sub>2 i) \<leftarrow> key) h\<^sub>2 h\<^sub>3 r"
    using assms by (auto simp: effect_def execute_simps)
  ultimately
  have "effect (insert_elt a k) h h\<^sub>3 r"
    by (auto simp: insert_elt_def intro: effect_intros)
  then show ?thesis by (metis effectE)
qed

lemma for_insert_elt_correct:
  assumes "l \<le> Array.length h a"
    and "1 \<le> l"
  shows "\<exists>h'. effect (for [1 ..< l] (insert_elt a)) h h' () \<and>
    Array.length h a = Array.length h' a \<and>
    sorted (take l (Array.get h' a)) \<and>
    multiset_of (Array.get h a) = multiset_of (Array.get h' a)"
using assms(2)
proof (induction rule: for_induct)
  case (succeed k h)
  then show ?case using assms and success_insert_elt [of k h a] by auto
next
  case base
  show ?case by (cases "Array.get h a") simp_all
next
  case (step j h' h'' u)
  with assms(1) have "j < Array.length h' a" by auto
  from step have sorted: "sorted (take j (Array.get h' a))" by blast
  from step(4) [unfolded insert_elt_def]
    obtain key and h\<^sub>1 and i and h\<^sub>2 and i'
    where key: "key = Array.get h' a ! j"
      and "effect (ref j) h' h\<^sub>1 i"
      and ref\<^sub>1: "Ref.get h\<^sub>1 i = j"
      and shiftr': "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
      and [simp]: "Ref.get h\<^sub>2 i = i'"
      and [simp]: "h'' = Array.update a i' key h\<^sub>2"
      and "i' < Array.length h\<^sub>2 a"
      by (elim effect_bindE effect_nthE effect_lookupE effect_updE)
         (auto intro: effect_intros, metis effect_refE)

  from \<open>effect (ref j) h' h\<^sub>1 i\<close> have [simp]: "Array.get h\<^sub>1 a = Array.get h' a"
    by (metis array_get_alloc effectE execute_ref option.sel)

  have [simp]: "Array.length h\<^sub>1 a = Array.length h' a" by (simp add: Array.length_def)

  from step and assms(1)
    have "j < Array.length h\<^sub>1 a" "sorted (take j (Array.get h\<^sub>1 a))" by auto
  note shiftr = effect_shiftr [OF ref\<^sub>1 this shiftr' [unfolded shiftr_def], simplified]
  have "i' \<le> j" using shiftr by simp

  have "i' < length (Array.get h\<^sub>2 a)"
    by (metis `i' < Array.length h\<^sub>2 a` length_def)
  have [simp]: "min (Suc j) i' = i'" using \<open>i' \<le> j\<close> by simp
  have [simp]: "min (length (Array.get h\<^sub>2 a)) i' = i'"
    using \<open>i' < length (Array.get h\<^sub>2 a)\<close> by (simp)
  have take_Suc_j: "take (Suc j) (list_update (Array.get h\<^sub>2 a) i' key) =
    take i' (Array.get h\<^sub>2 a) @ key # take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))"
    unfolding upd_conv_take_nth_drop [OF \<open>i' < length (Array.get h\<^sub>2 a)\<close>]
    by (auto) (metis Suc_diff_le `i' \<le> j` take_Suc_Cons)

  have "Array.length h a = Array.length h'' a"
    using shiftr by (auto) (metis step.hyps(1))
  moreover
  have "multiset_of (Array.get h a) = multiset_of (Array.get h'' a)"
    using shiftr and step by (simp add: key)
  moreover
  have "sorted (take (Suc j) (Array.get h'' a))"
  proof -
    from ro_shiftr_p.effect_while_post [OF shiftr' [unfolded shiftr_def]]
      have "i' = 0 \<or> (0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1))"
      by (auto dest!: ro_shiftr_p.success_not_cond_effect)
         (auto elim!: effect_elims simp: shiftr_p_def)
    then show ?thesis
    proof
      assume [simp]: "i' = 0"
      have *: "take (Suc j) (list_update (Array.get h\<^sub>2 a) 0 key) =
        key # take j (drop 1 (Array.get h\<^sub>2 a))"
        by (simp) (metis `i' = 0` append_Nil take_Suc_j semiring_numeral_div_class.diff_zero take_0)
      from sorted and shiftr
        have "sorted (take j (drop 1 (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take j (drop 1 (Array.get h\<^sub>2 a))). key < x" by simp_all
      then have "sorted (key # take j (drop 1 (Array.get h\<^sub>2 a)))"
        by (metis less_imp_le sorted_Cons)
      then show ?thesis by (simp add: *)
    next
      assume "0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1)"
      moreover
      have "sorted (take i' (Array.get h\<^sub>2 a) @ take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a)))"
        and "\<forall>x \<in> set (take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))). key < x"
        using shiftr by auto
      ultimately have "\<forall>x \<in> set (take i' (Array.get h\<^sub>2 a)). x \<le> key"
        using sorted_take_nth [OF _ \<open>i' < length (Array.get h\<^sub>2 a)\<close>, of key]
        by (simp add: sorted_append)
      then show ?thesis
        using shiftr by (auto simp: take_Suc_j sorted_append) (metis less_imp_le sorted.Cons)
    qed
  qed
  ultimately
  show ?case by blast
qed

lemma insertion_sort_correct:
  "\<exists>h'. effect (insertion_sort a) h h' u \<and>
    multiset_of (Array.get h a) = multiset_of (Array.get h' a) \<and>
    sorted (Array.get h' a)"
proof (cases "Array.length h a = 0")
  assume "Array.length h a = 0"
  then have "effect (insertion_sort a) h h ()"
    and "multiset_of (Array.get h a) = multiset_of (Array.get h a)"
    and "sorted (Array.get h a)"
    by (auto simp: insertion_sort_def length_def intro!: effect_intros)
  then show ?thesis by auto
next
  assume "Array.length h a \<noteq> 0"
  then have "1 \<le> Array.length h a" by auto
  from for_insert_elt_correct [OF le_refl this]
    show ?thesis
    by (auto simp: insertion_sort_alt_def sort_upto_def)
       (metis One_nat_def effect_bindI effect_insertion_sort effect_lengthI insertion_sort_alt_def sort_upto_def)
qed

export_code insertion_sort in Haskell

end