(* Authors: Lammich, Wimmer *)
section \<open>Generic Worklist Algorithm with Subsumption\<close>
theory Worklist_Subsumption_Multiset
  imports
    Refine_Imperative_HOL.Sepref
    Worklist_Locales
    Unified_PW (* Only for shared definitions *)
begin

subsection \<open>Utilities\<close>

definition take_from_set where
  "take_from_set s = ASSERT (s \<noteq> {}) \<then> SPEC (\<lambda> (x, s'). x \<in> s \<and> s' = s - {x})"

lemma take_from_set_correct:
  assumes "s \<noteq> {}"
  shows "take_from_set s \<le> SPEC (\<lambda> (x, s'). x \<in> s \<and> s' = s - {x})"
using assms unfolding take_from_set_def by simp

lemmas [refine_vcg] = take_from_set_correct[THEN order.trans]

definition take_from_mset where
  "take_from_mset s = ASSERT (s \<noteq> {#}) \<then> SPEC (\<lambda> (x, s'). x \<in># s \<and> s' = s - {#x#})"

lemma take_from_mset_correct:
  assumes "s \<noteq> {#}"
  shows "take_from_mset s \<le> SPEC (\<lambda> (x, s'). x \<in># s \<and> s' = s - {#x#})"
using assms unfolding take_from_mset_def by simp

lemmas [refine_vcg] = take_from_mset_correct[THEN order.trans]

lemma set_mset_mp: "set_mset m \<subseteq> s \<Longrightarrow> n < count m x \<Longrightarrow> x\<in>s"
  by (meson count_greater_zero_iff le_less_trans subsetCE zero_le)

lemma pred_not_lt_is_zero: "(\<not> n - Suc 0 < n) \<longleftrightarrow> n=0" by auto

lemma (in Search_Space_finite_strict) finitely_branching:
  assumes "reachable a"
  shows "finite (Collect (E a))"
  by (metis assms finite_reachable finite_subset mem_Collect_eq reachable_step subsetI)

subsection \<open>Standard Worklist Algorithm\<close>

