header {* \isaheader{Generic Algorithms for Sequences} *}
theory ListGA
imports "../spec/ListSpec"
begin

subsection {* Iterators *}

subsubsection {* iteratei (by get, size) *}

locale idx_iteratei_loc =
  list_size + list_get +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
  assumes [simp]: "\<And>s. invar s"
begin

  fun idx_iteratei_aux
    :: "nat \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('a \<Rightarrow>'\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
  where
    "idx_iteratei_aux sz i l c f \<sigma> = (
      if i=0 \<or> \<not> c \<sigma> then \<sigma>
      else idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)
    )"

  declare idx_iteratei_aux.simps[simp del]

  lemma idx_iteratei_aux_simps[simp]:
    "i=0 \<Longrightarrow> idx_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<not>c \<sigma> \<Longrightarrow> idx_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<lbrakk>i\<noteq>0; c \<sigma>\<rbrakk> \<Longrightarrow> idx_iteratei_aux sz i l c f \<sigma> = idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)"
    apply -
    apply (subst idx_iteratei_aux.simps, simp)+
    done

  definition idx_iteratei where
    "idx_iteratei l c f \<sigma> \<equiv> idx_iteratei_aux (size l) (size l) l c f \<sigma>"

  lemma idx_iteratei_correct:
    shows "idx_iteratei s = foldli (\<alpha> s)"
  proof -
    {
      fix n l
      assume A: "Suc n \<le> length l"
      hence B: "length l - Suc n < length l" by simp
      from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
      from Cons_nth_drop_Suc[OF B, simplified] have
        "drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l"
        by simp
    } note drop_aux=this

    {
      fix s c f \<sigma> i
      assume "invar s" "i\<le>size s"
      hence "idx_iteratei_aux (size s) i s c f \<sigma>
        = foldli (drop (size s - i) (\<alpha> s)) c f \<sigma>"
      proof (induct i arbitrary: \<sigma>)
        case 0 with size_correct[of s] show ?case by simp
      next
        case (Suc n)
        note [simp, intro!] = Suc.prems(1)
        show ?case proof (cases "c \<sigma>")
          case False thus ?thesis by simp
        next
          case True[simp, intro!]
          show ?thesis using Suc by (simp add: get_correct size_correct drop_aux)
        qed
      qed
    } note aux=this

    show ?thesis
      unfolding idx_iteratei_def[abs_def]
      by (auto simp add: fun_eq_iff aux[of _ "size s", simplified])
  qed

  lemmas idx_iteratei_unfold[code_unfold] = idx_iteratei_correct[symmetric]

  subsubsection {* reverse\_iteratei (by get, size) *}

  fun idx_reverse_iteratei_aux
    :: "nat \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('a \<Rightarrow>'\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where
    "idx_reverse_iteratei_aux sz i l c f \<sigma> = (
      if i=0 \<or> \<not> c \<sigma> then \<sigma>
      else idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) \<sigma>)
    )"

  declare idx_reverse_iteratei_aux.simps[simp del]

  lemma idx_reverse_iteratei_aux_simps[simp]:
    "i=0 \<Longrightarrow> idx_reverse_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<not>c \<sigma> \<Longrightarrow> idx_reverse_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<lbrakk>i\<noteq>0; c \<sigma>\<rbrakk> \<Longrightarrow> idx_reverse_iteratei_aux sz i l c f \<sigma>
    = idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) \<sigma>)"
    by (subst idx_reverse_iteratei_aux.simps, simp)+

  definition "idx_reverse_iteratei l c f \<sigma>
    == idx_reverse_iteratei_aux (size l) (size l) l c f \<sigma>"

  lemma idx_reverse_iteratei_correct:
    shows "idx_reverse_iteratei s = foldri (\<alpha> s)"
  proof -
    {
      fix s c f \<sigma> i
      assume "invar s" "i\<le>size s"
      hence "idx_reverse_iteratei_aux (size s) i s c f \<sigma>
        = foldri (take i (\<alpha> s)) c f \<sigma>"
      proof (induct i arbitrary: \<sigma>)
        case 0 with size_correct[of s] show ?case by simp
      next
        case (Suc n)
        note [simp, intro!] = Suc.prems(1)
        show ?case proof (cases "c \<sigma>")
          case False thus ?thesis by simp
        next
          case True[simp, intro!]
          show ?thesis using Suc
            by (simp add: get_correct size_correct take_Suc_conv_app_nth)
        qed
      qed
    } note aux=this

    show ?thesis
      unfolding idx_reverse_iteratei_def[abs_def]
      apply (simp add: fun_eq_iff aux[of _ "size s", simplified])
      apply (simp add: size_correct)
    done
  qed

  lemmas idx_reverse_iteratei_unfold[code_unfold]
    = idx_reverse_iteratei_correct[symmetric]

end

subsection {* Size (by iterator) *}

locale it_size_loc = poly_list_iteratei +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
begin

  definition it_size :: "'s \<Rightarrow> nat"
    where "it_size l == iterate l (\<lambda>x res. Suc res) (0::nat)"

  lemma it_size_impl: shows "list_size \<alpha> invar it_size"
    apply (unfold_locales)
    apply (unfold it_size_def)
    apply (simp add: iterate_correct foldli_foldl)
    done
end

subsubsection {* Size (by reverse\_iterator) *}

locale rev_it_size_loc = poly_list_rev_iteratei +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
begin

  definition rev_it_size :: "'s \<Rightarrow> nat"
    where "rev_it_size l == rev_iterate l (\<lambda>x res. Suc res) (0::nat)"

  lemma rev_it_size_impl:
    shows "list_size \<alpha> invar rev_it_size"
    apply (unfold_locales)
    apply (unfold rev_it_size_def)
    apply (simp add: rev_iterate_correct foldri_foldr)
    done

end

subsection {* Get (by iteratori) *}
locale it_get_loc = poly_list_iteratei +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
begin

  definition it_get:: "'s \<Rightarrow> nat \<Rightarrow> 'a"
    where "it_get s i \<equiv>
      the (snd (iteratei s
                (\<lambda>(i,x). x=None)
                (\<lambda>x (i,_). if i=0 then (0,Some x) else (i - 1,None))
                (i,None)))"

  lemma it_get_correct:
    shows "list_get \<alpha> invar it_get"
  proof
    fix s i
    assume "invar s" "i < length (\<alpha> s)"

    def l \<equiv> "\<alpha> s"
    from `i < length (\<alpha> s)`
    show "it_get s i = \<alpha> s ! i"
      unfolding it_get_def iteratei_correct l_def[symmetric]
    proof (induct i arbitrary: l)
      case 0
      then obtain x xs where l_eq[simp]: "l = x # xs" by (cases l, auto)
      thus ?case by simp
    next
      case (Suc i)
      note ind_hyp = Suc(1)
      note Suc_i_le = Suc(2)
      from Suc_i_le obtain x xs
        where l_eq[simp]: "l = x # xs" by (cases l, auto)

      from ind_hyp [of xs] Suc_i_le
      show ?case by simp
    qed
  qed
end

end


(* Author: Tobias Nipkow and Gerwin Klein *)

header "Compiler for IMP"

theory Repeat_Compiler_Template
imports "Repeat_Big_Step" "~~/src/HOL/IMP/Star"
begin

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the excution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = (if f then size cb2 else (size cb2::int)+n);
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])" |
(* begin mod *)
"ccomp (REPEAT c UNTIL b) = undefined"
(* end mod *)

value "ccomp (REPEAT ''u'' ::= Plus (V ''u'') (N 1) UNTIL Less (N 0) (V ''u''))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
next
  case (RepeatTrue c s1 s2 b)
  show ?case
    sorry
next
  case (RepeatFalse c s1 s2 b s3)
  show ?case
    sorry
qed fastforce+

end


subsection "Auxiliary lemmas for graphs"

theory Graph_Definition_Aux
imports Graph_Definition SeprefUF
begin

context valid_graph
begin

lemma  nodes_connected_sym: "nodes_connected G a b = nodes_connected G b a"
  using is_path_undir_sym by auto

lemma  Domain_nodes_connected: "Domain {(x, y) |x y. nodes_connected G x y} = V"
  apply auto subgoal for x apply(rule exI[where x=x]) apply(rule exI[where x="[]"]) by auto
  done
lemma  Range_nodes_connected: "Range {(x, y) |x y. nodes_connected G x y} = V"
  apply auto subgoal for x apply(rule exI[where x=x]) apply(rule exI[where x="[]"]) by auto
  done

\<comment> \<open>adaptation of a proof by Julian Biendarra\<close>
lemma   nodes_connected_insert_per_union:
  "(nodes_connected (add_edge a w b H) x y) \<longleftrightarrow> (x,y) \<in> per_union {(x,y)| x y. nodes_connected H x y} a b"
  if  "subgraph H G" and PER: "part_equiv {(x,y)| x y. nodes_connected H x y}"
    and V: "a\<in>V" "b\<in>V" for x y
