theory Worklist_Scratch
  imports Worklist_Subsumption1
begin

locale Search_Space_Key_Defs =
  Search_Space'_Defs E for E :: "'v \<Rightarrow> 'v \<Rightarrow> bool" +
  fixes key :: "'v \<Rightarrow> 'k"

locale Search_Space_Key =
  Search_Space_Key_Defs + Search_Space' +
  assumes subsumes_key[intro, simp]: "a \<preceq> b \<Longrightarrow> key a = key b"

locale Worklist_Map =
  Search_Space_Key + Worklist1
begin

definition
  "map_list_rel =
    {(m, l). (\<Union> x \<in> ran m. set x) = set l \<and> (\<forall> k. \<forall> xs. m k = Some xs \<longrightarrow> (\<forall> v \<in> set xs. key v = k))}"

lemma map_list_rel_alt_def:
  "map_list_rel =
    {(m, l). set l = (\<Union> x \<in> ran m. set x) \<and> (\<forall> k. \<forall> xs. m k = Some xs \<longrightarrow> (\<forall> v \<in> set xs. key v = k))}"
  unfolding map_list_rel_def
  by auto

definition
  "wait_rel = {((ml, m), l). (m, l) \<in> map_list_rel \<and> key ` set l \<subseteq> set ml}"

lemma ran_upd_cases:
  "(x \<in> ran m) \<or> (x = y)" if "x \<in> ran (m(a \<mapsto> y))"
  using that unfolding ran_def by (auto split: if_split_asm)

lemma ran_upd_cases2:
  "(\<exists> k. m k = Some x \<and> k \<noteq> a) \<or> (x = y)" if "x \<in> ran (m(a \<mapsto> y))"
  using that unfolding ran_def by (auto split: if_split_asm)