context Search_Space_Defs_Empty begin

  definition "worklist_start_subsumed passed wait = (\<exists> a \<in> passed \<union> set_mset wait. a\<^sub>0 \<preceq> a)"

  definition
    "worklist_var =
    inv_image (finite_psupset (Collect reachable) <*lex*> measure size) (\<lambda> (a, b,c). (a,b))"

  definition "worklist_inv_frontier passed wait =
    (\<forall> a \<in> passed. \<forall> a'. E a a' \<and> \<not> empty a' \<longrightarrow> (\<exists> b' \<in> passed \<union> set_mset wait. a' \<preceq> b'))"

  definition "worklist_inv \<equiv> \<lambda> (passed, wait, brk).
    passed \<subseteq> Collect reachable \<and>
    (brk \<longrightarrow> (\<exists> f. reachable f \<and> F f)) \<and>
    (\<not> brk \<longrightarrow>
      worklist_inv_frontier passed wait
    \<and> (\<forall> a \<in> passed \<union> set_mset wait. \<not> F a)
    \<and> worklist_start_subsumed passed wait
    \<and> set_mset wait \<subseteq> Collect reachable)
    "

  definition "add_succ_spec wait a \<equiv> SPEC (\<lambda>(wait',brk).
    if \<exists>a'. E a a' \<and> F a' then
      brk
    else
      \<not>brk \<and> set_mset wait' \<subseteq> set_mset wait \<union> {a' . E a a'} \<and>
      (\<forall> s \<in> set_mset wait \<union> {a' . E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s')
  )"

  definition worklist_algo where
    "worklist_algo = do
      {
        if F a\<^sub>0 then RETURN True
        else do {
          let passed = {};
          let wait = {#a\<^sub>0#};
          (passed, wait, brk) \<leftarrow> WHILEIT worklist_inv (\<lambda> (passed, wait, brk). \<not> brk \<and> wait \<noteq> {#})
            (\<lambda> (passed, wait, brk). do
              {
                (a, wait) \<leftarrow> take_from_mset wait;
                ASSERT (reachable a);
                if (\<exists> a' \<in> passed. a \<preceq> a') then RETURN (passed, wait, brk) else
                do
                  {
                    (wait,brk) \<leftarrow> add_succ_spec wait a;
                    let passed = insert a passed;
                    RETURN (passed, wait, brk)
                  }
              }
            )
            (passed, wait, False);
            RETURN brk
        }
      }
    "

end

subsubsection \<open>Correctness Proof\<close>

lemma (in Search_Space) empty_E_star:
  "empty x'" if "E\<^sup>*\<^sup>* x x'" "reachable x" "empty x"
  using that unfolding reachable_def
  by (induction rule: converse_rtranclp_induct)
     (blast intro: empty_E[unfolded reachable_def] rtranclp.rtrancl_into_rtrancl)+

context Search_Space_finite_strict begin

  lemma wf_worklist_var:
    "wf worklist_var"
  unfolding worklist_var_def by (auto simp: finite_reachable)

  context
  begin

  private lemma aux1:
    assumes "\<forall>x\<in>passed. \<not> a \<preceq> x"
        and "passed \<subseteq> Collect reachable"
        and "reachable a"
    shows "
    ((insert a passed, wait', brk'),
     passed, wait, brk)
    \<in> worklist_var"
  proof -
    from assms have "a \<notin> passed" by auto
    with assms(2,3) show ?thesis
    by (auto simp: worklist_inv_def worklist_var_def finite_psupset_def)
  qed

  private lemma aux2:
    assumes
      "a' \<in> passed"
      "a \<preceq> a'"
      "a \<in># wait"
      "worklist_inv_frontier passed wait"
    shows "worklist_inv_frontier passed (wait - {#a#})"
    using assms unfolding worklist_inv_frontier_def
    using trans
    apply clarsimp
    by (metis (no_types, lifting) Un_iff count_eq_zero_iff count_single mset_contains_eq mset_un_cases)

  private lemma aux5:
    assumes
      "a' \<in> passed"
      "a \<preceq> a'"
      "a \<in># wait"
      "worklist_start_subsumed passed wait"
    shows "worklist_start_subsumed passed (wait - {#a#})"
    using assms unfolding worklist_start_subsumed_def apply clarsimp
    by (metis Un_iff insert_DiffM2 local.trans mset_right_cancel_elem)

  (* XXX Move to misc *)
  lemma mset_remove_member:
    "x \<in># A - B" if "x \<in># A" "x \<notin># B"
    using that
    by (metis count_greater_zero_iff in_diff_count not_in_iff)

  private lemma aux3:
    assumes
      "set_mset wait \<subseteq> Collect reachable"
      "a \<in># wait"
      "\<forall> s \<in> set_mset (wait - {#a#}) \<union> {a'. E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s'"
      "worklist_inv_frontier passed wait"
    shows "worklist_inv_frontier (insert a passed) wait'"
  proof -
    from assms(1,2) have "reachable a"
      by (simp add: subset_iff)
    with finitely_branching have [simp, intro!]: "finite (Collect (E a))" .

    show ?thesis unfolding worklist_inv_frontier_def
      apply safe
      subgoal
        using assms by auto
      subgoal for b b'
      proof -
        assume A: "E b b'" "\<not> empty b'" "b \<in> passed"
        with assms obtain b'' where b'': "b'' \<in> passed \<union> set_mset wait" "b' \<preceq> b''"
          unfolding worklist_inv_frontier_def by blast
        from this(1) show ?thesis
          apply standard
          subgoal
            using \<open>b' \<preceq> b''\<close> by auto
          subgoal
            apply (cases "a = b''")
            subgoal
              using b''(2) by blast
            subgoal premises prems
            proof -
              from prems have "b'' \<in># wait - {#a#}"
                by (auto simp: mset_remove_member)
              with assms prems \<open>b' \<preceq> b''\<close> show ?thesis
                by (blast intro: local.trans)
            qed
            done
          done
      qed
      done
  qed

  private lemma aux6:
    assumes
      "a \<in># wait"
      "worklist_start_subsumed passed wait"
      "\<forall> s \<in> set_mset (wait - {#a#}) \<union> {a'. E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s'"
    shows "worklist_start_subsumed (insert a passed) wait'"
    using assms unfolding worklist_start_subsumed_def
    apply clarsimp
    apply (erule disjE)
     apply blast
    subgoal premises prems for x
    proof (cases "a = x")
      case True
      with prems show ?thesis by simp
    next
      case False
      with \<open>x \<in># wait\<close> have "x \<in> set_mset (wait - {#a#})"
        by (metis insert_DiffM insert_noteq_member prems(1))
      with prems(2,4) \<open>_ \<preceq> x\<close> show ?thesis
        by (auto dest: trans)
    qed
  done

  lemma aux4:
    assumes "worklist_inv_frontier passed {#}" "reachable x" "worklist_start_subsumed passed {#}"
            "passed \<subseteq> Collect reachable"
    shows "\<exists> x' \<in> passed. x \<preceq> x'"
  proof -
    from \<open>reachable x\<close> have "E\<^sup>*\<^sup>* a\<^sub>0 x" by (simp add: reachable_def)
    from assms(3) obtain b where "a\<^sub>0 \<preceq> b" "b \<in> passed" unfolding worklist_start_subsumed_def by auto
    have "\<exists>x'. \<exists> x''. E\<^sup>*\<^sup>* b x' \<and> x \<preceq> x' \<and> x' \<preceq> x'' \<and> x'' \<in> passed" if
                     "E\<^sup>*\<^sup>* a x"  "a \<preceq> b"   "b \<preceq> b'"   "b' \<in> passed"
                     "reachable a" "reachable b" for a b b'
    using that proof (induction arbitrary: b b' rule: converse_rtranclp_induct)
      case base
      then show ?case by auto
    next
      case (step a a1 b b')
      show ?case
      proof (cases "empty a")
        case True
        with step.prems step.hyps have "empty x" by - (rule empty_E_star, auto)
        with step.prems show ?thesis by (auto intro: empty_subsumes)
      next
        case False
        with \<open>E a a1\<close> \<open>a \<preceq> b\<close> \<open>reachable a\<close> \<open>reachable b\<close> obtain b1 where
          "E b b1" "a1 \<preceq> b1"
          using mono by blast
        show ?thesis
        proof (cases "empty b1")
          case True
          with empty_mono \<open>a1 \<preceq> b1\<close> have "empty a1" by blast
          with step.prems step.hyps have "empty x" by - (rule empty_E_star, auto simp: reachable_def)
          with step.prems show ?thesis by (auto intro: empty_subsumes)
        next
          case False
          from \<open>E b b1\<close> \<open>a1 \<preceq> b1\<close> obtain b1' where "E b' b1'" "b1 \<preceq> b1'"
            using \<open>\<not> empty a\<close> empty_mono assms(4) mono step.prems by blast
          from empty_mono[OF \<open>\<not> empty b1\<close> \<open>b1 \<preceq> b1'\<close>] have "\<not> empty b1'"
            by auto
          with \<open>E b' b1'\<close> \<open>b' \<in> passed\<close> assms(1) obtain b1'' where "b1'' \<in> passed" "b1' \<preceq> b1''"
            unfolding worklist_inv_frontier_def by auto
          with \<open>b1 \<preceq> _\<close> have "b1 \<preceq> b1''" using trans by blast
          with step.IH[OF \<open>a1 \<preceq> b1\<close> this \<open>b1'' \<in> passed\<close>] \<open>reachable a\<close> \<open>E a a1\<close> \<open>reachable b\<close> \<open>E b b1\<close>
          obtain x' x'' where
            "E\<^sup>*\<^sup>* b1 x'" "x \<preceq> x'" "x' \<preceq> x''" "x'' \<in> passed"
            by (auto intro: reachable_step)
          moreover from \<open>E b b1\<close> \<open>E\<^sup>*\<^sup>* b1 x'\<close> have "E\<^sup>*\<^sup>* b x'" by auto
          ultimately show ?thesis by auto
        qed
      qed
    qed
    from this[OF \<open>E\<^sup>*\<^sup>* a\<^sub>0 x\<close> \<open>a\<^sub>0 \<preceq> b\<close> refl \<open>b \<in> _\<close>] assms(4) \<open>b \<in> passed\<close> show ?thesis
      by (auto intro: trans)
  qed

  theorem worklist_algo_correct:
    "worklist_algo \<le> SPEC (\<lambda> brk. brk \<longleftrightarrow> F_reachable)"
  proof -
    note [simp] = size_Diff_submset pred_not_lt_is_zero
    note [dest] = set_mset_mp
    show ?thesis
    unfolding worklist_algo_def add_succ_spec_def F_reachable_def
      apply (refine_vcg wf_worklist_var)
      (* F a\<^sub>0*)
      apply (auto; fail)
      (* Invar start*)
      apply (auto simp: worklist_inv_def worklist_inv_frontier_def worklist_start_subsumed_def; fail)
      (* Precondition for take-from-set *)
      apply (simp; fail)
      (* State is subsumed by passed*)
        (* Assertion *)
        apply (auto simp: worklist_inv_def; fail)
        (*Invariant*)
        apply (auto simp: worklist_inv_def aux2 aux5
              dest: in_diffD
              split: if_split_asm; fail)
        (*Variant*)
        apply (auto simp: worklist_inv_def worklist_var_def intro: finite_subset[OF _ finite_reachable]; fail)

      (* Insert successors to wait *)
        (*Invariant*)
        apply (clarsimp split: if_split_asm) (* Split on F in successors *)
          (* Found final state *)
          apply (clarsimp simp: worklist_inv_def; blast intro: reachable_step; fail)
          (* No final state *)
      apply (auto
        simp: worklist_inv_def aux3 aux6 finitely_branching
        dest: in_diffD)[]
       apply (metis Un_iff in_diffD insert_subset mem_Collect_eq mset_add set_mset_add_mset_insert)
    subgoal for ab aaa baa aba aca _ x
    proof -
      (* s/h alternative: *)
      (* by (metis (mono_tags, hide_lams) Un_iff in_diffD mem_Collect_eq reachable_step subsetCE *)
      assume
        "reachable aba"
        "set_mset aca \<subseteq> set_mset (aaa - {#aba#}) \<union> Collect (E aba)"
        "set_mset aaa \<subseteq> Collect reachable"
        "x \<in># aca"
      then show ?thesis
        by (auto intro: reachable_step dest: in_diffD)
    qed
        apply (auto simp: worklist_inv_def aux1; fail)
      (* I \<and> \<not> b \<longrightarrow> post *)
      using F_mono by (fastforce simp: worklist_inv_def dest!: aux4)
  qed

  lemmas [refine_vcg] = worklist_algo_correct[THEN order.trans]

  end \<comment> \<open>Context\<close>

end \<comment> \<open>Search Space\<close>

context Search_Space''_Defs
begin

  definition "worklist_inv_frontier' passed wait =
    (\<forall> a \<in> passed. \<forall> a'. E a a' \<and> \<not> empty a' \<longrightarrow> (\<exists> b' \<in> passed \<union> set_mset wait. a' \<preceq> b'))"

  definition "worklist_start_subsumed' passed wait = (\<exists> a \<in> passed \<union> set_mset wait. a\<^sub>0 \<preceq> a)"

  definition "worklist_inv' \<equiv> \<lambda> (passed, wait, brk).
    worklist_inv (passed, wait, brk) \<and> (\<forall> a \<in> passed. \<not> empty a) \<and> (\<forall> a \<in> set_mset wait. \<not> empty a)
      "

  definition "add_succ_spec' wait a \<equiv> SPEC (\<lambda>(wait',brk).
    (
    if \<exists>a'. E a a' \<and> F a' then
        brk
      else
        \<not>brk \<and> set_mset wait' \<subseteq> set_mset wait \<union> {a' . E a a'} \<and>
        (\<forall> s \<in> set_mset wait \<union> {a' . E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s')
    ) \<and> (\<forall> s \<in> set_mset wait'. \<not> empty s)
    )"

  definition worklist_algo' where
    "worklist_algo' = do
      {
        if F a\<^sub>0 then RETURN True
        else do {
          let passed = {};
          let wait = {#a\<^sub>0#};
          (passed, wait, brk) \<leftarrow> WHILEIT worklist_inv' (\<lambda> (passed, wait, brk). \<not> brk \<and> wait \<noteq> {#})
            (\<lambda> (passed, wait, brk). do
              {
                (a, wait) \<leftarrow> take_from_mset wait;
                ASSERT (reachable a);
                if (\<exists> a' \<in> passed. a \<unlhd> a') then RETURN (passed, wait, brk) else
                do
                  {
                    (wait,brk) \<leftarrow> add_succ_spec' wait a;
                    let passed = insert a passed;
                    RETURN (passed, wait, brk)
                  }
              }
            )
            (passed, wait, False);
            RETURN brk
        }
      }
    "

end \<comment> \<open>Search Space'' Defs\<close>

context Search_Space''_start
begin

  lemma worklist_algo_list_inv_ref[refine]:
    fixes x x'
    assumes
      "\<not> F a\<^sub>0" "\<not> F a\<^sub>0"
      "(x, x') \<in> {((passed,wait,brk), (passed',wait',brk')).
        passed = passed' \<and> wait = wait' \<and> brk = brk' \<and> (\<forall> a \<in> passed. \<not> empty a)
        \<and> (\<forall> a \<in> set_mset wait. \<not> empty a)}"
      "worklist_inv x'"
    shows "worklist_inv' x"
    using assms
    unfolding worklist_inv'_def worklist_inv_def
    by auto

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

  lemma [refine]:
    "add_succ_spec' wait x \<le>
    \<Down> ({(wait, wait'). wait = wait' \<and> (\<forall> a \<in> set_mset wait. \<not> empty a)} \<times>\<^sub>r bool_rel)
      (add_succ_spec wait' x')"
    if "wait = wait'" "x = x'" "\<forall> a \<in> set_mset wait. \<not> empty a"
    using that
    unfolding add_succ_spec'_def add_succ_spec_def
    by (auto simp: pw_le_iff refine_pw_simps)

  lemma worklist_algo'_ref[refine]: "worklist_algo' \<le> \<Down>Id worklist_algo"
    using [[goals_limit=15]]
      unfolding worklist_algo'_def worklist_algo_def
      apply (refine_rcg)
                 prefer 3
        apply assumption
                    apply refine_dref_type
        by (auto simp: empty_subsumes')

end \<comment> \<open>Search Space'' Start\<close>

context Search_Space''_Defs
begin

  definition worklist_algo'' where
    "worklist_algo'' \<equiv>
      if empty a\<^sub>0 then RETURN False else worklist_algo'
    "

end \<comment> \<open>Search Space'' Defs\<close>

context Search_Space''_finite_strict
begin

  lemma worklist_algo''_correct:
    "worklist_algo'' \<le> SPEC (\<lambda> brk. brk \<longleftrightarrow> F_reachable)"
  proof (cases "empty a\<^sub>0")
    case True
    then show ?thesis
      unfolding worklist_algo''_def F_reachable_def reachable_def
      using empty_E_star final_non_empty by auto
  next
    case False
    interpret Search_Space''_start
      by standard (rule \<open>\<not> empty _\<close>)
    note worklist_algo'_ref
    also note worklist_algo_correct
    finally show ?thesis
      using False unfolding worklist_algo''_def by simp
  qed

end \<comment> \<open>Search Space'' (strictly finite)\<close>

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


theory ZF_Tests
  imports ZF
begin

consts carrier :: "i \<Rightarrow> i"
consts add :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
consts Int_Add :: i
consts Nat_Add :: i

lemma [TC]: "x \<in> carrier(A) \<Longrightarrow> y \<in> carrier(A) \<Longrightarrow> add(A, x, y) \<in> carrier(A)"
  sorry

lemma [TC]: "x \<in> carrier(Nat_Add) \<Longrightarrow> x \<in> carrier(Int_Add)"
  sorry

schematic_goal
  "x \<in> carrier(Nat_Add) \<Longrightarrow> y \<in> carrier(Int_Add) \<Longrightarrow> add(?A, x, y) \<in> carrier(?A)"
  by typecheck (*greedy instantiation leads to unprovable goal; can be solved
  by re-stating carrier lemma with subtyping judgements*)
  oops

lemma "x \<in> carrier(Nat_Add) \<Longrightarrow> y \<in> carrier(Int_Add) \<Longrightarrow> add(Int_Add, x, y) \<in> carrier(Int_Add)"
  by typecheck

consts nat :: i
consts int :: i
consts pos_int :: i
consts succ :: "i \<Rightarrow> i"

lemma [TC]: "x \<in> nat \<Longrightarrow> x \<in> int"
  sorry

lemma [TC]: "x \<in> nat \<Longrightarrow> succ(x) \<in> nat"
  sorry

lemma "x \<in> nat \<Longrightarrow> succ(x) \<in> int"
  by typecheck

(*adding the following two instead will make the typechecker loop*)
(* lemma [TC]: "x \<in> pos_int \<Longrightarrow> x \<in> nat"
  sorry

lemma [TC]: "x \<in> nat \<Longrightarrow> x \<in> pos_int"
  sorry *)

lemma [TC]: "x \<in> int \<Longrightarrow> succ(x) \<in> int"
  sorry

lemma "x \<in> int \<Longrightarrow> succ(x) \<in> pos_int"
  by (typecheck | auto)+ (*no progress or unprovable goal*)

end


section \<open>Data: Maybe\<close>

theory Data_Maybe
  imports
    Type_Classes
    Data_Function
    Data_List
    Data_Bool
begin

domain 'a Maybe = Nothing | Just (lazy "'a")

abbreviation maybe :: "'b \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a Maybe \<rightarrow> 'b" where
  "maybe \<equiv> Maybe_case"

fixrec isJust :: "'a Maybe \<rightarrow> tr" where
  "isJust\<cdot>(Just\<cdot>a) = TT" |
  "isJust\<cdot>Nothing = FF"

fixrec isNothing :: "'a Maybe \<rightarrow> tr" where
  "isNothing = neg oo isJust"

fixrec fromJust :: "'a Maybe \<rightarrow> 'a" where
  "fromJust\<cdot>(Just\<cdot>a) = a" |
  "fromJust\<cdot>Nothing = \<bottom>"

fixrec fromMaybe :: "'a \<rightarrow> 'a Maybe \<rightarrow> 'a" where
  "fromMaybe\<cdot>d\<cdot>Nothing = d" |
  "fromMaybe\<cdot>d\<cdot>(Just\<cdot>a) = a"

fixrec maybeToList :: "'a Maybe \<rightarrow> ['a]" where
  "maybeToList\<cdot>Nothing = []" |
  "maybeToList\<cdot>(Just\<cdot>a) = [a]"

fixrec listToMaybe :: "['a] \<rightarrow> 'a Maybe" where
  "listToMaybe\<cdot>[] = Nothing" |
  "listToMaybe\<cdot>(a:_) = Just\<cdot>a"

(* FIXME: The Prelude definition uses list comps, which are too advanced for our syntax *)
fixrec catMaybes :: "['a Maybe] \<rightarrow> ['a]" where
  "catMaybes = concatMap\<cdot>maybeToList"

fixrec mapMaybe :: "('a \<rightarrow> 'b Maybe) \<rightarrow> ['a] \<rightarrow> ['b]" where
  "mapMaybe\<cdot>f = catMaybes oo map\<cdot>f"

instantiation Maybe :: (Eq) Eq_strict
begin

definition
  "eq = maybe\<cdot>(maybe\<cdot>TT\<cdot>(\<Lambda> y. FF))\<cdot>(\<Lambda> x. maybe\<cdot>FF\<cdot>(\<Lambda> y. eq\<cdot>x\<cdot>y))"

instance proof
  fix x :: "'a Maybe"
  show "eq\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding eq_Maybe_def by (cases x) simp_all
  show "eq\<cdot>\<bottom>\<cdot>x = \<bottom>"
    unfolding eq_Maybe_def by simp
qed

end

lemma eq_Maybe_simps [simp]:
  "eq\<cdot>Nothing\<cdot>Nothing = TT"
  "eq\<cdot>Nothing\<cdot>(Just\<cdot>y) = FF"
  "eq\<cdot>(Just\<cdot>x)\<cdot>Nothing = FF"
  "eq\<cdot>(Just\<cdot>x)\<cdot>(Just\<cdot>y) = eq\<cdot>x\<cdot>y"
  unfolding eq_Maybe_def by simp_all

instance Maybe :: (Eq_sym) Eq_sym
proof
  fix x y :: "'a Maybe"
  show "eq\<cdot>x\<cdot>y = eq\<cdot>y\<cdot>x"
    by (cases x, simp, cases y, simp, simp, simp,
        cases y, simp, simp, simp add: eq_sym)
qed

instance Maybe :: (Eq_equiv) Eq_equiv
proof
  fix x y z :: "'a Maybe"
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    by (cases x, simp_all)
  assume "eq\<cdot>x\<cdot>y = TT" and "eq\<cdot>y\<cdot>z = TT" then show "eq\<cdot>x\<cdot>z = TT"
    by (cases x, simp, cases y, simp, cases z, simp, simp, simp, simp,
        cases y, simp, simp, cases z, simp, simp, simp, fast elim: eq_trans)
qed

instance Maybe :: (Eq_eq) Eq_eq
proof
  fix x y :: "'a Maybe"
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    by (cases x, simp_all)
  assume "eq\<cdot>x\<cdot>y = TT" then show "x = y"
    by (cases x, simp, cases y, simp, simp, simp,
        cases y, simp, simp, simp, fast)
qed

instantiation Maybe :: (Ord) Ord_strict
begin

definition
  "compare = maybe\<cdot>(maybe\<cdot>EQ\<cdot>(\<Lambda> y. LT))\<cdot>(\<Lambda> x. maybe\<cdot>GT\<cdot>(\<Lambda> y. compare\<cdot>x\<cdot>y))"

instance proof
  fix x :: "'a Maybe"
  show "compare\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding compare_Maybe_def by (cases x) simp_all
  show "compare\<cdot>\<bottom>\<cdot>x = \<bottom>"
    unfolding compare_Maybe_def by simp
qed

end

lemma compare_Maybe_simps [simp]:
  "compare\<cdot>Nothing\<cdot>Nothing = EQ"
  "compare\<cdot>Nothing\<cdot>(Just\<cdot>y) = LT"
  "compare\<cdot>(Just\<cdot>x)\<cdot>Nothing = GT"
  "compare\<cdot>(Just\<cdot>x)\<cdot>(Just\<cdot>y) = compare\<cdot>x\<cdot>y"
  unfolding compare_Maybe_def by simp_all

instance Maybe :: (Ord_linear) Ord_linear
proof
  fix x y z :: "'a Maybe"
  show "eq\<cdot>x\<cdot>y = is_EQ\<cdot>(compare\<cdot>x\<cdot>y)"
    by (cases x, simp, cases y, simp, simp, simp,
        cases y, simp, simp, simp add: eq_conv_compare)
  show "oppOrdering\<cdot>(compare\<cdot>x\<cdot>y) = compare\<cdot>y\<cdot>x"
    by (cases x, simp, (cases y, simp, simp, simp)+)
  show "compare\<cdot>x\<cdot>x \<sqsubseteq> EQ"
    by (cases x) simp_all
  { assume "compare\<cdot>x\<cdot>y = EQ" then show "x = y"
      by (cases x, simp, cases y, simp, simp, simp,
          cases y, simp, simp, simp) (erule compare_EQ_dest) }
  { assume "compare\<cdot>x\<cdot>y = LT" and "compare\<cdot>y\<cdot>z = LT" then show "compare\<cdot>x\<cdot>z = LT"
      apply (cases x, simp)
       apply (cases y, simp, simp)
       apply (cases z, simp, simp, simp)
      apply (cases y, simp, simp)
      apply (cases z, simp, simp)
      apply (auto elim: compare_LT_trans)
      done }
qed

lemma isJust_strict [simp]: "isJust\<cdot>\<bottom>  = \<bottom>" by (fixrec_simp)
lemma fromMaybe_strict [simp]: "fromMaybe\<cdot>x\<cdot>\<bottom>  = \<bottom>" by (fixrec_simp)
lemma maybeToList_strict [simp]: "maybeToList\<cdot>\<bottom>  = \<bottom>" by (fixrec_simp)

end


(*  Title:      ZF/AC/WO6_WO1.thy
    Author:     Krzysztof Grabczewski

Proofs needed to state that formulations WO1,...,WO6 are all equivalent.
The only hard one is WO6 \<Longrightarrow> WO1.

Every proof (except WO6 \<Longrightarrow> WO1 and WO1 \<Longrightarrow> WO2) are described as "clear"
by Rubin & Rubin (page 2).
They refer reader to a book by Gödel to see the proof WO1 \<Longrightarrow> WO2.
Fortunately order types made this proof also very easy.
*)

theory WO6_WO1
imports Cardinal_aux
begin

(* Auxiliary definitions used in proof *)
definition
  NN  :: "i \<Rightarrow> i"  where
    "NN(y) \<equiv> {m \<in> nat. \<exists>a. \<exists>f. Ord(a) \<and> domain(f)=a  \<and>
                        (\<Union>b<a. f`b) = y \<and> (\<forall>b<a. f`b \<lesssim> m)}"

definition
  uu  :: "[i, i, i, i] \<Rightarrow> i"  where
    "uu(f, beta, gamma, delta) \<equiv> (f`beta * f`gamma) \<inter> f`delta"

(** Definitions for case 1 **)
definition
  vv1 :: "[i, i, i] \<Rightarrow> i"  where
     "vv1(f,m,b) \<equiv>
           let g = \<mu> g. (\<exists>d. Ord(d) \<and> (domain(uu(f,b,g,d)) \<noteq> 0 \<and>
                                 domain(uu(f,b,g,d)) \<lesssim> m));
               d = \<mu> d. domain(uu(f,b,g,d)) \<noteq> 0 \<and>
                            domain(uu(f,b,g,d)) \<lesssim> m
           in  if f`b \<noteq> 0 then domain(uu(f,b,g,d)) else 0"

definition
  ww1 :: "[i, i, i] \<Rightarrow> i"  where
     "ww1(f,m,b) \<equiv> f`b - vv1(f,m,b)"

definition
  gg1 :: "[i, i, i] \<Rightarrow> i"  where
     "gg1(f,a,m) \<equiv> \<lambda>b \<in> a++a. if b<a then vv1(f,m,b) else ww1(f,m,b--a)"

(** Definitions for case 2 **)
definition
  vv2 :: "[i, i, i, i] \<Rightarrow> i"  where
     "vv2(f,b,g,s) \<equiv>
           if f`g \<noteq> 0 then {uu(f, b, g, \<mu> d. uu(f,b,g,d) \<noteq> 0)`s} else 0"

definition
  ww2 :: "[i, i, i, i] \<Rightarrow> i"  where
     "ww2(f,b,g,s) \<equiv> f`g - vv2(f,b,g,s)"

definition
  gg2 :: "[i, i, i, i] \<Rightarrow> i"  where
     "gg2(f,a,b,s) \<equiv>
              \<lambda>g \<in> a++a. if g<a then vv2(f,b,g,s) else ww2(f,b,g--a,s)"

lemma WO2_WO3: "WO2 \<Longrightarrow> WO3"
by (unfold WO2_def WO3_def, fast)

(* ********************************************************************** *)

lemma WO3_WO1: "WO3 \<Longrightarrow> WO1"
  unfolding eqpoll_def WO1_def WO3_def
apply (intro allI)
apply (drule_tac x=A in spec)
apply (blast intro: bij_is_inj well_ord_rvimage
                    well_ord_Memrel [THEN well_ord_subset])
done

(* ********************************************************************** *)

lemma WO1_WO2: "WO1 \<Longrightarrow> WO2"
  unfolding eqpoll_def WO1_def WO2_def
apply (blast intro!: Ord_ordertype ordermap_bij)
done

(* ********************************************************************** *)

lemma lam_sets: "f \<in> A->B \<Longrightarrow> (\<lambda>x \<in> A. {f`x}): A -> {{b}. b \<in> B}"
by (fast intro!: lam_type apply_type)

lemma surj_imp_eq': "f \<in> surj(A,B) \<Longrightarrow> (\<Union>a \<in> A. {f`a}) = B"
  unfolding surj_def
apply (fast elim!: apply_type)
done

lemma surj_imp_eq: "\<lbrakk>f \<in> surj(A,B); Ord(A)\<rbrakk> \<Longrightarrow> (\<Union>a<A. {f`a}) = B"
by (fast dest!: surj_imp_eq' intro!: ltI elim!: ltE)

lemma WO1_WO4: "WO1 \<Longrightarrow> WO4(1)"
  unfolding WO1_def WO4_def
apply (rule allI)
apply (erule_tac x = A in allE)
apply (erule exE)
apply (intro exI conjI)
apply (erule Ord_ordertype)
apply (erule ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun, THEN lam_sets, THEN domain_of_fun])
apply (simp_all add: singleton_eqpoll_1 eqpoll_imp_lepoll Ord_ordertype
       ordermap_bij [THEN bij_converse_bij, THEN bij_is_surj, THEN surj_imp_eq]
       ltD)
done

(* ********************************************************************** *)

lemma WO4_mono: "\<lbrakk>m\<le>n; WO4(m)\<rbrakk> \<Longrightarrow> WO4(n)"
  unfolding WO4_def
apply (blast dest!: spec intro: lepoll_trans [OF _ le_imp_lepoll])
done

(* ********************************************************************** *)

lemma WO4_WO5: "\<lbrakk>m \<in> nat; 1\<le>m; WO4(m)\<rbrakk> \<Longrightarrow> WO5"
by (unfold WO4_def WO5_def, blast)

(* ********************************************************************** *)

lemma WO5_WO6: "WO5 \<Longrightarrow> WO6"
by (unfold WO4_def WO5_def WO6_def, blast)

(* **********************************************************************
    The proof of "WO6 \<Longrightarrow> WO1".  Simplified by L C Paulson.

    From the book "Equivalents of the Axiom of Choice" by Rubin & Rubin,
    pages 2-5
************************************************************************* *)

lemma lt_oadd_odiff_disj:
      "\<lbrakk>k < i++j;  Ord(i);  Ord(j)\<rbrakk>
       \<Longrightarrow> k < i  |  (\<not> k<i \<and> k = i ++ (k--i) \<and> (k--i)<j)"
apply (rule_tac i = k and j = i in Ord_linear2)
prefer 4
   apply (drule odiff_lt_mono2, assumption)
   apply (simp add: oadd_odiff_inverse odiff_oadd_inverse)
apply (auto elim!: lt_Ord)
done

(* ********************************************************************** *)
(* The most complicated part of the proof - lemma ii - p. 2-4             *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(* some properties of relation uu(beta, gamma, delta) - p. 2              *)
(* ********************************************************************** *)

lemma domain_uu_subset: "domain(uu(f,b,g,d)) \<subseteq> f`b"
by (unfold uu_def, blast)

lemma quant_domain_uu_lepoll_m:
     "\<forall>b<a. f`b \<lesssim> m \<Longrightarrow> \<forall>b<a. \<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<lesssim> m"
by (blast intro: domain_uu_subset [THEN subset_imp_lepoll] lepoll_trans)

lemma uu_subset1: "uu(f,b,g,d) \<subseteq> f`b * f`g"
by (unfold uu_def, blast)

lemma uu_subset2: "uu(f,b,g,d) \<subseteq> f`d"
by (unfold uu_def, blast)

lemma uu_lepoll_m: "\<lbrakk>\<forall>b<a. f`b \<lesssim> m;  d<a\<rbrakk> \<Longrightarrow> uu(f,b,g,d) \<lesssim> m"
by (blast intro: uu_subset2 [THEN subset_imp_lepoll] lepoll_trans)

(* ********************************************************************** *)
(* Two cases for lemma ii                                                 *)
(* ********************************************************************** *)
lemma cases:
     "\<forall>b<a. \<forall>g<a. \<forall>d<a. u(f,b,g,d) \<lesssim> m
      \<Longrightarrow> (\<forall>b<a. f`b \<noteq> 0 \<longrightarrow>
                  (\<exists>g<a. \<exists>d<a. u(f,b,g,d) \<noteq> 0 \<and> u(f,b,g,d) \<prec> m))
        | (\<exists>b<a. f`b \<noteq> 0 \<and> (\<forall>g<a. \<forall>d<a. u(f,b,g,d) \<noteq> 0 \<longrightarrow>
                                        u(f,b,g,d) \<approx> m))"
  unfolding lesspoll_def
apply (blast del: equalityI)
done

(* ********************************************************************** *)
(* Lemmas used in both cases                                              *)
(* ********************************************************************** *)
lemma UN_oadd: "Ord(a) \<Longrightarrow> (\<Union>b<a++a. C(b)) = (\<Union>b<a. C(b) \<union> C(a++b))"
by (blast intro: ltI lt_oadd1 oadd_lt_mono2 dest!: lt_oadd_disj)

(* ********************************************************************** *)
(* Case 1: lemmas                                                        *)
(* ********************************************************************** *)

lemma vv1_subset: "vv1(f,m,b) \<subseteq> f`b"
by (simp add: vv1_def Let_def domain_uu_subset)

(* ********************************************************************** *)
(* Case 1: Union of images is the whole "y"                              *)
(* ********************************************************************** *)
lemma UN_gg1_eq:
  "\<lbrakk>Ord(a);  m \<in> nat\<rbrakk> \<Longrightarrow> (\<Union>b<a++a. gg1(f,a,m)`b) = (\<Union>b<a. f`b)"
by (simp add: gg1_def UN_oadd lt_oadd1 oadd_le_self [THEN le_imp_not_lt]
              lt_Ord odiff_oadd_inverse ltD vv1_subset [THEN Diff_partition]
              ww1_def)

lemma domain_gg1: "domain(gg1(f,a,m)) = a++a"
by (simp add: lam_funtype [THEN domain_of_fun] gg1_def)

(* ********************************************************************** *)
(* every value of defined function is less than or equipollent to m       *)
(* ********************************************************************** *)
lemma nested_LeastI:
     "\<lbrakk>P(a, b);  Ord(a);  Ord(b);
         Least_a = (\<mu> a. \<exists>x. Ord(x) \<and> P(a, x))\<rbrakk>
      \<Longrightarrow> P(Least_a, \<mu> b. P(Least_a, b))"
apply (erule ssubst)
apply (rule_tac Q = "\<lambda>z. P (z, \<mu> b. P (z, b))" in LeastI2)
apply (fast elim!: LeastI)+
done

lemmas nested_Least_instance =
       nested_LeastI [of "\<lambda>g d. domain(uu(f,b,g,d)) \<noteq> 0 \<and>
                                domain(uu(f,b,g,d)) \<lesssim> m"] for f b m

lemma gg1_lepoll_m:
     "\<lbrakk>Ord(a);  m \<in> nat;
         \<forall>b<a. f`b \<noteq>0 \<longrightarrow>
             (\<exists>g<a. \<exists>d<a. domain(uu(f,b,g,d)) \<noteq> 0  \<and>
                          domain(uu(f,b,g,d)) \<lesssim> m);
         \<forall>b<a. f`b \<lesssim> succ(m);  b<a++a\<rbrakk>
      \<Longrightarrow> gg1(f,a,m)`b \<lesssim> m"
apply (simp add: gg1_def empty_lepollI)
apply (safe dest!: lt_oadd_odiff_disj)
(*Case b<a   \<in> show vv1(f,m,b) \<lesssim> m *)
 apply (simp add: vv1_def Let_def empty_lepollI)
 apply (fast intro: nested_Least_instance [THEN conjunct2]
             elim!: lt_Ord)
(*Case a\<le>b \<in> show ww1(f,m,b--a) \<lesssim> m *)
apply (simp add: ww1_def empty_lepollI)
apply (case_tac "f` (b--a) = 0", simp add: empty_lepollI)
apply (rule Diff_lepoll, blast)
apply (rule vv1_subset)
apply (drule ospec [THEN mp], assumption+)
apply (elim oexE conjE)
apply (simp add: vv1_def Let_def lt_Ord nested_Least_instance [THEN conjunct1])
done

(* ********************************************************************** *)
(* Case 2: lemmas                                                        *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(* Case 2: vv2_subset                                                    *)
(* ********************************************************************** *)

lemma ex_d_uu_not_empty:
     "\<lbrakk>b<a;  g<a;  f`b\<noteq>0;  f`g\<noteq>0;
         y*y \<subseteq> y;  (\<Union>b<a. f`b)=y\<rbrakk>
      \<Longrightarrow> \<exists>d<a. uu(f,b,g,d) \<noteq> 0"
by (unfold uu_def, blast)

lemma uu_not_empty:
     "\<lbrakk>b<a; g<a; f`b\<noteq>0; f`g\<noteq>0;  y*y \<subseteq> y; (\<Union>b<a. f`b)=y\<rbrakk>
      \<Longrightarrow> uu(f,b,g,\<mu> d. (uu(f,b,g,d) \<noteq> 0)) \<noteq> 0"
apply (drule ex_d_uu_not_empty, assumption+)
apply (fast elim!: LeastI lt_Ord)
done

lemma not_empty_rel_imp_domain: "\<lbrakk>r \<subseteq> A*B; r\<noteq>0\<rbrakk> \<Longrightarrow> domain(r)\<noteq>0"
by blast

lemma Least_uu_not_empty_lt_a:
     "\<lbrakk>b<a; g<a; f`b\<noteq>0; f`g\<noteq>0; y*y \<subseteq> y; (\<Union>b<a. f`b)=y\<rbrakk>
      \<Longrightarrow> (\<mu> d. uu(f,b,g,d) \<noteq> 0) < a"
apply (erule ex_d_uu_not_empty [THEN oexE], assumption+)
apply (blast intro: Least_le [THEN lt_trans1] lt_Ord)
done

lemma subset_Diff_sing: "\<lbrakk>B \<subseteq> A; a\<notin>B\<rbrakk> \<Longrightarrow> B \<subseteq> A-{a}"
by blast

(*Could this be proved more directly?*)
lemma supset_lepoll_imp_eq:
     "\<lbrakk>A \<lesssim> m; m \<lesssim> B; B \<subseteq> A; m \<in> nat\<rbrakk> \<Longrightarrow> A=B"
apply (erule natE)
apply (fast dest!: lepoll_0_is_0 intro!: equalityI)
apply (safe intro!: equalityI)
apply (rule ccontr)
apply (rule succ_lepoll_natE)
 apply (erule lepoll_trans)
 apply (rule lepoll_trans)
  apply (erule subset_Diff_sing [THEN subset_imp_lepoll], assumption)
 apply (rule Diff_sing_lepoll, assumption+)
done

lemma uu_Least_is_fun:
     "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f, b, g, d))\<noteq>0 \<longrightarrow>
          domain(uu(f, b, g, d)) \<approx> succ(m);
          \<forall>b<a. f`b \<lesssim> succ(m);  y*y \<subseteq> y;
          (\<Union>b<a. f`b)=y;  b<a;  g<a;  d<a;
          f`b\<noteq>0;  f`g\<noteq>0;  m \<in> nat;  s \<in> f`b\<rbrakk>
      \<Longrightarrow> uu(f, b, g, \<mu> d. uu(f,b,g,d)\<noteq>0) \<in> f`b -> f`g"
apply (drule_tac x2=g in ospec [THEN ospec, THEN mp])
   apply (rule_tac [3] not_empty_rel_imp_domain [OF uu_subset1 uu_not_empty])
        apply (rule_tac [2] Least_uu_not_empty_lt_a, assumption+)
apply (rule rel_is_fun)
    apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll])
   apply (erule uu_lepoll_m)
   apply (rule Least_uu_not_empty_lt_a, assumption+)
apply (rule uu_subset1)
apply (rule supset_lepoll_imp_eq [OF _ eqpoll_sym [THEN eqpoll_imp_lepoll]])
apply (fast intro!: domain_uu_subset)+
done

lemma vv2_subset:
     "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f, b, g, d))\<noteq>0 \<longrightarrow>
                       domain(uu(f, b, g, d)) \<approx> succ(m);
         \<forall>b<a. f`b \<lesssim> succ(m); y*y \<subseteq> y;
         (\<Union>b<a. f`b)=y;  b<a;  g<a;  m \<in> nat;  s \<in> f`b\<rbrakk>
      \<Longrightarrow> vv2(f,b,g,s) \<subseteq> f`g"
apply (simp add: vv2_def)
apply (blast intro: uu_Least_is_fun [THEN apply_type])
done

(* ********************************************************************** *)
(* Case 2: Union of images is the whole "y"                              *)
(* ********************************************************************** *)
lemma UN_gg2_eq:
     "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<noteq> 0 \<longrightarrow>
               domain(uu(f,b,g,d)) \<approx> succ(m);
         \<forall>b<a. f`b \<lesssim> succ(m); y*y \<subseteq> y;
         (\<Union>b<a. f`b)=y;  Ord(a);  m \<in> nat;  s \<in> f`b;  b<a\<rbrakk>
      \<Longrightarrow> (\<Union>g<a++a. gg2(f,a,b,s) ` g) = y"
  unfolding gg2_def
apply (drule sym)
apply (simp add: ltD UN_oadd  oadd_le_self [THEN le_imp_not_lt]
                 lt_Ord odiff_oadd_inverse ww2_def
                 vv2_subset [THEN Diff_partition])
done

lemma domain_gg2: "domain(gg2(f,a,b,s)) = a++a"
by (simp add: lam_funtype [THEN domain_of_fun] gg2_def)

(* ********************************************************************** *)
(* every value of defined function is less than or equipollent to m       *)
(* ********************************************************************** *)

lemma vv2_lepoll: "\<lbrakk>m \<in> nat; m\<noteq>0\<rbrakk> \<Longrightarrow> vv2(f,b,g,s) \<lesssim> m"
  unfolding vv2_def
apply (simp add: empty_lepollI)
apply (fast dest!: le_imp_subset [THEN subset_imp_lepoll, THEN lepoll_0_is_0]
       intro!: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
               not_lt_imp_le [THEN le_imp_subset, THEN subset_imp_lepoll]
               nat_into_Ord nat_1I)
done

lemma ww2_lepoll:
    "\<lbrakk>\<forall>b<a. f`b \<lesssim> succ(m);  g<a;  m \<in> nat;  vv2(f,b,g,d) \<subseteq> f`g\<rbrakk>
     \<Longrightarrow> ww2(f,b,g,d) \<lesssim> m"
  unfolding ww2_def
apply (case_tac "f`g = 0")
apply (simp add: empty_lepollI)
apply (drule ospec, assumption)
apply (rule Diff_lepoll, assumption+)
apply (simp add: vv2_def not_emptyI)
done

lemma gg2_lepoll_m:
     "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<noteq> 0 \<longrightarrow>
                      domain(uu(f,b,g,d)) \<approx> succ(m);
         \<forall>b<a. f`b \<lesssim> succ(m);  y*y \<subseteq> y;
         (\<Union>b<a. f`b)=y;  b<a;  s \<in> f`b;  m \<in> nat;  m\<noteq> 0;  g<a++a\<rbrakk>
      \<Longrightarrow> gg2(f,a,b,s) ` g \<lesssim> m"
apply (simp add: gg2_def empty_lepollI)
apply (safe elim!: lt_Ord2 dest!: lt_oadd_odiff_disj)
 apply (simp add: vv2_lepoll)
apply (simp add: ww2_lepoll vv2_subset)
done

(* ********************************************************************** *)
(* lemma ii                                                               *)
(* ********************************************************************** *)
lemma lemma_ii: "\<lbrakk>succ(m) \<in> NN(y); y*y \<subseteq> y; m \<in> nat; m\<noteq>0\<rbrakk> \<Longrightarrow> m \<in> NN(y)"
  unfolding NN_def
apply (elim CollectE exE conjE)
apply (rule quant_domain_uu_lepoll_m [THEN cases, THEN disjE], assumption)
(* case 1 *)
apply (simp add: lesspoll_succ_iff)
apply (rule_tac x = "a++a" in exI)
apply (fast intro!: Ord_oadd domain_gg1 UN_gg1_eq gg1_lepoll_m)
(* case 2 *)
apply (elim oexE conjE)
apply (rule_tac A = "f`B" for B in not_emptyE, assumption)
apply (rule CollectI)
apply (erule succ_natD)
apply (rule_tac x = "a++a" in exI)
apply (rule_tac x = "gg2 (f,a,b,x) " in exI)
apply (simp add: Ord_oadd domain_gg2 UN_gg2_eq gg2_lepoll_m)
done

(* ********************************************************************** *)
(* lemma iv - p. 4:                                                       *)
(* For every set x there is a set y such that   x \<union> (y * y) \<subseteq> y         *)
(* ********************************************************************** *)

(* The leading \<forall>-quantifier looks odd but makes the proofs shorter
   (used only in the following two lemmas)                          *)

lemma z_n_subset_z_succ_n:
     "\<forall>n \<in> nat. rec(n, x, \<lambda>k r. r \<union> r*r) \<subseteq> rec(succ(n), x, \<lambda>k r. r \<union> r*r)"
by (fast intro: rec_succ [THEN ssubst])

lemma le_subsets:
     "\<lbrakk>\<forall>n \<in> nat. f(n)<=f(succ(n)); n\<le>m; n \<in> nat; m \<in> nat\<rbrakk>
      \<Longrightarrow> f(n)<=f(m)"
apply (erule_tac P = "n\<le>m" in rev_mp)
apply (rule_tac P = "\<lambda>z. n\<le>z \<longrightarrow> f (n) \<subseteq> f (z) " in nat_induct)
apply (auto simp add: le_iff)
done

lemma le_imp_rec_subset:
     "\<lbrakk>n\<le>m; m \<in> nat\<rbrakk>
      \<Longrightarrow> rec(n, x, \<lambda>k r. r \<union> r*r) \<subseteq> rec(m, x, \<lambda>k r. r \<union> r*r)"
apply (rule z_n_subset_z_succ_n [THEN le_subsets])
apply (blast intro: lt_nat_in_nat)+
done

lemma lemma_iv: "\<exists>y. x \<union> y*y \<subseteq> y"
apply (rule_tac x = "\<Union>n \<in> nat. rec (n, x, \<lambda>k r. r \<union> r*r) " in exI)
apply safe
apply (rule nat_0I [THEN UN_I], simp)
apply (rule_tac a = "succ (n \<union> na) " in UN_I)
apply (erule Un_nat_type [THEN nat_succI], assumption)
apply (auto intro: le_imp_rec_subset [THEN subsetD]
            intro!: Un_upper1_le Un_upper2_le Un_nat_type
            elim!: nat_into_Ord)
done

(* ********************************************************************** *)
(* Rubin & Rubin wrote,                                                   *)
(* "It follows from (ii) and mathematical induction that if y*y \<subseteq> y then *)
(* y can be well-ordered"                                                 *)

(* In fact we have to prove                                               *)
(*      * WO6 \<Longrightarrow> NN(y) \<noteq> 0                                              *)
(*      * reverse induction which lets us infer that 1 \<in> NN(y)            *)
(*      * 1 \<in> NN(y) \<Longrightarrow> y can be well-ordered                             *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(*      WO6 \<Longrightarrow> NN(y) \<noteq> 0                                                *)
(* ********************************************************************** *)

lemma WO6_imp_NN_not_empty: "WO6 \<Longrightarrow> NN(y) \<noteq> 0"
by (unfold WO6_def NN_def, clarify, blast)

(* ********************************************************************** *)
(*      1 \<in> NN(y) \<Longrightarrow> y can be well-ordered                               *)
(* ********************************************************************** *)

lemma lemma1:
     "\<lbrakk>(\<Union>b<a. f`b)=y; x \<in> y; \<forall>b<a. f`b \<lesssim> 1; Ord(a)\<rbrakk> \<Longrightarrow> \<exists>c<a. f`c = {x}"
by (fast elim!: lepoll_1_is_sing)

lemma lemma2:
     "\<lbrakk>(\<Union>b<a. f`b)=y; x \<in> y; \<forall>b<a. f`b \<lesssim> 1; Ord(a)\<rbrakk>
      \<Longrightarrow> f` (\<mu> i. f`i = {x}) = {x}"
apply (drule lemma1, assumption+)
apply (fast elim!: lt_Ord intro: LeastI)
done

lemma NN_imp_ex_inj: "1 \<in> NN(y) \<Longrightarrow> \<exists>a f. Ord(a) \<and> f \<in> inj(y, a)"
  unfolding NN_def
apply (elim CollectE exE conjE)
apply (rule_tac x = a in exI)
apply (rule_tac x = "\<lambda>x \<in> y. \<mu> i. f`i = {x}" in exI)
apply (rule conjI, assumption)
apply (rule_tac d = "\<lambda>i. THE x. x \<in> f`i" in lam_injective)
apply (drule lemma1, assumption+)
apply (fast elim!: Least_le [THEN lt_trans1, THEN ltD] lt_Ord)
apply (rule lemma2 [THEN ssubst], assumption+, blast)
done

lemma y_well_ord: "\<lbrakk>y*y \<subseteq> y; 1 \<in> NN(y)\<rbrakk> \<Longrightarrow> \<exists>r. well_ord(y, r)"
apply (drule NN_imp_ex_inj)
apply (fast elim!: well_ord_rvimage [OF _ well_ord_Memrel])
done

(* ********************************************************************** *)
(*      reverse induction which lets us infer that 1 \<in> NN(y)              *)
(* ********************************************************************** *)

lemma rev_induct_lemma [rule_format]:
     "\<lbrakk>n \<in> nat; \<And>m. \<lbrakk>m \<in> nat; m\<noteq>0; P(succ(m))\<rbrakk> \<Longrightarrow> P(m)\<rbrakk>
      \<Longrightarrow> n\<noteq>0 \<longrightarrow> P(n) \<longrightarrow> P(1)"
by (erule nat_induct, blast+)

lemma rev_induct:
     "\<lbrakk>n \<in> nat;  P(n);  n\<noteq>0;
         \<And>m. \<lbrakk>m \<in> nat; m\<noteq>0; P(succ(m))\<rbrakk> \<Longrightarrow> P(m)\<rbrakk>
      \<Longrightarrow> P(1)"
by (rule rev_induct_lemma, blast+)

lemma NN_into_nat: "n \<in> NN(y) \<Longrightarrow> n \<in> nat"
by (simp add: NN_def)

lemma lemma3: "\<lbrakk>n \<in> NN(y); y*y \<subseteq> y; n\<noteq>0\<rbrakk> \<Longrightarrow> 1 \<in> NN(y)"
apply (rule rev_induct [OF NN_into_nat], assumption+)
apply (rule lemma_ii, assumption+)
done

(* ********************************************************************** *)
(* Main theorem "WO6 \<Longrightarrow> WO1"                                             *)
(* ********************************************************************** *)

(* another helpful lemma *)
lemma NN_y_0: "0 \<in> NN(y) \<Longrightarrow> y=0"
  unfolding NN_def
apply (fast intro!: equalityI dest!: lepoll_0_is_0 elim: subst)
done

lemma WO6_imp_WO1: "WO6 \<Longrightarrow> WO1"
  unfolding WO1_def
apply (rule allI)
apply (case_tac "A=0")
apply (fast intro!: well_ord_Memrel nat_0I [THEN nat_into_Ord])
apply (rule_tac x = A in lemma_iv [elim_format])
apply (erule exE)
apply (drule WO6_imp_NN_not_empty)
apply (erule Un_subset_iff [THEN iffD1, THEN conjE])
apply (erule_tac A = "NN (y) " in not_emptyE)
apply (frule y_well_ord)
 apply (fast intro!: lemma3 dest!: NN_y_0 elim!: not_emptyE)
apply (fast elim: well_ord_subset)
done

end


(*  Title:      HOL/UNITY/Simple/NSP_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Original file is ../Auth/NS_Public_Bad
*)

section\<open>Analyzing the Needham-Schroeder Public-Key Protocol in UNITY\<close>

theory NSP_Bad imports "../../Auth/Public" "../UNITY_Main" begin

text\<open>This is the flawed version, vulnerable to Lowe's attack.
From page 260 of
  Burrows, Abadi and Needham.  A Logic of Authentication.
  Proc. Royal Soc. 426 (1989).
\<close>

type_synonym state = "event list"

  (*The spy MAY say anything he CAN say.  We do not expect him to
    invent new nonces here, but he can also use NS1.  Common to
    all similar protocols.*)
definition
  Fake :: "(state*state) set"
  where "Fake = {(s,s').
              \<exists>B X. s' = Says Spy B X # s
                    & X \<in> synth (analz (spies s))}"

  (*The numeric suffixes on A identify the rule*)

  (*Alice initiates a protocol run, sending a nonce to Bob*)
definition
  NS1 :: "(state*state) set"
  where "NS1 = {(s1,s').
             \<exists>A1 B NA.
                 s' = Says A1 B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A1\<rbrace>) # s1
               & Nonce NA \<notin> used s1}"

  (*Bob responds to Alice's message with a further nonce*)
definition
  NS2 :: "(state*state) set"
  where "NS2 = {(s2,s').
             \<exists>A' A2 B NA NB.
                 s' = Says B A2 (Crypt (pubK A2) \<lbrace>Nonce NA, Nonce NB\<rbrace>) # s2
               & Says A' B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A2\<rbrace>) \<in> set s2
               & Nonce NB \<notin> used s2}"

  (*Alice proves her existence by sending NB back to Bob.*)
definition
  NS3 :: "(state*state) set"
  where "NS3 = {(s3,s').
             \<exists>A3 B' B NA NB.
                 s' = Says A3 B (Crypt (pubK B) (Nonce NB)) # s3
               & Says A3  B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A3\<rbrace>) \<in> set s3
               & Says B' A3 (Crypt (pubK A3) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s3}"

definition Nprg :: "state program" where
    (*Initial trace is empty*)
    "Nprg = mk_total_program({[]}, {Fake, NS1, NS2, NS3}, UNIV)"

declare spies_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>For other theories, e.g. Mutex and Lift, using [iff] slows proofs down.
  Here, it facilitates re-use of the Auth proofs.\<close>

declare Fake_def [THEN def_act_simp, iff]
declare NS1_def [THEN def_act_simp, iff]
declare NS2_def [THEN def_act_simp, iff]
declare NS3_def [THEN def_act_simp, iff]

declare Nprg_def [THEN def_prg_Init, simp]

text\<open>A "possibility property": there are traces that reach the end.
  Replace by LEADSTO proof!\<close>
lemma "A \<noteq> B ==>
       \<exists>NB. \<exists>s \<in> reachable Nprg. Says A B (Crypt (pubK B) (Nonce NB)) \<in> set s"
apply (intro exI bexI)
apply (rule_tac [2] act = "totalize_act NS3" in reachable.Acts)
apply (rule_tac [3] act = "totalize_act NS2" in reachable.Acts)
apply (rule_tac [4] act = "totalize_act NS1" in reachable.Acts)
apply (rule_tac [5] reachable.Init)
apply (simp_all (no_asm_simp) add: Nprg_def totalize_act_def)
apply auto
done

subsection\<open>Inductive Proofs about @{term ns_public}\<close>

lemma ns_constrainsI:
     "(!!act s s'. [| act \<in> {Id, Fake, NS1, NS2, NS3};
                      (s,s') \<in> act;  s \<in> A |] ==> s' \<in> A')
      ==> Nprg \<in> A co A'"
apply (simp add: Nprg_def mk_total_program_def)
apply (rule constrainsI, auto)
done

text\<open>This ML code does the inductions directly.\<close>
ML\<open>
fun ns_constrains_tac ctxt i =
  SELECT_GOAL
    (EVERY
     [REPEAT (eresolve_tac ctxt @{thms Always_ConstrainsI} 1),
      REPEAT (resolve_tac ctxt [@{thm StableI}, @{thm stableI}, @{thm constrains_imp_Constrains}] 1),
      resolve_tac ctxt @{thms ns_constrainsI} 1,
      full_simp_tac ctxt 1,
      REPEAT (FIRSTGOAL (eresolve_tac ctxt [disjE])),
      ALLGOALS (clarify_tac (ctxt delrules [impI, @{thm impCE}])),
      REPEAT (FIRSTGOAL (analz_mono_contra_tac ctxt)),
      ALLGOALS (asm_simp_tac ctxt)]) i;

(*Tactic for proving secrecy theorems*)
fun ns_induct_tac ctxt =
  (SELECT_GOAL o EVERY)
     [resolve_tac ctxt @{thms AlwaysI} 1,
      force_tac ctxt 1,
      (*"reachable" gets in here*)
      resolve_tac ctxt [@{thm Always_reachable} RS @{thm Always_ConstrainsI} RS @{thm StableI}] 1,
      ns_constrains_tac ctxt 1];
\<close>

method_setup ns_induct = \<open>
    Scan.succeed (SIMPLE_METHOD' o ns_induct_tac)\<close>
    "for inductive reasoning about the Needham-Schroeder protocol"

text\<open>Converts invariants into statements about reachable states\<close>
lemmas Always_Collect_reachableD =
     Always_includes_reachable [THEN subsetD, THEN CollectD]

text\<open>Spy never sees another agent's private key! (unless it's bad at start)\<close>
lemma Spy_see_priK:
     "Nprg \<in> Always {s. (Key (priK A) \<in> parts (spies s)) = (A \<in> bad)}"
apply ns_induct
apply blast
done
declare Spy_see_priK [THEN Always_Collect_reachableD, simp]

lemma Spy_analz_priK:
     "Nprg \<in> Always {s. (Key (priK A) \<in> analz (spies s)) = (A \<in> bad)}"
by (rule Always_reachable [THEN Always_weaken], auto)
declare Spy_analz_priK [THEN Always_Collect_reachableD, simp]

subsection\<open>Authenticity properties obtained from NS2\<close>

text\<open>It is impossible to re-use a nonce in both NS1 and NS2 provided the
     nonce is secret.  (Honest users generate fresh nonces.)\<close>
lemma no_nonce_NS1_NS2:
 "Nprg
  \<in> Always {s. Crypt (pubK C) \<lbrace>NA', Nonce NA\<rbrace> \<in> parts (spies s) -->
                Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (spies s) -->
                Nonce NA \<in> analz (spies s)}"
apply ns_induct
apply (blast intro: analz_insertI)+
done

text\<open>Adding it to the claset slows down proofs...\<close>
lemmas no_nonce_NS1_NS2_reachable =
       no_nonce_NS1_NS2 [THEN Always_Collect_reachableD, rule_format]

text\<open>Unicity for NS1: nonce NA identifies agents A and B\<close>
lemma unique_NA_lemma:
     "Nprg
  \<in> Always {s. Nonce NA \<notin> analz (spies s) -->
                Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts(spies s) -->
                Crypt(pubK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(spies s) -->
                A=A' & B=B'}"
apply ns_induct
apply auto
txt\<open>Fake, NS1 are non-trivial\<close>
done

text\<open>Unicity for NS1: nonce NA identifies agents A and B\<close>
lemma unique_NA:
     "[| Crypt(pubK B)  \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts(spies s);
         Crypt(pubK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(spies s);
         Nonce NA \<notin> analz (spies s);
         s \<in> reachable Nprg |]
      ==> A=A' & B=B'"
by (blast dest: unique_NA_lemma [THEN Always_Collect_reachableD])

text\<open>Secrecy: Spy does not see the nonce sent in msg NS1 if A and B are secure\<close>
lemma Spy_not_see_NA:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says A B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s
                  --> Nonce NA \<notin> analz (spies s)}"
apply ns_induct
txt\<open>NS3\<close>
prefer 4 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt\<open>NS2\<close>
prefer 3 apply (blast dest: unique_NA)
txt\<open>NS1\<close>
prefer 2 apply blast
txt\<open>Fake\<close>
apply spy_analz
done

text\<open>Authentication for A: if she receives message 2 and has used NA
  to start a run, then B has sent message 2.\<close>
lemma A_trusts_NS2:
 "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says A B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s &
                  Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts (knows Spy s)
         --> Says B A (Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s}"
  (*insert an invariant for use in some of the subgoals*)
apply (insert Spy_not_see_NA [of A B NA], simp, ns_induct)
apply (auto dest: unique_NA)
done

text\<open>If the encrypted message appears then it originated with Alice in NS1\<close>
lemma B_trusts_NS1:
     "Nprg \<in> Always
              {s. Nonce NA \<notin> analz (spies s) -->
                  Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (spies s)
         --> Says A B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s}"
apply ns_induct
apply blast
done

subsection\<open>Authenticity properties obtained from NS2\<close>

text\<open>Unicity for NS2: nonce NB identifies nonce NA and agent A.
   Proof closely follows that of \<open>unique_NA\<close>.\<close>
lemma unique_NB_lemma:
 "Nprg
  \<in> Always {s. Nonce NB \<notin> analz (spies s)  -->
                Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts (spies s) -->
                Crypt(pubK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(spies s) -->
                A=A' & NA=NA'}"
apply ns_induct
apply auto
txt\<open>Fake, NS2 are non-trivial\<close>
done

lemma unique_NB:
     "[| Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts(spies s);
         Crypt(pubK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(spies s);
         Nonce NB \<notin> analz (spies s);
         s \<in> reachable Nprg |]
      ==> A=A' & NA=NA'"
apply (blast dest: unique_NB_lemma [THEN Always_Collect_reachableD])
done

text\<open>NB remains secret PROVIDED Alice never responds with round 3\<close>
lemma Spy_not_see_NB:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s &
                  (ALL C. Says A C (Crypt (pubK C) (Nonce NB)) \<notin> set s)
                  --> Nonce NB \<notin> analz (spies s)}"
apply ns_induct
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>NS3: because NB determines A\<close>
prefer 4 apply (blast dest: unique_NB)
txt\<open>NS2: by freshness and unicity of NB\<close>
prefer 3 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt\<open>NS1: by freshness\<close>
prefer 2 apply blast
txt\<open>Fake\<close>
apply spy_analz
done

text\<open>Authentication for B: if he receives message 3 and has used NB
  in message 2, then A has sent message 3--to somebody....\<close>
lemma B_trusts_NS3:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Crypt (pubK B) (Nonce NB) \<in> parts (spies s) &
                  Says B A  (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s
                  --> (\<exists>C. Says A C (Crypt (pubK C) (Nonce NB)) \<in> set s)}"
  (*insert an invariant for use in some of the subgoals*)
apply (insert Spy_not_see_NB [of A B NA NB], simp, ns_induct)
apply (simp_all (no_asm_simp) add: ex_disj_distrib)
apply auto
txt\<open>NS3: because NB determines A. This use of \<open>unique_NB\<close> is robust.\<close>
apply (blast intro: unique_NB [THEN conjunct1])
done

text\<open>Can we strengthen the secrecy theorem?  NO\<close>
lemma "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s
                  --> Nonce NB \<notin> analz (spies s)}"
apply ns_induct
apply auto
txt\<open>Fake\<close>
apply spy_analz
txt\<open>NS2: by freshness and unicity of NB\<close>
 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt\<open>NS3: unicity of NB identifies A and NA, but not B\<close>
apply (frule_tac A'=A in Says_imp_spies [THEN parts.Inj, THEN unique_NB])
apply (erule Says_imp_spies [THEN parts.Inj], auto)
apply (rename_tac s B' C)
txt\<open>This is the attack!
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

(*
THIS IS THE ATTACK!
[| A \<notin> bad; B \<notin> bad |]
==> Nprg
   \<in> Always
       {s. Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s -->
           Nonce NB \<notin> analz (knows Spy s)}
 1. !!s B' C.
       [| A \<notin> bad; B \<notin> bad; s \<in> reachable Nprg
          Says A C (Crypt (pubK C) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s;
          Says B' A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s;
          C \<in> bad; Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s;
          Nonce NB \<notin> analz (knows Spy s) |]
       ==> False
*)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2008         |
            |                   June 2008  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_semantics
imports CSP_T_semantics Domain_F_cms
begin

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

         1. semantic clause
         2.
         3.
         4.

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

(*********************************************************
                    semantic clause
 *********************************************************)

primrec
  failures :: "('p,'a) proc =>  ('p => 'a domF) => 'a setF"
where
  "failures(STOP)    = (%M. {f. EX X. f = (<>, X) }f)"

 |"failures(SKIP)    = (%M. {f. (EX X. f = (<>, X) & X <= Evset) |
                                (EX X. f = (<Tick>, X)) }f)"
 |"failures(DIV)     = (%M. {}f)"

 |"failures(a -> P)  = (%M. {f. (EX X.   f = (<>,X) & Ev a ~: X) |
                         (EX s X. f = (<Ev a> ^^^ s, X) & (s,X) :f failures(P) M ) }f)"

 |"failures(? :X -> Pf) = (%M. {f. (EX Y.     f = (<>,Y) & Ev`X Int Y = {}) |
                         (EX a s Y. f = (<Ev a> ^^^ s, Y) &
                                   (s,Y) :f failures(Pf a) M & a : X) }f)"

 |"failures(P [+] Q) = (%M. {f.
       (EX   X. f = (<>,X) & f :f failures(P) M IntF failures(Q) M) |
       (EX s X. f = (s,X)  & f :f failures(P) M UnF  failures(Q) M & s ~= <>) |
       (EX   X. f = (<>,X) & <Tick> :t traces(P) (fstF o M) UnT
                                       traces(Q) (fstF o M) & X <= Evset) }f)"

 |"failures(P |~| Q) = (%M. failures(P) M UnF failures(Q) M)"

 |"failures(!! :C .. Pf) = (%M. {f. EX c: sumset C. f :f failures(Pf c) M}f)"

 |"failures(IF b THEN P ELSE Q) = (%M. if b then failures(P) M else failures(Q) M)"

 |"failures(P |[X]| Q)  = (%M. {f.
      EX u Y Z. f = (u, Y Un Z) & Y-((Ev`X) Un {Tick})= Z-((Ev`X) Un {Tick}) &
     (EX s t. u : s |[X]|tr t & (s,Y) :f failures(P) M & (t,Z) :f failures(Q) M) }f)"

 |"failures(P -- X)  = (%M. {f.
      EX s Y. f = (s --tr X, Y) & (s,(Ev`X) Un Y) :f failures(P) M}f)"

 |"failures(P [[r]]) = (%M. {f.
      EX s t X. f = (t,X) & s [[r]]* t & (s, [[r]]inv X) :f failures(P) M }f)"

 |"failures(P ;; Q) = (%M. {f.
     (EX t X. f = (t,X) & (t, X Un {Tick}) :f failures(P) M & noTick t) |
     (EX s t X. f = (s ^^^ t,X) & s ^^^ <Tick> :t traces(P) (fstF o M) &
                                    (t, X) :f failures(Q) M & noTick s) }f)"

 |"failures(P |. n) = (%M. failures(P) M .|. n)"

 |"failures($p)     = (%M. sndF (M p))"

declare failures.simps [simp del]

(*** for dealing with both !nat and !set ***)

lemma failures_inv_inj[simp]:
   "inj g ==> (EX c. (EX n. c = g n & n : N) & f :f failures (Pf (inv g c)) x)
            = (EX z:N. f :f failures (Pf z) x)"
by (auto)

lemma Rep_int_choice_failures_nat:
  "failures(!nat :N .. Pf) = (%M. {f. EX n:N. f :f failures(Pf n) M}f)"
apply (simp add: Rep_int_choice_ss_def)
apply (simp add: failures.simps)
done

lemma Rep_int_choice_failures_set:
  "failures(!set :Xs .. Pf) = (%M. {f. EX X:Xs. f :f failures(Pf X) M}f)"
apply (simp add: Rep_int_choice_ss_def)
apply (simp add: failures.simps)
done

lemma Rep_int_choice_failures_com_lm:
   "(EX z. (EX a. z = {a} & a : X) & f :f failures (Pf (the_elem z)) M)
  = (EX a:X. f :f failures (Pf a) M)"
apply (auto)
apply (rule_tac x="{a}" in exI)
apply (auto)
done

lemma Rep_int_choice_failures_com:
  "failures(! :X .. Pf) = (%M. {f. EX a:X. f :f failures(Pf a) M}f)"
apply (simp add: Rep_int_choice_com_def)
apply (simp add: Rep_int_choice_failures_set)
apply (simp add: Rep_int_choice_failures_com_lm)
done

lemma Rep_int_choice_failures_f:
  "inj g ==> failures(!<g> :X .. Pf) =
             (%M. {f. EX a:X. f :f failures(Pf a) M}f)"
apply (simp add: Rep_int_choice_f_def)
apply (simp add: Rep_int_choice_failures_com)
done

lemmas Rep_int_choice_failures =
       Rep_int_choice_failures_nat
       Rep_int_choice_failures_set
       Rep_int_choice_failures_com
       Rep_int_choice_failures_f

(*
lemmas failures_def = failures.simps Rep_int_choice_failures
*)
lemmas failures_iff = failures.simps Rep_int_choice_failures

(*********************************************************
                     semantics
 *********************************************************)

definition
  semFf   :: "('p,'a) proc => ('p => 'a domF) => 'a domF" ("[[_]]Ff")
  where
  semFf_def  : "[[P]]Ff == (%M. (traces(P) (fstF o M) ,, failures(P) M))"

definition
  semFfun :: "('p => ('p,'a) proc) => ('p => 'a domF) => ('p => 'a domF)"
                                                         ("[[_]]Ffun")
  where
  semFfun_def: "[[Pf]]Ffun == (%M. %p. [[Pf p]]Ff M)"

(*
notation (xsymbols) semFf   ("\<lbrakk>_\<rbrakk>Ff")
notation (xsymbols) semFfun ("\<lbrakk>_\<rbrakk>Ffun")
*)

(*** relation ***)

lemma semFf_semFfun:
  "(%p. [[Pf p]]Ff M) = [[Pf]]Ffun M"
by (simp add: semFfun_def semFf_def)

(*------------------------------------------------------------------*
        M such that [[p]]Ff M = [[PNfun(p)]]Ff M
   such M is the fixed point of the function [[PNfun(p)]]Ffun
 *------------------------------------------------------------------*)

definition
  semFfix  :: "('p => ('p,'a) proc) => ('p => 'a domF)"      ("[[_]]Ffix")
  where
  semFfix_def :
   "[[Pf]]Ffix == (if (FPmode = CMSmode) then (UFP ([[Pf]]Ffun))
                                         else (LFP ([[Pf]]Ffun)))"

(*
notation (xsymbols) semFfix ("\<lbrakk>_\<rbrakk>Ffix")
*)

definition
 MF :: "('p => 'a domF)"
 where
 MF_def : "MF == [[PNfun]]Ffix"

(*** semantics ***)

definition
  semF  :: "('p,'a) proc => 'a domF"      ("[[_]]F")
  where
  semF_def : "[[P]]F == [[P]]Ff MF"
(*
notation (xsymbols) semF ("\<lbrakk>_\<rbrakk>F")
*)

(*********************************************************
              relations over processes
 *********************************************************)

definition
  refF :: "('p,'a) proc => ('p => 'a domF) =>
           ('q => 'a domF) => ('q,'a) proc => bool"
                               ("(0_ /<=F[_,_] /_)" [51,0,0,50] 50)
  where
  refF_def : "P1 <=F[M1,M2] P2 == [[P2]]Ff M2 <= [[P1]]Ff M1"

definition
  eqF :: "('p,'a) proc => ('p => 'a domF) =>
           ('q => 'a domF) => ('q,'a) proc => bool"
                               ("(0_ /=F[_,_] /_)"[51,0,0,50] 50)
  where
  eqF_def  : "P1  =F[M1,M2] P2 == [[P1]]Ff M1  = [[P2]]Ff M2"

(*------------------------------------*
 |              X-Symbols             |
 *------------------------------------*)

(*
notation (xsymbols) refF ("(0_ /\<sqsubseteq>F[_,_] /_)" [51,100,100,50] 50)
*)

(*********************************************************
        relations over processes (fixed point)
 *********************************************************)

abbreviation
 refFfix :: "('p,'a) proc => ('q,'a) proc => bool" ("(0_ /<=F /_)" [51,50] 50)
 where "P1 <=F P2 == P1 <=F[MF,MF] P2"

abbreviation
 eqFfix :: "('p,'a) proc => ('q,'a) proc => bool"  ("(0_ /=F /_)" [51,50] 50)
 where "P1  =F P2 == P1  =F[MF,MF] P2"

(* =F and <=F *)

lemma refF_semF: "(P1 <=F P2) = ([[P2]]F <= [[P1]]F)"
apply (simp add: refF_def)
apply (simp add: semF_def)
done

lemma eqF_semF: "(P1 =F P2) = ([[P1]]F = [[P2]]F)"
apply (simp add: eqF_def)
apply (simp add: semF_def)
done

(*------------------------------------*
 |              X-Symbols             |
 *------------------------------------*)
(*
notation (xsymbols) refFfix ("(0_ /\<sqsubseteq>F /_)" [51,50] 50)
*)

(*------------------*
 |      csp law     |
 *------------------*)

(*** eq and ref ***)

lemma cspF_eq_ref_iff:
 "(P1 =F[M1,M2] P2) = (P1 <=F[M1,M2] P2 & P2 <=F[M2,M1] P1)"
by (auto simp add: refF_def eqF_def)

lemma cspF_eq_ref:
  "P1 =F[M1,M2] P2 ==> P1 <=F[M1,M2] P2"
by (simp add: cspF_eq_ref_iff)

lemma cspF_ref_eq:
  "[| P1 <=F[M1,M2] P2 ; P2 <=F[M2,M1] P1 |] ==> P1 =F[M1,M2] P2"
by (simp add: cspF_eq_ref_iff)

(*** reflexivity ***)

lemma cspF_reflex_eq_P[simp]: "P =F[M,M] P"
by (simp add: eqF_def)

lemma cspF_reflex_eq_STOP[simp]: "STOP =F[M1,M2] STOP"
by (simp add: eqF_def semFf_def traces_iff failures_iff)

lemma cspF_reflex_eq_SKIP[simp]: "SKIP =F[M1,M2] SKIP"
by (simp add: eqF_def semFf_def traces_iff failures_iff)

lemma cspF_reflex_eq_DIV[simp]: "DIV =F[M1,M2] DIV"
by (simp add: eqF_def semFf_def traces_iff failures_iff)

lemmas cspF_reflex_eq = cspF_reflex_eq_P
                        cspF_reflex_eq_STOP
                        cspF_reflex_eq_SKIP
                        cspF_reflex_eq_DIV

lemma cspF_reflex_ref_P[simp]: "P <=F[M,M] P"
by (simp add: refF_def)

lemma cspF_reflex_ref_STOP[simp]: "STOP <=F[M1,M2] STOP"
by (simp add: refF_def semFf_def traces_iff failures_iff)

lemma cspF_reflex_ref_SKIP[simp]: "SKIP <=F[M1,M2] SKIP"
by (simp add: refF_def semFf_def traces_iff failures_iff)

lemma cspF_reflex_ref_DIV[simp]: "DIV <=F[M1,M2] DIV"
by (simp add: refF_def semFf_def traces_iff failures_iff)

lemmas cspF_reflex_ref = cspF_reflex_ref_P
                         cspF_reflex_ref_STOP
                         cspF_reflex_ref_SKIP
                         cspF_reflex_ref_DIV

lemmas cspF_reflex = cspF_reflex_eq cspF_reflex_ref

(*** symmetry ***)

lemma cspF_sym: "P1 =F[M1,M2] P2 ==> P2 =F[M2,M1] P1"
by (simp add: eqF_def)

lemma cspF_symE:
  "[| P1 =F[M1,M2] P2 ; P2 =F[M2,M1] P1 ==> Z |] ==> Z"
by (simp add: eqF_def)

(*** transitivity ***)

lemma cspF_trans_left_eq:
  "[| P1 =F[M1,M2] P2 ; P2 =F[M2,M3] P3 |] ==> P1 =F[M1,M3] P3"
by (simp add: eqF_def)

lemma cspF_trans_left_ref:
  "[| P1 <=F[M1,M2] P2 ; P2 <=F[M2,M3] P3 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def)

lemmas cspF_trans_left = cspF_trans_left_eq cspF_trans_left_ref
lemmas cspF_trans = cspF_trans_left

lemma cspF_trans_right_eq:
  "[| P2 =F[M2,M3] P3 ; P1 =F[M1,M2] P2 |] ==> P1 =F[M1,M3] P3"
by (simp add: eqF_def)

lemma cspF_trans_right_ref:
  "[| P2 <=F[M2,M3] P3 ;  P1 <=F[M1,M2] P2 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def)

lemmas cspF_trans_rught = cspF_trans_right_eq cspF_trans_right_ref

(*** rewrite (eq) ***)

lemma cspF_rw_left_eq_MF:
  "[| P1 =F P2 ; P2 =F P3 |] ==> P1 =F P3"
by (simp add: eqF_def)

lemma cspF_rw_left_eq:
  "[| P1 =F[M1,M1] P2 ; P2 =F[M1,M3] P3 |] ==> P1 =F[M1,M3] P3"
by (simp add: eqF_def)

lemma cspF_rw_left_ref_MF:
  "[| P1 =F P2 ; P2 <=F P3 |] ==> P1 <=F P3"
by (simp add: refF_def eqF_def)

lemma cspF_rw_left_ref:
  "[| P1 =F[M1,M1] P2 ; P2 <=F[M1,M3] P3 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def eqF_def)

lemmas cspF_rw_left =
   cspF_rw_left_eq_MF cspF_rw_left_ref_MF
   cspF_rw_left_eq cspF_rw_left_ref

lemma cspF_rw_right_eq:
  "[| P3 =F[M3,M3] P2 ; P1 =F[M1,M3] P2 |] ==> P1 =F[M1,M3] P3"
by (simp add: eqF_def)

lemma cspF_rw_right_eq_MF:
  "[| P3 =F P2 ; P1 =F P2 |] ==> P1 =F P3"
by (simp add: eqF_def)

lemma cspF_rw_right_ref:
  "[| P3 =F[M3,M3] P2 ; P1 <=F[M1,M3] P2 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def eqF_def)

lemma cspF_rw_right_ref_MF:
  "[| P3 =F P2 ; P1 <=F P2 |] ==> P1 <=F P3"
by (simp add: refF_def eqF_def)

lemmas cspF_rw_right =
   cspF_rw_right_eq_MF cspF_rw_right_ref_MF
   cspF_rw_right_eq cspF_rw_right_ref

(*** rewrite (ref) ***)

lemma cspF_tr_left_eq:
   "[| P1 =F[M1,M1] P2 ; P2 =F[M1,M3] P3 |] ==> P1 =F[M1,M3] P3"
by (simp add: eqF_def)

lemma cspF_tr_left_ref:
   "[| P1 <=F[M1,M1] P2 ; P2 <=F[M1,M3] P3 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def eqF_def)

lemmas cspF_tr_left = cspF_tr_left_eq cspF_tr_left_ref

lemma cspF_tr_right_eq:
   "[| P2 =F[M3,M3] P3 ; P1 =F[M1,M3] P2 |] ==> P1 =F[M1,M3] P3"
by (simp add: eqF_def)

lemma cspF_tr_right_ref:
  "[| P2 <=F[M3,M3] P3 ; P1 <=F[M1,M3] P2 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def eqF_def)

lemmas cspF_tr_right = cspF_tr_right_eq cspF_tr_right_ref

(*----------------------------------------*
 |   rewriting processes in assumptions   |
 *----------------------------------------*)

(*** rewrite (eq) ***)

lemma cspF_rw_left_eqE_MF:
  "[| P1 =F P3 ; P1 =F P2 ; [| P2 =F P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 =F P3")
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemma cspF_rw_left_eqE:
  "[| P1 =F[M1,M3] P3 ; P1 =F[M1,M1] P2 ;
      [| P2 =F[M1,M3] P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 =F[M1,M3] P3")
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemma cspF_rw_left_refE_MF:
  "[| P1 <=F P3 ; P1 =F P2 ; [| P2 <=F P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 <=F P3")
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemma cspF_rw_left_refE:
  "[| P1 <=F[M1,M3] P3 ; P1 =F[M1,M1] P2 ;
      [| P2 <=F[M1,M3] P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 <=F[M1,M3] P3")
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemmas cspF_rw_leftE =
   cspF_rw_left_eqE_MF cspF_rw_left_refE_MF
   cspF_rw_left_eqE    cspF_rw_left_refE

(* right *)

lemma cspF_rw_right_eqE_MF:
  "[| P1 =F P3 ; P3 =F P2 ; [| P1 =F P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 =F P2")
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemma cspF_rw_right_eqE:
  "[| P1 =F[M1,M3] P3 ; P3 =F[M3,M3] P2 ;
      [| P1 =F[M1,M3] P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 =F[M1,M3] P2")
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemma cspF_rw_right_refE_MF:
  "[| P1 <=F P3 ; P3 =F P2 ; [| P1 <=F P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 <=F P2")
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemma cspF_rw_right_refE:
  "[| P1 <=F[M1,M3] P3 ; P3 =F[M3,M3] P2 ;
      [| P1 <=F[M1,M3] P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 <=F[M1,M3] P2")
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_sym)
apply (simp)
apply (simp)
done

lemmas cspF_rw_rightE =
   cspF_rw_right_eqE_MF cspF_rw_right_refE_MF
   cspF_rw_right_eqE    cspF_rw_right_refE

(*-----------------------------------------*
 |                   noPN                  |
 *-----------------------------------------*)

lemma failures_noPN_Constant_lm_EC:
  "[| ALL P:range Pf. (EX F. failures P = (%M. F)) |]
       ==> (EX F2. failures (? :X -> Pf) = (%M. F2))"
apply (auto simp add: failures_iff)
apply (simp add: choice_ALL_EX)
apply (erule exE)
apply (auto)
done

lemma failures_noPN_Constant_lm_RIC:
  "[| ALL P:range Pf. (EX F. failures P = (%M. F)) |]
       ==> (EX F2. failures (!! :X .. Pf) = (%M. F2))"
apply (auto simp add: failures_iff)
apply (simp add: choice_ALL_EX)
apply (erule exE)
apply (auto)
done

lemma failures_noPN_Constant_lm:
  "noPN P --> (EX F. failures P = (%M. F))"
apply (induct_tac P)
apply (simp add: failures_iff, force)
apply (simp add: failures_iff, force)
apply (simp add: failures_iff, force)
apply (simp add: failures_iff, force)

(* Ext_pre_choice *)
 apply (intro impI)
 apply (simp add: failures_noPN_Constant_lm_EC)

(* Ext_choice *)
 apply (intro impI)
 apply (simp add: failures_iff)
 apply (elim exE)
 apply (simp add: failures_iff)
 apply (subgoal_tac "ALL P. noPN P --> (EX T. traces P = (%M. T))")
 apply (frule_tac x="x1" in spec)
 apply (drule_tac x="x2" in spec)
 apply (simp)
 apply (elim exE)
 apply (simp)
 apply (force)
 apply (simp add: traces_noPN_Constant)

apply (simp add: failures_iff, force)

(* Rep_int_choice_nat *)
 apply (intro impI)
 apply (simp add: failures_noPN_Constant_lm_RIC)

(* IF *)
 apply (simp add: failures_iff)
 apply (case_tac "x1")
 apply (simp)
 apply (simp)

apply (simp add: failures_iff, force)
apply (simp add: failures_iff, force)
apply (simp add: failures_iff, force)

(* Seq_comp *)
 apply (intro impI)
 apply (simp)
 apply (elim exE)
 apply (simp add: failures_iff)
 apply (subgoal_tac "ALL P. noPN P --> (EX T. traces P = (%M. T))")
 apply (drule_tac x="x1" in spec)
 apply (simp)
 apply (elim exE)
 apply (simp)
 apply (force)
 apply (simp add: traces_noPN_Constant)

apply (simp add: failures_iff, force)
apply (simp add: failures_iff)
done

lemma failures_noPN_Constant:
  "noPN P ==> (EX F. failures P = (%M. F))"
apply (simp add: failures_noPN_Constant_lm)
done

end


theory Diff_Arr
  imports Diff_Arr_Rel Master_Assn
begin

(* TODO: Use Locale instead of context *)
context
begin

type_synonym 'a diff_arr = "'a cell ref"

qualified definition from_array ::
  "('a::heap) array \<Rightarrow> 'a diff_arr Heap"
where
  "from_array a = do {
    ref (Array a)
  }"

qualified definition from_list ::
  "('a::heap) list \<Rightarrow> 'a diff_arr Heap"
where
  "from_list xs = do {
    a \<leftarrow> Array.of_list xs;
    from_array a
  }"

qualified partial_function (heap) lookup ::
  "('a::heap) diff_arr \<Rightarrow> nat \<Rightarrow> 'a Heap"
where
  "lookup diff_arr i = do {
      cell \<leftarrow> !diff_arr;
      case cell of
        Array array            \<Rightarrow>
          Array.nth array i
      | Upd i' value diff_arr' \<Rightarrow>
          if i = i'
          then return value
          else lookup diff_arr' i
  }"
declare lookup.simps[code]

(* TODO: use array_copy? *)
qualified partial_function (heap) realize ::
  "('a::heap) diff_arr \<Rightarrow> 'a array Heap"
where
  "realize diff_arr = do {
    cell \<leftarrow> !diff_arr;
     case cell of
        Array arr \<Rightarrow> do {
            len \<leftarrow> Array.len arr;
            xs  \<leftarrow> Array.freeze arr;
            Array.make len (List.nth xs)
        }
      | Upd i v diff_arr \<Rightarrow> do {
          arr \<leftarrow> realize diff_arr;
          Array.upd i v arr
        }
  }"
declare realize.simps[code]

abbreviation update_if_none where
  "update_if_none m i v \<equiv> (case m i of None \<Rightarrow> m(i \<mapsto> v) | Some _ \<Rightarrow> m)"

(* Tailrec version, ask Peter if this makes sense *)
qualified partial_function (heap) realize_tailrec ::
  "(nat \<rightharpoonup> 'a) \<Rightarrow> ('a::heap) diff_arr \<Rightarrow> 'a array Heap"
where
  "realize_tailrec upds diff_arr = do {
    cell \<leftarrow> !diff_arr;
     case cell of
        Array arr \<Rightarrow> do {
            len \<leftarrow> Array.len arr;
            xs  \<leftarrow> Array.freeze arr;
            Array.make len (\<lambda>i. case upds i of None \<Rightarrow> List.nth xs i | Some v \<Rightarrow> v)
        }
      | Upd i v diff_arr \<Rightarrow> realize_tailrec (update_if_none upds i v) diff_arr
  }"
declare realize_tailrec.simps[code]

qualified partial_function (heap) update' ::
    "('a cell ref \<Rightarrow> 'a array Heap) \<Rightarrow>('a::heap) diff_arr \<Rightarrow> nat \<Rightarrow> 'a::heap \<Rightarrow> 'a diff_arr Heap"
where
  "update' realize_impl diff_arr i v = do {
      cell \<leftarrow> !diff_arr;
      case cell of
        Array arr \<Rightarrow> do {
          new_diff_arr \<leftarrow> ref (Array arr);
          old_v \<leftarrow> Array.nth arr i;
          diff_arr :=\<^sub>R Upd i old_v new_diff_arr;
          Array.upd i v arr;
          return new_diff_arr
        }
      | Upd _ _ _ \<Rightarrow> do {
          arr \<leftarrow> realize_impl diff_arr;
          Array.upd i v arr;
          ref (Array arr)
        }
  }"
declare update'.simps[code]

abbreviation update where "update \<equiv> update' realize"

abbreviation update_tailrec where "update_tailrec \<equiv> update' (realize_tailrec Map.empty)"

qualified partial_function (heap) length ::
  "('a::heap) diff_arr \<Rightarrow> nat Heap"
where
  "length diff_arr = do {
      cell \<leftarrow> !diff_arr;
      case cell of
        Array array   \<Rightarrow> Array.len array
      | Upd _ _ diff_arr \<Rightarrow> length diff_arr
  }"
declare length.simps[code]

lemma ref_lookup_upd: "\<lbrakk>t \<turnstile> xs \<sim>\<^sub>n a; 0 < n\<rbrakk> \<Longrightarrow>
  <master_assn t> !a <\<lambda>c. master_assn t * \<up>(\<exists>i v diff_arr. c = Upd i v diff_arr)>"
proof(induction n)
  case 0
  then show ?case
    by sep_auto
next
  case (Suc n)
  from Suc(2) show ?case
    apply sep_auto
    apply(sep_drule r: open_master_assn)
    apply sep_auto
    apply(sep_drule r: close_master_assn_upd)
    by sep_auto
qed

(* TODO: Is it okay to have both from_array'/from_list' and from_array/from_list
         in sep_heap_rules? *)
lemma from_array' [sep_heap_rules]:
  "<a \<mapsto>\<^sub>a xs>
      from_array a
   <\<lambda>r. let t = [(r, Array' xs)]
        in master_assn t * \<up>(t \<turnstile> xs \<sim> r)>"
  unfolding Diff_Arr.from_array_def diff_arr_rel_def master_assn_def
  apply auto
  by(sep_auto simp: exI[where x = "0"])

lemma from_list' [sep_heap_rules]:
  "<emp>
    from_list xs
   <\<lambda>r. let t = [(r, Array' xs)]
        in  master_assn t * \<up>(t \<turnstile> xs \<sim> r)>"
  unfolding Diff_Arr.from_list_def
  by sep_auto

lemma from_array [sep_heap_rules]:
  "<a \<mapsto>\<^sub>a xs> from_array a <\<lambda>r. \<exists>\<^sub>At. master_assn t * \<up>(t \<turnstile> xs \<sim> r)>"
  by(sep_auto simp: Let_def)

lemma from_list [sep_heap_rules]:
  "<emp> from_list xs <\<lambda>r. \<exists>\<^sub>At. master_assn t * \<up>(t \<turnstile> xs \<sim> r)>"
  by(sep_auto simp: Let_def)

lemma lookup_aux:
  "<\<up>(t \<turnstile> xs \<sim>\<^sub>n a \<and> i < List.length xs) * master_assn t>
      lookup a i
   <\<lambda>r. master_assn t * \<up>(r = xs!i)>"
proof(induction n arbitrary: xs a)
  case 0
  then show ?case
    apply sep_auto
    apply(subst lookup.simps)
    apply(sep_drule r: open_master_assn)
    by(sep_auto simp: close_master_assn_array)
next
  case (Suc n)
  then show ?case
    apply(sep_auto)
    apply(subst lookup.simps)
    apply(sep_drule r: open_master_assn)
    by(sep_auto simp: close_master_assn_upd')
qed

lemma lookup [sep_heap_rules]:
  "<master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr \<and> i < List.length xs)>
     lookup diff_arr i
   <\<lambda>r. master_assn t * \<up>(r = xs!i)>"
  unfolding diff_arr_rel_def
  using lookup_aux[of t]
  by sep_auto

lemma realize_aux:
 "<master_assn t * \<up>(t \<turnstile> xs \<sim>\<^sub>n diff_arr)>
     realize diff_arr
  <\<lambda>arr. master_assn t * arr \<mapsto>\<^sub>a xs>"
proof(induction n arbitrary: diff_arr xs)
  case 0
  then show ?case
    apply sep_auto
    apply(subst realize.simps)
    apply(sep_drule r: open_master_assn)
    apply(sep_auto simp: map_nth)
    apply(sep_drule r: close_master_assn_array)
    by sep_auto
next
  case (Suc n)
  then show ?case
    apply sep_auto
    apply(subst realize.simps)
    apply(sep_drule r: open_master_assn)
    apply sep_auto
    apply(sep_drule r: close_master_assn_upd)
    by sep_auto+
qed

lemma realize [sep_heap_rules]:
  "<master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr)>
     realize diff_arr
   <\<lambda>arr. master_assn t * arr \<mapsto>\<^sub>a xs>"
  unfolding diff_arr_rel_def
  using realize_aux[of t]
  by sep_auto

lemma realize_tailrec_aux:
 "<master_assn t * \<up>(t \<turnstile> xs \<sim>\<^sub>n diff_arr)>
     realize_tailrec upds diff_arr
  <\<lambda>arr. master_assn t * arr \<mapsto>\<^sub>a
        (map (\<lambda>i. case upds i of None \<Rightarrow> xs ! i | Some v \<Rightarrow> v) [0..<List.length xs])>"
proof(induction n arbitrary: t diff_arr xs upds)
  case 0
  then show ?case
    apply sep_auto
    apply(subst realize_tailrec.simps)
    apply(sep_drule r: open_master_assn)
    apply sep_auto
    apply(sep_drule r: close_master_assn_array)
    by(sep_auto simp: map_nth)
next
  case (Suc n)

  have [simp]: "\<And>i i' xs' upds x. i < List.length xs' \<Longrightarrow>
  (case (case upds i of None \<Rightarrow> upds(i \<mapsto> x) | Some x \<Rightarrow> upds) i' of
     None \<Rightarrow> xs' ! i'
   | Some v \<Rightarrow> v) =
  (case upds i' of None \<Rightarrow> xs'[i := x] ! i' | Some v \<Rightarrow> v)"
  by(auto simp: nth_list_update split: option.splits)

  from Suc show ?case
    apply sep_auto
    apply(subst realize_tailrec.simps)
    apply(sep_drule r: open_master_assn)
    apply sep_auto
    apply(sep_drule r: close_master_assn_upd)
    apply sep_auto+
    subgoal for i x a' xs'
      using Suc[of t xs' a' "update_if_none upds i x "]
      by sep_auto
    done
qed

lemma realize_tailrec [sep_heap_rules]:
  "<master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr)>
     realize_tailrec Map.empty diff_arr
   <\<lambda>arr. master_assn t * arr \<mapsto>\<^sub>a xs>"
  unfolding diff_arr_rel_def
  using realize_tailrec_aux[of t xs _ diff_arr Map.empty]
  by(sep_auto simp: map_nth)

lemma update_diff_arr_rel: "\<lbrakk>
  i < List.length xs;
  (diff_arr, Array' xs) \<in>\<^sub>L t;
  distinct (map fst t);
  t \<turnstile> xs' \<sim>\<^sub>n' diff_arr'
\<rbrakk> \<Longrightarrow> \<exists>n. (new_diff_arr, Array' (xs[i := v])) #
          (diff_arr, Upd' i (xs ! i) new_diff_arr) #
          remove1 (diff_arr, Array' xs) t \<turnstile> xs' \<sim>\<^sub>n diff_arr'"
proof(induction t xs' n' diff_arr' arbitrary: xs' diff_arr' rule: diff_arr_rel'.induct)
  case (1 t xs' diff_arr')
  then show ?case
  proof(cases "diff_arr' = diff_arr")
    case True
    with 1 have "xs' = xs"
      using distinct_map_fstD[of t]
      by auto

    with True 1 show ?thesis
      apply -
      apply(rule exI[where x = 1])
      apply(sep_auto)
      apply(rule exI[where x = i])
      apply(rule exI[where x = "xs ! i"])
      apply(rule exI[where x = new_diff_arr])
      by sep_auto
  next
    case False
    with 1 show ?thesis
      by(sep_auto simp: exI[where x = 0])
  qed
next
  case (2 t xs' n' diff_arr')

  then obtain i' v' diff_arr'' xs'' where unfold_diff_arr_rel:
      "(diff_arr', Upd' i' v' diff_arr'') \<in>\<^sub>L t"
      "t \<turnstile> xs'' \<sim>\<^sub>n' diff_arr''"
      "i' < List.length xs''"
      "xs' = xs''[i' := v']"
    by sep_auto

  with 2 obtain n'' where
     "(new_diff_arr, Array' (xs[i := v])) #
      (diff_arr, Upd' i (xs ! i) new_diff_arr) #
      remove1 (diff_arr, Array' xs) t \<turnstile> xs'' \<sim>\<^sub>n'' diff_arr''"
    by blast

  with unfold_diff_arr_rel show ?case
    apply -
    apply(rule exI[where x = "Suc n''"])
    by auto
qed

lemma update':
  assumes
    "i < List.length xs"
    "t \<turnstile> xs \<sim>\<^sub>n diff_arr"
    "\<And>t xs diff_arr. <master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr)>
       realize_impl diff_arr
     <\<lambda>arr. master_assn t * arr \<mapsto>\<^sub>a xs>"
  shows
    "<master_assn t>
       update' realize_impl diff_arr i v
     <\<lambda>diff_arr. \<exists>\<^sub>At'. master_assn t' *
       \<up>((\<forall>xs' diff_arr'. t \<turnstile> xs' \<sim> diff_arr' \<longrightarrow> t' \<turnstile> xs' \<sim> diff_arr') \<and>
         (t' \<turnstile> xs[i := v] \<sim> diff_arr))>"
proof(cases "n = 0")
  case True
  with assms show ?thesis
    unfolding diff_arr_rel_def
    apply(simp add: update'.simps)
    apply(hoare_triple_preI rule: master_assn_distinct)
    apply(sep_drule r: open_master_assn)
    apply(sep_auto eintros del: exI)
    subgoal for new_arr new_diff_arr
      apply(rule exI[where x =
         "(new_diff_arr, Array' (xs[i := v])) #
          (diff_arr, Upd' i (xs ! i) new_diff_arr) #
          (remove1 (diff_arr, Array' xs) t)"
            ])
      by(sep_auto simp: update_diff_arr_rel open_master_assn_cons exI[where x = 0])
    done
next
  case False
  with assms show ?thesis
    unfolding diff_arr_rel_def
    apply(subst update'.simps)
    apply(sep_auto heap: ref_lookup_upd eintros del: exI)
    subgoal for _ new_diff_arr
      apply(rule exI[where x = "(new_diff_arr, Array' (xs[i := v])) # t"])
      by(sep_auto simp: diff_arr_rel'_cons' exI[where x = 0] open_master_assn_cons[of new_diff_arr])
    done
qed

lemma update [sep_heap_rules]:
  "<master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr \<and> i < List.length xs)>
     update diff_arr i v
   <\<lambda>diff_arr. \<exists>\<^sub>At'. master_assn t' *
    \<up>((\<forall>xs' diff_arr'. t \<turnstile> xs' \<sim> diff_arr' \<longrightarrow> t' \<turnstile> xs' \<sim> diff_arr') \<and>
      (t' \<turnstile> xs[i := v] \<sim> diff_arr))>"
  using realize
  by(sep_auto heap: update' simp: diff_arr_rel_def)

lemma update_tailrec [sep_heap_rules]:
  "<master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr \<and> i < List.length xs)>
     update_tailrec diff_arr i v
   <\<lambda>diff_arr. \<exists>\<^sub>At'. master_assn t' *
    \<up>((\<forall>xs' diff_arr'. t \<turnstile> xs' \<sim> diff_arr' \<longrightarrow> t' \<turnstile> xs' \<sim> diff_arr') \<and>
      (t' \<turnstile> xs[i := v] \<sim> diff_arr))>"
  using realize_tailrec
  by(sep_auto heap: update' simp: diff_arr_rel_def)

lemma length_aux: "t \<turnstile> xs \<sim>\<^sub>n diff_arr \<Longrightarrow>
  <master_assn t>
    length diff_arr
  <\<lambda>len. master_assn t * \<up>(len = List.length xs)>"
proof(induction t xs n diff_arr rule: diff_arr_rel'.induct)
  case 1
  then show ?case
    apply sep_auto
    apply(subst length.simps)
    apply(sep_drule r: open_master_assn)
    by(sep_auto simp: close_master_assn_array)
next
  case 2
  then show ?case
    apply sep_auto
    apply(subst length.simps)
    apply(sep_drule r: open_master_assn)
    by(sep_auto simp: close_master_assn_upd')
qed

lemma length [sep_heap_rules]:
  "<master_assn t * \<up>(t \<turnstile> xs \<sim> diff_arr)>
     length diff_arr
   <\<lambda>len. master_assn t * \<up>(len = List.length xs)>"
  unfolding diff_arr_rel_def
  by(sep_auto heap: length_aux)

end

end