proof -
  let ?uf = "{(x,y)| x y. nodes_connected H x y}"
  from valid_subgraph[OF \<open>subgraph H G\<close>]
  have valid_H: "valid_graph H" .
  from \<open>subgraph H G\<close>
  have nodes_H: "nodes H = V"
    unfolding subgraph_def ..
  with \<open>a\<in>V\<close> \<open>b\<in>V\<close>
  have nodes_add_H: "nodes (add_edge a w b H) = nodes H"
    by auto
  have "Domain ?uf = nodes H" using valid_graph.Domain_nodes_connected[OF valid_H] .
  show ?thesis
  proof
    assume "nodes_connected (add_edge a w b H) x y"
    then obtain p where p: "is_path_undir (add_edge a w b H) x p y"
      by blast
    from \<open>a\<in>V\<close> \<open>b\<in>V\<close> \<open>Domain {(x,y)| x y. nodes_connected H x y} = nodes H\<close> nodes_H
    have [simp]: "a\<in>Domain (per_union ?uf a b)" "b\<in>Domain (per_union ?uf a b)"
      by auto
    from PER have PER': "part_equiv (per_union ?uf a b)"
      by (auto simp: union_part_equivp)
    show "(x,y) \<in> per_union ?uf a b"
    proof (cases "(a, w, b) \<in> set p \<or> (b, w, a) \<in> set p")
      case True
      from valid_graph.is_path_undir_split_distinct[OF add_edge_valid[OF valid_H] p True]
      obtain p' p'' u u' where
        "is_path_undir (add_edge a w b H) x p' u \<and>
        is_path_undir (add_edge a w b H) u' p'' y" and
        u: "u\<in>{a,b} \<and> u'\<in>{a,b}" and
        "(a, w, b) \<notin> set p' \<and> (b, w, a) \<notin> set p' \<and>
        (a, w, b) \<notin> set p'' \<and> (b, w, a) \<notin> set p''"
        by auto
      with \<open>a\<in>V\<close> \<open>b\<in>V\<close> \<open>Domain ?uf = nodes H\<close> \<open>subgraph H G\<close>
        valid_graph.add_edge_was_path[OF valid_H]
      have "is_path_undir H x p' u \<and> is_path_undir H u' p'' y"
        unfolding subgraph_def by auto
      with V  u nodes_H have comps: "(x,u) \<in> ?uf \<and> (u', y) \<in> ?uf" by auto
      from comps  have "(x,u) \<in> per_union ?uf a b" apply(intro per_union_impl)
        by auto
      also from u \<open>a\<in>V\<close> \<open>b\<in>V\<close> \<open>Domain ?uf = nodes H\<close> nodes_H
        part_equiv_refl'[OF PER' \<open>a\<in>Domain (per_union ?uf a b)\<close>]
        part_equiv_refl'[OF PER' \<open>b\<in>Domain (per_union ?uf a b)\<close>] part_equiv_sym[OF PER']
        per_union_related[OF PER]
      have "(u,u') \<in> per_union ?uf a b"
        by auto
      also (part_equiv_trans[OF PER']) from comps
      have "(u',y) \<in> per_union ?uf a b" apply(intro per_union_impl)
        by auto
      finally (part_equiv_trans[OF PER']) show ?thesis by simp
    next
      case False
      with \<open>a\<in>V\<close> \<open>b\<in>V\<close> nodes_H valid_graph.add_edge_was_path[OF valid_H p(1)]
      have "is_path_undir H x p y"
        by auto
      with     nodes_add_H have "(x,y)\<in>?uf" by auto
      from per_union_impl[OF this] show ?thesis .
    qed
  next
    assume asm: "(x, y) \<in> per_union ?uf a b"
    show "nodes_connected (add_edge a w b H) x y"
      proof (cases "(x, y) \<in> ?uf")
        case True
        with nodes_add_H have "nodes_connected H x y"
          by auto
        with valid_graph.add_edge_is_path[OF valid_H] show ?thesis
          by blast
      next
        case False
        with asm part_equiv_sym[OF PER]
        have "(x,a) \<in> ?uf \<and> (b,y) \<in> ?uf \<or>
              (x,b) \<in> ?uf \<and> (a,y) \<in> ?uf"
          unfolding per_union_def
          by auto
        with  \<open>a\<in>V\<close> \<open>b\<in>V\<close> nodes_H nodes_add_H obtain p q p' q'
          where "is_path_undir H x p a \<and> is_path_undir H b q y \<or>
                 is_path_undir H x p' b \<and> is_path_undir H a q' y"
          by fastforce
        with valid_graph.add_edge_is_path[OF valid_H]
        have "is_path_undir (add_edge a w b H) x p a \<and>
              is_path_undir (add_edge a w b H) b q y \<or>
              is_path_undir (add_edge a w b H) x p' b \<and>
              is_path_undir (add_edge a w b H) a q' y"
          by blast
        with valid_graph.is_path_undir_split'[OF add_edge_valid[OF valid_H]]
        have "is_path_undir (add_edge a w b H) x (p @ (a, w, b) # q) y \<or>
              is_path_undir (add_edge a w b H) x (p' @ (b, w, a) # q') y"
          by auto
        with valid_graph.is_path_undir_sym[OF add_edge_valid[OF valid_H]]
        show ?thesis
          by blast
      qed
    qed
  qed

lemma  is_path_undir_append: "is_path_undir G v p1 u \<Longrightarrow> is_path_undir G u p2 w
      \<Longrightarrow> is_path_undir G v (p1@p2) w"
  using is_path_undir_split by auto

lemma
  augment_edge:
  assumes sg: "subgraph G1 G" "subgraph G2 G" and
    p: "(u, v) \<in> {(a, b) |a b. nodes_connected G1 a b}"
  and notinE2:  "(u, v) \<notin> {(a, b) |a b. nodes_connected G2 a b}"

shows "\<exists>a b e. (a, b) \<notin> {(a, b) |a b. nodes_connected G2 a b} \<and> e \<notin> edges G2 \<and> e \<in> edges G1 \<and> (case e of (aa, w, ba) \<Rightarrow> a=aa \<and> b=ba \<or> a=ba \<and> b=aa)"
proof -
  from sg have [simp]: "nodes G1 = nodes G" "nodes G2 = nodes G" unfolding subgraph_def by auto
  from p obtain p where a: "is_path_undir G1 u p v" by blast
  from notinE2 have b: "~(\<exists>p. is_path_undir G2 u p v)" by auto
  from a b show ?thesis
  proof (induct p arbitrary: u)
    case Nil
    then have "u=v" "u\<in>nodes G1" by auto
    then have "is_path_undir G2 u [] v" by auto
    have "(u, v) \<in> {(a, b) |a b. nodes_connected G2 a b}"
      apply auto
      apply(rule exI[where x="[]"]) by fact
    with Nil(2) show ?case by blast
next
  case (Cons a p)
  from Cons(2) obtain w x y u' where axy: "a=(u,w,u')" and 2: "(x=u \<and> y=u') \<or> (x=u' \<and> y=u)" and e': "is_path_undir G1 u' p v"
      and uwE1: "(x,w,y) \<in> edges G1" apply(cases a) by auto
  show ?case
  proof (cases "(x,w,y)\<in>edges G2 \<or> (y,w,x)\<in>edges G2")
    case True
    have e2': "~(\<exists>p. is_path_undir G2 u' p v)"
    proof (rule ccontr, clarsimp)
      fix p2
      assume "is_path_undir G2 u' p2 v"
      with True axy 2 have "is_path_undir G2 u (a#p2) v" by auto
      with Cons(3) show False by blast
    qed
    from Cons(1)[OF e' e2'] show ?thesis .
  next
    case False
    {
      assume e2': "~(\<exists>p. is_path_undir G2 u' p v)"
      from Cons(1)[OF e' e2'] have ?thesis .
    } moreover {
      assume e2': "\<exists>p. is_path_undir G2 u' p v"
      then obtain p1 where p1: "is_path_undir G2 u' p1 v" by auto

      from False axy have "(x, w, y)\<notin>edges G2" by auto
      moreover
      have "(u,u') \<notin> {(a, b) |a b. nodes_connected G2 a b}"
      proof(rule ccontr, auto simp add:  )
        fix p2
        assume "is_path_undir G2 u p2 u'"
        with p1 have "is_path_undir G2 u (p2@p1) v"
          using valid_graph.is_path_undir_append[OF valid_subgraph[OF assms(2)]]
          by auto
        then show "False" using Cons(3) by blast
      qed
      moreover
      note uwE1
      ultimately have ?thesis
        apply -
        apply(rule exI[where x="u"])
        apply(rule exI[where x="u'"])
        apply(rule exI[where x="(x,w,y)"])
        using 2 by fastforce
    }
    ultimately show ?thesis by auto
  qed
qed
qed

lemma  nodes_connected_refl: "a\<in>V \<Longrightarrow> nodes_connected G a a"
  apply(rule exI[where x="[]"]) by auto

lemma assumes sg: "subgraph H G"
  shows connected_VV: "{(x, y) |x y. nodes_connected H x y} \<subseteq> V\<times>V"
    and connected_refl: "refl_on V {(x, y) |x y. nodes_connected H x y}"
    and connected_trans: "trans {(x, y) |x y. nodes_connected H x y}"
    and connected_sym: "sym {(x, y) |x y. nodes_connected H x y}"
    and connected_equiv: "equiv V {(x, y) |x y. nodes_connected H x y}"
proof -
  have *: "\<And>R S. Domain R \<subseteq> S \<Longrightarrow> Range R \<subseteq> S \<Longrightarrow> R \<subseteq> S\<times>S" by auto
  from sg have [simp]: "nodes H = V" by (auto simp: subgraph_def)
  from sg valid_subgraph have v: "valid_graph H"  by auto

  from valid_graph.Domain_nodes_connected[OF this] valid_graph.Range_nodes_connected[OF this]
  show i: "{(x, y) |x y. nodes_connected H x y} \<subseteq> V\<times>V" apply(intro *) by auto

  have ii: "\<And>x. x \<in> V \<Longrightarrow> (x, x) \<in> {(x, y) |x y. nodes_connected H x y}"
    using valid_graph.nodes_connected_refl[OF v] by auto
  show "refl_on V {(x, y) |x y. nodes_connected H x y}"
    apply(rule refl_onI) by fact+

  from valid_graph.is_path_undir_append[OF v]
  show "trans {(x, y) |x y. nodes_connected H x y}" unfolding trans_def by fast

  from valid_graph.nodes_connected_sym[OF v]
  show "sym {(x, y) |x y. nodes_connected H x y}" unfolding sym_def by fast

  show "equiv V {(x, y) |x y. nodes_connected H x y}" apply (rule equivI) by fact+
qed

lemma  forest_maximally_connected_incl_max1:
  assumes
    "forest H"
    "subgraph H G"
  shows "(\<forall>(a,w,b)\<in>edges G - edges H. \<not> (forest (add_edge a w b H))) \<Longrightarrow> maximally_connected H G"
proof -

  from assms(2) have V[simp]: "nodes H = nodes G" unfolding subgraph_def by auto

  assume pff: "(\<forall>(a,w,b)\<in>E - edges H. \<not> (forest (add_edge a w b H)))"
  { fix u v
    assume uv: "v\<in>V" "u\<in>V"
    assume "nodes_connected G u v"
    then have i: "(u, v) \<in> {(a, b) |a b. nodes_connected G a b}" by auto

    have "nodes_connected H u v"
    proof (rule ccontr)
      assume "\<not>nodes_connected H u v"
      then have ii: "(u, v) \<notin> {(a, b) |a b. nodes_connected H a b}" by auto
      have "subgraph G G" by(auto simp: subgraph_def)
      from augment_edge[OF this assms(2) i ii] obtain e a b where
         k: "(a, b) \<notin> {(a, b) |a b. nodes_connected H a b}"
        and nn: "e \<notin> edges H" "e \<in> E" and ee: "(case e of (aa, w, ba) \<Rightarrow> a=aa \<and> b=ba \<or> a=ba \<and> b=aa) "
        by blast
      obtain x w y where e: "e=(x,w,y)" apply(cases e) by auto
      from e ee have "x=a \<and> y=b \<or> x=b \<and> y=a" by auto
      with k have k': "\<not> nodes_connected H x y"
        using valid_graph.nodes_connected_sym[OF valid_subgraph[OF assms(2)]] by auto
      have xy: "x\<in>V" "y\<in>V" using e nn(2) by (auto dest: E_validD)
      then have nxy: "x\<in>nodes H"  "y\<in>nodes H" by auto
      from forest.forest_add_edge[OF assms(1) nxy k' ]  have
        "forest (add_edge x w y H)" .
      moreover have "(x,w,y)\<in>E-edges H" using nn e by auto
      ultimately show "False" using pff by blast
    qed
  }
  then show "maximally_connected H G"
    unfolding maximally_connected_def by auto
qed

lemma   forest_maximally_connected_incl_max2:
  assumes
    "forest H"
    "subgraph H G"
  shows "maximally_connected H G \<Longrightarrow> (\<forall>(a,w,b)\<in>E - edges H. \<not> (forest (add_edge a w b H)))"
proof -
  from assms(2) have V[simp]: "nodes H = nodes G" unfolding subgraph_def by auto

  assume mc: "maximally_connected H G"
  then have k: "\<And>v v'. v\<in>V \<Longrightarrow>  v'\<in>V \<Longrightarrow>
          nodes_connected G v v' \<Longrightarrow> nodes_connected H v v'"
    unfolding maximally_connected_def by auto

  show "(\<forall>(a,w,b)\<in>E - edges H. \<not> (forest (add_edge a w b H)))"
  proof (safe)
    fix x w y
    assume i: "(x, w, y) \<in> E" and ni: "(x, w, y) \<notin> edges H"
      and f: "forest (add_edge x w y H)"
    from i have xy: "x\<in>V" "y\<in>V" by (auto dest: E_validD)
    from f have "\<forall>(a,wa,b)\<in>insert (x, w, y) (edges H). \<not> nodes_connected (delete_edge a wa b (add_edge x w y H)) a b"
      unfolding forest_def forest_axioms_def by auto
    then have "\<not> nodes_connected (delete_edge x w y (add_edge x w y H)) x y"
      by auto
    moreover have "(delete_edge x w y (add_edge x w y H)) = H"
      using ni xy by(auto simp: add_edge_def delete_edge_def insert_absorb)
    ultimately have "\<not> nodes_connected H x y" by auto
    moreover from i have "nodes_connected G x y" apply - apply(rule exI[where x="[(x,w,y)]"])
      by (auto dest: E_validD)
    ultimately   show "False" using k[OF xy] by simp
  qed
qed

lemma  forest_maximally_connected_incl_max_conv:
  assumes
    "forest H"
    "subgraph H G"
  shows "maximally_connected H G = (\<forall>(a,w,b)\<in>E - edges H. \<not> (forest (add_edge a w b H)))"
  using assms forest_maximally_connected_incl_max2 forest_maximally_connected_incl_max1 by blast

end

end


theory Exe2p4
  imports Main
begin

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] a = [a]" |
"snoc (h # t) a = h # (snoc t a)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (h # t) = snoc (reverse t) h"

lemma rev_rev_id : "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  done

end


(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>Relationship to Strong List Specification\<close>

text\<open>In this section we show that our list specification is stronger than the
$\mathcal{A}_\textsf{strong}$ specification of collaborative text editing by
Attiya et al.~\<^cite>\<open>"Attiya:2016kh"\<close>. We do this by showing that the OpSet
interpretation of any set of insertion and deletion operations satisfies all
of the consistency criteria that constitute the $\mathcal{A}_\textsf{strong}$
specification.

Attiya et al.'s specification is as follows~\<^cite>\<open>"Attiya:2016kh"\<close>:

\begin{displayquote}
An abstract execution $A = (H, \textsf{vis})$ belongs to the
\emph{strong list specification} $\mathcal{A}_\textsf{strong}$ if and only if
there is a relation
$\textsf{lo} \subseteq \textsf{elems}(A) \times \textsf{elems}(A)$, called the
\emph{list order}, such that:
\begin{enumerate}
\item Each event $e = \mathit{do}(\mathit{op}, w) \in H$ returns a sequence of
elements $w=a_0 \dots a_{n-1}$, where $a_i \in \textsf{elems}(A)$, such that
\begin{enumerate}
\item $w$ contains exactly the elements visible to $e$ that have been inserted,
but not deleted:
\[ \forall a.\; a \in w \quad\Longleftrightarrow\quad (\mathit{do}(\textsf{ins}(a, \_), \_) \le_\textsf{vis} e)
\;\wedge\; \neg(\mathit{do}(\textsf{del}(a), \_) \le_\textsf{vis} e). \]
\item The order of the elements is consistent with the list order:
\[ \forall i, j.\; (i < j) \;\Longrightarrow\; (a_i, a_j) \in \textsf{lo}. \]
\item Elements are inserted at the specified position:
if $\mathit{op} = \textsf{ins}(a, k)$, then $a = a_{\mathrm{min} \{k,\; n-1\}}$.
\end{enumerate}
\item The list order $\textsf{lo}$ is transitive, irreflexive and total, and
thus determines the order of all insert operations in the execution.
\end{enumerate}
\end{displayquote}

This specification considers only insertion and deletion operations, but no
assignment. Moreover, it considers only a single list object, not a graph of
composable objects like in our paper. Thus, we prove the relationship to
$\mathcal{A}_\textsf{strong}$ using a simplified interpretation function that
defines only insertion and deletion on a single list.\<close>

theory List_Spec
  imports Insert_Spec
begin

text\<open>We first define a datatype for list operations, with two constructors:
\isa{Insert ref val}, and \isa{Delete ref}. For insertion, the \isa{ref} argument
is the ID of the existing element after which we want to insert, or \isa{None}
to insert at the head of the list.
The \isa{val} argument is an arbitrary value to associate with the list element.
For deletion, the \isa{ref} argument is the ID of the existing list element
to delete.\<close>

datatype ('oid, 'val) list_op =
  Insert "'oid option" "'val" |
  Delete "'oid"

text\<open>When interpreting operations, the result is a pair (\isa{list, vals}).
The \isa{list} contains the IDs of list elements in the correct order
(equivalent to the list relation in the paper), and \isa{vals} is a mapping
from list element IDs to values (equivalent to the element relation in the paper).

Insertion delegates to the previously defined \isa{insert-spec} interpretation
function. Deleting a list element removes it from \isa{vals}.\<close>

fun interp_op :: "('oid list \<times> ('oid \<rightharpoonup> 'val)) \<Rightarrow> ('oid \<times> ('oid, 'val) list_op)
               \<Rightarrow> ('oid list \<times> ('oid \<rightharpoonup> 'val))" where
  "interp_op (list, vals) (oid, Insert ref val) = (insert_spec list (oid, ref), vals(oid \<mapsto> val))" |
  "interp_op (list, vals) (oid, Delete ref    ) = (list, vals(ref := None))"

definition interp_ops :: "('oid \<times> ('oid, 'val) list_op) list \<Rightarrow> ('oid list \<times> ('oid \<rightharpoonup> 'val))" where
  "interp_ops ops \<equiv> foldl interp_op ([], Map.empty) ops"

text\<open>\isa{list-order ops x y} holds iff, after interpreting the list of
operations \isa{ops}, the list element with ID \isa{x} appears before the
list element with ID \isa{y} in the resulting list.\<close>

definition list_order :: "('oid \<times> ('oid, 'val) list_op) list \<Rightarrow> 'oid \<Rightarrow> 'oid \<Rightarrow> bool" where
  "list_order ops x y \<equiv> \<exists>xs ys zs. fst (interp_ops ops) = xs @ [x] @ ys @ [y] @ zs"

text\<open>The \isa{make-insert} function generates a new operation for insertion into
a given index in a given list.
The exclamation mark is Isabelle's list subscript operator.\<close>

fun make_insert :: "'oid list \<Rightarrow> 'val \<Rightarrow> nat \<Rightarrow> ('oid, 'val) list_op" where
  "make_insert list val 0       = Insert None val" |
  "make_insert []   val k       = Insert None val" |
  "make_insert list val (Suc k) = Insert (Some (list ! (min k (length list - 1)))) val"

text\<open>The \isa{list-ops} predicate is a specialisation of \isa{spec-ops} to
the \isa{list-op} datatype: it describes a list of (ID, operation) pairs that
is sorted by ID, and can thus be used for the sequential interpretation of
the OpSet.\<close>

fun list_op_deps :: "('oid, 'val) list_op \<Rightarrow> 'oid set" where
  "list_op_deps (Insert (Some ref) _) = {ref}" |
  "list_op_deps (Insert  None      _) = {}"    |
  "list_op_deps (Delete  ref        ) = {ref}"

locale list_opset = opset opset list_op_deps
  for opset :: "('oid::{linorder} \<times> ('oid, 'val) list_op) set"

definition list_ops :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> bool" where
  "list_ops ops \<equiv> spec_ops ops list_op_deps"

subsection\<open>Lemmas about insertion and deletion\<close>

definition insertions :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> ('oid \<times> 'oid option) list" where
  "insertions ops \<equiv> List.map_filter (\<lambda>oper.
      case oper of (oid, Insert ref val) \<Rightarrow> Some (oid, ref) |
                   (oid, Delete ref    ) \<Rightarrow> None) ops"

definition inserted_ids :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> 'oid list" where
  "inserted_ids ops \<equiv> List.map_filter (\<lambda>oper.
      case oper of (oid, Insert ref val) \<Rightarrow> Some oid |
                   (oid, Delete ref    ) \<Rightarrow> None) ops"

definition deleted_ids :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> 'oid list" where
  "deleted_ids ops \<equiv> List.map_filter (\<lambda>oper.
      case oper of (oid, Insert ref val) \<Rightarrow> None |
                   (oid, Delete ref    ) \<Rightarrow> Some ref) ops"

lemma interp_ops_unfold_last:
  shows "interp_ops (xs @ [x]) = interp_op (interp_ops xs) x"
  by (simp add: interp_ops_def)

lemma map_filter_append:
  shows "List.map_filter P (xs @ ys) = List.map_filter P xs @ List.map_filter P ys"
  by (auto simp add: List.map_filter_def)

lemma map_filter_Some:
  assumes "P x = Some y"
  shows "List.map_filter P [x] = [y]"
  by (simp add: assms map_filter_simps(1) map_filter_simps(2))

lemma map_filter_None:
  assumes "P x = None"
  shows "List.map_filter P [x] = []"
  by (simp add: assms map_filter_simps(1) map_filter_simps(2))

lemma insertions_last_ins:
  shows "insertions (xs @ [(oid, Insert ref val)]) = insertions xs @ [(oid, ref)]"
  by (simp add: insertions_def map_filter_Some map_filter_append)

lemma insertions_last_del:
  shows "insertions (xs @ [(oid, Delete ref)]) = insertions xs"
  by (simp add: insertions_def map_filter_None map_filter_append)

lemma insertions_fst_subset:
  shows "set (map fst (insertions ops)) \<subseteq> set (map fst ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  then show "set (map fst (insertions [])) \<subseteq> set (map fst [])"
    by (simp add: insert_ops_def spec_ops_def insertions_def map_filter_def)
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "set (map fst (insertions (ops @ [a]))) \<subseteq> set (map fst (ops @ [a]))"
  proof(cases oper)
    case (Insert ref val)
    hence "insertions (ops @ [a]) = insertions ops @ [(oid, ref)]"
      by (simp add: a_pair insertions_last_ins)
    then show ?thesis using snoc.IH a_pair by auto
  next
    case (Delete ref)
    hence "insertions (ops @ [a]) = insertions ops"
      by (simp add: a_pair insertions_last_del)
    then show ?thesis using snoc.IH by auto
  qed
qed

lemma insertions_subset:
  assumes "list_ops A" and "list_ops B"
    and "set A \<subseteq> set B"
  shows "set (insertions A) \<subseteq> set (insertions B)"
  using assms proof(induction B arbitrary: A rule: List.rev_induct)
  case Nil
  then show "set (insertions A) \<subseteq> set (insertions [])"
    by (simp add: insertions_def map_filter_simps(2))
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  have "list_ops ops"
    using list_ops_def spec_ops_rem_last snoc.prems(2) by blast
  then show "set (insertions A) \<subseteq> set (insertions (ops @ [a]))"
  proof(cases "a \<in> set A")
    case True
    then obtain as bs where A_split: "A = as @ a # bs \<and> a \<notin> set as"
      by (meson split_list_first)
    hence "remove1 a A = as @ bs"
      by (simp add: remove1_append)
    hence as_bs: "insertions (remove1 a A) = insertions as @ insertions bs"
      by (simp add: insertions_def map_filter_append)
    moreover have "A = as @ [a] @ bs"
      by (simp add: A_split)
    hence as_a_bs: "insertions A = insertions as @ insertions [a] @ insertions bs"
      by (metis insertions_def map_filter_append)
    moreover have IH: "set (insertions (remove1 a A)) \<subseteq> set (insertions ops)"
    proof -
      have "list_ops (remove1 a A)"
        using snoc.prems(1) list_ops_def spec_ops_remove1 by blast
      moreover have "set (remove1 a A) \<subseteq> set ops"
      proof -
        have "distinct A"
          using snoc.prems(1) list_ops_def spec_ops_distinct by blast
        hence "a \<notin> set (remove1 a A)"
          by auto
        moreover have "set (ops @ [a]) = set ops \<union> {a}"
          by auto
        moreover have "set (remove1 a A) \<subseteq> set A"
          by (simp add: set_remove1_subset)
        ultimately show "set (remove1 a A) \<subseteq> set ops"
          using snoc.prems(3) by blast
      qed
      ultimately show ?thesis
        by (simp add: \<open>list_ops ops\<close> snoc.IH)
    qed
    ultimately show ?thesis
    proof(cases oper)
      case (Insert ref val)
      hence "insertions [a] = [(oid, ref)]"
        by (simp add: insertions_def map_filter_Some a_pair)
      hence "set (insertions A) = set (insertions (remove1 a A)) \<union> {(oid, ref)}"
        using as_a_bs as_bs by auto
      moreover have "set (insertions (ops @ [a])) = set (insertions ops) \<union> {(oid, ref)}"
        by (simp add: Insert a_pair insertions_last_ins)
      ultimately show ?thesis
        using IH by auto
    next
      case (Delete ref)
      hence "insertions [a] = []"
        by (simp add: insertions_def map_filter_None a_pair)
      hence "set (insertions A) = set (insertions (remove1 a A))"
        using as_a_bs as_bs by auto
      moreover have "set (insertions (ops @ [a])) = set (insertions ops)"
        by (simp add: Delete a_pair insertions_last_del)
      ultimately show ?thesis
        using IH by auto
    qed
  next
    case False
    hence "set A \<subseteq> set ops"
      using DiffE snoc.prems by auto
    hence "set (insertions A) \<subseteq> set (insertions ops)"
      using snoc.IH snoc.prems(1) \<open>list_ops ops\<close> by blast
    moreover have "set (insertions ops) \<subseteq> set (insertions (ops @ [a]))"
      by (simp add: insertions_def map_filter_append)
    ultimately show ?thesis
      by blast
  qed
qed

lemma list_ops_insertions:
  assumes "list_ops ops"
  shows "insert_ops (insertions ops)"
  using assms proof(induction ops rule: List.rev_induct)
  case Nil
  then show "insert_ops (insertions [])"
    by (simp add: insert_ops_def spec_ops_def insertions_def map_filter_def)
next
  case (snoc a ops)
  hence IH: "insert_ops (insertions ops)"
    using list_ops_def spec_ops_rem_last by blast
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "insert_ops (insertions (ops @ [a]))"
  proof(cases oper)
    case (Insert ref val)
    hence "insertions (ops @ [a]) = insertions ops @ [(oid, ref)]"
      by (simp add: a_pair insertions_last_ins)
    moreover have "\<And>i. i \<in> set (map fst ops) \<Longrightarrow> i < oid"
      using a_pair list_ops_def snoc.prems spec_ops_id_inc by fastforce
    hence "\<And>i. i \<in> set (map fst (insertions ops)) \<Longrightarrow> i < oid"
      using insertions_fst_subset by blast
    moreover have "list_op_deps oper = set_option ref"
      using Insert by (cases ref, auto)
    hence "\<And>r. r \<in> set_option ref \<Longrightarrow> r < oid"
      using list_ops_def spec_ops_ref_less
      by (metis a_pair last_in_set snoc.prems snoc_eq_iff_butlast)
    ultimately show ?thesis
      using IH insert_ops_def spec_ops_add_last by metis
  next
    case (Delete ref)
    hence "insertions (ops @ [a]) = insertions ops"
      by (simp add: a_pair insertions_last_del)
    then show ?thesis by (simp add: IH)
  qed
qed

lemma inserted_ids_last_ins:
  shows "inserted_ids (xs @ [(oid, Insert ref val)]) = inserted_ids xs @ [oid]"
  by (simp add: inserted_ids_def map_filter_Some map_filter_append)

lemma inserted_ids_last_del:
  shows "inserted_ids (xs @ [(oid, Delete ref)]) = inserted_ids xs"
  by (simp add: inserted_ids_def map_filter_None map_filter_append)

lemma inserted_ids_exist:
  shows "oid \<in> set (inserted_ids ops) \<longleftrightarrow> (\<exists>ref val. (oid, Insert ref val) \<in> set ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  then show "oid \<in> set (inserted_ids []) \<longleftrightarrow> (\<exists>ref val. (oid, Insert ref val) \<in> set [])"
    by (simp add: inserted_ids_def List.map_filter_def)
next
  case (snoc a ops)
  obtain i oper where a_pair: "a = (i, oper)"
    by fastforce
  then show "oid \<in> set (inserted_ids (ops @ [a])) \<longleftrightarrow>
             (\<exists>ref val. (oid, Insert ref val) \<in> set (ops @ [a]))"
  proof(cases oper)
    case (Insert r v)
    moreover from this have "inserted_ids (ops @ [a]) = inserted_ids ops @ [i]"
      by (simp add: a_pair inserted_ids_last_ins)
    ultimately show ?thesis
      using snoc.IH a_pair by auto
  next
    case (Delete r)
    moreover from this have "inserted_ids (ops @ [a]) = inserted_ids ops"
      by (simp add: a_pair inserted_ids_last_del)
    ultimately show ?thesis
      by (simp add: a_pair snoc.IH)
  qed
qed

lemma deleted_ids_last_ins:
  shows "deleted_ids (xs @ [(oid, Insert ref val)]) = deleted_ids xs"
  by (simp add: deleted_ids_def map_filter_None map_filter_append)

lemma deleted_ids_last_del:
  shows "deleted_ids (xs @ [(oid, Delete ref)]) = deleted_ids xs @ [ref]"
  by (simp add: deleted_ids_def map_filter_Some map_filter_append)

lemma deleted_ids_exist:
  shows "ref \<in> set (deleted_ids ops) \<longleftrightarrow> (\<exists>i. (i, Delete ref) \<in> set ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  then show "ref \<in> set (deleted_ids []) \<longleftrightarrow> (\<exists>i. (i, Delete ref) \<in> set [])"
    by (simp add: deleted_ids_def List.map_filter_def)
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "ref \<in> set (deleted_ids (ops @ [a])) \<longleftrightarrow> (\<exists>i. (i, Delete ref) \<in> set (ops @ [a]))"
  proof(cases oper)
    case (Insert r v)
    moreover from this have "deleted_ids (ops @ [a]) = deleted_ids ops"
      by (simp add: a_pair deleted_ids_last_ins)
    ultimately show ?thesis
      using a_pair snoc.IH by auto
  next
    case (Delete r)
    moreover from this have "deleted_ids (ops @ [a]) = deleted_ids ops @ [r]"
      by (simp add: a_pair deleted_ids_last_del)
    ultimately show ?thesis
      using a_pair snoc.IH by auto
  qed
qed

lemma deleted_ids_refs_older:
  assumes "list_ops (ops @ [(oid, oper)])"
  shows "\<And>ref. ref \<in> set (deleted_ids ops) \<Longrightarrow> ref < oid"
proof -
  fix ref
  assume "ref \<in> set (deleted_ids ops)"
  then obtain i where in_ops: "(i, Delete ref) \<in> set ops"
    using deleted_ids_exist by blast
  have "ref < i"
  proof -
    have "\<And>i oper r. (i, oper) \<in> set ops \<Longrightarrow> r \<in> list_op_deps oper \<Longrightarrow> r < i"
      by (meson assms list_ops_def spec_ops_ref_less spec_ops_rem_last)
    thus "ref < i"
      using in_ops by auto
  qed
  moreover have "i < oid"
  proof -
    have "\<And>i. i \<in> set (map fst ops) \<Longrightarrow> i < oid"
      using assms by (simp add: list_ops_def spec_ops_id_inc)
    thus ?thesis
      by (metis in_ops in_set_zipE zip_map_fst_snd)
  qed
  ultimately show "ref < oid"
    using order.strict_trans by blast
qed

subsection\<open>Lemmas about interpreting operations\<close>

lemma interp_ops_list_equiv:
  shows "fst (interp_ops ops) = interp_ins (insertions ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  have 1: "fst (interp_ops []) = []"
    by (simp add: interp_ops_def)
  have 2: "interp_ins (insertions []) = []"
    by (simp add: insertions_def map_filter_def interp_ins_def)
  show "fst (interp_ops []) = interp_ins (insertions [])"
    by (simp add: 1 2)
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "fst (interp_ops (ops @ [a])) = interp_ins (insertions (ops @ [a]))"
  proof(cases oper)
    case (Insert ref val)
    hence "insertions (ops @ [a]) = insertions ops @ [(oid, ref)]"
      by (simp add: a_pair insertions_last_ins)
    hence "interp_ins (insertions (ops @ [a])) = insert_spec (interp_ins (insertions ops)) (oid, ref)"
      by (simp add: interp_ins_tail_unfold)
    moreover have "fst (interp_ops (ops @ [a])) = insert_spec (fst (interp_ops ops)) (oid, ref)"
      by (metis Insert a_pair fst_conv interp_op.simps(1) interp_ops_unfold_last prod.collapse)
    ultimately show ?thesis
      using snoc.IH by auto
  next
    case (Delete ref)
    hence "insertions (ops @ [a]) = insertions ops"
      by (simp add: a_pair insertions_last_del)
    moreover have "fst (interp_ops (ops @ [a])) = fst (interp_ops ops)"
      by (metis Delete a_pair eq_fst_iff interp_op.simps(2) interp_ops_unfold_last)
    ultimately show ?thesis
      using snoc.IH by auto
  qed
qed

lemma interp_ops_distinct:
  assumes "list_ops ops"
  shows "distinct (fst (interp_ops ops))"
  by (simp add: assms interp_ins_distinct interp_ops_list_equiv list_ops_insertions)

lemma list_order_equiv:
  shows "list_order ops x y \<longleftrightarrow> Insert_Spec.list_order (insertions ops) x y"
  by (simp add: Insert_Spec.list_order_def List_Spec.list_order_def interp_ops_list_equiv)

lemma interp_ops_vals_domain:
  assumes "list_ops ops"
  shows "dom (snd (interp_ops ops)) = set (inserted_ids ops) - set (deleted_ids ops)"
  using assms proof(induction ops rule: List.rev_induct)
  case Nil
  have 1: "interp_ops [] = ([], Map.empty)"
    by (simp add: interp_ops_def)
  moreover have 2: "inserted_ids [] = []" and "deleted_ids [] = []"
    by (auto simp add: inserted_ids_def deleted_ids_def map_filter_simps(2))
  ultimately show "dom (snd (interp_ops [])) = set (inserted_ids []) - set (deleted_ids [])"
    by (simp add: 1 2)
next
  case (snoc x xs)
  hence IH: "dom (snd (interp_ops xs)) = set (inserted_ids xs) - set (deleted_ids xs)"
    using list_ops_def spec_ops_rem_last by blast
  obtain oid oper where x_pair: "x = (oid, oper)"
    by fastforce
  obtain list vals where interp_xs: "interp_ops xs = (list, vals)"
    by fastforce
  then show "dom (snd (interp_ops (xs @ [x]))) =
             set (inserted_ids (xs @ [x])) - set (deleted_ids (xs @ [x]))"
  proof(cases oper)
    case (Insert ref val)
    hence "interp_ops (xs @ [x]) = (insert_spec list (oid, ref), vals(oid \<mapsto> val))"
      by (simp add: interp_ops_unfold_last interp_xs x_pair)
    hence "dom (snd (interp_ops (xs @ [x]))) = (dom vals) \<union> {oid}"
      by simp
    moreover have "set (inserted_ids xs) - set (deleted_ids xs) = dom vals"
      using IH interp_xs by auto
    moreover have "inserted_ids (xs @ [x]) = inserted_ids xs @ [oid]"
      by (simp add: Insert inserted_ids_last_ins x_pair)
    moreover have "deleted_ids (xs @ [x]) = deleted_ids xs"
      by (simp add: Insert deleted_ids_last_ins x_pair)
    hence "set (inserted_ids (xs @ [x])) - set (deleted_ids (xs @ [x])) =
           {oid} \<union> set (inserted_ids xs) - set (deleted_ids xs)"
      using calculation(3) by auto
    moreover have "... = {oid} \<union> (set (inserted_ids xs) - set (deleted_ids xs))"
      using deleted_ids_refs_older snoc.prems x_pair by blast
    ultimately show ?thesis by auto
  next
    case (Delete ref)
    hence "interp_ops (xs @ [x]) = (list, vals(ref := None))"
      by (simp add: interp_ops_unfold_last interp_xs x_pair)
    hence "dom (snd (interp_ops (xs @ [x]))) = (dom vals) - {ref}"
      by simp
    moreover have "set (inserted_ids xs) - set (deleted_ids xs) = dom vals"
      using IH interp_xs by auto
    moreover have "inserted_ids (xs @ [x]) = inserted_ids xs"
      by (simp add: Delete inserted_ids_last_del x_pair)
    moreover have "deleted_ids (xs @ [x]) = deleted_ids xs @ [ref]"
      by (simp add: Delete deleted_ids_last_del x_pair)
    hence "set (inserted_ids (xs @ [x])) - set (deleted_ids (xs @ [x])) =
           set (inserted_ids xs) - (set (deleted_ids xs) \<union> {ref})"
      using calculation(3) by auto
    moreover have "... = set (inserted_ids xs) - set (deleted_ids xs) - {ref}"
      by blast
    ultimately show ?thesis by auto
  qed
qed

lemma insert_spec_nth_oid:
  assumes "distinct xs"
    and "n < length xs"
  shows "insert_spec xs (oid, Some (xs ! n)) ! Suc n = oid"
  using assms proof(induction xs arbitrary: n)
  case Nil
  then show "insert_spec [] (oid, Some ([] ! n)) ! Suc n = oid"
    by simp
next
  case (Cons a xs)
  have "distinct (a # xs)"
    using Cons.prems(1) by auto
  then show "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) ! Suc n = oid"
  proof(cases "a = (a # xs) ! n")
    case True
    then have "n = 0"
      using \<open>distinct (a # xs)\<close> Cons.prems(2) gr_implies_not_zero by force
    then show "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) ! Suc n = oid"
      by auto
  next
    case False
    then have "n > 0"
      using \<open>distinct (a # xs)\<close> Cons.prems(2) gr_implies_not_zero by force
    then obtain m where "n = Suc m"
      using Suc_pred' by blast
    then show "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) ! Suc n = oid"
      using Cons.IH Cons.prems by auto
  qed
qed

lemma insert_spec_inc_length:
  assumes "distinct xs"
    and "n < length xs"
  shows "length (insert_spec xs (oid, Some (xs ! n))) = Suc (length xs)"
  using assms proof(induction xs arbitrary: n, simp)
  case (Cons a xs)
  have "distinct (a # xs)"
    using Cons.prems(1) by auto
  then show "length (insert_spec (a # xs) (oid, Some ((a # xs) ! n))) = Suc (length (a # xs))"
  proof(cases n)
    case 0
    hence "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) = a # oid # xs"
      by simp
    then show ?thesis
      by simp
  next
    case (Suc nat)
    hence "nat < length xs"
      using Cons.prems(2) by auto
    hence "length (insert_spec xs (oid, Some (xs ! nat))) = Suc (length xs)"
      using Cons.IH Cons.prems(1) by auto
    then show ?thesis
      by (simp add: Suc)
  qed
qed

lemma list_split_two_elems:
  assumes "distinct xs"
    and "x \<in> set xs" and "y \<in> set xs"
    and "x \<noteq> y"
  shows "\<exists>pre mid suf. xs = pre @ x # mid @ y # suf \<or> xs = pre @ y # mid @ x # suf"
proof -
  obtain as bs where as_bs: "xs = as @ [x] @ bs"
    using assms(2) split_list_first by fastforce
  show ?thesis
  proof(cases "y \<in> set as")
    case True
    then obtain cs ds where "as = cs @ [y] @ ds"
      using assms(3) split_list_first by fastforce
    then show ?thesis
      by (auto simp add: as_bs)
  next
    case False
    then have "y \<in> set bs"
      using as_bs assms(3) assms(4) by auto
    then obtain cs ds where "bs = cs @ [y] @ ds"
      using assms(3) split_list_first by fastforce
    then show ?thesis
      by (auto simp add: as_bs)
  qed
qed

subsection\<open>Satisfying all conditions of $\mathcal{A}_\textsf{strong}$\<close>

text\<open>Part 1(a) of Attiya et al.'s specification states that whenever the
list is observed, the elements of the list are exactly those that have
been inserted but not deleted. $\mathcal{A}_\textsf{strong}$ uses the
visibility relation $\le_\textsf{vis}$ to capture the operations known
to a node at some arbitrary point in the execution; in the OpSet model,
we can simply prove the theorem for an arbitrary OpSet, since the
contents of the OpSet at a particular time on a particular node correspond
exactly to the set of operations known to that node at that time.\<close>

theorem inserted_but_not_deleted:
  assumes "list_ops ops"
    and "interp_ops ops = (list, vals)"
  shows "a \<in> dom (vals) \<longleftrightarrow> (\<exists>ref val. (a, Insert ref val) \<in> set ops) \<and>
                            (\<nexists>i. (i, Delete a) \<in> set ops)"
  using assms deleted_ids_exist inserted_ids_exist interp_ops_vals_domain
  by (metis Diff_iff snd_conv)

text\<open>Part 1(b) states that whenever the list is observed, the order of
list elements is consistent with the global list order. We can define the
global list order simply as the list order that arises from interpreting
the OpSet containing all operations in the entire execution. Then, at any
point in the execution, the OpSet is some subset of the set of all
operations.

We can then rephrase condition 1(b) as follows: whenever list element \isa{x}
appears before list element \isa{y} in the interpretation of \isa{some-ops},
then for any OpSet \isa{all-ops} that is a superset of \isa{some-ops},
\isa{x} must also appear before \isa{y} in the interpretation of \isa{all-ops}.
In other words, adding more operations to the OpSet does not change the
relative order of any existing list elements.\<close>

theorem list_order_consistent:
  assumes "list_ops some_ops" and "list_ops all_ops"
    and "set some_ops \<subseteq> set all_ops"
    and "list_order some_ops x y"
  shows "list_order all_ops x y"
  using assms list_order_monotonic list_ops_insertions insertions_subset list_order_equiv by metis

text\<open>Part 1(c) states that inserted elements appear at the specified position:
that is, immediately after an insertion of \isa{oid} at index \isa{k}, the list
index \isa{k} does indeed contain \isa{oid} (provided that \isa{k} is less than the
length of the list). We prove this property below.\<close>

theorem correct_position_insert:
  assumes "list_ops (ops @ [(oid, ins)])"
    and "ins = make_insert (fst (interp_ops ops)) val k"
    and "list = fst (interp_ops (ops @ [(oid, ins)]))"
  shows "list ! (min k (length list - 1)) = oid"
proof(cases "k = 0 \<or> fst (interp_ops ops) = []")
  case True
  moreover from this
  have "make_insert (fst (interp_ops ops)) val k = Insert None val"
    and min_k: "min k (length (fst (interp_ops ops))) = 0"
    by (cases k, auto)
  hence "fst (interp_ops (ops @ [(oid, ins)])) = oid # fst (interp_ops ops)"
    using assms(2) interp_ops_unfold_last
    by (metis fst_conv insert_spec.simps(1) interp_op.simps(1) prod.collapse)
  ultimately show ?thesis
    by (simp add: min_k assms(3))
next
  case False
  moreover from this have "k > 0" and "fst (interp_ops ops) \<noteq> []"
    using neq0_conv by blast+
  from this obtain nat where "k = Suc nat"
    using gr0_implies_Suc by blast
  hence "make_insert (fst (interp_ops ops)) val k =
      Insert (Some ((fst (interp_ops ops)) ! (min nat (length (fst (interp_ops ops)) - 1)))) val"
    using False by (cases "fst (interp_ops ops)", auto)
  hence "fst (interp_ops (ops @ [(oid, ins)])) =
         insert_spec (fst (interp_ops ops)) (oid, Some ((fst (interp_ops ops)) ! (min nat (length (fst (interp_ops ops)) - 1))))"
    by (metis assms(2) fst_conv interp_op.simps(1) interp_ops_unfold_last prod.collapse)
  moreover have "min nat (length (fst (interp_ops ops)) - 1) < length (fst (interp_ops ops))"
    by (simp add: \<open>fst (interp_ops ops) \<noteq> []\<close> min.strict_coboundedI2)
  moreover have "distinct (fst (interp_ops ops))"
    using interp_ops_distinct list_ops_def spec_ops_rem_last assms(1) by blast
  moreover have "length list = Suc (length (fst (interp_ops ops)))"
    using assms(3) calculation by (simp add: insert_spec_inc_length)
  ultimately show ?thesis
    using assms insert_spec_nth_oid
    by (metis Suc_diff_1 \<open>k = Suc nat\<close> diff_Suc_1 length_greater_0_conv min_Suc_Suc)
qed

text\<open>Part 2 states that the list order relation must be transitive, irreflexive,
and total. These three properties are straightforward to prove, using our
definition of the \isa{list-order} predicate.\<close>

theorem list_order_trans:
  assumes "list_ops ops"
    and "list_order ops x y"
    and "list_order ops y z"
  shows "list_order ops x z"
  using assms list_order_trans list_ops_insertions list_order_equiv by blast

theorem list_order_irrefl:
  assumes "list_ops ops"
  shows "\<not> list_order ops x x"
proof -
  have "list_order ops x x \<Longrightarrow> False"
  proof -
    assume "list_order ops x x"
    then obtain xs ys zs where split: "fst (interp_ops ops) = xs @ [x] @ ys @ [x] @ zs"
      by (meson List_Spec.list_order_def)
    moreover have "distinct (fst (interp_ops ops))"
      by (simp add: assms interp_ops_distinct)
    ultimately show False
      by (simp add: split)
  qed
  thus "\<not> list_order ops x x"
    by blast
qed

theorem list_order_total:
  assumes "list_ops ops"
    and "x \<in> set (fst (interp_ops ops))"
    and "y \<in> set (fst (interp_ops ops))"
    and "x \<noteq> y"
  shows "list_order ops x y \<or> list_order ops y x"
proof -
  have "distinct (fst (interp_ops ops))"
    using assms(1) by (simp add: interp_ops_distinct)
  then obtain pre mid suf
    where "fst (interp_ops ops) = pre @ x # mid @ y # suf \<or>
           fst (interp_ops ops) = pre @ y # mid @ x # suf"
    using list_split_two_elems assms by metis
  then show "list_order ops x y \<or> list_order ops y x"
    by (simp add: list_order_def, blast)
qed

end


(* Title: Examples/SML_Relativization/Topology/SML_Ordered_Topological_Spaces.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about ordered topological spaces\<close>
theory SML_Ordered_Topological_Spaces
  imports
    SML_Topological_Space
    "../Lattices/SML_Linorders"
begin

subsection\<open>Ordered topological space\<close>

subsubsection\<open>Definitions and common properties\<close>

locale order_topology_ow =
  order_ow U le ls for U :: "'at set" and le ls +
  fixes \<tau> :: "'at set \<Rightarrow> bool"
  assumes open_generated_order: "s \<subseteq> U \<Longrightarrow>
    \<tau> s =
      (
        (
          in_topology_generated_by
            (
              (\<lambda>a. (on U with (<\<^sub>o\<^sub>w) : {..< a})) ` U \<union>
              (\<lambda>a. (on U with (<\<^sub>o\<^sub>w) : {a <..})) ` U
            )
          on U : \<guillemotleft>open\<guillemotright> s
        )
      )"
begin

sublocale topological_space_ow
proof -
  define \<tau>' where \<tau>':
    "\<tau>' = generate_topology_on
      (
        (\<lambda>a. (on U with (<\<^sub>o\<^sub>w) : {..< a})) ` U \<union>
        (\<lambda>a. (on U with (<\<^sub>o\<^sub>w) : {a <..})) ` U
      )
      U"
  have
    "(
      (\<lambda>a. (on U with (<\<^sub>o\<^sub>w) : {..< a})) ` U \<union>
      (\<lambda>a. (on U with (<\<^sub>o\<^sub>w) : {a <..})) ` U
    ) \<subseteq> Pow U"
    unfolding lessThan_def greaterThan_def lessThan_ow_def greaterThan_ow_def
    by auto
  then have "topological_space_ow U \<tau>'"
    unfolding \<tau>' by (simp add: topological_space_generate_topology)
  moreover then have "s \<subseteq> U \<Longrightarrow> \<tau>' s = \<tau> s" for s
    unfolding \<tau>' using open_generated_order by blast
  ultimately show "topological_space_ow U \<tau>"
    unfolding \<tau>' by (rule ts_open_eq_ts_open)
qed

end

locale ts_ot_ow =
  ts: topological_space_ow U\<^sub>1 \<tau>\<^sub>1 + ot: order_topology_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
  for U\<^sub>1 :: "'at set" and \<tau>\<^sub>1 and U\<^sub>2 :: "'bt set" and le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
begin

sublocale topological_space_pair_ow U\<^sub>1 \<tau>\<^sub>1 U\<^sub>2 \<tau>\<^sub>2 ..

end

locale order_topology_pair_ow =
  ot\<^sub>1: order_topology_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 + ot\<^sub>2: order_topology_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
  for U\<^sub>1 :: "'at set" and le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 and U\<^sub>2 :: "'bt set" and le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
begin

sublocale ts_ot_ow U\<^sub>1 \<tau>\<^sub>1 U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2 ..

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma order_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (rel_set A ===> (=)) ===>
      (=)
    ) (order_topology_ow (Collect (Domainp A))) class.order_topology"
  unfolding order_topology_ow_def class.order_topology_def
  unfolding order_topology_ow_axioms_def class.order_topology_axioms_def
proof(intro rel_funI, standard; elim conjE)
  let ?U = "Collect (Domainp A)"
  fix le :: "['a, 'a] \<Rightarrow> bool"
    and le' :: "['b, 'b] \<Rightarrow> bool"
    and ls :: "['a, 'a] \<Rightarrow> bool"
    and ls' :: "['b, 'b] \<Rightarrow> bool"
    and \<tau> :: "'a set \<Rightarrow> bool"
    and \<tau>' :: "'b set \<Rightarrow> bool"
  assume [transfer_rule]: "(A ===> A ===> (=)) le le'"
    and [transfer_rule]: "(A ===> A ===> (=)) ls ls'"
    and [transfer_rule]: "(rel_set A ===> (=)) \<tau> \<tau>'"
    and oow: "order_ow (Collect (Domainp A)) le ls"
    and \<tau>:
      "\<forall>s\<subseteq>Collect (Domainp A). \<tau> s =
        generate_topology_on
          (lessThan_ow ?U ls ` ?U \<union> greaterThan_ow ?U ls ` ?U) ?U s"
  have [transfer_rule]: "Domainp A = (\<lambda>x. x \<in> Collect (Domainp A))" by auto
  interpret oow: order_ow ?U le ls by (rule oow)
  interpret co: order le' ls' by transfer (rule oow)
  have ineq_fold:
    "lessThan.with ls y \<equiv> {x. ls x y}"
    "greaterThan.with ls y \<equiv> {x. ls y x}"
    for ls :: "'c \<Rightarrow> 'c \<Rightarrow> bool" and y
    unfolding lessThan.with_def greaterThan.with_def by auto
  have
    "\<tau>' = generate_topology (
      range (ord.lessThan ls') \<union> range (ord.greaterThan ls')
      )"
    unfolding co.lessThan_def co.greaterThan_def
    unfolding ineq_fold[symmetric]
    by (transfer, intro allI impI) (auto simp: \<tau>)
  from co.order_axioms this show
    "class.order le' ls' \<and>
      \<tau>' = generate_topology (
        range (ord.lessThan ls') \<union> range (ord.greaterThan ls')
      )"
    by simp