definition
  "add_succ1_map wait a \<equiv>
   nfoldli (succs a) (\<lambda>(_,brk). \<not>brk)
    (\<lambda>a ((waitl, wait), brk).
      do {
      ASSERT (\<forall> wait \<in> ran wait. \<forall> x \<in> set wait. \<not> empty x);
      if F a then RETURN ((waitl, wait), True) else RETURN ((
        let k = key a; wait' = (case wait k of Some wait' \<Rightarrow> wait' | None \<Rightarrow> [])
        in
          if (\<exists> x \<in> set wait'. a \<preceq> x \<and> \<not> x \<preceq> a) \<or> empty a
          then (waitl, wait(k \<mapsto> [x \<leftarrow> wait'. \<not> x \<preceq> a]))
          else (k # waitl, wait(k \<mapsto> (a # [x \<leftarrow> wait'. \<not> x \<preceq> a])))),False)
      }
    )
    (wait,False)"

lemma add_succ1_map_ref[refine]:
  "add_succ1_map wait a \<le> \<Down>(wait_rel \<times>\<^sub>r Id) (add_succ1 wait' a')"
  if "(wait, wait') \<in> wait_rel" "(a, a') \<in> Id"
  unfolding add_succ1_map_def add_succ1_def
  apply refine_rcg
        apply refine_dref_type
  using that apply (auto; fail)+
  subgoal unfolding map_list_rel_def wait_rel_def by auto
    apply (auto; fail)
   apply (auto; fail)
  subgoal premises assms for a' a _ _ wait f _ waitl wait' f'
  proof -
    from assms have [simp]: "a' = a" "f = f'" by simp+
    from assms have rel: "(wait', wait) \<in> map_list_rel" unfolding wait_rel_def by simp
    then have union: "set wait = (\<Union>x\<in>ran wait'. set x)"
      unfolding map_list_rel_def by auto
    from assms have rel': "key ` set wait \<subseteq> set waitl" unfolding wait_rel_def by simp
    from rel have keys[simp]: "key v = k" if "wait' k = Some xs" "v\<in>set xs" for k xs v
      using that unfolding map_list_rel_def by auto
    define k where "k \<equiv> key a"
    define xs where "xs \<equiv> case wait' k of None \<Rightarrow> [] | Some wait' \<Rightarrow> wait'"
    have *:
      "(\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a' \<longleftrightarrow> (\<exists>x\<in>set wait. a \<preceq> x \<and> \<not> x \<preceq> a) \<or> empty a"
    proof (simp, safe, goal_cases)
      case (1 x)
      with rel show ?case
        unfolding xs_def union by (auto intro: ranI[OF sym])
    next
      case (2 x)
      with rel show ?case unfolding xs_def union ran_def k_def by auto
    qed
    have "(\<Union>x\<in>ran (wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])). set x) = set [x\<leftarrow>wait . \<not> x \<preceq> a]"
    proof (safe, goal_cases)
      case prems: (1 x xs')
      from ran_upd_cases2[OF prems(1)] show ?case
      proof (safe, goal_cases)
        case (1 k')
        with \<open>x \<in> _\<close> have "\<not> x \<preceq> a" unfolding k_def by (auto dest: keys)
        with 1 \<open>x \<in> _\<close> show ?case by (auto intro: ranI simp: union)
      next
        case 2
        with \<open>x \<in> _\<close> have "\<not> x \<preceq> a" by auto
        with 2 \<open>x \<in> _\<close> show ?case
          unfolding xs_def by (auto simp: union split: option.split_asm intro: ranI)
      qed
    next
      case (2 x)
      then have "\<not> x \<preceq> a" "x \<in> set wait"
        by auto
      from this(2) obtain k' xs' where k': "wait' k' = Some xs'" "x \<in> set xs'"
        unfolding union ran_def by auto
      show ?case
      proof (cases "k' = k")
        case True
        with k' \<open>\<not> x \<preceq> a\<close> have "x \<in> set [x\<leftarrow>xs . \<not> x \<preceq> a']"
          unfolding xs_def by auto
        then show ?thesis unfolding ran_def by auto
      next
        case False
        with k' show ?thesis by (auto intro!: ranI)
      qed
    qed
    then have **: "(wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a']), [x\<leftarrow>wait . \<not> x \<preceq> a]) \<in> map_list_rel"
      unfolding map_list_rel_def xs_def by (auto intro: keys[OF sym])
    have ***: "(wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a']), a # [x\<leftarrow>wait . \<not> x \<preceq> a]) \<in> map_list_rel"
      unfolding map_list_rel_def
      apply safe
      subgoal for x xs'
        using ** unfolding map_list_rel_alt_def by (fastforce simp: ran_def dest!: ran_upd_cases2)
      subgoal premises prems' for x
      proof -
        show ?thesis
        proof (cases "x = a")
          case True
          then show ?thesis by (force intro: ranI)
        next
          case False
          with prems' ** have "x \<in> (\<Union>x\<in>ran (wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])). set x)"
            unfolding map_list_rel_alt_def by auto
          with False show ?thesis by (fastforce dest!: ran_upd_cases2 simp: ran_def)
        qed
      qed
      subgoal
        using **
        apply (auto split: if_split_asm)
        unfolding map_list_rel_alt_def
         apply auto
        unfolding k_def by fastforce
      done
    have unfold:
      "(let k = key a'; xs = case wait' k of None \<Rightarrow> [] | Some wait' \<Rightarrow> wait'
          in if (\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a'
             then (waitl, wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a']))
             else (k # waitl, wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a'])))
       = (if (\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a'
          then (waitl, wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a']))
          else (k # waitl, wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a'])))"
      unfolding xs_def k_def by (simp add: Let_def)
    have
      "((let k = key a'; xs = case wait' k of None \<Rightarrow> [] | Some wait' \<Rightarrow> wait'
           in if (\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a'
              then (waitl, wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a']))
              else (k # waitl, wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a']))),
           if (\<exists>x\<in>set wait. a \<preceq> x \<and> \<not> x \<preceq> a) \<or> empty a then [x\<leftarrow>wait . \<not> x \<preceq> a]
           else a # [x\<leftarrow>wait . \<not> x \<preceq> a]) \<in> wait_rel"
      using ** *** rel' unfolding *[symmetric] unfold wait_rel_def k_def by auto
    then show ?thesis by auto
  qed
  done

(*
definition
  "add_succ1_map wait a \<equiv>
   nfoldli (succs a) (\<lambda>(_,brk). \<not>brk)
    (\<lambda>a (wait,brk).
      do {
      ASSERT (\<forall> wait \<in> ran wait. \<forall> x \<in> set wait. \<not> empty x);
      if F a then RETURN (wait,True) else RETURN ((
        let k = key a; wait' = (case wait k of Some wait' \<Rightarrow> wait' | None \<Rightarrow> [])
        in
          if (\<exists> x \<in> set wait'. a \<preceq> x \<and> \<not> x \<preceq> a) \<or> empty a
          then wait(k \<mapsto> [x \<leftarrow> wait'. \<not> x \<preceq> a])
          else wait(k \<mapsto> (a # [x \<leftarrow> wait'. \<not> x \<preceq> a]))),False)
      }
    )
    (wait,False)"

lemma add_succ1_map_ref[refine]:
  "add_succ1_map wait a \<le> \<Down>(map_list_rel \<times>\<^sub>r Id) (add_succ1 wait' a')"
  if "(wait, wait') \<in> map_list_rel" "(a, a') \<in> Id"
  unfolding add_succ1_map_def add_succ1_def
  apply refine_rcg
        apply refine_dref_type
  using that apply (auto; fail)+
  subgoal unfolding map_list_rel_def by auto
    apply (auto; fail)
   apply (auto; fail)
  subgoal premises assms for a' a _ _ wait f wait' f'
  proof -
    from assms have [simp]: "a' = a" "f = f'" by simp+
    from assms have rel: "(wait', wait) \<in> map_list_rel" by simp
    then have union: "set wait = (\<Union>x\<in>ran wait'. set x)"
      unfolding map_list_rel_def by auto
    from rel have keys[simp]: "key v = k" if "wait' k = Some xs" "v\<in>set xs" for k xs v
      using that unfolding map_list_rel_def by auto
    define k where "k \<equiv> key a"
    define xs where "xs \<equiv> case wait' k of None \<Rightarrow> [] | Some wait' \<Rightarrow> wait'"
    have *:
      "(\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a' \<longleftrightarrow> (\<exists>x\<in>set wait. a \<preceq> x \<and> \<not> x \<preceq> a) \<or> empty a"
    proof (simp, safe, goal_cases)
      case (1 x)
      with rel show ?case
        unfolding xs_def union by (auto intro: ranI[OF sym])
    next
      case (2 x)
      with rel show ?case unfolding xs_def union ran_def k_def by auto
    qed
    have "(\<Union>x\<in>ran (wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])). set x) = set [x\<leftarrow>wait . \<not> x \<preceq> a]"
    proof (safe, goal_cases)
      case prems: (1 x xs')
      from ran_upd_cases2[OF prems(1)] show ?case
      proof (safe, goal_cases)
        case (1 k')
        with \<open>x \<in> _\<close> have "\<not> x \<preceq> a" unfolding k_def by (auto dest: keys)
        with 1 \<open>x \<in> _\<close> show ?case by (auto intro: ranI simp: union)
      next
        case 2
        with \<open>x \<in> _\<close> have "\<not> x \<preceq> a" by auto
        with 2 \<open>x \<in> _\<close> show ?case
          unfolding xs_def by (auto simp: union split: option.split_asm intro: ranI)
      qed
    next
      case (2 x)
      then have "\<not> x \<preceq> a" "x \<in> set wait"
        by auto
      from this(2) obtain k' xs' where k': "wait' k' = Some xs'" "x \<in> set xs'"
        unfolding union ran_def by auto
      show ?case
      proof (cases "k' = k")
        case True
        with k' \<open>\<not> x \<preceq> a\<close> have "x \<in> set [x\<leftarrow>xs . \<not> x \<preceq> a']"
          unfolding xs_def by auto
        then show ?thesis unfolding ran_def by auto
      next
        case False
        with k' show ?thesis by (auto intro!: ranI)
      qed
    qed
    then have **: "(wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a']), [x\<leftarrow>wait . \<not> x \<preceq> a]) \<in> map_list_rel"
      unfolding map_list_rel_def xs_def by (auto intro: keys[OF sym])
    have ***: "(wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a']), a # [x\<leftarrow>wait . \<not> x \<preceq> a]) \<in> map_list_rel"
      unfolding map_list_rel_def
      apply safe
      subgoal for x xs'
        using ** unfolding map_list_rel_alt_def by (fastforce simp: ran_def dest!: ran_upd_cases2)
      subgoal premises prems' for x
      proof -
        show ?thesis
        proof (cases "x = a")
          case True
          then show ?thesis by (force intro: ranI)
        next
          case False
          with prems' ** have "x \<in> (\<Union>x\<in>ran (wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])). set x)"
            unfolding map_list_rel_alt_def by auto
          with False show ?thesis by (fastforce dest!: ran_upd_cases2 simp: ran_def)
        qed
      qed
      subgoal
        using **
        apply (auto split: if_split_asm)
        unfolding map_list_rel_alt_def
         apply auto
        unfolding k_def by fastforce
      done
    have unfold:
      "(let k = key a'; xs = case wait' k of None \<Rightarrow> [] | Some wait' \<Rightarrow> wait'
          in if (\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a' then wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])
             else wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a']))
       = (if (\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a' then wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])
          else wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a']))"
      unfolding xs_def k_def by (simp add: Let_def)
    have
      "((let k = key a'; xs = case wait' k of None \<Rightarrow> [] | Some wait' \<Rightarrow> wait'
           in if (\<exists>x\<in>set xs. a' \<preceq> x \<and> \<not> x \<preceq> a') \<or> empty a' then wait'(k \<mapsto> [x\<leftarrow>xs . \<not> x \<preceq> a'])
              else wait'(k \<mapsto> a' # [x\<leftarrow>xs . \<not> x \<preceq> a'])),
           if (\<exists>x\<in>set wait. a \<preceq> x \<and> \<not> x \<preceq> a) \<or> empty a then [x\<leftarrow>wait . \<not> x \<preceq> a]
           else a # [x\<leftarrow>wait . \<not> x \<preceq> a]) \<in> map_list_rel"
      unfolding *[symmetric] unfold using ** *** by auto
    then show ?thesis by auto
  qed
  done
*)

term ASSERT

term take_from_list

definition take_from_wait :: "_ \<Rightarrow> _ \<Rightarrow> _ nres" where
  "take_from_wait wait wait_map = do {
    ASSERT (wait \<noteq> []);
    (k, wait) \<leftarrow> take_from_list wait;
    let v = wait_map k;
    case v of
      None \<Rightarrow> RETURN (None, wait, wait_map) |
      Some wait' \<Rightarrow>
        case wait' of
          [] \<Rightarrow> RETURN (None, wait, wait_map) |
          (n # wait') \<Rightarrow> RETURN (Some n, wait, wait_map(k \<mapsto> wait'))
  }
  "

(*
lemma take_from_list_correct:
  assumes "s \<noteq> []"
  shows "take_from_list s \<le> SPEC (\<lambda> (x, s'). s = x # s')"
using assms unfolding take_from_list_def by simp

lemmas [refine_vcg] = take_from_list_correct[THEN order.trans]
*)

abbreviation "ran' m \<equiv> (\<Union> x \<in> ran m. set x)"

definition "worklist_inv_frontier_map passed wait_map =
    (\<forall> a \<in> passed. \<forall> a'. E a a' \<and> \<not> empty a' \<longrightarrow> (\<exists> b' \<in> passed \<union> ran' wait_map. a' \<preceq> b'))"

definition "start_subsumed_map passed wait_map = (\<exists> a \<in> passed \<union> ran' wait_map. a\<^sub>0 \<preceq> a)"

definition "worklist_inv_map \<equiv> \<lambda> (passed, (wait, wait_map), brk).
    passed \<subseteq> Collect reachable \<and>
    (brk \<longrightarrow> (\<exists> f. reachable f \<and> F f)) \<and>
    (\<not> brk \<longrightarrow>
      worklist_inv_frontier_map passed wait_map
    \<and> (\<forall> a \<in> passed \<union> ran' wait_map. \<not> F a)
    \<and> start_subsumed_map passed wait_map
    \<and> ran' wait_map \<subseteq> Collect reachable)
    \<and> (\<forall> a \<in> passed. \<not> empty a) \<and> (\<forall> wait \<in> ran wait_map. \<forall> x \<in> set wait. \<not> empty x)
    \<and> key ` ran' wait_map \<subseteq> set wait
    "

definition worklist_algo_map' where
    "worklist_algo_map' = do
      {
        if F a\<^sub>0 then RETURN True
        else do {
          let passed = {};
          let w_wm = ([key a\<^sub>0], \<lambda> x. if x = key a\<^sub>0 then Some [a\<^sub>0] else None);
          (passed, (wait, wait_map), brk) \<leftarrow> WHILEIT worklist_inv_map (\<lambda> (passed, (wait, wait_map), brk). \<not> brk \<and> ran' wait_map \<noteq> {})
            (\<lambda> (passed, (wait, wait_map), brk). do
              {
                (a, wait, wait_map) \<leftarrow> take_from_wait wait wait_map;
                case a of
                  None \<Rightarrow> RETURN (passed, (wait, wait_map), brk) |
                  Some a \<Rightarrow>
                    if (\<exists> a' \<in> passed. a \<unlhd> a') then RETURN (passed, (wait, wait_map), brk) else
                    do
                      {
                        ((wait,wait_map),brk) \<leftarrow> add_succ1_map (wait,wait_map) a;
                        let passed = insert a passed;
                        RETURN (passed, (wait, wait_map), brk)
                      }
              }
            )
            (passed, w_wm, False);
            RETURN brk
        }
      }
    "

lemma worklist_inv_map_list:
  "worklist_inv_map x" if
  "(x, x') \<in> Id \<times>\<^sub>r wait_rel \<times>\<^sub>r Id" "worklist_inv_list x'"
  using that
  unfolding worklist_inv_list_def worklist_inv_map_def
  apply safe
    sorry

lemma take_from_list_ref[refine]:
    "take_from_list wait \<le>
     \<Down> {((x, wait), (y, wait')). x = y \<and> wait = wait' \<and> \<not> empty x \<and> (\<forall> a \<in> set wait. \<not> empty a)}
       (take_from_list wait')"
    if "wait = wait'" "\<forall> a \<in> set wait. \<not> empty a" "wait \<noteq> []"
    using that
    by (auto 4 4 simp: pw_le_iff refine_pw_simps dest!: take_from_list_correct)

lemma take_from_wait_ref:
  "take_from_wait wait wait_map \<le> \<Down>{((a, w_wm), (a', l)). wait_rel w_wm l \<and> a \<in> ran' wait \<and> a' \<in> set wait \<and> set l} take_from_list wait'"
  if "((wait, wait_map), wait') \<in> wait_rel"
  oops

  lemma worklist_algo_map'_ref[refine]: "worklist_algo_map' \<le> \<Down>Id worklist_algo1'"
    unfolding worklist_algo_map'_def worklist_algo1'_def
    apply (refine_rcg)
          prefer 3
          apply (rule worklist_inv_map_list, assumption, assumption)
         apply simp
        apply (simp add: wait_rel_def map_list_rel_def)
       apply auto[]
        apply (auto simp: wait_rel_def map_list_rel_def)[]
       apply (auto simp: wait_rel_def map_list_rel_def)[]
    subgoal
      sorry
    prefer 3
      apply (simp; fail)
        apply (auto simp: worklist_inv_map_def)[]

    apply refine_dref_type
    unfolding worklist_inv_list_def
    by aut

end

locale Search_Space_Pair =
  Search_Space_Pair_Defs + Search_Space' +
  assumes "(a1, b1) \<preceq> (a2, b2) \<Longrightarrow> a1 = a2"

locale Search_Space_Pair_Defs =
  Search_Space'_Defs E a\<^sub>0 F subsumes empty subsumes'
    for E :: "'a * 'b \<Rightarrow> 'a * 'b \<Rightarrow> bool"
    and a\<^sub>0 :: "'a * 'b"
    and F :: "'a * 'b \<Rightarrow> bool"
    and subsumes :: "'a * 'b \<Rightarrow> 'a * 'b \<Rightarrow> bool" (infix "\<preceq>" 50)
    and empty :: "'a * 'b \<Rightarrow> bool"
    and subsumes' :: "'a * 'b \<Rightarrow> 'a * 'b \<Rightarrow> bool" (infix "\<unlhd>" 50)
begin

term "x \<unlhd> y"

end

locale Search_Space_Pair =
  Search_Space_Pair_Defs + Search_Space' +
  assumes "(a1, b1) \<preceq> (a2, b2) \<Longrightarrow> a1 = a2"

end \<comment> \<open>End of Theory\<close>


(*  Title:      HOL/NanoJava/Equivalence.thy
    Author:     David von Oheimb
    Copyright   2001 Technische Universitaet Muenchen
*)

section "Equivalence of Operational and Axiomatic Semantics"

theory Equivalence imports OpSem AxSem begin

subsection "Validity"

definition valid :: "[assn,stmt, assn] => bool" ("|= {(1_)}/ (_)/ {(1_)}" [3,90,3] 60) where
 "|=  {P} c {Q} \<equiv> \<forall>s   t. P s --> (\<exists>n. s -c  -n\<rightarrow> t) --> Q   t"

definition evalid   :: "[assn,expr,vassn] => bool" ("|=e {(1_)}/ (_)/ {(1_)}" [3,90,3] 60) where
 "|=e {P} e {Q} \<equiv> \<forall>s v t. P s --> (\<exists>n. s -e\<succ>v-n\<rightarrow> t) --> Q v t"

definition nvalid   :: "[nat, triple    ] => bool" ("|=_: _"  [61,61] 60) where
 "|=n:  t \<equiv> let (P,c,Q) = t in \<forall>s   t. s -c  -n\<rightarrow> t --> P s --> Q   t"

definition envalid   :: "[nat,etriple    ] => bool" ("|=_:e _" [61,61] 60) where
 "|=n:e t \<equiv> let (P,e,Q) = t in \<forall>s v t. s -e\<succ>v-n\<rightarrow> t --> P s --> Q v t"

definition nvalids :: "[nat,       triple set] => bool" ("||=_: _" [61,61] 60) where
 "||=n: T \<equiv> \<forall>t\<in>T. |=n: t"

definition cnvalids :: "[triple set,triple set] => bool" ("_ ||=/ _"  [61,61] 60) where
 "A ||=  C \<equiv> \<forall>n. ||=n: A --> ||=n: C"

definition cenvalid  :: "[triple set,etriple   ] => bool" ("_ ||=e/ _" [61,61] 60) where
 "A ||=e t \<equiv> \<forall>n. ||=n: A --> |=n:e t"

notation (xsymbols)
  valid  ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" [3,90,3] 60) and
  evalid  ("\<Turnstile>\<^sub>e {(1_)}/ (_)/ {(1_)}" [3,90,3] 60) and
  nvalid  ("\<Turnstile>_: _" [61,61] 60) and
  envalid  ("\<Turnstile>_:\<^sub>e _" [61,61] 60) and
  nvalids  ("|\<Turnstile>_: _" [61,61] 60) and
  cnvalids  ("_ |\<Turnstile>/ _" [61,61] 60) and
  cenvalid  ("_ |\<Turnstile>\<^sub>e/ _"[61,61] 60)

lemma nvalid_def2: "\<Turnstile>n: (P,c,Q) \<equiv> \<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q t"
by (simp add: nvalid_def Let_def)

lemma valid_def2: "\<Turnstile> {P} c {Q} = (\<forall>n. \<Turnstile>n: (P,c,Q))"
apply (simp add: valid_def nvalid_def2)
apply blast
done

lemma envalid_def2: "\<Turnstile>n:\<^sub>e (P,e,Q) \<equiv> \<forall>s v t. s -e\<succ>v-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q v t"
by (simp add: envalid_def Let_def)

lemma evalid_def2: "\<Turnstile>\<^sub>e {P} e {Q} = (\<forall>n. \<Turnstile>n:\<^sub>e (P,e,Q))"
apply (simp add: evalid_def envalid_def2)
apply blast
done

lemma cenvalid_def2:
  "A|\<Turnstile>\<^sub>e (P,e,Q) = (\<forall>n. |\<Turnstile>n: A \<longrightarrow> (\<forall>s v t. s -e\<succ>v-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q v t))"
by(simp add: cenvalid_def envalid_def2)

subsection "Soundness"

declare exec_elim_cases [elim!] eval_elim_cases [elim!]

lemma Impl_nvalid_0: "\<Turnstile>0: (P,Impl M,Q)"
by (clarsimp simp add: nvalid_def2)

lemma Impl_nvalid_Suc: "\<Turnstile>n: (P,body M,Q) \<Longrightarrow> \<Turnstile>Suc n: (P,Impl M,Q)"
by (clarsimp simp add: nvalid_def2)

lemma nvalid_SucD: "\<And>t. \<Turnstile>Suc n:t \<Longrightarrow> \<Turnstile>n:t"
by (force simp add: split_paired_all nvalid_def2 intro: exec_mono)

lemma nvalids_SucD: "Ball A (nvalid (Suc n)) \<Longrightarrow>  Ball A (nvalid n)"
by (fast intro: nvalid_SucD)

lemma Loop_sound_lemma [rule_format (no_asm)]:
"\<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> P s \<and> s<x> \<noteq> Null \<longrightarrow> P t \<Longrightarrow>
  (s -c0-n0\<rightarrow> t \<longrightarrow> P s \<longrightarrow> c0 = While (x) c \<longrightarrow> n0 = n \<longrightarrow> P t \<and> t<x> = Null)"
apply (rule_tac ?P2.1="%s e v n t. True" in exec_eval.induct [THEN conjunct1])
apply clarsimp+
done

lemma Impl_sound_lemma:
"\<lbrakk>\<forall>z n. Ball (A \<union> B) (nvalid n) \<longrightarrow> Ball (f z ` Ms) (nvalid n);
  Cm\<in>Ms; Ball A (nvalid na); Ball B (nvalid na)\<rbrakk> \<Longrightarrow> nvalid na (f z Cm)"
by blast

lemma all_conjunct2: "\<forall>l. P' l \<and> P l \<Longrightarrow> \<forall>l. P l"
by fast

lemma all3_conjunct2:
  "\<forall>a p l. (P' a p l \<and> P a p l) \<Longrightarrow> \<forall>a p l. P a p l"
by fast

lemma cnvalid1_eq:
  "A |\<Turnstile> {(P,c,Q)} \<equiv> \<forall>n. |\<Turnstile>n: A \<longrightarrow> (\<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q t)"
by(simp add: cnvalids_def nvalids_def nvalid_def2)

lemma hoare_sound_main:"\<And>t. (A |\<turnstile> C \<longrightarrow> A |\<Turnstile> C) \<and> (A |\<turnstile>\<^sub>e t \<longrightarrow> A |\<Turnstile>\<^sub>e t)"
apply (tactic "split_all_tac @{context} 1", rename_tac P e Q)
apply (rule hoare_ehoare.induct)
(*18*)
apply (tactic {* ALLGOALS (REPEAT o dresolve_tac [@{thm all_conjunct2}, @{thm all3_conjunct2}]) *})
apply (tactic {* ALLGOALS (REPEAT o thin_tac @{context} "hoare ?x ?y") *})
apply (tactic {* ALLGOALS (REPEAT o thin_tac @{context} "ehoare ?x ?y") *})
apply (simp_all only: cnvalid1_eq cenvalid_def2)
                 apply fast
                apply fast
               apply fast
              apply (clarify,tactic "smp_tac @{context} 1 1",erule(2) Loop_sound_lemma,(rule HOL.refl)+)
             apply fast
            apply fast
           apply fast
          apply fast
         apply fast
        apply fast
       apply (clarsimp del: Meth_elim_cases) (* Call *)
      apply (force del: Impl_elim_cases)
     defer
     prefer 4 apply blast (*  Conseq *)
    prefer 4 apply blast (* eConseq *)
   apply (simp_all (no_asm_use) only: cnvalids_def nvalids_def)
   apply blast
  apply blast
 apply blast
apply (rule allI)
apply (rule_tac x=Z in spec)
apply (induct_tac "n")
 apply  (clarify intro!: Impl_nvalid_0)
apply (clarify  intro!: Impl_nvalid_Suc)
apply (drule nvalids_SucD)
apply (simp only: HOL.all_simps)
apply (erule (1) impE)
apply (drule (2) Impl_sound_lemma)
 apply  blast
apply assumption
done

theorem ehoare_sound: "{} \<turnstile>\<^sub>e {P} e {Q} \<Longrightarrow> \<Turnstile>\<^sub>e {P} e {Q}"
apply (simp only: evalid_def2)
apply (drule hoare_sound_main [THEN conjunct2, rule_format])
apply (unfold cenvalid_def nvalids_def)
apply fast
done

subsection "(Relative) Completeness"

definition MGT :: "stmt => state => triple" where
         "MGT  c Z \<equiv> (\<lambda>s. Z = s, c, \<lambda>  t. \<exists>n. Z -c-  n\<rightarrow> t)"

definition MGTe   :: "expr => state => etriple" where
         "MGTe e Z \<equiv> (\<lambda>s. Z = s, e, \<lambda>v t. \<exists>n. Z -e\<succ>v-n\<rightarrow> t)"

notation (xsymbols)
  MGTe  ("MGT\<^sub>e")
notation (HTML output)
  MGTe  ("MGT\<^sub>e")

lemma MGF_implies_complete:
 "\<forall>Z. {} |\<turnstile> { MGT c Z} \<Longrightarrow> \<Turnstile>  {P} c {Q} \<Longrightarrow> {} \<turnstile>  {P} c {Q}"
apply (simp only: valid_def2)
apply (unfold MGT_def)
apply (erule hoare_ehoare.Conseq)
apply (clarsimp simp add: nvalid_def2)
done

lemma eMGF_implies_complete:
 "\<forall>Z. {} |\<turnstile>\<^sub>e MGT\<^sub>e e Z \<Longrightarrow> \<Turnstile>\<^sub>e {P} e {Q} \<Longrightarrow> {} \<turnstile>\<^sub>e {P} e {Q}"
apply (simp only: evalid_def2)
apply (unfold MGTe_def)
apply (erule hoare_ehoare.eConseq)
apply (clarsimp simp add: envalid_def2)
done

declare exec_eval.intros[intro!]

lemma MGF_Loop: "\<forall>Z. A \<turnstile> {op = Z} c {\<lambda>t. \<exists>n. Z -c-n\<rightarrow> t} \<Longrightarrow>
  A \<turnstile> {op = Z} While (x) c {\<lambda>t. \<exists>n. Z -While (x) c-n\<rightarrow> t}"
apply (rule_tac P' = "\<lambda>Z s. (Z,s) \<in> ({(s,t). \<exists>n. s<x> \<noteq> Null \<and> s -c-n\<rightarrow> t})^*"
       in hoare_ehoare.Conseq)
apply  (rule allI)
apply  (rule hoare_ehoare.Loop)
apply  (erule hoare_ehoare.Conseq)
apply  clarsimp
apply  (blast intro:rtrancl_into_rtrancl)
apply (erule thin_rl)
apply clarsimp
apply (erule_tac x = Z in allE)
apply clarsimp
apply (erule converse_rtrancl_induct)
apply  blast
apply clarsimp
apply (drule (1) exec_exec_max)
apply (blast del: exec_elim_cases)
done

lemma MGF_lemma: "\<forall>M Z. A |\<turnstile> {MGT (Impl M) Z} \<Longrightarrow>
 (\<forall>Z. A |\<turnstile> {MGT c Z}) \<and> (\<forall>Z. A |\<turnstile>\<^sub>e MGT\<^sub>e e Z)"
apply (simp add: MGT_def MGTe_def)
apply (rule stmt_expr.induct)
apply (rule_tac [!] allI)

apply (rule Conseq1 [OF hoare_ehoare.Skip])
apply blast

apply (rule hoare_ehoare.Comp)
apply  (erule spec)
apply (erule hoare_ehoare.Conseq)
apply clarsimp
apply (drule (1) exec_exec_max)
apply blast

apply (erule thin_rl)
apply (rule hoare_ehoare.Cond)
apply  (erule spec)
apply (rule allI)
apply (simp)
apply (rule conjI)
apply  (rule impI, erule hoare_ehoare.Conseq, clarsimp, drule (1) eval_exec_max,
        erule thin_rl, erule thin_rl, force)+

apply (erule MGF_Loop)

apply (erule hoare_ehoare.eConseq [THEN hoare_ehoare.LAss])
apply fast

apply (erule thin_rl)
apply (rename_tac expr1 u v Z, rule_tac Q = "\<lambda>a s. \<exists>n. Z -expr1\<succ>Addr a-n\<rightarrow> s" in hoare_ehoare.FAss)
apply  (drule spec)
apply  (erule eConseq2)
apply  fast
apply (rule allI)
apply (erule hoare_ehoare.eConseq)
apply clarsimp
apply (drule (1) eval_eval_max)
apply blast

apply (simp only: split_paired_all)
apply (rule hoare_ehoare.Meth)
apply (rule allI)
apply (drule spec, drule spec, erule hoare_ehoare.Conseq)
apply blast

apply (simp add: split_paired_all)

apply (rule eConseq1 [OF hoare_ehoare.NewC])
apply blast

apply (erule hoare_ehoare.eConseq [THEN hoare_ehoare.Cast])
apply fast

apply (rule eConseq1 [OF hoare_ehoare.LAcc])
apply blast

apply (erule hoare_ehoare.eConseq [THEN hoare_ehoare.FAcc])
apply fast

apply (rename_tac expr1 u expr2 Z)
apply (rule_tac R = "\<lambda>a v s. \<exists>n1 n2 t. Z -expr1\<succ>a-n1\<rightarrow> t \<and> t -expr2\<succ>v-n2\<rightarrow> s" in
                hoare_ehoare.Call)
apply   (erule spec)
apply  (rule allI)
apply  (erule hoare_ehoare.eConseq)
apply  clarsimp
apply  blast
apply (rule allI)+
apply (rule hoare_ehoare.Meth)
apply (rule allI)
apply (drule spec, drule spec, erule hoare_ehoare.Conseq)
apply (erule thin_rl, erule thin_rl)
apply (clarsimp del: Impl_elim_cases)
apply (drule (2) eval_eval_exec_max)
apply (force del: Impl_elim_cases)
done

lemma MGF_Impl: "{} |\<turnstile> {MGT (Impl M) Z}"
apply (unfold MGT_def)
apply (rule Impl1')
apply  (rule_tac [2] UNIV_I)
apply clarsimp
apply (rule hoare_ehoare.ConjI)
apply clarsimp
apply (rule ssubst [OF Impl_body_eq])
apply (fold MGT_def)
apply (rule MGF_lemma [THEN conjunct1, rule_format])
apply (rule hoare_ehoare.Asm)
apply force
done

theorem hoare_relative_complete: "\<Turnstile> {P} c {Q} \<Longrightarrow> {} \<turnstile> {P} c {Q}"
apply (rule MGF_implies_complete)
apply  (erule_tac [2] asm_rl)
apply (rule allI)
apply (rule MGF_lemma [THEN conjunct1, rule_format])
apply (rule MGF_Impl)
done

theorem ehoare_relative_complete: "\<Turnstile>\<^sub>e {P} e {Q} \<Longrightarrow> {} \<turnstile>\<^sub>e {P} e {Q}"
apply (rule eMGF_implies_complete)
apply  (erule_tac [2] asm_rl)
apply (rule allI)
apply (rule MGF_lemma [THEN conjunct2, rule_format])
apply (rule MGF_Impl)
done

lemma cFalse: "A \<turnstile> {\<lambda>s. False} c {Q}"
apply (rule cThin)
apply (rule hoare_relative_complete)
apply (auto simp add: valid_def)
done

lemma eFalse: "A \<turnstile>\<^sub>e {\<lambda>s. False} e {Q}"
apply (rule eThin)
apply (rule ehoare_relative_complete)
apply (auto simp add: evalid_def)
done

end


subsection \<open>Multiple step relations\<close>

subsubsection \<open>Registers\<close>

theory MultipleStepRegister
  imports SingleStepRegister
begin

lemma lm04_22_multiple_register:
  fixes c :: nat
    and l :: register
    and ic :: configuration
    and p :: program
    and q :: nat
    and a :: nat

  defines "b == B c"
      and "m == length p"
      and "n == length (snd ic)"

assumes is_val: "is_valid_initial ic p a"
assumes c_gt_cells: "cells_bounded ic p c"
assumes l: "l < n"
and "0 < l"
and q: "q > 0"

assumes terminate: "terminates ic p q"

assumes c: "c > 1"

  defines "r == RLe ic p b q"
      and "z == ZLe ic p b q"
      and "s == SKe ic p b q"

shows "r l = b * r l
           + b * (\<Sum>R+ p l s)
           - b * (\<Sum>R- p l (\<lambda>k. z l && s k))"
proof -
  have 0: "snd ic ! l = 0" using assms(4, 7) by (cases "ic"; auto simp add: is_valid_initial_def)

  have "b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t)) \<le> b^(Suc t) *  R ic p l t " for t
     proof (cases "t=0")
       case True
       hence "R ic p l 0 = 0" by (auto simp add: 0 R_def)
       thus ?thesis by (auto simp add: True Z_def sum_rsub.simps)
     next
       case False
       define cs where "cs \<equiv> fst (steps ic p t)"
       have sub: "(\<Sum>R- p l (\<lambda>k. Z ic p l t * S ic p k t))
        = (if issub (p!cs) \<and> l = modifies (p!cs) then Z ic p l t else 0)"
         using single_step_sub Z_def R_def is_val l n_def cs_def by auto
       show ?thesis using sub by (auto simp add: sum_rsub.simps R_def Z_def)
     qed

    from this have positive: "b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))
                    \<le> b^(Suc t) *  R ic p l t
                    + b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t))" for t
      by (auto simp add: Nat.trans_le_add1)

  have commute_add: "(\<Sum>t=0..q-1. \<Sum>R+ p l (\<lambda>k. b^t * S ic p k t))
      = \<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q-1. (b^t * S ic p k t))"
    using sum_radd_commutative[of "p" "l" "\<lambda>k t. b^t * S ic p k t " "q-1"] by auto

  have r_q: "l<n \<longrightarrow> R ic p l q = 0"
    using terminate terminates_def correct_halt_def by (auto simp: n_def R_def)
  hence z_q: "l<n \<longrightarrow> Z ic p l q = 0"
    using terminate terminates_def correct_halt_def by (auto simp: Z_def)
  have "\<forall>k<length p-1. \<not> ishalt (p!k)"
    using is_val is_valid_initial_def[of "ic" "p" "a"] is_valid_def[of "ic" "p"]
          program_includes_halt.simps by blast
  hence s_q: "\<forall>k < length p - 1. S ic p k q = 0"
    using terminate terminates_def correct_halt_def S_def by auto

  from r_q have rq: "(\<Sum>x = 0..q - 1. int b ^ x * int (snd (steps ic p x) ! l)) =
                     (\<Sum>x = 0..q. int b ^ x * int (snd (steps ic p x) ! l))"
    by (auto simp: r_q R_def l;
        smt Suc_pred mult_0_right of_nat_0 of_nat_mult power_mult_distrib q sum.atLeast0_atMost_Suc zero_power)

  have "(\<Sum>t = 0..q - 1. b ^ t * (Z ic p l t * S ic p k t))
              + (b^(Suc (q-1)) * (Z ic p l (Suc (q-1)) * S ic p k (Suc (q-1))))
              = (\<Sum>t = 0..Suc (q-1). b ^ t * (Z ic p l t * S ic p k t)) " for k
    using comm_monoid_add_class.sum.atLeast0_atMost_Suc by auto
  hence zq: "(\<Sum>t = 0..q - 1. b ^ t * (Z ic p l t * S ic p k t))
              = (\<Sum>t = 0..q. b ^ t * (Z ic p l t * S ic p k t)) " for k
    using z_q q l by auto

  have "(if isadd (p ! k) \<and> l = modifies (p ! k) then \<Sum>t = 0..q - Suc 0. b ^ t * S ic p k t else 0)
      = (if isadd (p ! k) \<and> l = modifies (p ! k) then \<Sum>t = 0..q. b ^ t * S ic p k t else 0)" for k
    proof (cases "p!k")
      case (Add x11 x12)
      have sep: "(\<Sum>t = 0..q-1. b ^ t * S ic p k t) + b^q * S ic p k q
               = (\<Sum>t = 0..(Suc (q-1)). b ^ t * S ic p k t)"
        using comm_monoid_add_class.sum.atLeast0_atMost_Suc[of "\<lambda>t. b^t * S ic p k t" "q-1"] q
        by auto
      have "ishalt (p ! (fst (steps ic p q)))"
        using terminates_halt_state[of "ic" "p"] is_val terminate by auto
      hence "S ic p k q = 0" using Add S_def[of "ic" "p" "k" "q"] by auto
      with sep q have "(\<Sum>t = 0..q - Suc 0. b ^ t * S ic p k t) = (\<Sum>t = 0..q. b ^ t * S ic p k t)"
        by auto
      thus ?thesis by auto
    next
      case (Sub x21 x22 x23)
      then show ?thesis by auto
    next
      case Halt
      then show ?thesis by auto
    qed

    hence add_q: "\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..(q-1). b^t * S ic p k t)
                = \<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q. b^t * S ic p k t)"
    using sum_radd.simps single_step_add[of "ic" "p" "a" "l" "snd ic"] is_val l n_def by auto

  (* Start *)
  have "r l = (\<Sum>t = 0..q. b^t * R ic p l t)" using r_def RLe_def by auto
  also have "... = R ic p l 0 + (\<Sum>t = 1..q. b^t * R ic p l t)"
    by (auto simp: q comm_monoid_add_class.sum.atLeast_Suc_atMost)
  also have "... = (\<Sum>t \<in> {1..q}. b^t * R ic p l t)"
    by (simp add: R_def 0)
  also have "... = (\<Sum>t \<in> (Suc ` {0..(q-1)}). b^t * R ic p l t)" using q by auto
  also have "... = (sum  ((\<lambda>t. b^t * R ic p l t) \<circ> Suc)) {0..(q-1)}"
    using comm_monoid_add_class.sum.reindex[of "Suc" "{0..(q-1)}" "(\<lambda>t. b^t * R ic p l t)"] by auto
  also have "... = (\<Sum>t = 0..(q-1). b^(Suc t) *(R ic p l t
                                              + (\<Sum>R+ p l (\<lambda>k. S ic p k t))
                                              - (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    using lm04_06_one_step_relation_register[of "ic" "p" "a" "l"] is_val l
    by (simp add: n_def m_def)

  also have "... = (\<Sum>t \<in> {0..(q-1)}. b^(Suc t) *  R ic p l t
                                + b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t))
                                - b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t)))"
    by (auto simp add: algebra_simps)

  finally have "int (r l) = (\<Sum>t \<in> {0..(q-1)}. int(
                                  b^(Suc t) *  R ic p l t
                                + b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t))
                                - b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    by auto

  also have "... = (\<Sum>t \<in> {0..(q-1)}. int (b^(Suc t) *  R ic p l t)
                                + int (b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                - int (b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    by (simp only: sum_int positive)

  also have "... = (\<Sum>t \<in> {0..(q-1)}. int (b^(Suc t) *  R ic p l t)
                                + (int (b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                -  int (b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t)))))"
    by (simp add: add_diff_eq)

  also have "... = (\<Sum>t \<in> {0..(q-1)}. int( b^(Suc t) *  R ic p l t ))
             + (\<Sum>t \<in> {0..(q-1)}. int( b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                - int( b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t ))))"
    by (auto simp only: sum.distrib)

  also have "... = int b * int (\<Sum>t \<in> {0..(q-1)}. b^t *  R ic p l t )
             + int b * (\<Sum>t \<in> {0..(q-1)}. int(b^t * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                        - int(b^t * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t ))))"
    by (auto simp: sum_distrib_left mult.assoc right_diff_distrib)

  also have "... = int b * int (\<Sum>t \<in> {0..(q-1)}. b^t *  R ic p l t )
             + int b * (\<Sum>t \<in> {0..(q-1)}. int(b^t * (\<Sum>R+ p l (\<lambda>k. S ic p k t))))
             - int b * (\<Sum>t \<in> {0..(q-1)}. int(b^t * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    by (auto simp add: sum.distrib int_distrib(4) sum_subtractf)

  also have "... = int b * int (\<Sum>t \<in> {0..(q-1)}. b^t *  R ic p l t )
             + int b * (\<Sum>t \<in> {0..(q-1)}. int(\<Sum>R+ p l (\<lambda>k. b^t * S ic p k t)))
             - int b * (\<Sum>t \<in> {0..(q-1)}. int(\<Sum>R- p l (\<lambda>k. b^t * (Z ic p l t * S ic p k t))))"
    using sum_radd_distrib sum_rsub_distrib by auto

  also have "... = int b * int (\<Sum>t = 0..q-1. b^t *  R ic p l t)
             + int b * int (\<Sum>t = 0..q-1. \<Sum>R+ p l (\<lambda>k. b^t * S ic p k t))
             - int b * int (\<Sum>t = 0..q-1. \<Sum>R- p l (\<lambda>k. b^t * (Z ic p l t * S ic p k t)))"
    by auto

  also have "... = int b * int (\<Sum>t = 0..q-1. b^t * R ic p l t)
             + int b * int (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q-1. b^t * S ic p k t))
            - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q-1. b^t * (Z ic p l t * S ic p k t)))"
    using sum_rsub_commutative[of "p" "l" "\<lambda>k t. b^t * (Z ic p l t * S ic p k t)" "q-1"]
    using sum_radd_commutative[of "p" "l" "\<lambda>k t. b^t * S ic p k t " "q-1"] by auto

  (* extend all sums until q, because values don't change at time q *)
  also have "... = int b * int (\<Sum>t=0..q. b^t * R ic p l t)
             + int b * int (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q-1. b^t * S ic p k t))
             - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q-1. b^t * (Z ic p l t * S ic p k t)))"
    by (auto simp: rq R_def; smt One_nat_def rq)

  also have "... = int b * int (\<Sum>t=0..q. b^t * R ic p l t)
             + int b * int (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q. b^t * S ic p k t))
             - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q. b^t * (Z ic p l t * S ic p k t)))"
    using zq add_q by auto

  also have "... = int b * int (RLe ic p b q l)
             + int b * int (\<Sum>R+ p l (SKe ic p b q))
             - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q. b^t * (Z ic p l t * S ic p k t)))"
    by (auto simp: RLe_def; metis SKe_def)

  (* prove multiplication turns into bitAND *)
  also have "... = int b * int (RLe ic p b q l)
             + int b * int (\<Sum>R+ p l (SKe ic p b q))
             - int b * int (\<Sum>R- p l (\<lambda>k. ZLe ic p b q l && SKe ic p b q k))"
    using mult_to_bitAND c_gt_cells b_def c by auto

  finally have "int(r l) = int b * int (r l)
             + int b * int (\<Sum>R+ p l s)
             - int b * int (\<Sum>R- p l (\<lambda>k. z l && s k))"
    by (auto simp: r_def s_def z_def)

  hence "r l = b * r l
             + b * \<Sum>R+ p l s
             - b * \<Sum>R- p l (\<lambda>k. z l && s k)"
    using int_ops(5) int_ops(7) nat_int nat_minus_as_int by presburger

  thus ?thesis by simp
qed

lemma lm04_23_multiple_register1:
  fixes c :: nat
    and l :: register
    and ic :: configuration
    and p :: program
    and q :: nat
    and a :: nat

  defines "b == B c"
      and "m == length p"
      and "n == length (snd ic)"

assumes is_val: "is_valid_initial ic p a"
assumes c_gt_cells: "cells_bounded ic p c"
assumes l: "l = 0"
and q: "q > 0"

assumes c: "c > 1"

 assumes terminate: "terminates ic p q"

  defines "r == RLe ic p b q"
      and "z == ZLe ic p b q"
      and "s == SKe ic p b q"

shows "r l = a + b * r l
           + b * (\<Sum>R+ p l s)
           - b * (\<Sum>R- p l (\<lambda>k. z l && s k))"
proof -
  have n: "n > 0" using is_val
    by (auto simp add: is_valid_initial_def n_def)

  have 0: "snd ic ! l = a"
    using assms by (cases "ic"; auto simp add: is_valid_initial_def List.hd_conv_nth)

  find_theorems "hd ?l = ?l ! 0"

  have bound_fst_ic: "(if fst ic \<le> length p-1 then 1 else 0) \<le> Suc 0" by auto
  have "(if issub (p ! k) \<and> l = modifies (p ! k) then if fst ic = k then 1 else 0 else 0)
      = (if k = fst ic \<and> issub (p ! k) \<and> l = modifies (p ! k) then 1 else 0)" for k by auto
  hence "(if issub (p ! k) \<and> l = modifies (p ! k) then if fst ic = k then Suc 0 else 0 else 0)
             \<le> (if k = fst ic then 1 else 0)" for k
    apply (cases "p!k")
    apply (cases "modifies (p!k)")
    by auto
  hence sub: " (\<Sum>k = 0..length p-1. if issub (p ! k) \<and> l = modifies (p ! k)
           then if fst ic = k then Suc 0 else 0 else 0) \<le> Suc 0"
    using Groups_Big.ordered_comm_monoid_add_class.sum_mono[of "{0..length p-1}"
       "\<lambda>k. (if issub (p ! k) \<and> l = modifies (p ! k) then if fst ic = k then Suc 0 else 0 else 0)"
       "\<lambda>k. (if k = fst ic then 1 else 0)"] bound_fst_ic Orderings.ord_class.ord_eq_le_trans by auto

  have "b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t)) \<le> b^(Suc t) *  R ic p l t " for t
     proof (cases "t=0")
       case True
       hence "a = R ic p l 0" by (auto simp add: 0 R_def)
       thus ?thesis
         apply (cases "a=0")
         subgoal by (auto simp add: True R_def Z_def sum_rsub.simps)
         subgoal
           apply (auto simp add: True R_def Z_def sum_rsub.simps S_def)
           using sub by auto
         done
     next
       case False
       define cs where "cs \<equiv> fst (steps ic p t)"
       have sub: "(\<Sum>R- p l (\<lambda>k. Z ic p l t * S ic p k t))
        = (if issub (p!cs) \<and> l = modifies (p!cs) then Z ic p l t else 0)"
         using single_step_sub Z_def R_def is_val l n_def cs_def n by auto
       show ?thesis using sub by (auto simp add: sum_rsub.simps R_def Z_def)
     qed

    from this have positive: "b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))
                    \<le> b^(Suc t) *  R ic p l t
                    + b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t))" for t
      by (auto simp add: Nat.trans_le_add1)

  have distrib_add: "\<And>t. b^t * \<Sum>R+ p l (\<lambda>k. S ic p k t) = \<Sum>R+ p l (\<lambda>k. b ^ t * S ic p k t)"
    by (simp add: sum_radd_distrib)
  have distrib_sub: "\<And>t. b^t * \<Sum>R- p l (\<lambda>k. Z ic p l t * S ic p k t)
                     = \<Sum>R- p l (\<lambda>k. b ^ t * (Z ic p l t * S ic p k t))"
    by (simp add: sum_rsub_distrib)

  have commute_add: "(\<Sum>t=0..q-1. \<Sum>R+ p l (\<lambda>k. b^t * S ic p k t))
      = \<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q-1. (b^t * S ic p k t))"
    using sum_radd_commutative[of "p" "l" "\<lambda>k t. b^t * S ic p k t " "q-1"] by auto

  have "length (snd ic) > 0" using is_val is_valid_initial_def[of "ic" "p" "a"] by auto
  hence r_q: "R ic p l q = 0"
    using terminate terminates_def correct_halt_def l by (auto simp: n_def R_def)
  hence z_q: "Z ic p l q = 0"
    using terminate by (auto simp: Z_def)

  have "\<forall>k<length p-1. \<not> ishalt (p!k)"
    using is_val is_valid_initial_def[of "ic" "p" "a"] is_valid_def[of "ic" "p"]
          program_includes_halt.simps by blast
  hence s_q: "\<forall>k < length p - 1. S ic p k q = 0"
    using terminate terminates_def correct_halt_def by (auto simp: S_def)

  from r_q have rq: "(\<Sum>x = 0..q - 1. int b ^ x * int (snd (steps ic p x) ! l)) =
                     (\<Sum>x = 0..q. int b ^ x * int (snd (steps ic p x) ! l))"
    by (auto simp: r_q R_def; smt Suc_pred mult_0_right of_nat_0 of_nat_mult power_mult_distrib q
        sum.atLeast0_atMost_Suc zero_power)

  have "(\<Sum>t = 0..q - 1. b ^ t * (Z ic p l t * S ic p k t))
              + (b^(Suc (q-1)) * (Z ic p l (Suc (q-1)) * S ic p k (Suc (q-1))))
              = (\<Sum>t = 0..Suc (q-1). b ^ t * (Z ic p l t * S ic p k t)) " for k
    using comm_monoid_add_class.sum.atLeast0_atMost_Suc by auto
  hence zq: "(\<Sum>t = 0..q - 1. b ^ t * (Z ic p l t * S ic p k t))
              = (\<Sum>t = 0..q. b ^ t * (Z ic p l t * S ic p k t)) " for k
    using z_q q by auto

  have "(if isadd (p ! k) \<and> l = modifies (p ! k) then \<Sum>t = 0..q - Suc 0. b ^ t * S ic p k t else 0)
      = (if isadd (p ! k) \<and> l = modifies (p ! k) then \<Sum>t = 0..q. b ^ t * S ic p k t else 0)" for k
    proof (cases "p!k")
      case (Add x11 x12)
      have sep: "(\<Sum>t = 0..q-1. b ^ t * S ic p k t) + b^q * S ic p k q
               = (\<Sum>t = 0..(Suc (q-1)). b ^ t * S ic p k t)"
        using comm_monoid_add_class.sum.atLeast0_atMost_Suc[of "\<lambda>t. b^t * S ic p k t" "q-1"] q
        by auto
      have "ishalt (p ! (fst (steps ic p q)))"
        using terminates_halt_state[of "ic" "p"] is_val terminate by auto
      hence "S ic p k q = 0" using Add S_def[of "ic" "p" "k" "q"] by auto
      with sep q have "(\<Sum>t = 0..q - Suc 0. b ^ t * S ic p k t) = (\<Sum>t = 0..q. b ^ t * S ic p k t)"
        by auto
      thus ?thesis by auto
    next
      case (Sub x21 x22 x23)
      then show ?thesis by auto
    next
      case Halt
      then show ?thesis by auto
    qed

    hence add_q: "\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..(q-1). b^t * S ic p k t)
                = \<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q. b^t * S ic p k t)"
    using sum_radd.simps single_step_add[of "ic" "p" "a" "l" "snd ic"] is_val l n_def by auto

  (* Start *)
  have "r l = (\<Sum>t = 0..q. b^t * R ic p l t)" using r_def RLe_def by auto
  also have "... = R ic p l 0 + (\<Sum>t = 1..q. b^t * R ic p l t)"
    by (auto simp: q comm_monoid_add_class.sum.atLeast_Suc_atMost)
  also have "... = a + (\<Sum>t \<in> {1..q}. b^t * R ic p l t)"
    by (simp add: R_def 0)
  also have "... = a + (\<Sum>t = (Suc 0)..(Suc (q-1)). b^t * R ic p l t)" using q by auto
  also have "... = a + (\<Sum>t \<in> (Suc ` {0..(q-1)}). b^t * R ic p l t)" by auto
  also have "... = a + (sum  ((\<lambda>t. b^t * R ic p l t) \<circ> Suc)) {0..(q-1)}"
    using comm_monoid_add_class.sum.reindex[of "Suc" "{0..(q-1)}" "(\<lambda>t. b^t * R ic p l t)"] by auto
  also have "... = a + (\<Sum>t = 0..(q-1). b^(Suc t) * R ic p l (Suc t))" by auto
  also have "... = a + (\<Sum>t = 0..(q-1). b^(Suc t) *(R ic p l t
                                              + (\<Sum>R+ p l (\<lambda>k. S ic p k t))
                                              - (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    using lm04_06_one_step_relation_register[of "ic" "p" "a" "l"] is_val n n_def l
    by (auto simp add: n_def m_def)

  also have "... = a + (\<Sum>t \<in> {0..(q-1)}. b^(Suc t) *  R ic p l t
                                + b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t))
                                - b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t)))"
    by (auto simp add: algebra_simps)

  finally have "int (r l) = int a +(\<Sum>t \<in> {0..(q-1)}. int(
                                  b^(Suc t) *  R ic p l t
                                + b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t))
                                - b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    by auto

  also have "... = int a + (\<Sum>t \<in> {0..(q-1)}. int (b^(Suc t) *  R ic p l t)
                                + int (b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                - int (b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    by (simp only: sum_int positive)

  also have "... = int a + (\<Sum>t \<in> {0..(q-1)}. int (b^(Suc t) *  R ic p l t)
                                + (int (b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                -  int (b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t)))))"
    by (simp add: add_diff_eq)

  also have "... = int a + (\<Sum>t \<in> {0..(q-1)}. int( b^(Suc t) *  R ic p l t ))
             + (\<Sum>t \<in> {0..(q-1)}. int( b^(Suc t) * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                - int( b^(Suc t) * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t ))))"
    by (auto simp only: sum.distrib)

  also have "... = int a + int b * int (\<Sum>t \<in> {0..(q-1)}. b^t *  R ic p l t )
             + int b * (\<Sum>t \<in> {0..(q-1)}. int(b^t * (\<Sum>R+ p l (\<lambda>k. S ic p k t)))
                                        - int(b^t * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t ))))"
    by (auto simp: sum_distrib_left mult.assoc right_diff_distrib)

  also have "... = int a + int b * int (\<Sum>t \<in> {0..(q-1)}. b^t *  R ic p l t )
             + int b * (\<Sum>t \<in> {0..(q-1)}. int(b^t * (\<Sum>R+ p l (\<lambda>k. S ic p k t))))
             - int b * (\<Sum>t \<in> {0..(q-1)}. int(b^t * (\<Sum>R- p l (\<lambda>k. (Z ic p l t) * S ic p k t))))"
    by (auto simp add: sum.distrib int_distrib(4) sum_subtractf)

  also have "... = int a + int b * int (\<Sum>t \<in> {0..(q-1)}. b^t *  R ic p l t )
             + int b * (\<Sum>t \<in> {0..(q-1)}. int(\<Sum>R+ p l (\<lambda>k. b^t * S ic p k t)))
             - int b * (\<Sum>t \<in> {0..(q-1)}. int(\<Sum>R- p l (\<lambda>k. b^t * (Z ic p l t * S ic p k t))))"
    using distrib_add distrib_sub by auto

  also have "... = int a + int b * int (\<Sum>t = 0..q-1. b^t *  R ic p l t)
             + int b * int (\<Sum>t = 0..q-1. \<Sum>R+ p l (\<lambda>k. b^t * S ic p k t))
             - int b * int (\<Sum>t = 0..q-1. \<Sum>R- p l (\<lambda>k. b^t * (Z ic p l t * S ic p k t)))"
    by auto

  also have "... = int a + int b * int (\<Sum>t = 0..q-1. b^t * R ic p l t)
             + int b * int (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q-1. b^t * S ic p k t))
            - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q-1. b^t * (Z ic p l t * S ic p k t)))"
    using sum_rsub_commutative[of "p" "l" "\<lambda>k t. b^t * (Z ic p l t * S ic p k t)" "q-1"]
    using sum_radd_commutative[of "p" "l" "\<lambda>k t. b^t * S ic p k t " "q-1"] by auto

  (* extend all sums until q, because values don't change at time q *)
  also have "... = int a + int b * int (\<Sum>t=0..q. b^t * R ic p l t)
             + int b * int (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q-1. b^t * S ic p k t))
             - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q-1. b^t * (Z ic p l t * S ic p k t)))"
    by (auto simp: rq R_def; smt One_nat_def rq)

  also have "... = int a + int b * int (\<Sum>t=0..q. b^t * R ic p l t)
             + int b * int (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q. b^t * S ic p k t))
             - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q. b^t * (Z ic p l t * S ic p k t)))"
    using zq add_q by auto

  also have "... = int a + int b * int (RLe ic p b q l)
             + int b * int (\<Sum>R+ p l (SKe ic p b q))
             - int b * int (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q. b^t * (Z ic p l t * S ic p k t)))"
    by (auto simp: RLe_def; metis SKe_def)

  (* prove multiplication turns into bitAND *)
  also have "... = int a + int b * int (RLe ic p b q l)
             + int b * int (\<Sum>R+ p l (SKe ic p b q))
             - int b * int (\<Sum>R- p l (\<lambda>k. ZLe ic p b q l && SKe ic p b q k))"
    using mult_to_bitAND c_gt_cells b_def c by auto

  finally have "int(r l) = int a + int b * int (r l)
             + int b * int (\<Sum>R+ p l s)
             - int b * int (\<Sum>R- p l (\<lambda>k. z l && s k))"
    by (auto simp: r_def s_def z_def)

  hence "r l = a + b * r l
             + b * \<Sum>R+ p l s
             - b * \<Sum>R- p l (\<lambda>k. z l && s k)"
    using int_ops(5) int_ops(7) nat_int nat_minus_as_int by presburger

  thus ?thesis by simp