next
  let ?U = "Collect (Domainp A)"
  fix le :: "['a, 'a] \<Rightarrow> bool"
    and le' :: "['b, 'b] \<Rightarrow> bool"
    and ls :: "['a, 'a] \<Rightarrow> bool"
    and ls' :: "['b, 'b] \<Rightarrow> bool"
    and \<tau> :: "'a set \<Rightarrow> bool"
    and \<tau>' :: "'b set \<Rightarrow> bool"
  assume [transfer_rule]: "(A ===> A ===> (=)) le le'"
    and [transfer_rule]: "(A ===> A ===> (=)) ls ls'"
    and [transfer_rule]: "(rel_set A ===> (=)) \<tau> \<tau>'"
    and co: "class.order le' ls'"
    and \<tau>': "\<tau>' = generate_topology
      (range (ord.lessThan ls') \<union> range (ord.greaterThan ls'))"
  have [transfer_rule]: "Domainp A = (\<lambda>x. x \<in> Collect (Domainp A))" by auto
  interpret co: order le' ls' by (rule co)
  have ineq_fold:
    "lessThan.with ls y \<equiv> {x. ls x y}"
    "greaterThan.with ls y \<equiv> {x. ls y x}"
    for ls :: "'c \<Rightarrow> 'c \<Rightarrow> bool" and y
    unfolding lessThan.with_def greaterThan.with_def by auto
  from co have "order_ow ?U le ls" by transfer
  moreover have
    "\<forall>s\<subseteq>Collect (Domainp A). \<tau> s =
      SML_Topological_Space.generate_topology_on
        (lessThan_ow ?U ls ` ?U \<union> greaterThan_ow ?U ls ` ?U) ?U s"
    by
      (
        rule \<tau>'[
          unfolded co.lessThan_def co.greaterThan_def,
          folded ineq_fold,
          untransferred
          ]
       )
  ultimately show
    "order_ow ?U le ls \<and>
      (
        \<forall>s\<subseteq>Collect (Domainp A). \<tau> s =
          SML_Topological_Space.generate_topology_on
            (lessThan_ow ?U ls ` ?U \<union> greaterThan_ow ?U ls ` ?U) ?U s
      )"
    by simp
qed

end

subsubsection\<open>Relativization\<close>

context order_topology_ow
begin

tts_context
  tts: (?'a to U)
  substituting order_topology_ow_axioms
  eliminating \<open>?U \<noteq> {}\<close> through simp
begin

tts_lemma open_greaterThan:
  assumes "a \<in> U"
  shows "\<tau> {a<\<^sub>o\<^sub>w..}"
    is order_topology_class.open_greaterThan.

tts_lemma open_lessThan:
  assumes "a \<in> U"
  shows "\<tau> {..<\<^sub>o\<^sub>wa}"
  is order_topology_class.open_lessThan.

tts_lemma open_greaterThanLessThan:
  assumes "a \<in> U" and "b \<in> U"
  shows "\<tau> {a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb}"
    is order_topology_class.open_greaterThanLessThan.

end

end

subsection\<open>Linearly ordered topological space\<close>

subsubsection\<open>Definitions and common properties\<close>

locale linorder_topology_ow =
  linorder_ow U le ls + order_topology_ow U le ls \<tau>
  for U :: "'at set" and le ls \<tau>

locale ts_lt_ow =
  ts: topological_space_ow U\<^sub>1 \<tau>\<^sub>1 + lt: linorder_topology_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
  for U\<^sub>1 :: "'at set" and \<tau>\<^sub>1 and U\<^sub>2 :: "'bt set" and le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
begin

sublocale ts_ot_ow U\<^sub>1 \<tau>\<^sub>1 U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2 ..

end

locale ot_lt_ow =
  ot: order_topology_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 + lt: linorder_topology_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
  for U\<^sub>1 :: "'at set" and le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 and U\<^sub>2 :: "'bt set" and le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
begin

sublocale ts_lt_ow U\<^sub>1 \<tau>\<^sub>1 U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2 ..
sublocale order_topology_pair_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2 ..

end

locale linorder_topology_pair_ow =
  lt\<^sub>1: linorder_topology_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 + lt\<^sub>2: linorder_topology_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
  for U\<^sub>1 :: "'at set" and le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 and U\<^sub>2 :: "'bt set" and le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2
begin

sublocale ot_lt_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 \<tau>\<^sub>1 U\<^sub>2 le\<^sub>2 ls\<^sub>2 \<tau>\<^sub>2 ..

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma linorder_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (rel_set A ===> (=)) ===>
      (=)
    )
    (linorder_topology_ow (Collect (Domainp A))) class.linorder_topology"
  unfolding linorder_topology_ow_def class.linorder_topology_def
  by transfer_prover