qed

end


header {* Target Language debug messages *}
theory Print
imports
  "../../Affine_Arithmetic/Executable_Euclidean_Space"
begin

text {* very ad-hoc... *}

subsection {* Printing *}

text {* Just for debugging purposes *}

definition print::"String.literal \<Rightarrow> unit" where "print x = ()"

definition int_to_string::"int \<Rightarrow> String.literal"
  where "int_to_string x = STR ''''"

context includes integer.lifting begin

lift_definition integer_to_string::"integer \<Rightarrow> String.literal"
  is int_to_string .

end

lemma [code]: "int_to_string x = integer_to_string (integer_of_int x)"
  by (simp add: integer_to_string_def)

definition "println x = (let _ = print x in print (STR ''\<newline>''))"

code_printing
  constant print \<rightharpoonup> (SML) "TextIO.print"
| constant "integer_to_string :: integer \<Rightarrow> String.literal" \<rightharpoonup> (SML) "Int.toString"

consts float2_float10::"int \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> int \<Rightarrow> (int * int)"

context includes integer.lifting begin

lift_definition float2_float10_integer::"integer \<Rightarrow> bool \<Rightarrow> integer \<Rightarrow> integer \<Rightarrow> (integer * integer)"
  is float2_float10 .

lemma float2_float10_code[code]: "float2_float10 x b m e =
  (case float2_float10_integer (integer_of_int x) b (integer_of_int m) (integer_of_int e) of (a, b) \<Rightarrow>
  (int_of_integer a, int_of_integer b))"
  by transfer simp