end

subsubsection\<open>Relativization\<close>

context linorder_topology_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting linorder_topology_ow_axioms
  eliminating \<open>?U \<noteq> {}\<close> through clarsimp
begin

tts_lemma open_right:
  assumes "S \<subseteq> U"
    and "x \<in> U"
    and "y \<in> U"
    and "\<tau> S"
    and "x \<in> S"
    and "x <\<^sub>o\<^sub>w y"
  shows "\<exists>z\<in>U. x <\<^sub>o\<^sub>w z \<and> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {x..<z}) \<subseteq> S"
    is linorder_topology_class.open_right.

tts_lemma open_left:
  assumes "S \<subseteq> U"
    and "x \<in> U"
    and "y \<in> U"
    and "\<tau> S"
    and "x \<in> S"
    and "y <\<^sub>o\<^sub>w x"
  shows "\<exists>z\<in>U. z <\<^sub>o\<^sub>w x \<and> {z<\<^sub>o\<^sub>w..x} \<subseteq> S"
    is linorder_topology_class.open_left.

tts_lemma connectedD_interval:
  assumes "U \<subseteq> U"
    and "x \<in> U"
    and "y \<in> U"
    and "z \<in> U"
    and "connected U"
    and "x \<in> U"
    and "y \<in> U"
    and "x \<le>\<^sub>o\<^sub>w z"
    and "z \<le>\<^sub>o\<^sub>w y"
  shows "z \<in> U"
    is linorder_topology_class.connectedD_interval.