end

code_printing
  code_module "Float2_Float10" \<rightharpoonup> (SML)
  --"this is taken from Approximation.thy" --"TODO: implement in Isabelle/HOL?"
{*
fun float2float10integer prec round_down m e = (
  let
    val (m, e) = (if e < 0 then (m,e) else (m * IntInf.pow (2, e), 0))

    fun frac c p 0 digits cnt = (digits, cnt, 0)
      | frac c 0 r digits cnt = (digits, cnt, r)
      | frac c p r digits cnt = (let
        val (d, r) = IntInf.divMod (r * 10, IntInf.pow (2, ~e))
      in frac (c orelse d <> 0) (if d <> 0 orelse c then p - 1 else p) r
              (digits * 10 + d) (cnt + 1)
      end)

    val sgn = Int.sign m
    val m = abs m

    val round_down = (sgn = 1 andalso round_down) orelse
                     (sgn = ~1 andalso not round_down)

    val (x, r) = IntInf.divMod (m, (IntInf.pow (2, ~e)))

    val p = ((if x = 0 then prec else prec - (IntInf.log2 x + 1)) * 3) div 10 + 1

    val (digits, e10, r) = if p > 0 then frac (x <> 0) p r 0 0 else (0,0,0)

    val digits = if round_down orelse r = 0 then digits else digits + 1

  in (sgn * (digits + x * (IntInf.pow (10, e10))), ~e10)
  end)
*}
| constant float2_float10_integer \<rightharpoonup> (SML) "float2float10integer"
code_reserved SML float2_float10_integer