tts_lemma connected_contains_Icc:
  assumes "A \<subseteq> U"
    and "a \<in> U"
    and "b \<in> U"
    and "connected A"
    and "a \<in> A"
    and "b \<in> A"
  shows "{a..\<^sub>o\<^sub>wb} \<subseteq> A"
    is Topological_Spaces.connected_contains_Icc.

tts_lemma connected_contains_Ioo:
  assumes "A \<subseteq> U"
    and "a \<in> U"
    and "b \<in> U"
    and "connected A"
    and "a \<in> A"
    and "b \<in> A"
  shows "{a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb} \<subseteq> A"
    is Topological_Spaces.connected_contains_Ioo.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting linorder_topology_ow_axioms
  eliminating \<open>?U \<noteq> {}\<close> through clarsimp
begin

tts_lemma not_in_connected_cases:
  assumes "S \<subseteq> U"
    and "x \<in> U"
    and "connected S"
    and "x \<notin> S"
    and "S \<noteq> {}"
    and "\<lbrakk>bdd_above S; \<And>y. \<lbrakk>y \<in> U; y \<in> S\<rbrakk> \<Longrightarrow> y \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> thesis"
    and "\<lbrakk>bdd_below S; \<And>y. \<lbrakk>y \<in> U; y \<in> S\<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> thesis"
  shows thesis
    is linorder_topology_class.not_in_connected_cases.

tts_lemma compact_attains_sup:
  assumes "S \<subseteq> U"
    and "compact S"
    and "S \<noteq> {}"
  shows "\<exists>x\<in>S. \<forall>y\<in>S. y \<le>\<^sub>o\<^sub>w x"
    is linorder_topology_class.compact_attains_sup.

tts_lemma compact_attains_inf:
  assumes "S \<subseteq> U"
    and "compact S"
    and "S \<noteq> {}"
  shows "\<exists>x\<in>S. Ball S ((\<le>\<^sub>o\<^sub>w) x)"
    is linorder_topology_class.compact_attains_inf.

end

end

text\<open>\newpage\<close>

end


section \<open> Sequent Calculus \<close>

theory utp_sequent
  imports utp_pred_laws
begin

definition sequent :: "'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> bool" (infixr "\<tturnstile>" 15) where
[upred_defs]: "sequent P Q = (Q \<sqsubseteq> P)"

utp_lift_notation sequent

abbreviation sequent_triv ("\<tturnstile> _" [15] 15) where "\<tturnstile> P \<equiv> (true \<tturnstile> P)"

translations
  "\<tturnstile> P" <= "true \<tturnstile> P"

text \<open> Conversion of UTP sequent to Isabelle proposition \<close>

lemma sequentI: "\<lbrakk> \<And> s. \<lbrakk>\<Gamma>\<rbrakk>\<^sub>e s \<Longrightarrow> \<lbrakk>\<phi>\<rbrakk>\<^sub>e s \<rbrakk> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  by (rel_auto)

lemma sTrue: "P \<tturnstile> true"
  by pred_auto

lemma sAx: "P \<tturnstile> P"
  by pred_auto

lemma sNotI: "\<Gamma> \<and> P \<tturnstile> false \<Longrightarrow> \<Gamma> \<tturnstile> \<not> P"
  by pred_auto

lemma sConjI: "\<lbrakk> \<Gamma> \<tturnstile> P; \<Gamma> \<tturnstile> Q \<rbrakk> \<Longrightarrow> \<Gamma> \<tturnstile> P \<and> Q"
  by pred_auto

lemma sImplI: "\<lbrakk> P \<and> \<Gamma> \<tturnstile> Q \<rbrakk> \<Longrightarrow> \<Gamma> \<tturnstile> (P \<Rightarrow> Q)"
  by pred_auto

lemma sAsmDisj:
  "\<lbrakk> A \<tturnstile> C; B \<tturnstile> C \<rbrakk> \<Longrightarrow> A \<or> B \<tturnstile> C"
  by (rel_auto)

lemma sDisjI1: "P \<tturnstile> Q \<Longrightarrow> P \<tturnstile> (Q \<or> R)"
  by (rel_auto)

lemma sDisjI2: "P \<tturnstile> R \<Longrightarrow> P \<tturnstile> (Q \<or> R)"
  by (rel_auto)

lemma sVarEqI:
  assumes "wb_lens x" "(&x = v \<and> P) \<tturnstile> (Q\<lbrakk>v/&x\<rbrakk>)"
  shows "(&x = v \<and> P) \<tturnstile> Q"
  using assms by (rel_simp, metis wb_lens.get_put)

lemma sWk: "\<lbrakk> `Q \<Rightarrow> P`; P \<tturnstile> R \<rbrakk> \<Longrightarrow> Q \<tturnstile> R"
  by (rel_auto)

lemma sWk1: "P \<tturnstile> R \<Longrightarrow> P \<and> Q \<tturnstile> R"
  by (rel_auto)

lemma sWk2: "Q \<tturnstile> R \<Longrightarrow> P \<and> Q \<tturnstile> R"
  by (rel_auto)

end


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

The proof of AC16(n, k) \<Longrightarrow> WO4(n-k)

Tidied (using locales) by LCP
*)

theory AC16_WO4
imports AC16_lemmas
begin

(* ********************************************************************** *)
(* The case of finite set                                                 *)
(* ********************************************************************** *)

lemma lemma1:
     "\<lbrakk>Finite(A); 0<m; m \<in> nat\<rbrakk>
      \<Longrightarrow> \<exists>a f. Ord(a) \<and> domain(f) = a \<and>
                (\<Union>b<a. f`b) = A \<and> (\<forall>b<a. f`b \<lesssim> m)"
  unfolding Finite_def