definition print_real::"real \<Rightarrow> unit" where "print_real x = ()"

lemma print_Floatreal[code]:
  "print_real (FloatR a b) =
    (let
      (m, e) = float2_float10 25 True a b;
      _ = print (int_to_string m);
      _ = print (STR ''e'');
      _ = print (int_to_string e)
     in
       ())"
  by simp_all

definition print_eucl::"'a::executable_euclidean_space \<Rightarrow> unit"
  where "print_eucl x =
    (let
      _ = print (STR ''('');
      _ = map (\<lambda>i. let _ = print_real (x \<bullet> i); _ = print (STR '', '') in ()) (Basis_list::'a list);
      _ = print (STR '')'')
    in ())"

definition bind_err:: "String.literal \<Rightarrow> 'c option \<Rightarrow> ('c \<Rightarrow> 'd option) \<Rightarrow> 'd option"
  where [simp]: "bind_err err = Option.bind"

lemma [code]:
  "bind_err err None f = (let _ = println err in None)"
  "bind_err err (Some x) f = f x"
  by auto

end


(* Title: Adaptation of Trie Implementation
   Author: Peter Gammie < peteg42 at gmail dot com >
*)

(*<*)
theory Trie2 imports
  MapOps
  ODList
  Trie.Trie
begin
(*>*)

definition
  trie_update_with :: "'key list \<Rightarrow> 'val \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where
  "trie_update_with ks v f \<equiv> update_with_trie ks (%vo. f(case vo of None \<Rightarrow> v | Some v \<Rightarrow> v))"

lemma [simp]:
  "trie_update_with (k#ks) v f (Trie vo ts) =
    Trie vo (AList.update_with_aux empty_trie k (trie_update_with ks v f) ts)"
by(simp add: trie_update_with_def empty_trie_def)

abbreviation
  trie_update_with' :: "'k list \<Rightarrow> ('k, 'v) trie \<Rightarrow> 'v \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) trie"
where
  "trie_update_with' \<equiv> (\<lambda>k m v f. trie_update_with k v f m)"

definition
  trie_update :: "'key list \<Rightarrow> 'val \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where
  "trie_update k v t = trie_update_with k v (\<lambda>v'. v) t"

text \<open>@{term "trie_lookup"}\<close>

lemma lookup_empty_trie [simp]: "lookup_trie empty_trie ks = None"
by (cases ks) (simp_all)

lemma lookup_trie_update_with:
  "lookup_trie (trie_update_with ks v f t) ks'
 = (if ks = ks' then Some (f (case lookup_trie t ks of None \<Rightarrow> v | Some v' \<Rightarrow> v')) else lookup_trie t ks')"
proof(induct ks "(%vo. f(case vo of None \<Rightarrow> v | Some v \<Rightarrow> v))" t arbitrary: v ks' rule: update_with_trie.induct)
  case (1 v ps vo ks')
  show ?case by (fastforce simp add: neq_Nil_conv dest: not_sym)
next
  case (2 k ks v ps vo ks')
  show ?case by(cases ks')(auto simp add: map_of_update_with_aux "2" empty_trie_def split: option.split)
qed

lemma lookup_trie_update:
  "lookup_trie (trie_update ks v t) ks' = (if ks = ks' then Some v else lookup_trie t ks')"
  unfolding trie_update_def by (auto simp add: lookup_trie_update_with)

text\<open>@{term "MapOps"}\<close>

definition
  trie_MapOps :: "(('k, 'e) trie, 'k list, 'e) MapOps"
where
  "trie_MapOps \<equiv>
     \<lparr> MapOps.empty = empty_trie,
       lookup = lookup_trie,
       update = trie_update \<rparr>"

lemma trie_MapOps[intro, simp]:
  "inj_on \<alpha> { x . \<alpha> x \<in> d } \<Longrightarrow> MapOps \<alpha> d trie_MapOps"
  apply rule
  unfolding trie_MapOps_def
  apply (auto dest: inj_onD simp add: lookup_trie_update)
  done

definition
  "trie_odlist_lookup = (\<lambda>M. lookup_trie M \<circ> toList)"

definition
  "trie_odlist_update = (\<lambda>k v. trie_update (toList k) v)"

definition
  trie_odlist_update_with :: "('k :: linorder) odlist \<Rightarrow> ('k, 'v) trie \<Rightarrow> 'v \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) trie"
where
  "trie_odlist_update_with = (\<lambda>k m v f. trie_update_with (toList k) v f m)"

definition
  trie_odlist_MapOps :: "(('k, 'e) trie, ('k ::linorder) odlist, 'e) MapOps"
where
  "trie_odlist_MapOps \<equiv>
     \<lparr> MapOps.empty = empty_trie,
       lookup = trie_odlist_lookup,
       update = trie_odlist_update \<rparr>"

lemma trie_odlist_MapOps[intro, simp]:
  "inj_on \<alpha> { x . \<alpha> x \<in> d } \<Longrightarrow> MapOps \<alpha> d trie_odlist_MapOps"
  apply rule
  unfolding trie_odlist_MapOps_def trie_odlist_lookup_def trie_odlist_update_def
  apply (auto dest: inj_onD simp add: lookup_trie_update)
  done

(*<*)
end
(*>*)


theory Safety
  imports Main "./Raft"
begin

lemma (in raft) majority_vote_for_leader:
  "\<lbrakk> valid_params n i; state (all_states ! n ! i) = leader \<rbrakk>
  \<Longrightarrow> majority number_of_nodes {s. \<exists>m \<in> all_messages ! (n - 1). m = message s (node i) (request_vote_response True) (currentTerm (all_states ! (n - 1) ! i))}"
  apply (induct n)
  apply (metis hd_0th initial_server_state_def initial_state node_state.distinct(3) raft.valid_params_def raft_axioms repeat_nth select_convs(1))
proof-
  fix n
  assume "(valid_params n i \<Longrightarrow>
          state (all_states ! n ! i) = leader \<Longrightarrow>
          majority number_of_nodes
           {s. \<exists>m\<in>all_messages ! (n - 1). m = message s (node i) (request_vote_response True) (currentTerm (all_states ! (n - 1) ! i))})"
    "valid_params (Suc n) i"
    "state (all_states ! Suc n ! i) = leader"

  have "(all_states ! n, all_messages ! n) \<rightarrow> (all_states ! Suc n, all_messages ! Suc n)"
    using transition_previous by force

  show "majority number_of_nodes
          ({s. \<exists>m\<in>all_messages ! (Suc n - 1). m = message s (node i) (request_vote_response True) (currentTerm (all_states ! (Suc n - 1) ! i))})"
    apply (cases "state (all_states ! n ! i) = leader")
    sorry
qed

lemma (in raft) currentTerm_monotonicity: "\<lbrakk> valid_params n i; m < n \<rbrakk> \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i)"
proof-
  { fix k
    have "\<lbrakk> k = n - m; valid_params n i; m < n \<rbrakk> \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i)"
      apply (induct k arbitrary: n m)
      apply simp
    proof-
      fix k n m
      assume "(\<And>n m. k = n - m \<Longrightarrow> valid_params n i \<Longrightarrow> m < n \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i))"
        "Suc k = n - m" "valid_params n i" "m < n"
      have "Suc k + m = n"
        by (simp add: \<open>Suc k = n - m\<close> \<open>m < n\<close> less_imp_le)
      hence "k + Suc m = n"
        by simp
      hence "k = n - Suc m"
        by simp

      have "(all_states ! m, all_messages ! m) \<rightarrow> (all_states ! (Suc m), all_messages ! (Suc m))"
        using transition by auto
      hence "currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! (Suc m) ! i)"
        by (metis \<open>m < n\<close> \<open>valid_params n i\<close> raft.valid_params_def raft_axioms state_length_invariant transition_currentTerm_monotonicity valid_params_length_smaller)

      have "currentTerm (all_states ! (Suc m) ! i) \<le> currentTerm (all_states ! n ! i)"
        by (metis Suc_lessI \<open>\<And>na m. \<lbrakk>k = na - m; valid_params na i; m < na\<rbrakk> \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! na ! i)\<close> \<open>k = n - Suc m\<close> \<open>m < n\<close> \<open>valid_params n i\<close> eq_imp_le less_eq_election_term_def)

      show "currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i)"
        by (meson \<open>currentTerm (all_states ! Suc m ! i) \<le> currentTerm (all_states ! n ! i)\<close> \<open>currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! Suc m ! i)\<close> le_trans less_eq_election_term_def)
    qed
  }
  hence "\<And>k. \<lbrakk> k = n - m; valid_params n i; m < n \<rbrakk> \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i)" by simp

  show "\<lbrakk> valid_params n i; m < n \<rbrakk> \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i)"
    by (meson \<open>\<And>k. \<lbrakk>k = n - m; valid_params n i; m < n\<rbrakk> \<Longrightarrow> currentTerm (all_states ! m ! i) \<le> currentTerm (all_states ! n ! i)\<close>)
qed

lemma (in raft) leader_has_promotion_point_in_past:
  assumes "state (all_states ! n ! i) = leader" "valid_params n i"
  obtains m where "m < n" "state (all_states ! m ! i) \<noteq> leader" "state (all_states ! (m + 1) ! i) = leader" "currentTerm (all_states ! m ! i) = currentTerm (all_states ! n ! i)"
  using assms
  apply (induct n)
  apply simp
  apply (metis hd_conv_nth initial_server_state_def initial_state less_numeral_extra(3) list.size(3) node_state.simps(4) repeat_nth select_convs(1) valid_params_def)
  sorry

lemma (in raft) vote_twice_same_term_is_not_allowed:
  "\<lbrakk> m \<in> all_messages ! n; m' \<in> all_messages ! n
  ; payload m = request_vote_response True; payload m' = request_vote_response True
  ; sender m = sender m'
  ; sender_term m = sender_term m'
  \<rbrakk> \<Longrightarrow> m = m'"
  sorry

theorem (in raft) election_safety: "
  \<lbrakk> valid_params n i
  ; valid_params n j
  ; state (all_states ! n ! i) = leader
  ; state (all_states ! n ! j) = leader
  ; currentTerm (all_states ! n ! i) = currentTerm (all_states ! n ! j) \<rbrakk> \<Longrightarrow> i = j"
proof-
  assume "valid_params n i" "valid_params n j" "state (all_states ! n ! i) = leader" "state (all_states ! n ! j) = leader" "currentTerm (all_states ! n ! i) = currentTerm (all_states ! n ! j)"
  obtain ni where "ni < n" "state (all_states ! ni ! i) \<noteq> leader" "state (all_states ! (ni + 1) ! i) = leader" "currentTerm (all_states ! ni ! i) = currentTerm (all_states ! n ! i)"
    using \<open>state (all_states ! n ! i) = leader\<close> \<open>valid_params n i\<close> raft.leader_has_promotion_point_in_past raft_axioms by blast
  obtain nj where "nj < n" "state (all_states ! nj ! j) \<noteq> leader" "state (all_states ! (nj + 1) ! j) = leader" "currentTerm (all_states ! nj ! j) = currentTerm (all_states ! n ! j)"
    using \<open>state (all_states ! n ! j) = leader\<close> \<open>valid_params n j\<close> leader_has_promotion_point_in_past by blast

  have "valid_params ni i"
    using \<open>ni < n\<close> \<open>valid_params n i\<close> raft.valid_params_length_smaller raft_axioms by blast
  have "majority (length (all_states ! ni)) ({s. \<exists>m \<in> all_messages ! ni. m = message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))})"
    apply (rule leader_promote_inversion_for_transition [where \<sigma>' = "all_states ! (ni + 1)", where ms' = "all_messages ! (ni + 1)"])
    using \<open>valid_params ni i\<close> raft.state_length_invariant raft.valid_params_def raft_axioms apply blast
    apply (simp add: transition)
    apply (simp add: \<open>state (all_states ! ni ! i) \<noteq> leader\<close>)
    using \<open>state (all_states ! (ni + 1) ! i) = leader\<close> by auto

  have "valid_params nj j"
    using \<open>nj < n\<close> \<open>valid_params n j\<close> valid_params_length_smaller by auto
  have "majority (length (all_states ! nj)) ({s. \<exists>m \<in> all_messages ! nj. m = message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))})"
    apply (rule leader_promote_inversion_for_transition [where \<sigma>' = "all_states ! (nj + 1)", where ms' = "all_messages ! (nj + 1)"])
    using \<open>valid_params nj j\<close> state_length_invariant valid_params_def apply blast
    apply (simp add: transition)
    apply (simp add: \<open>state (all_states ! nj ! j) \<noteq> leader\<close>)
    using \<open>state (all_states ! (nj + 1) ! j) = leader\<close> by auto

  have "length (all_states ! ni) = number_of_nodes"
    using \<open>valid_params ni i\<close> state_length_invariant by auto
  have "length (all_states ! nj) = number_of_nodes"
    using \<open>valid_params nj j\<close> state_length_invariant by auto

  have "\<And>s. node_of s < number_of_nodes \<Longrightarrow> s \<in> node ` {0..<number_of_nodes}"
    by force
  have card_of_u: "(card (node ` {0..<number_of_nodes})) = number_of_nodes"
  proof-
    have "inj_on node {0..<number_of_nodes}"
      by (meson inj_onI node.inject)
    show "card (node ` {0..<number_of_nodes}) = number_of_nodes"
      by (simp add: \<open>inj_on node {0..<number_of_nodes}\<close> card_image)
  qed

  have "all_messages ! ni \<subseteq> all_messages ! n"
    by (simp add: \<open>ni < n\<close> less_or_eq_imp_le message_monotonicity)
  have "all_messages ! nj \<subseteq> all_messages ! n"
    by (simp add: \<open>nj < n\<close> less_imp_le_nat message_monotonicity)
  have "{s. \<exists>m \<in> all_messages ! ni. m = message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))} \<inter> {s. \<exists>m \<in> all_messages ! nj. m = message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))} \<noteq> {}"
    apply (rule majority_pigeonhole [where u = "node ` {0..<number_of_nodes}"])
    apply simp_all
  proof-
    show "{s. message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i)) \<in> all_messages ! ni} \<subseteq> node ` {0..<number_of_nodes}"
      apply auto
      by (metis \<open>\<And>s. node_of s < number_of_nodes \<Longrightarrow> s \<in> node ` {0..<number_of_nodes}\<close> \<open>valid_params ni i\<close> all_messages_contains_valid_sender message.sel(1) raft.valid_params_def raft_axioms)
  next
    show "{s. message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j)) \<in> all_messages ! nj} \<subseteq> node ` {0..<number_of_nodes}"
      apply auto
      by (metis \<open>\<And>s. node_of s < number_of_nodes \<Longrightarrow> s \<in> node ` {0..<number_of_nodes}\<close> \<open>valid_params nj j\<close> all_messages_contains_valid_sender message.sel(1) raft.valid_params_def raft_axioms)
  next
    show "majority (card (node ` {0..<number_of_nodes})) {s. message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i)) \<in> all_messages ! ni}"
      apply (simp add: card_of_u)
      using \<open>length (all_states ! ni) = number_of_nodes\<close> \<open>majority (length (all_states ! ni)) {s. \<exists>m\<in>all_messages ! ni. m = message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))}\<close> by auto
  next
    show "majority (card (node ` {0..<number_of_nodes})) {s. message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j)) \<in> all_messages ! nj}"
      apply (simp add: card_of_u)
      using \<open>length (all_states ! nj) = number_of_nodes\<close> \<open>majority (length (all_states ! nj)) {s. \<exists>m\<in>all_messages ! nj. m = message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))}\<close> by auto
  qed

  then obtain z where "z \<in> {s. \<exists>m \<in> all_messages ! ni. m = message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))} \<inter> {s. \<exists>m \<in> all_messages ! nj. m = message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))}"
    by auto
  obtain m1 where "m1 \<in> all_messages ! ni" "m1 = message z (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))"
    using \<open>z \<in> {s. \<exists>m\<in>all_messages ! ni. m = message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))} \<inter> {s. \<exists>m\<in>all_messages ! nj. m = message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))}\<close> by blast
  obtain m2 where "m2 \<in> all_messages ! nj" "m2 = message z (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))"
    using \<open>z \<in> {s. \<exists>m\<in>all_messages ! ni. m = message s (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))} \<inter> {s. \<exists>m\<in>all_messages ! nj. m = message s (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))}\<close> by blast

  have "m1 = m2"
    apply (rule vote_twice_same_term_is_not_allowed [where n = n])
    using \<open>all_messages ! ni \<subseteq> all_messages ! n\<close> \<open>m1 \<in> all_messages ! ni\<close> apply blast
    using \<open>all_messages ! nj \<subseteq> all_messages ! n\<close> \<open>m2 \<in> all_messages ! nj\<close> apply auto[1]
    using \<open>m1 = message z (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))\<close> apply auto[1]
    apply (simp add: \<open>m2 = message z (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))\<close>)
    apply (simp add: \<open>m1 = message z (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))\<close> \<open>m2 = message z (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))\<close>)
    by (simp add: \<open>currentTerm (all_states ! n ! i) = currentTerm (all_states ! n ! j)\<close> \<open>currentTerm (all_states ! ni ! i) = currentTerm (all_states ! n ! i)\<close> \<open>currentTerm (all_states ! nj ! j) = currentTerm (all_states ! n ! j)\<close> \<open>m1 = message z (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))\<close> \<open>m2 = message z (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))\<close>)

  show "i = j"
    using \<open>m1 = m2\<close> \<open>m1 = message z (node i) (request_vote_response True) (currentTerm (all_states ! ni ! i))\<close> \<open>m2 = message z (node j) (request_vote_response True) (currentTerm (all_states ! nj ! j))\<close> by fastforce
qed

end