apply (erule bexE)
apply (drule eqpoll_sym [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]])
apply (erule exE)
apply (rule_tac x = n in exI)
apply (rule_tac x = "\<lambda>i \<in> n. {f`i}" in exI)
apply (simp add: ltD bij_def surj_def)
apply (fast intro!: ltI nat_into_Ord lam_funtype [THEN domain_of_fun]
               singleton_eqpoll_1 [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
                    nat_1_lepoll_iff [THEN iffD2]
          elim!: apply_type ltE)
done

(* ********************************************************************** *)
(* The case of infinite set                                               *)
(* ********************************************************************** *)

(* well_ord(x,r) \<Longrightarrow> well_ord({{y,z}. y \<in> x}, Something(x,z))  **)
lemmas well_ord_paired = paired_bij [THEN bij_is_inj, THEN well_ord_rvimage]

lemma lepoll_trans1: "\<lbrakk>A \<lesssim> B; \<not> A \<lesssim> C\<rbrakk> \<Longrightarrow> \<not> B \<lesssim> C"
by (blast intro: lepoll_trans)

(* ********************************************************************** *)
(* There exists a well ordered set y such that ...                        *)
(* ********************************************************************** *)

lemmas lepoll_paired = paired_eqpoll [THEN eqpoll_sym, THEN eqpoll_imp_lepoll]

lemma lemma2: "\<exists>y R. well_ord(y,R) \<and> x \<inter> y = 0 \<and> \<not>y \<lesssim> z \<and> \<not>Finite(y)"
apply (rule_tac x = "{{a,x}. a \<in> nat \<union> Hartog (z) }" in exI)
apply (rule well_ord_Un [OF Ord_nat [THEN well_ord_Memrel]
                         Ord_Hartog [THEN well_ord_Memrel], THEN exE])
apply (blast intro!: Ord_Hartog well_ord_Memrel well_ord_paired
                      lepoll_trans1 [OF _ not_Hartog_lepoll_self]
                      lepoll_trans [OF subset_imp_lepoll lepoll_paired]
       elim!: nat_not_Finite [THEN notE]
       elim: mem_asym
       dest!: Un_upper1 [THEN subset_imp_lepoll, THEN lepoll_Finite]
              lepoll_paired [THEN lepoll_Finite])
done

lemma infinite_Un: "\<not>Finite(B) \<Longrightarrow> \<not>Finite(A \<union> B)"
by (blast intro: subset_Finite)

(* ********************************************************************** *)
(* There is a v \<in> s(u) such that k \<lesssim> x \<inter> y (in our case succ(k))    *)
(* The idea of the proof is the following \<in>                               *)
(* Suppose not, i.e. every element of s(u) has exactly k-1 elements of y   *)
(* Thence y is less than or equipollent to {v \<in> Pow(x). v \<approx> n#-k}      *)
(*   We have obtained this result in two steps \<in>                          *)
(*   1. y is less than or equipollent to {v \<in> s(u). a \<subseteq> v}                  *)
(*      where a is certain k-2 element subset of y                        *)
(*   2. {v \<in> s(u). a \<subseteq> v} is less than or equipollent                       *)
(*      to {v \<in> Pow(x). v \<approx> n-k}                                       *)
(* ********************************************************************** *)

(*Proof simplified by LCP*)
lemma succ_not_lepoll_lemma:
     "\<lbrakk>\<not>(\<exists>x \<in> A. f`x=y); f \<in> inj(A, B); y \<in> B\<rbrakk>
      \<Longrightarrow> (\<lambda>a \<in> succ(A). if(a=A, y, f`a)) \<in> inj(succ(A), B)"
apply (rule_tac d = "\<lambda>z. if (z=y, A, converse (f) `z) " in lam_injective)
apply (force simp add: inj_is_fun [THEN apply_type])
(*this preliminary simplification prevents looping somehow*)
apply (simp (no_asm_simp))
apply force
done

lemma succ_not_lepoll_imp_eqpoll: "\<lbrakk>\<not>A \<approx> B; A \<lesssim> B\<rbrakk> \<Longrightarrow> succ(A) \<lesssim> B"
  unfolding lepoll_def eqpoll_def bij_def surj_def
apply (fast elim!: succ_not_lepoll_lemma inj_is_fun)
done

(* ********************************************************************** *)
(* There is a k-2 element subset of y                                     *)
(* ********************************************************************** *)

lemmas ordertype_eqpoll =
       ordermap_bij [THEN exI [THEN eqpoll_def [THEN def_imp_iff, THEN iffD2]]]

lemma cons_cons_subset:
     "\<lbrakk>a \<subseteq> y; b \<in> y-a; u \<in> x\<rbrakk> \<Longrightarrow> cons(b, cons(u, a)) \<in> Pow(x \<union> y)"
by fast

lemma cons_cons_eqpoll:
     "\<lbrakk>a \<approx> k; a \<subseteq> y; b \<in> y-a; u \<in> x; x \<inter> y = 0\<rbrakk>
      \<Longrightarrow> cons(b, cons(u, a)) \<approx> succ(succ(k))"
by (fast intro!: cons_eqpoll_succ)

lemma set_eq_cons:
     "\<lbrakk>succ(k) \<approx> A; k \<approx> B; B \<subseteq> A; a \<in> A-B; k \<in> nat\<rbrakk> \<Longrightarrow> A = cons(a, B)"
apply (rule equalityI)
prefer 2 apply fast
apply (rule Diff_eq_0_iff [THEN iffD1])
apply (rule equals0I)
apply (drule eqpoll_sym [THEN eqpoll_imp_lepoll])
apply (drule eqpoll_sym [THEN cons_eqpoll_succ], fast)
apply (drule cons_eqpoll_succ, fast)
apply (fast elim!: lepoll_trans [THEN lepoll_trans, THEN succ_lepoll_natE,
         OF eqpoll_sym [THEN eqpoll_imp_lepoll] subset_imp_lepoll])
done

lemma cons_eqE: "\<lbrakk>cons(x,a) = cons(y,a); x \<notin> a\<rbrakk> \<Longrightarrow> x = y "
by (fast elim!: equalityE)

lemma eq_imp_Int_eq: "A = B \<Longrightarrow> A \<inter> C = B \<inter> C"
by blast

(* ********************************************************************** *)
(* some arithmetic                                                        *)
(* ********************************************************************** *)

lemma eqpoll_sum_imp_Diff_lepoll_lemma [rule_format]:
     "\<lbrakk>k \<in> nat; m \<in> nat\<rbrakk>
      \<Longrightarrow> \<forall>A B. A \<approx> k #+ m \<and> k \<lesssim> B \<and> B \<subseteq> A \<longrightarrow> A-B \<lesssim> m"
apply (induct_tac "k")
apply (simp add: add_0)
apply (blast intro: eqpoll_imp_lepoll lepoll_trans
                    Diff_subset [THEN subset_imp_lepoll])
apply (intro allI impI)
apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE], fast)
apply (erule_tac x = "A - {xa}" in allE)
apply (erule_tac x = "B - {xa}" in allE)
apply (erule impE)
apply (simp add: add_succ)
apply (fast intro!: Diff_sing_eqpoll lepoll_Diff_sing)
apply (subgoal_tac "A - {xa} - (B - {xa}) = A - B", simp)
apply blast
done

lemma eqpoll_sum_imp_Diff_lepoll:
     "\<lbrakk>A \<approx> succ(k #+ m); B \<subseteq> A; succ(k) \<lesssim> B;  k \<in> nat; m \<in> nat\<rbrakk>
      \<Longrightarrow> A-B \<lesssim> m"
apply (simp only: add_succ [symmetric])
apply (blast intro: eqpoll_sum_imp_Diff_lepoll_lemma)
done

(* ********************************************************************** *)
(* similar properties for \<approx>                                          *)
(* ********************************************************************** *)

lemma eqpoll_sum_imp_Diff_eqpoll_lemma [rule_format]:
     "\<lbrakk>k \<in> nat; m \<in> nat\<rbrakk>
      \<Longrightarrow> \<forall>A B. A \<approx> k #+ m \<and> k \<approx> B \<and> B \<subseteq> A \<longrightarrow> A-B \<approx> m"
apply (induct_tac "k")
apply (force dest!: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_0_is_0])
apply (intro allI impI)
apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE])
apply (fast elim!: eqpoll_imp_lepoll)
apply (erule_tac x = "A - {xa}" in allE)
apply (erule_tac x = "B - {xa}" in allE)
apply (erule impE)
apply (force intro: eqpoll_sym intro!: Diff_sing_eqpoll)
apply (subgoal_tac "A - {xa} - (B - {xa}) = A - B", simp)
apply blast
done

lemma eqpoll_sum_imp_Diff_eqpoll:
     "\<lbrakk>A \<approx> succ(k #+ m); B \<subseteq> A; succ(k) \<approx> B; k \<in> nat; m \<in> nat\<rbrakk>
      \<Longrightarrow> A-B \<approx> m"
apply (simp only: add_succ [symmetric])
apply (blast intro: eqpoll_sum_imp_Diff_eqpoll_lemma)
done

(* ********************************************************************** *)
(* LL can be well ordered                                                 *)
(* ********************************************************************** *)

lemma subsets_lepoll_0_eq_unit: "{x \<in> Pow(X). x \<lesssim> 0} = {0}"
by (fast dest!: lepoll_0_is_0 intro!: lepoll_refl)

lemma subsets_lepoll_succ:
     "n \<in> nat \<Longrightarrow> {z \<in> Pow(y). z \<lesssim> succ(n)} =
                  {z \<in> Pow(y). z \<lesssim> n} \<union> {z \<in> Pow(y). z \<approx> succ(n)}"
by (blast intro: leI le_imp_lepoll nat_into_Ord
                    lepoll_trans eqpoll_imp_lepoll
          dest!: lepoll_succ_disj)

lemma Int_empty:
     "n \<in> nat \<Longrightarrow> {z \<in> Pow(y). z \<lesssim> n} \<inter> {z \<in> Pow(y). z \<approx> succ(n)} = 0"
by (blast intro: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
                 succ_lepoll_natE)

locale AC16 =
  fixes x and y and k and l and m and t_n and R and MM and LL and GG and s
  defines k_def:     "k   \<equiv> succ(l)"
      and MM_def:    "MM  \<equiv> {v \<in> t_n. succ(k) \<lesssim> v \<inter> y}"
      and LL_def:    "LL  \<equiv> {v \<inter> y. v \<in> MM}"
      and GG_def:    "GG  \<equiv> \<lambda>v \<in> LL. (THE w. w \<in> MM \<and> v \<subseteq> w) - v"
      and s_def:     "s(u) \<equiv> {v \<in> t_n. u \<in> v \<and> k \<lesssim> v \<inter> y}"
  assumes all_ex:    "\<forall>z \<in> {z \<in> Pow(x \<union> y) . z \<approx> succ(k)}.
                       \<exists>! w. w \<in> t_n \<and> z \<subseteq> w "
    and disjoint[iff]:  "x \<inter> y = 0"
    and "includes":  "t_n \<subseteq> {v \<in> Pow(x \<union> y). v \<approx> succ(k #+ m)}"
    and WO_R[iff]:      "well_ord(y,R)"
    and lnat[iff]:      "l \<in> nat"
    and mnat[iff]:      "m \<in> nat"
    and mpos[iff]:      "0<m"
    and Infinite[iff]:  "\<not> Finite(y)"
    and noLepoll:  "\<not> y \<lesssim> {v \<in> Pow(x). v \<approx> m}"
begin

lemma knat [iff]: "k \<in> nat"
by (simp add: k_def)

(* ********************************************************************** *)
(*   1. y is less than or equipollent to {v \<in> s(u). a \<subseteq> v}                *)
(*      where a is certain k-2 element subset of y                        *)
(* ********************************************************************** *)

lemma Diff_Finite_eqpoll: "\<lbrakk>l \<approx> a; a \<subseteq> y\<rbrakk> \<Longrightarrow> y - a \<approx> y"
apply (insert WO_R Infinite lnat)
apply (rule eqpoll_trans)
apply (rule Diff_lesspoll_eqpoll_Card)
apply (erule well_ord_cardinal_eqpoll [THEN eqpoll_sym])
apply (blast intro: lesspoll_trans1
            intro!: Card_cardinal
                    Card_cardinal [THEN Card_is_Ord, THEN nat_le_infinite_Ord,
                                   THEN le_imp_lepoll]
            dest: well_ord_cardinal_eqpoll
                   eqpoll_sym  eqpoll_imp_lepoll
                   n_lesspoll_nat [THEN lesspoll_trans2]
                   well_ord_cardinal_eqpoll [THEN eqpoll_sym,
                          THEN eqpoll_imp_lepoll, THEN lepoll_infinite])+
done

lemma s_subset: "s(u) \<subseteq> t_n"
by (unfold s_def, blast)

lemma sI:
      "\<lbrakk>w \<in> t_n; cons(b,cons(u,a)) \<subseteq> w; a \<subseteq> y; b \<in> y-a; l \<approx> a\<rbrakk>
       \<Longrightarrow> w \<in> s(u)"
  unfolding s_def succ_def k_def
apply (blast intro!: eqpoll_imp_lepoll [THEN cons_lepoll_cong]
             intro: subset_imp_lepoll lepoll_trans)
done

lemma in_s_imp_u_in: "v \<in> s(u) \<Longrightarrow> u \<in> v"
by (unfold s_def, blast)

lemma ex1_superset_a:
     "\<lbrakk>l \<approx> a;  a \<subseteq> y;  b \<in> y - a;  u \<in> x\<rbrakk>
      \<Longrightarrow> \<exists>! c. c \<in> s(u) \<and> a \<subseteq> c \<and> b \<in> c"
apply (rule all_ex [simplified k_def, THEN ballE])
 apply (erule ex1E)
 apply (rule_tac a = w in ex1I, blast intro: sI)
 apply (blast dest: s_subset [THEN subsetD] in_s_imp_u_in)
apply (blast del: PowI
             intro!: cons_cons_subset eqpoll_sym [THEN cons_cons_eqpoll])
done

lemma the_eq_cons:
     "\<lbrakk>\<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y;
         l \<approx> a;  a \<subseteq> y;  b \<in> y - a;  u \<in> x\<rbrakk>
      \<Longrightarrow> (THE c. c \<in> s(u) \<and> a \<subseteq> c \<and> b \<in> c) \<inter> y = cons(b, a)"
apply (frule ex1_superset_a [THEN theI], assumption+)
apply (rule set_eq_cons)
apply (fast+)
done

lemma y_lepoll_subset_s:
     "\<lbrakk>\<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y;
         l \<approx> a;  a \<subseteq> y;  u \<in> x\<rbrakk>
      \<Longrightarrow> y \<lesssim> {v \<in> s(u). a \<subseteq> v}"
apply (rule Diff_Finite_eqpoll [THEN eqpoll_sym, THEN eqpoll_imp_lepoll,
                                THEN lepoll_trans],  fast+)
apply (rule_tac  f3 = "\<lambda>b \<in> y-a. THE c. c \<in> s (u) \<and> a \<subseteq> c \<and> b \<in> c"
        in exI [THEN lepoll_def [THEN def_imp_iff, THEN iffD2]])
apply (simp add: inj_def)
apply (rule conjI)
apply (rule lam_type)
apply (frule ex1_superset_a [THEN theI], fast+, clarify)
apply (rule cons_eqE [of _ a])
apply (drule_tac A = "THE c. P (c)" and C = y for P in eq_imp_Int_eq)
apply (simp_all add: the_eq_cons)
done

(* ********************************************************************** *)
(* back to the second part                                                *)
(* ********************************************************************** *)

(*relies on the disjointness of x, y*)
lemma x_imp_not_y [dest]: "a \<in> x \<Longrightarrow> a \<notin> y"
by (blast dest:  disjoint [THEN equalityD1, THEN subsetD, OF IntI])

lemma w_Int_eq_w_Diff:
     "w \<subseteq> x \<union> y \<Longrightarrow> w \<inter> (x - {u}) = w - cons(u, w \<inter> y)"
by blast

lemma w_Int_eqpoll_m:
     "\<lbrakk>w \<in> {v \<in> s(u). a \<subseteq> v};
         l \<approx> a;  u \<in> x;
         \<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y\<rbrakk>
      \<Longrightarrow> w \<inter> (x - {u}) \<approx> m"
apply (erule CollectE)
apply (subst w_Int_eq_w_Diff)
apply (fast dest!: s_subset [THEN subsetD]
                   "includes" [simplified k_def, THEN subsetD])
apply (blast dest: s_subset [THEN subsetD]
                   "includes" [simplified k_def, THEN subsetD]
             dest: eqpoll_sym [THEN cons_eqpoll_succ, THEN eqpoll_sym]
                   in_s_imp_u_in
            intro!: eqpoll_sum_imp_Diff_eqpoll)
done

(* ********************************************************************** *)
(*   2. {v \<in> s(u). a \<subseteq> v} is less than or equipollent                       *)
(*      to {v \<in> Pow(x). v \<approx> n-k}                                       *)
(* ********************************************************************** *)

lemma eqpoll_m_not_empty: "a \<approx> m \<Longrightarrow> a \<noteq> 0"
apply (insert mpos)
apply (fast elim!: zero_lt_natE dest!: eqpoll_succ_imp_not_empty)
done

lemma cons_cons_in:
     "\<lbrakk>z \<in> xa \<inter> (x - {u}); l \<approx> a; a \<subseteq> y; u \<in> x\<rbrakk>
      \<Longrightarrow> \<exists>! w. w \<in> t_n \<and> cons(z, cons(u, a)) \<subseteq> w"
apply (rule all_ex [THEN bspec])
  unfolding k_def
apply (fast intro!: cons_eqpoll_succ elim: eqpoll_sym)
done

lemma subset_s_lepoll_w:
     "\<lbrakk>\<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y; a \<subseteq> y; l \<approx> a; u \<in> x\<rbrakk>
      \<Longrightarrow> {v \<in> s(u). a \<subseteq> v} \<lesssim> {v \<in> Pow(x). v \<approx> m}"
apply (rule_tac f3 = "\<lambda>w \<in> {v \<in> s (u) . a \<subseteq> v}. w \<inter> (x - {u})"
       in exI [THEN lepoll_def [THEN def_imp_iff, THEN iffD2]])
apply (simp add: inj_def)
apply (intro conjI lam_type CollectI)
  apply fast
 apply (blast intro: w_Int_eqpoll_m)
apply (intro ballI impI)
(** LEVEL 8 **)
apply (rule w_Int_eqpoll_m [THEN eqpoll_m_not_empty, THEN not_emptyE])
apply (blast, assumption+)
apply (drule equalityD1 [THEN subsetD], assumption)
apply (frule cons_cons_in, assumption+)
apply (blast dest: ex1_two_eq intro: s_subset [THEN subsetD] in_s_imp_u_in)+
done

(* ********************************************************************** *)
(* well_ord_subsets_lepoll_n                                              *)
(* ********************************************************************** *)

lemma well_ord_subsets_eqpoll_n:
     "n \<in> nat \<Longrightarrow> \<exists>S. well_ord({z \<in> Pow(y) . z \<approx> succ(n)}, S)"
apply (rule WO_R [THEN well_ord_infinite_subsets_eqpoll_X,
                  THEN eqpoll_def [THEN def_imp_iff, THEN iffD1], THEN exE])
apply (fast intro: bij_is_inj [THEN well_ord_rvimage])+
done

lemma well_ord_subsets_lepoll_n:
     "n \<in> nat \<Longrightarrow> \<exists>R. well_ord({z \<in> Pow(y). z \<lesssim> n}, R)"
apply (induct_tac "n")
apply (force intro!: well_ord_unit simp add: subsets_lepoll_0_eq_unit)
apply (erule exE)
apply (rule well_ord_subsets_eqpoll_n [THEN exE], assumption)
apply (simp add: subsets_lepoll_succ)
apply (drule well_ord_radd, assumption)
apply (erule Int_empty [THEN disj_Un_eqpoll_sum,
                  THEN eqpoll_def [THEN def_imp_iff, THEN iffD1], THEN exE])
apply (fast elim!: bij_is_inj [THEN well_ord_rvimage])
done

lemma LL_subset: "LL \<subseteq> {z \<in> Pow(y). z \<lesssim> succ(k #+ m)}"
  unfolding LL_def MM_def
apply (insert "includes")
apply (blast intro: subset_imp_lepoll eqpoll_imp_lepoll lepoll_trans)
done

lemma well_ord_LL: "\<exists>S. well_ord(LL,S)"
apply (rule well_ord_subsets_lepoll_n [THEN exE, of "succ(k#+m)"])
apply simp
apply (blast intro: well_ord_subset [OF _ LL_subset])
done

(* ********************************************************************** *)
(* every element of LL is a contained in exactly one element of MM        *)
(* ********************************************************************** *)

lemma unique_superset_in_MM:
     "v \<in> LL \<Longrightarrow> \<exists>! w. w \<in> MM \<and> v \<subseteq> w"
apply (unfold MM_def LL_def, safe, fast)
apply (rule lepoll_imp_eqpoll_subset [THEN exE], assumption)
apply (rule_tac x = x in all_ex [THEN ballE])
apply (blast intro: eqpoll_sym)+
done

(* ********************************************************************** *)
(* The function GG satisfies the conditions of WO4                        *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(* The union of appropriate values is the whole x                         *)
(* ********************************************************************** *)

lemma Int_in_LL: "w \<in> MM \<Longrightarrow> w \<inter> y \<in> LL"
by (unfold LL_def, fast)

lemma in_LL_eq_Int:
     "v \<in> LL \<Longrightarrow> v = (THE x. x \<in> MM \<and> v \<subseteq> x) \<inter> y"
apply (unfold LL_def, clarify)
apply (subst unique_superset_in_MM [THEN the_equality2])
apply (auto simp add: Int_in_LL)
done

lemma unique_superset1: "a \<in> LL \<Longrightarrow> (THE x. x \<in> MM \<and> a \<subseteq> x) \<in> MM"
by (erule unique_superset_in_MM [THEN theI, THEN conjunct1])

lemma the_in_MM_subset:
     "v \<in> LL \<Longrightarrow> (THE x. x \<in> MM \<and> v \<subseteq> x) \<subseteq> x \<union> y"
apply (drule unique_superset1)
  unfolding MM_def
apply (fast dest!: unique_superset1 "includes" [THEN subsetD])
done

lemma GG_subset: "v \<in> LL \<Longrightarrow> GG ` v \<subseteq> x"
  unfolding GG_def
apply (frule the_in_MM_subset)
apply (frule in_LL_eq_Int)
apply (force elim: equalityE)
done

lemma nat_lepoll_ordertype: "nat \<lesssim> ordertype(y, R)"
apply (rule nat_le_infinite_Ord [THEN le_imp_lepoll])
 apply (rule Ord_ordertype [OF WO_R])
apply (rule ordertype_eqpoll [THEN eqpoll_imp_lepoll, THEN lepoll_infinite])
 apply (rule WO_R)
apply (rule Infinite)
done

lemma ex_subset_eqpoll_n: "n \<in> nat \<Longrightarrow> \<exists>z. z \<subseteq> y \<and> n \<approx> z"
apply (erule nat_lepoll_imp_ex_eqpoll_n)
apply (rule lepoll_trans [OF nat_lepoll_ordertype])
apply (rule ordertype_eqpoll [THEN eqpoll_sym, THEN eqpoll_imp_lepoll])
apply (rule WO_R)
done

lemma exists_proper_in_s: "u \<in> x \<Longrightarrow> \<exists>v \<in> s(u). succ(k) \<lesssim> v \<inter> y"
apply (rule ccontr)
apply (subgoal_tac "\<forall>v \<in> s (u) . k \<approx> v \<inter> y")
prefer 2 apply (simp add: s_def, blast intro: succ_not_lepoll_imp_eqpoll)
  unfolding k_def
apply (insert all_ex "includes" lnat)
apply (rule ex_subset_eqpoll_n [THEN exE], assumption)
apply (rule noLepoll [THEN notE])
apply (blast intro: lepoll_trans [OF y_lepoll_subset_s subset_s_lepoll_w])
done

lemma exists_in_MM: "u \<in> x \<Longrightarrow> \<exists>w \<in> MM. u \<in> w"
apply (erule exists_proper_in_s [THEN bexE])
apply (unfold MM_def s_def, fast)
done

lemma exists_in_LL: "u \<in> x \<Longrightarrow> \<exists>w \<in> LL. u \<in> GG`w"
apply (rule exists_in_MM [THEN bexE], assumption)
apply (rule bexI)
apply (erule_tac [2] Int_in_LL)
  unfolding GG_def
apply (simp add: Int_in_LL)
apply (subst unique_superset_in_MM [THEN the_equality2])
apply (fast elim!: Int_in_LL)+
done

lemma OUN_eq_x: "well_ord(LL,S) \<Longrightarrow>
      (\<Union>b<ordertype(LL,S). GG ` (converse(ordermap(LL,S)) ` b)) = x"
apply (rule equalityI)
apply (rule subsetI)
apply (erule OUN_E)
apply (rule GG_subset [THEN subsetD])
prefer 2 apply assumption
apply (blast intro: ltD  ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun,
                                       THEN apply_type])
apply (rule subsetI)
apply (erule exists_in_LL [THEN bexE])
apply (force intro: ltI [OF _ Ord_ordertype]
                    ordermap_type [THEN apply_type]
             simp add: ordermap_bij [THEN bij_is_inj, THEN left_inverse])
done

(* ********************************************************************** *)
(* Every element of the family is less than or equipollent to n-k (m)     *)
(* ********************************************************************** *)

lemma in_MM_eqpoll_n: "w \<in> MM \<Longrightarrow> w \<approx> succ(k #+ m)"
  unfolding MM_def
apply (fast dest: "includes" [THEN subsetD])
done

lemma in_LL_eqpoll_n: "w \<in> LL \<Longrightarrow> succ(k) \<lesssim> w"
by (unfold LL_def MM_def, fast)

lemma in_LL: "w \<in> LL \<Longrightarrow> w \<subseteq> (THE x. x \<in> MM \<and> w \<subseteq> x)"
by (erule subset_trans [OF in_LL_eq_Int [THEN equalityD1] Int_lower1])

lemma all_in_lepoll_m:
      "well_ord(LL,S) \<Longrightarrow>
       \<forall>b<ordertype(LL,S). GG ` (converse(ordermap(LL,S)) ` b) \<lesssim> m"
  unfolding GG_def
apply (rule oallI)
apply (simp add: ltD ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun, THEN apply_type])
apply (insert "includes")
apply (rule eqpoll_sum_imp_Diff_lepoll)
apply (blast del: subsetI
             dest!: ltD
             intro!: eqpoll_sum_imp_Diff_lepoll in_LL_eqpoll_n
             intro: in_LL   unique_superset1 [THEN in_MM_eqpoll_n]
                    ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun,
                                  THEN apply_type])+
done

lemma "conclusion":
     "\<exists>a f. Ord(a) \<and> domain(f) = a \<and> (\<Union>b<a. f ` b) = x \<and> (\<forall>b<a. f ` b \<lesssim> m)"
apply (rule well_ord_LL [THEN exE])
apply (rename_tac S)
apply (rule_tac x = "ordertype (LL,S)" in exI)
apply (rule_tac x = "\<lambda>b \<in> ordertype(LL,S).
                      GG ` (converse (ordermap (LL,S)) ` b)"  in exI)
apply (simp add: ltD)
apply (blast intro: lam_funtype [THEN domain_of_fun]
                    Ord_ordertype  OUN_eq_x  all_in_lepoll_m [THEN ospec])
done

end

(* ********************************************************************** *)
(* The main theorem AC16(n, k) \<Longrightarrow> WO4(n-k)                               *)
(* ********************************************************************** *)

theorem AC16_WO4:
     "\<lbrakk>AC_Equiv.AC16(k #+ m, k); 0 < k; 0 < m; k \<in> nat; m \<in> nat\<rbrakk> \<Longrightarrow> WO4(m)"
  unfolding AC_Equiv.AC16_def WO4_def
apply (rule allI)
apply (case_tac "Finite (A)")
apply (rule lemma1, assumption+)
apply (cut_tac lemma2)
apply (elim exE conjE)
apply (erule_tac x = "A \<union> y" in allE)
apply (frule infinite_Un, drule mp, assumption)
apply (erule zero_lt_natE, assumption, clarify)
apply (blast intro: AC16.conclusion [OF AC16.intro])
done

end