(*  Title:      ZF/List_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*Lists in Zermelo-Fraenkel Set Theory*}

theory List_ZF imports Datatype_ZF ArithSimp begin

consts
  list       :: "i=>i"

datatype
  "list(A)" = Nil | Cons ("a \<in> A", "l \<in> list(A)")

syntax
 "_Nil" :: i  ("[]")
 "_List" :: "is => i"  ("[(_)]")

translations
  "[x, xs]"     == "CONST Cons(x, [xs])"
  "[x]"         == "CONST Cons(x, [])"
  "[]"          == "CONST Nil"

consts
  length :: "i=>i"
  hd     :: "i=>i"
  tl     :: "i=>i"

primrec
  "length([]) = 0"
  "length(Cons(a,l)) = succ(length(l))"

primrec
  "hd([]) = 0"
  "hd(Cons(a,l)) = a"

primrec
  "tl([]) = []"
  "tl(Cons(a,l)) = l"

consts
  map         :: "[i=>i, i] => i"
  set_of_list :: "i=>i"
  app         :: "[i,i]=>i"                        (infixr "@" 60)

(*map is a binding operator -- it applies to meta-level functions, not
object-level functions.  This simplifies the final form of term_rec_conv,
although complicating its derivation.*)
primrec
  "map(f,[]) = []"
  "map(f,Cons(a,l)) = Cons(f(a), map(f,l))"

primrec
  "set_of_list([]) = 0"
  "set_of_list(Cons(a,l)) = cons(a, set_of_list(l))"

primrec
  app_Nil:  "[] @ ys = ys"
  app_Cons: "(Cons(a,l)) @ ys = Cons(a, l @ ys)"

consts
  rev :: "i=>i"
  flat       :: "i=>i"
  list_add   :: "i=>i"

primrec
  "rev([]) = []"
  "rev(Cons(a,l)) = rev(l) @ [a]"

primrec
  "flat([]) = []"
  "flat(Cons(l,ls)) = l @ flat(ls)"

primrec
  "list_add([]) = 0"
  "list_add(Cons(a,l)) = a #+ list_add(l)"

consts
  drop       :: "[i,i]=>i"

primrec
  drop_0:    "drop(0,l) = l"
  drop_succ: "drop(succ(i), l) = tl (drop(i,l))"

(*** Thanks to Sidi Ehmety for the following ***)

definition
(* Function `take' returns the first n elements of a list *)
  take     :: "[i,i]=>i"  where
  "take(n, as) == list_rec(\<lambda>n\<in>nat. [],
                %a l r. \<lambda>n\<in>nat. nat_case([], %m. Cons(a, r`m), n), as)`n"

definition
  nth :: "[i, i]=>i"  where
  --{*returns the (n+1)th element of a list, or 0 if the
   list is too short.*}
  "nth(n, as) == list_rec(\<lambda>n\<in>nat. 0,
                          %a l r. \<lambda>n\<in>nat. nat_case(a, %m. r`m, n), as) ` n"

definition
  list_update :: "[i, i, i]=>i"  where
  "list_update(xs, i, v) == list_rec(\<lambda>n\<in>nat. Nil,
      %u us vs. \<lambda>n\<in>nat. nat_case(Cons(v, us), %m. Cons(u, vs`m), n), xs)`i"

consts
  filter :: "[i=>o, i] => i"
  upt :: "[i, i] =>i"

primrec
  "filter(P, Nil) = Nil"
  "filter(P, Cons(x, xs)) =
     (if P(x) then Cons(x, filter(P, xs)) else filter(P, xs))"

primrec
  "upt(i, 0) = Nil"
  "upt(i, succ(j)) = (if i \<le> j then upt(i, j)@[j] else Nil)"

definition
  min :: "[i,i] =>i"  where
    "min(x, y) == (if x \<le> y then x else y)"

definition
  max :: "[i, i] =>i"  where
    "max(x, y) == (if x \<le> y then y else x)"

(*** Aspects of the datatype definition ***)

declare list.intros [simp,TC]

(*An elimination rule, for type-checking*)
inductive_cases ConsE: "Cons(a,l) \<in> list(A)"

lemma Cons_type_iff [simp]: "Cons(a,l) \<in> list(A) \<longleftrightarrow> a \<in> A & l \<in> list(A)"
by (blast elim: ConsE)

(*Proving freeness results*)
lemma Cons_iff: "Cons(a,l)=Cons(a',l') \<longleftrightarrow> a=a' & l=l'"
by auto

lemma Nil_Cons_iff: "~ Nil=Cons(a,l)"
by auto

lemma list_unfold: "list(A) = {0} + (A * list(A))"
by (blast intro!: list.intros [unfolded list.con_defs]
          elim: list.cases [unfolded list.con_defs])

(**  Lemmas to justify using "list" in other recursive type definitions **)

lemma list_mono: "A<=B ==> list(A) \<subseteq> list(B)"
apply (unfold list.defs )
apply (rule lfp_mono)
apply (simp_all add: list.bnd_mono)
apply (assumption | rule univ_mono basic_monos)+
done

(*There is a similar proof by list induction.*)
lemma list_univ: "list(univ(A)) \<subseteq> univ(A)"
apply (unfold list.defs list.con_defs)
apply (rule lfp_lowerbound)
apply (rule_tac [2] A_subset_univ [THEN univ_mono])
apply (blast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
done

(*These two theorems justify datatypes involving list(nat), list(A), ...*)
lemmas list_subset_univ = subset_trans [OF list_mono list_univ]

lemma list_into_univ: "[| l \<in> list(A);  A \<subseteq> univ(B) |] ==> l \<in> univ(B)"
by (blast intro: list_subset_univ [THEN subsetD])

lemma list_case_type:
    "[| l \<in> list(A);
        c \<in> C(Nil);
        !!x y. [| x \<in> A;  y \<in> list(A) |] ==> h(x,y): C(Cons(x,y))
     |] ==> list_case(c,h,l) \<in> C(l)"
by (erule list.induct, auto)

lemma list_0_triv: "list(0) = {Nil}"
apply (rule equalityI, auto)
apply (induct_tac x, auto)
done

(*** List functions ***)

lemma tl_type: "l \<in> list(A) ==> tl(l) \<in> list(A)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: list.intros)
done

(** drop **)

lemma drop_Nil [simp]: "i \<in> nat ==> drop(i, Nil) = Nil"
apply (induct_tac "i")
apply (simp_all (no_asm_simp))
done

lemma drop_succ_Cons [simp]: "i \<in> nat ==> drop(succ(i), Cons(a,l)) = drop(i,l)"
apply (rule sym)
apply (induct_tac "i")
apply (simp (no_asm))
apply (simp (no_asm_simp))
done

lemma drop_type [simp,TC]: "[| i \<in> nat; l \<in> list(A) |] ==> drop(i,l) \<in> list(A)"
apply (induct_tac "i")
apply (simp_all (no_asm_simp) add: tl_type)
done

declare drop_succ [simp del]

(** Type checking -- proved by induction, as usual **)

lemma list_rec_type [TC]:
    "[| l \<in> list(A);
        c \<in> C(Nil);
        !!x y r. [| x \<in> A;  y \<in> list(A);  r \<in> C(y) |] ==> h(x,y,r): C(Cons(x,y))
     |] ==> list_rec(c,h,l) \<in> C(l)"
by (induct_tac "l", auto)

(** map **)

lemma map_type [TC]:
    "[| l \<in> list(A);  !!x. x \<in> A ==> h(x): B |] ==> map(h,l) \<in> list(B)"
apply (simp add: map_list_def)
apply (typecheck add: list.intros list_rec_type, blast)
done

lemma map_type2 [TC]: "l \<in> list(A) ==> map(h,l) \<in> list({h(u). u \<in> A})"
apply (erule map_type)
apply (erule RepFunI)
done

(** length **)

lemma length_type [TC]: "l \<in> list(A) ==> length(l) \<in> nat"
by (simp add: length_list_def)

lemma lt_length_in_nat:
   "[|x < length(xs); xs \<in> list(A)|] ==> x \<in> nat"
by (frule lt_nat_in_nat, typecheck)

(** app **)

lemma app_type [TC]: "[| xs: list(A);  ys: list(A) |] ==> xs@ys \<in> list(A)"
by (simp add: app_list_def)

(** rev **)

lemma rev_type [TC]: "xs: list(A) ==> rev(xs) \<in> list(A)"
by (simp add: rev_list_def)

(** flat **)

lemma flat_type [TC]: "ls: list(list(A)) ==> flat(ls) \<in> list(A)"
by (simp add: flat_list_def)

(** set_of_list **)

lemma set_of_list_type [TC]: "l \<in> list(A) ==> set_of_list(l) \<in> Pow(A)"
apply (unfold set_of_list_list_def)
apply (erule list_rec_type, auto)
done

lemma set_of_list_append:
     "xs: list(A) ==> set_of_list (xs@ys) = set_of_list(xs) \<union> set_of_list(ys)"
apply (erule list.induct)
apply (simp_all (no_asm_simp) add: Un_cons)
done

(** list_add **)

lemma list_add_type [TC]: "xs: list(nat) ==> list_add(xs) \<in> nat"
by (simp add: list_add_list_def)

(*** theorems about map ***)

lemma map_ident [simp]: "l \<in> list(A) ==> map(%u. u, l) = l"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

lemma map_compose: "l \<in> list(A) ==> map(h, map(j,l)) = map(%u. h(j(u)), l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

lemma map_app_distrib: "xs: list(A) ==> map(h, xs@ys) = map(h,xs) @ map(h,ys)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
done

lemma map_flat: "ls: list(list(A)) ==> map(h, flat(ls)) = flat(map(map(h),ls))"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: map_app_distrib)
done

lemma list_rec_map:
     "l \<in> list(A) ==>
      list_rec(c, d, map(h,l)) =
      list_rec(c, %x xs r. d(h(x), map(h,xs), r), l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

(** theorems about list(Collect(A,P)) -- used in Induct/Term.thy **)

(* @{term"c \<in> list(Collect(B,P)) ==> c \<in> list"} *)
lemmas list_CollectD = Collect_subset [THEN list_mono, THEN subsetD]

lemma map_list_Collect: "l \<in> list({x \<in> A. h(x)=j(x)}) ==> map(h,l) = map(j,l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

(*** theorems about length ***)

lemma length_map [simp]: "xs: list(A) ==> length(map(h,xs)) = length(xs)"
by (induct_tac "xs", simp_all)

lemma length_app [simp]:
     "[| xs: list(A); ys: list(A) |]
      ==> length(xs@ys) = length(xs) #+ length(ys)"
by (induct_tac "xs", simp_all)

lemma length_rev [simp]: "xs: list(A) ==> length(rev(xs)) = length(xs)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp) add: length_app)
done

lemma length_flat:
     "ls: list(list(A)) ==> length(flat(ls)) = list_add(map(length,ls))"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: length_app)
done

(** Length and drop **)

(*Lemma for the inductive step of drop_length*)
lemma drop_length_Cons [rule_format]:
     "xs: list(A) ==>
           \<forall>x.  \<exists>z zs. drop(length(xs), Cons(x,xs)) = Cons(z,zs)"
by (erule list.induct, simp_all)

lemma drop_length [rule_format]:
     "l \<in> list(A) ==> \<forall>i \<in> length(l). (\<exists>z zs. drop(i,l) = Cons(z,zs))"
apply (erule list.induct, simp_all, safe)
apply (erule drop_length_Cons)
apply (rule natE)
apply (erule Ord_trans [OF asm_rl length_type Ord_nat], assumption, simp_all)
apply (blast intro: succ_in_naturalD length_type)
done

(*** theorems about app ***)

lemma app_right_Nil [simp]: "xs: list(A) ==> xs@Nil=xs"
by (erule list.induct, simp_all)

lemma app_assoc: "xs: list(A) ==> (xs@ys)@zs = xs@(ys@zs)"
by (induct_tac "xs", simp_all)

lemma flat_app_distrib: "ls: list(list(A)) ==> flat(ls@ms) = flat(ls)@flat(ms)"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: app_assoc)
done

(*** theorems about rev ***)

lemma rev_map_distrib: "l \<in> list(A) ==> rev(map(h,l)) = map(h,rev(l))"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: map_app_distrib)
done

(*Simplifier needs the premises as assumptions because rewriting will not
  instantiate the variable ?A in the rules' typing conditions; note that
  rev_type does not instantiate ?A.  Only the premises do.
*)
lemma rev_app_distrib:
     "[| xs: list(A);  ys: list(A) |] ==> rev(xs@ys) = rev(ys)@rev(xs)"
apply (erule list.induct)
apply (simp_all add: app_assoc)
done

lemma rev_rev_ident [simp]: "l \<in> list(A) ==> rev(rev(l))=l"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: rev_app_distrib)
done

lemma rev_flat: "ls: list(list(A)) ==> rev(flat(ls)) = flat(map(rev,rev(ls)))"
apply (induct_tac "ls")
apply (simp_all add: map_app_distrib flat_app_distrib rev_app_distrib)
done

(*** theorems about list_add ***)

lemma list_add_app:
     "[| xs: list(nat);  ys: list(nat) |]
      ==> list_add(xs@ys) = list_add(ys) #+ list_add(xs)"
apply (induct_tac "xs", simp_all)
done

lemma list_add_rev: "l \<in> list(nat) ==> list_add(rev(l)) = list_add(l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: list_add_app)
done

lemma list_add_flat:
     "ls: list(list(nat)) ==> list_add(flat(ls)) = list_add(map(list_add,ls))"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: list_add_app)
done

(** New induction rules **)

lemma list_append_induct [case_names Nil snoc, consumes 1]:
    "[| l \<in> list(A);
        P(Nil);
        !!x y. [| x \<in> A;  y \<in> list(A);  P(y) |] ==> P(y @ [x])
     |] ==> P(l)"
apply (subgoal_tac "P(rev(rev(l)))", simp)
apply (erule rev_type [THEN list.induct], simp_all)
done

lemma list_complete_induct_lemma [rule_format]:
 assumes ih:
    "\<And>l. [| l \<in> list(A);
             \<forall>l' \<in> list(A). length(l') < length(l) \<longrightarrow> P(l')|]
          ==> P(l)"
  shows "n \<in> nat ==> \<forall>l \<in> list(A). length(l) < n \<longrightarrow> P(l)"
apply (induct_tac n, simp)
apply (blast intro: ih elim!: leE)
done

theorem list_complete_induct:
      "[| l \<in> list(A);
          \<And>l. [| l \<in> list(A);
                  \<forall>l' \<in> list(A). length(l') < length(l) \<longrightarrow> P(l')|]
               ==> P(l)
       |] ==> P(l)"
apply (rule list_complete_induct_lemma [of A])
   prefer 4 apply (rule le_refl, simp)
  apply blast
 apply simp
apply assumption
done

(*** Thanks to Sidi Ehmety for these results about min, take, etc. ***)

(** min FIXME: replace by Int! **)
(* Min theorems are also true for i, j ordinals *)
lemma min_sym: "[| i \<in> nat; j \<in> nat |] ==> min(i,j)=min(j,i)"
apply (unfold min_def)
apply (auto dest!: not_lt_imp_le dest: lt_not_sym intro: le_anti_sym)
done

lemma min_type [simp,TC]: "[| i \<in> nat; j \<in> nat |] ==> min(i,j):nat"
by (unfold min_def, auto)

lemma min_0 [simp]: "i \<in> nat ==> min(0,i) = 0"
apply (unfold min_def)
apply (auto dest: not_lt_imp_le)
done

lemma min_02 [simp]: "i \<in> nat ==> min(i, 0) = 0"
apply (unfold min_def)
apply (auto dest: not_lt_imp_le)
done

lemma lt_min_iff: "[| i \<in> nat; j \<in> nat; k \<in> nat |] ==> i<min(j,k) \<longleftrightarrow> i<j & i<k"
apply (unfold min_def)
apply (auto dest!: not_lt_imp_le intro: lt_trans2 lt_trans)
done

lemma min_succ_succ [simp]:
     "[| i \<in> nat; j \<in> nat |] ==>  min(succ(i), succ(j))= succ(min(i, j))"
apply (unfold min_def, auto)
done

(*** more theorems about lists ***)

(** filter **)

lemma filter_append [simp]:
     "xs:list(A) ==> filter(P, xs@ys) = filter(P, xs) @ filter(P, ys)"
by (induct_tac "xs", auto)

lemma filter_type [simp,TC]: "xs:list(A) ==> filter(P, xs):list(A)"
by (induct_tac "xs", auto)

lemma length_filter: "xs:list(A) ==> length(filter(P, xs)) \<le> length(xs)"
apply (induct_tac "xs", auto)
apply (rule_tac j = "length (l) " in le_trans)
apply (auto simp add: le_iff)
done

lemma filter_is_subset: "xs:list(A) ==> set_of_list(filter(P,xs)) \<subseteq> set_of_list(xs)"
by (induct_tac "xs", auto)

lemma filter_False [simp]: "xs:list(A) ==> filter(%p. False, xs) = Nil"
by (induct_tac "xs", auto)

lemma filter_True [simp]: "xs:list(A) ==> filter(%p. True, xs) = xs"
by (induct_tac "xs", auto)

(** length **)

lemma length_is_0_iff [simp]: "xs:list(A) ==> length(xs)=0 \<longleftrightarrow> xs=Nil"
by (erule list.induct, auto)

lemma length_is_0_iff2 [simp]: "xs:list(A) ==> 0 = length(xs) \<longleftrightarrow> xs=Nil"
by (erule list.induct, auto)

lemma length_tl [simp]: "xs:list(A) ==> length(tl(xs)) = length(xs) #- 1"
by (erule list.induct, auto)

lemma length_greater_0_iff: "xs:list(A) ==> 0<length(xs) \<longleftrightarrow> xs \<noteq> Nil"
by (erule list.induct, auto)

lemma length_succ_iff: "xs:list(A) ==> length(xs)=succ(n) \<longleftrightarrow> (\<exists>y ys. xs=Cons(y, ys) & length(ys)=n)"
by (erule list.induct, auto)

(** more theorems about append **)

lemma append_is_Nil_iff [simp]:
     "xs:list(A) ==> (xs@ys = Nil) \<longleftrightarrow> (xs=Nil & ys = Nil)"
by (erule list.induct, auto)

lemma append_is_Nil_iff2 [simp]:
     "xs:list(A) ==> (Nil = xs@ys) \<longleftrightarrow> (xs=Nil & ys = Nil)"
by (erule list.induct, auto)

lemma append_left_is_self_iff [simp]:
     "xs:list(A) ==> (xs@ys = xs) \<longleftrightarrow> (ys = Nil)"
by (erule list.induct, auto)

lemma append_left_is_self_iff2 [simp]:
     "xs:list(A) ==> (xs = xs@ys) \<longleftrightarrow> (ys = Nil)"
by (erule list.induct, auto)

(*TOO SLOW as a default simprule!*)
lemma append_left_is_Nil_iff [rule_format]:
     "[| xs:list(A); ys:list(A); zs:list(A) |] ==>
   length(ys)=length(zs) \<longrightarrow> (xs@ys=zs \<longleftrightarrow> (xs=Nil & ys=zs))"
apply (erule list.induct)
apply (auto simp add: length_app)
done

(*TOO SLOW as a default simprule!*)
lemma append_left_is_Nil_iff2 [rule_format]:
     "[| xs:list(A); ys:list(A); zs:list(A) |] ==>
   length(ys)=length(zs) \<longrightarrow> (zs=ys@xs \<longleftrightarrow> (xs=Nil & ys=zs))"
apply (erule list.induct)
apply (auto simp add: length_app)
done

lemma append_eq_append_iff [rule_format,simp]:
     "xs:list(A) ==> \<forall>ys \<in> list(A).
      length(xs)=length(ys) \<longrightarrow> (xs@us = ys@vs) \<longleftrightarrow> (xs=ys & us=vs)"
apply (erule list.induct)
apply (simp (no_asm_simp))
apply clarify
apply (erule_tac a = ys in list.cases, auto)
done

lemma append_eq_append [rule_format]:
  "xs:list(A) ==>
   \<forall>ys \<in> list(A). \<forall>us \<in> list(A). \<forall>vs \<in> list(A).
   length(us) = length(vs) \<longrightarrow> (xs@us = ys@vs) \<longrightarrow> (xs=ys & us=vs)"
apply (induct_tac "xs")
apply (force simp add: length_app, clarify)
apply (erule_tac a = ys in list.cases, simp)
apply (subgoal_tac "Cons (a, l) @ us =vs")
 apply (drule rev_iffD1 [OF _ append_left_is_Nil_iff], simp_all, blast)
done

lemma append_eq_append_iff2 [simp]:
 "[| xs:list(A); ys:list(A); us:list(A); vs:list(A); length(us)=length(vs) |]
  ==>  xs@us = ys@vs \<longleftrightarrow> (xs=ys & us=vs)"
apply (rule iffI)
apply (rule append_eq_append, auto)
done

lemma append_self_iff [simp]:
     "[| xs:list(A); ys:list(A); zs:list(A) |] ==> xs@ys=xs@zs \<longleftrightarrow> ys=zs"
by simp

lemma append_self_iff2 [simp]:
     "[| xs:list(A); ys:list(A); zs:list(A) |] ==> ys@xs=zs@xs \<longleftrightarrow> ys=zs"
by simp

(* Can also be proved from append_eq_append_iff2,
but the proof requires two more hypotheses: x \<in> A and y \<in> A *)
lemma append1_eq_iff [rule_format,simp]:
     "xs:list(A) ==> \<forall>ys \<in> list(A). xs@[x] = ys@[y] \<longleftrightarrow> (xs = ys & x=y)"
apply (erule list.induct)
 apply clarify
 apply (erule list.cases)
 apply simp_all
txt{*Inductive step*}
apply clarify
apply (erule_tac a=ys in list.cases, simp_all)
done

lemma append_right_is_self_iff [simp]:
     "[| xs:list(A); ys:list(A) |] ==> (xs@ys = ys) \<longleftrightarrow> (xs=Nil)"
by (simp (no_asm_simp) add: append_left_is_Nil_iff)

lemma append_right_is_self_iff2 [simp]:
     "[| xs:list(A); ys:list(A) |] ==> (ys = xs@ys) \<longleftrightarrow> (xs=Nil)"
apply (rule iffI)
apply (drule sym, auto)
done

lemma hd_append [rule_format,simp]:
     "xs:list(A) ==> xs \<noteq> Nil \<longrightarrow> hd(xs @ ys) = hd(xs)"
by (induct_tac "xs", auto)

lemma tl_append [rule_format,simp]:
     "xs:list(A) ==> xs\<noteq>Nil \<longrightarrow> tl(xs @ ys) = tl(xs)@ys"
by (induct_tac "xs", auto)

(** rev **)
lemma rev_is_Nil_iff [simp]: "xs:list(A) ==> (rev(xs) = Nil \<longleftrightarrow> xs = Nil)"
by (erule list.induct, auto)

lemma Nil_is_rev_iff [simp]: "xs:list(A) ==> (Nil = rev(xs) \<longleftrightarrow> xs = Nil)"
by (erule list.induct, auto)

lemma rev_is_rev_iff [rule_format,simp]:
     "xs:list(A) ==> \<forall>ys \<in> list(A). rev(xs)=rev(ys) \<longleftrightarrow> xs=ys"
apply (erule list.induct, force, clarify)
apply (erule_tac a = ys in list.cases, auto)
done

lemma rev_list_elim [rule_format]:
     "xs:list(A) ==>
      (xs=Nil \<longrightarrow> P) \<longrightarrow> (\<forall>ys \<in> list(A). \<forall>y \<in> A. xs =ys@[y] \<longrightarrow>P)\<longrightarrow>P"
by (erule list_append_induct, auto)

(** more theorems about drop **)

lemma length_drop [rule_format,simp]:
     "n \<in> nat ==> \<forall>xs \<in> list(A). length(drop(n, xs)) = length(xs) #- n"
apply (erule nat_induct)
apply (auto elim: list.cases)
done

lemma drop_all [rule_format,simp]:
     "n \<in> nat ==> \<forall>xs \<in> list(A). length(xs) \<le> n \<longrightarrow> drop(n, xs)=Nil"
apply (erule nat_induct)
apply (auto elim: list.cases)
done

lemma drop_append [rule_format]:
     "n \<in> nat ==>
      \<forall>xs \<in> list(A). drop(n, xs@ys) = drop(n,xs) @ drop(n #- length(xs), ys)"
apply (induct_tac "n")
apply (auto elim: list.cases)
done

lemma drop_drop:
    "m \<in> nat ==> \<forall>xs \<in> list(A). \<forall>n \<in> nat. drop(n, drop(m, xs))=drop(n #+ m, xs)"
apply (induct_tac "m")
apply (auto elim: list.cases)
done

(** take **)

lemma take_0 [simp]: "xs:list(A) ==> take(0, xs) =  Nil"
apply (unfold take_def)
apply (erule list.induct, auto)
done

lemma take_succ_Cons [simp]:
    "n \<in> nat ==> take(succ(n), Cons(a, xs)) = Cons(a, take(n, xs))"
by (simp add: take_def)

(* Needed for proving take_all *)
lemma take_Nil [simp]: "n \<in> nat ==> take(n, Nil) = Nil"
by (unfold take_def, auto)

lemma take_all [rule_format,simp]:
     "n \<in> nat ==> \<forall>xs \<in> list(A). length(xs) \<le> n  \<longrightarrow> take(n, xs) = xs"
apply (erule nat_induct)
apply (auto elim: list.cases)
done

lemma take_type [rule_format,simp,TC]:
     "xs:list(A) ==> \<forall>n \<in> nat. take(n, xs):list(A)"
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma take_append [rule_format,simp]:
 "xs:list(A) ==>
  \<forall>ys \<in> list(A). \<forall>n \<in> nat. take(n, xs @ ys) =
                            take(n, xs) @ take(n #- length(xs), ys)"
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma take_take [rule_format]:
   "m \<in> nat ==>
    \<forall>xs \<in> list(A). \<forall>n \<in> nat. take(n, take(m,xs))= take(min(n, m), xs)"
apply (induct_tac "m", auto)
apply (erule_tac a = xs in list.cases)
apply (auto simp add: take_Nil)
apply (erule_tac n=n in natE)
apply (auto intro: take_0 take_type)
done

(** nth **)

lemma nth_0 [simp]: "nth(0, Cons(a, l)) = a"
by (simp add: nth_def)

lemma nth_Cons [simp]: "n \<in> nat ==> nth(succ(n), Cons(a,l)) = nth(n,l)"
by (simp add: nth_def)

lemma nth_empty [simp]: "nth(n, Nil) = 0"
by (simp add: nth_def)

lemma nth_type [rule_format,simp,TC]:
     "xs:list(A) ==> \<forall>n. n < length(xs) \<longrightarrow> nth(n,xs) \<in> A"
apply (erule list.induct, simp, clarify)
apply (subgoal_tac "n \<in> nat")
 apply (erule natE, auto dest!: le_in_nat)
done

lemma nth_eq_0 [rule_format]:
     "xs:list(A) ==> \<forall>n \<in> nat. length(xs) \<le> n \<longrightarrow> nth(n,xs) = 0"
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma nth_append [rule_format]:
  "xs:list(A) ==>
   \<forall>n \<in> nat. nth(n, xs @ ys) = (if n < length(xs) then nth(n,xs)
                                else nth(n #- length(xs), ys))"
apply (induct_tac "xs", simp, clarify)
apply (erule natE, auto)
done

lemma set_of_list_conv_nth:
    "xs:list(A)
     ==> set_of_list(xs) = {x \<in> A. \<exists>i\<in>nat. i<length(xs) & x = nth(i,xs)}"
apply (induct_tac "xs", simp_all)
apply (rule equalityI, auto)
apply (rule_tac x = 0 in bexI, auto)
apply (erule natE, auto)
done

(* Other theorems about lists *)

lemma nth_take_lemma [rule_format]:
 "k \<in> nat ==>
  \<forall>xs \<in> list(A). (\<forall>ys \<in> list(A). k \<le> length(xs) \<longrightarrow> k \<le> length(ys) \<longrightarrow>
      (\<forall>i \<in> nat. i<k \<longrightarrow> nth(i,xs) = nth(i,ys))\<longrightarrow> take(k,xs) = take(k,ys))"
apply (induct_tac "k")
apply (simp_all (no_asm_simp) add: lt_succ_eq_0_disj all_conj_distrib)
apply clarify
(*Both lists are non-empty*)
apply (erule_tac a=xs in list.cases, simp)
apply (erule_tac a=ys in list.cases, clarify)
apply (simp (no_asm_use) )
apply clarify
apply (simp (no_asm_simp))
apply (rule conjI, force)
apply (rename_tac y ys z zs)
apply (drule_tac x = zs and x1 = ys in bspec [THEN bspec], auto)
done

lemma nth_equalityI [rule_format]:
     "[| xs:list(A); ys:list(A); length(xs) = length(ys);
         \<forall>i \<in> nat. i < length(xs) \<longrightarrow> nth(i,xs) = nth(i,ys) |]
      ==> xs = ys"
apply (subgoal_tac "length (xs) \<le> length (ys) ")
apply (cut_tac k="length(xs)" and xs=xs and ys=ys in nth_take_lemma)
apply (simp_all add: take_all)
done

(*The famous take-lemma*)

lemma take_equalityI [rule_format]:
    "[| xs:list(A); ys:list(A); (\<forall>i \<in> nat. take(i, xs) = take(i,ys)) |]
     ==> xs = ys"
apply (case_tac "length (xs) \<le> length (ys) ")
apply (drule_tac x = "length (ys) " in bspec)
apply (drule_tac [3] not_lt_imp_le)
apply (subgoal_tac [5] "length (ys) \<le> length (xs) ")
apply (rule_tac [6] j = "succ (length (ys))" in le_trans)
apply (rule_tac [6] leI)
apply (drule_tac [5] x = "length (xs) " in bspec)
apply (simp_all add: take_all)
done

lemma nth_drop [rule_format]:
  "n \<in> nat ==> \<forall>i \<in> nat. \<forall>xs \<in> list(A). nth(i, drop(n, xs)) = nth(n #+ i, xs)"
apply (induct_tac "n", simp_all, clarify)
apply (erule list.cases, auto)
done

lemma take_succ [rule_format]:
  "xs\<in>list(A)
   ==> \<forall>i. i < length(xs) \<longrightarrow> take(succ(i), xs) = take(i,xs) @ [nth(i, xs)]"
apply (induct_tac "xs", auto)
apply (subgoal_tac "i\<in>nat")
apply (erule natE)
apply (auto simp add: le_in_nat)
done

lemma take_add [rule_format]:
     "[|xs\<in>list(A); j\<in>nat|]
      ==> \<forall>i\<in>nat. take(i #+ j, xs) = take(i,xs) @ take(j, drop(i,xs))"
apply (induct_tac "xs", simp_all, clarify)
apply (erule_tac n = i in natE, simp_all)
done

lemma length_take:
     "l\<in>list(A) ==> \<forall>n\<in>nat. length(take(n,l)) = min(n, length(l))"
apply (induct_tac "l", safe, simp_all)
apply (erule natE, simp_all)
done

subsection{*The function zip*}

text{*Crafty definition to eliminate a type argument*}

consts
  zip_aux        :: "[i,i]=>i"

primrec (*explicit lambda is required because both arguments of "un" vary*)
  "zip_aux(B,[]) =
     (\<lambda>ys \<in> list(B). list_case([], %y l. [], ys))"

  "zip_aux(B,Cons(x,l)) =
     (\<lambda>ys \<in> list(B).
        list_case(Nil, %y zs. Cons(<x,y>, zip_aux(B,l)`zs), ys))"

definition
  zip :: "[i, i]=>i"  where
   "zip(xs, ys) == zip_aux(set_of_list(ys),xs)`ys"

(* zip equations *)

lemma list_on_set_of_list: "xs \<in> list(A) ==> xs \<in> list(set_of_list(xs))"
apply (induct_tac xs, simp_all)
apply (blast intro: list_mono [THEN subsetD])
done

lemma zip_Nil [simp]: "ys:list(A) ==> zip(Nil, ys)=Nil"
apply (simp add: zip_def list_on_set_of_list [of _ A])
apply (erule list.cases, simp_all)
done

lemma zip_Nil2 [simp]: "xs:list(A) ==> zip(xs, Nil)=Nil"
apply (simp add: zip_def list_on_set_of_list [of _ A])
apply (erule list.cases, simp_all)
done

lemma zip_aux_unique [rule_format]:
     "[|B<=C;  xs \<in> list(A)|]
      ==> \<forall>ys \<in> list(B). zip_aux(C,xs) ` ys = zip_aux(B,xs) ` ys"
apply (induct_tac xs)
 apply simp_all
 apply (blast intro: list_mono [THEN subsetD], clarify)
apply (erule_tac a=ys in list.cases, auto)
apply (blast intro: list_mono [THEN subsetD])
done

lemma zip_Cons_Cons [simp]:
     "[| xs:list(A); ys:list(B); x \<in> A; y \<in> B |] ==>
      zip(Cons(x,xs), Cons(y, ys)) = Cons(<x,y>, zip(xs, ys))"
apply (simp add: zip_def, auto)
apply (rule zip_aux_unique, auto)
apply (simp add: list_on_set_of_list [of _ B])
apply (blast intro: list_on_set_of_list list_mono [THEN subsetD])
done

lemma zip_type [rule_format,simp,TC]:
     "xs:list(A) ==> \<forall>ys \<in> list(B). zip(xs, ys):list(A*B)"
apply (induct_tac "xs")
apply (simp (no_asm))
apply clarify
apply (erule_tac a = ys in list.cases, auto)
done

(* zip length *)
lemma length_zip [rule_format,simp]:
     "xs:list(A) ==> \<forall>ys \<in> list(B). length(zip(xs,ys)) =
                                     min(length(xs), length(ys))"
apply (unfold min_def)
apply (induct_tac "xs", simp_all, clarify)
apply (erule_tac a = ys in list.cases, auto)
done

lemma zip_append1 [rule_format]:
 "[| ys:list(A); zs:list(B) |] ==>
  \<forall>xs \<in> list(A). zip(xs @ ys, zs) =
                 zip(xs, take(length(xs), zs)) @ zip(ys, drop(length(xs),zs))"
apply (induct_tac "zs", force, clarify)
apply (erule_tac a = xs in list.cases, simp_all)
done

lemma zip_append2 [rule_format]:
 "[| xs:list(A); zs:list(B) |] ==> \<forall>ys \<in> list(B). zip(xs, ys@zs) =
       zip(take(length(ys), xs), ys) @ zip(drop(length(ys), xs), zs)"
apply (induct_tac "xs", force, clarify)
apply (erule_tac a = ys in list.cases, auto)
done

lemma zip_append [simp]:
 "[| length(xs) = length(us); length(ys) = length(vs);
     xs:list(A); us:list(B); ys:list(A); vs:list(B) |]
  ==> zip(xs@ys,us@vs) = zip(xs, us) @ zip(ys, vs)"
by (simp (no_asm_simp) add: zip_append1 drop_append diff_self_eq_0)

lemma zip_rev [rule_format,simp]:
 "ys:list(B) ==> \<forall>xs \<in> list(A).
    length(xs) = length(ys) \<longrightarrow> zip(rev(xs), rev(ys)) = rev(zip(xs, ys))"
apply (induct_tac "ys", force, clarify)
apply (erule_tac a = xs in list.cases)
apply (auto simp add: length_rev)
done

lemma nth_zip [rule_format,simp]:
   "ys:list(B) ==> \<forall>i \<in> nat. \<forall>xs \<in> list(A).
                    i < length(xs) \<longrightarrow> i < length(ys) \<longrightarrow>
                    nth(i,zip(xs, ys)) = <nth(i,xs),nth(i, ys)>"
apply (induct_tac "ys", force, clarify)
apply (erule_tac a = xs in list.cases, simp)
apply (auto elim: natE)
done

lemma set_of_list_zip [rule_format]:
     "[| xs:list(A); ys:list(B); i \<in> nat |]
      ==> set_of_list(zip(xs, ys)) =
          {<x, y>:A*B. \<exists>i\<in>nat. i < min(length(xs), length(ys))
          & x = nth(i, xs) & y = nth(i, ys)}"
by (force intro!: Collect_cong simp add: lt_min_iff set_of_list_conv_nth)

(** list_update **)

lemma list_update_Nil [simp]: "i \<in> nat ==>list_update(Nil, i, v) = Nil"
by (unfold list_update_def, auto)

lemma list_update_Cons_0 [simp]: "list_update(Cons(x, xs), 0, v)= Cons(v, xs)"
by (unfold list_update_def, auto)

lemma list_update_Cons_succ [simp]:
  "n \<in> nat ==>
    list_update(Cons(x, xs), succ(n), v)= Cons(x, list_update(xs, n, v))"
apply (unfold list_update_def, auto)
done

lemma list_update_type [rule_format,simp,TC]:
     "[| xs:list(A); v \<in> A |] ==> \<forall>n \<in> nat. list_update(xs, n, v):list(A)"
apply (induct_tac "xs")
apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done

lemma length_list_update [rule_format,simp]:
     "xs:list(A) ==> \<forall>i \<in> nat. length(list_update(xs, i, v))=length(xs)"
apply (induct_tac "xs")
apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done

lemma nth_list_update [rule_format]:
     "[| xs:list(A) |] ==> \<forall>i \<in> nat. \<forall>j \<in> nat. i < length(xs)  \<longrightarrow>
         nth(j, list_update(xs, i, x)) = (if i=j then x else nth(j, xs))"
apply (induct_tac "xs")
 apply simp_all
apply clarify
apply (rename_tac i j)
apply (erule_tac n=i in natE)
apply (erule_tac [2] n=j in natE)
apply (erule_tac n=j in natE, simp_all, force)
done

lemma nth_list_update_eq [simp]:
     "[| i < length(xs); xs:list(A) |] ==> nth(i, list_update(xs, i,x)) = x"
by (simp (no_asm_simp) add: lt_length_in_nat nth_list_update)

lemma nth_list_update_neq [rule_format,simp]:
  "xs:list(A) ==>
     \<forall>i \<in> nat. \<forall>j \<in> nat. i \<noteq> j \<longrightarrow> nth(j, list_update(xs,i,x)) = nth(j,xs)"
apply (induct_tac "xs")
 apply (simp (no_asm))
apply clarify
apply (erule natE)
apply (erule_tac [2] natE, simp_all)
apply (erule natE, simp_all)
done

lemma list_update_overwrite [rule_format,simp]:
     "xs:list(A) ==> \<forall>i \<in> nat. i < length(xs)
   \<longrightarrow> list_update(list_update(xs, i, x), i, y) = list_update(xs, i,y)"
apply (induct_tac "xs")
 apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done

lemma list_update_same_conv [rule_format]:
     "xs:list(A) ==>
      \<forall>i \<in> nat. i < length(xs) \<longrightarrow>
                 (list_update(xs, i, x) = xs) \<longleftrightarrow> (nth(i, xs) = x)"
apply (induct_tac "xs")
 apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done

lemma update_zip [rule_format]:
     "ys:list(B) ==>
      \<forall>i \<in> nat. \<forall>xy \<in> A*B. \<forall>xs \<in> list(A).
        length(xs) = length(ys) \<longrightarrow>
        list_update(zip(xs, ys), i, xy) = zip(list_update(xs, i, fst(xy)),
                                              list_update(ys, i, snd(xy)))"
apply (induct_tac "ys")
 apply auto
apply (erule_tac a = xs in list.cases)
apply (auto elim: natE)
done

lemma set_update_subset_cons [rule_format]:
  "xs:list(A) ==>
   \<forall>i \<in> nat. set_of_list(list_update(xs, i, x)) \<subseteq> cons(x, set_of_list(xs))"
apply (induct_tac "xs")
 apply simp
apply (rule ballI)
apply (erule natE, simp_all, auto)
done

lemma set_of_list_update_subsetI:
     "[| set_of_list(xs) \<subseteq> A; xs:list(A); x \<in> A; i \<in> nat|]
   ==> set_of_list(list_update(xs, i,x)) \<subseteq> A"
apply (rule subset_trans)
apply (rule set_update_subset_cons, auto)
done

(** upt **)

lemma upt_rec:
     "j \<in> nat ==> upt(i,j) = (if i<j then Cons(i, upt(succ(i), j)) else Nil)"
apply (induct_tac "j", auto)
apply (drule not_lt_imp_le)
apply (auto simp: lt_Ord intro: le_anti_sym)
done

lemma upt_conv_Nil [simp]: "[| j \<le> i; j \<in> nat |] ==> upt(i,j) = Nil"
apply (subst upt_rec, auto)
apply (auto simp add: le_iff)
apply (drule lt_asym [THEN notE], auto)
done

(*Only needed if upt_Suc is deleted from the simpset*)
lemma upt_succ_append:
     "[| i \<le> j; j \<in> nat |] ==> upt(i,succ(j)) = upt(i, j)@[j]"
by simp

lemma upt_conv_Cons:
     "[| i<j; j \<in> nat |]  ==> upt(i,j) = Cons(i,upt(succ(i),j))"
apply (rule trans)
apply (rule upt_rec, auto)
done

lemma upt_type [simp,TC]: "j \<in> nat ==> upt(i,j):list(nat)"
by (induct_tac "j", auto)

(*LOOPS as a simprule, since j<=j*)
lemma upt_add_eq_append:
     "[| i \<le> j; j \<in> nat; k \<in> nat |] ==> upt(i, j #+k) = upt(i,j)@upt(j,j#+k)"
apply (induct_tac "k")
apply (auto simp add: app_assoc app_type)
apply (rule_tac j = j in le_trans, auto)
done

lemma length_upt [simp]: "[| i \<in> nat; j \<in> nat |] ==>length(upt(i,j)) = j #- i"
apply (induct_tac "j")
apply (rule_tac [2] sym)
apply (auto dest!: not_lt_imp_le simp add: diff_succ diff_is_0_iff)
done

lemma nth_upt [rule_format,simp]:
     "[| i \<in> nat; j \<in> nat; k \<in> nat |] ==> i #+ k < j \<longrightarrow> nth(k, upt(i,j)) = i #+ k"
apply (induct_tac "j", simp)
apply (simp add: nth_append le_iff)
apply (auto dest!: not_lt_imp_le
            simp add: nth_append less_diff_conv add_commute)
done

lemma take_upt [rule_format,simp]:
     "[| m \<in> nat; n \<in> nat |] ==>
         \<forall>i \<in> nat. i #+ m \<le> n \<longrightarrow> take(m, upt(i,n)) = upt(i,i#+m)"
apply (induct_tac "m")
apply (simp (no_asm_simp) add: take_0)
apply clarify
apply (subst upt_rec, simp)
apply (rule sym)
apply (subst upt_rec, simp)
apply (simp_all del: upt.simps)
apply (rule_tac j = "succ (i #+ x) " in lt_trans2)
apply auto
done

lemma map_succ_upt:
     "[| m \<in> nat; n \<in> nat |] ==> map(succ, upt(m,n))= upt(succ(m), succ(n))"
apply (induct_tac "n")
apply (auto simp add: map_app_distrib)
done

lemma nth_map [rule_format,simp]:
     "xs:list(A) ==>
      \<forall>n \<in> nat. n < length(xs) \<longrightarrow> nth(n, map(f, xs)) = f(nth(n, xs))"
apply (induct_tac "xs", simp)
apply (rule ballI)
apply (induct_tac "n", auto)
done

lemma nth_map_upt [rule_format]:
     "[| m \<in> nat; n \<in> nat |] ==>
      \<forall>i \<in> nat. i < n #- m \<longrightarrow> nth(i, map(f, upt(m,n))) = f(m #+ i)"
apply (rule_tac n = m and m = n in diff_induct, typecheck, simp, simp)
apply (subst map_succ_upt [symmetric], simp_all, clarify)
apply (subgoal_tac "i < length (upt (0, x))")
 prefer 2
 apply (simp add: less_diff_conv)
 apply (rule_tac j = "succ (i #+ y) " in lt_trans2)
  apply simp
 apply simp
apply (subgoal_tac "i < length (upt (y, x))")
 apply (simp_all add: add_commute less_diff_conv)
done

(** sublist (a generalization of nth to sets) **)

definition
  sublist :: "[i, i] => i"  where
    "sublist(xs, A)==
     map(fst, (filter(%p. snd(p): A, zip(xs, upt(0,length(xs))))))"

lemma sublist_0 [simp]: "xs:list(A) ==>sublist(xs, 0) =Nil"
by (unfold sublist_def, auto)

lemma sublist_Nil [simp]: "sublist(Nil, A) = Nil"
by (unfold sublist_def, auto)

lemma sublist_shift_lemma:
 "[| xs:list(B); i \<in> nat |] ==>
  map(fst, filter(%p. snd(p):A, zip(xs, upt(i,i #+ length(xs))))) =
  map(fst, filter(%p. snd(p):nat & snd(p) #+ i \<in> A, zip(xs,upt(0,length(xs)))))"
apply (erule list_append_induct)
apply (simp (no_asm_simp))
apply (auto simp add: add_commute length_app filter_append map_app_distrib)
done

lemma sublist_type [simp,TC]:
     "xs:list(B) ==> sublist(xs, A):list(B)"
apply (unfold sublist_def)
apply (induct_tac "xs")
apply (auto simp add: filter_append map_app_distrib)
done

lemma upt_add_eq_append2:
     "[| i \<in> nat; j \<in> nat |] ==> upt(0, i #+ j) = upt(0, i) @ upt(i, i #+ j)"
by (simp add: upt_add_eq_append [of 0] nat_0_le)

lemma sublist_append:
 "[| xs:list(B); ys:list(B)  |] ==>
  sublist(xs@ys, A) = sublist(xs, A) @ sublist(ys, {j \<in> nat. j #+ length(xs): A})"
apply (unfold sublist_def)
apply (erule_tac l = ys in list_append_induct, simp)
apply (simp (no_asm_simp) add: upt_add_eq_append2 app_assoc [symmetric])
apply (auto simp add: sublist_shift_lemma length_type map_app_distrib app_assoc)
apply (simp_all add: add_commute)
done

lemma sublist_Cons:
     "[| xs:list(B); x \<in> B |] ==>
      sublist(Cons(x, xs), A) =
      (if 0 \<in> A then [x] else []) @ sublist(xs, {j \<in> nat. succ(j) \<in> A})"
apply (erule_tac l = xs in list_append_induct)
apply (simp (no_asm_simp) add: sublist_def)
apply (simp del: app_Cons add: app_Cons [symmetric] sublist_append, simp)
done

lemma sublist_singleton [simp]:
     "sublist([x], A) = (if 0 \<in> A then [x] else [])"
by (simp add: sublist_Cons)

lemma sublist_upt_eq_take [rule_format, simp]:
    "xs:list(A) ==> \<forall>n\<in>nat. sublist(xs,n) = take(n,xs)"
apply (erule list.induct, simp)
apply (clarify )
apply (erule natE)
apply (simp_all add: nat_eq_Collect_lt Ord_mem_iff_lt sublist_Cons)
done

lemma sublist_Int_eq:
     "xs \<in> list(B) ==> sublist(xs, A \<inter> nat) = sublist(xs, A)"
apply (erule list.induct)
apply (simp_all add: sublist_Cons)
done

text{*Repetition of a List Element*}

consts   repeat :: "[i,i]=>i"
primrec
  "repeat(a,0) = []"

  "repeat(a,succ(n)) = Cons(a,repeat(a,n))"

lemma length_repeat: "n \<in> nat ==> length(repeat(a,n)) = n"
by (induct_tac n, auto)

lemma repeat_succ_app: "n \<in> nat ==> repeat(a,succ(n)) = repeat(a,n) @ [a]"
apply (induct_tac n)
apply (simp_all del: app_Cons add: app_Cons [symmetric])
done

lemma repeat_type [TC]: "[|a \<in> A; n \<in> nat|] ==> repeat(a,n) \<in> list(A)"
by (induct_tac n, auto)

end


(*  Author:  Tobias Nipkow  *)

section "Properties of Tame Graph Enumeration (1)"

theory GeneratorProps
imports Plane1Props Generator TameProps LowerBound
begin

lemma genPolyTame_spec:
 "generatePolygonTame n v f g = [g' \<leftarrow> generatePolygon n v f g . \<not> notame g']"
by(simp add:generatePolygonTame_def generatePolygon_def enum_enumerator)

lemma genPolyTame_subset_genPoly:
 "g' \<in> set(generatePolygonTame i v f g) \<Longrightarrow>
  g' \<in> set(generatePolygon i v f g)"
by(auto simp add:generatePolygon_def generatePolygonTame_def enum_enumerator)

lemma next_tame0_subset_plane:
 "set(next_tame0 p g) \<subseteq> set(next_plane p g)"
by(auto simp add:next_tame0_def next_plane_def polysizes_def
           elim!:genPolyTame_subset_genPoly simp del:upt_Suc)

lemma genPoly_new_face:
 "\<lbrakk>g' \<in> set (generatePolygon n v f g); minGraphProps g; f \<in> set (nonFinals g);
   v \<in> \<V> f; n \<ge> 3 \<rbrakk> \<Longrightarrow>
  \<exists>f \<in> set(finals g') - set(finals g). |vertices f| = n"
apply(auto simp add:generatePolygon_def image_def)
apply(rename_tac "is")
apply(frule enumerator_length2)
 apply arith
apply(frule (4) pre_subdivFace_indexToVertexList)
 apply(arith)
apply(subgoal_tac "indexToVertexList f v is \<noteq> []")
 prefer 2 apply(subst length_0_conv[symmetric]) apply simp
apply(simp add: subdivFace_subdivFace'_eq)
apply(clarsimp simp:neq_Nil_conv)
apply(rename_tac "ovs")
apply(subgoal_tac "|indexToVertexList f v is| = |ovs| + 1")
 prefer 2 apply(simp)
apply(drule (1) pre_subdivFace_pre_subdivFace')
apply(drule (1) final_subdivFace')
  apply(simp add:nonFinals_def)
 apply(simp add:pre_subdivFace'_def)
apply (simp (no_asm_use))
apply(simp)
apply blast
done

(* Could prove = instead of \<ge>, but who needs it? *)
lemma genPoly_incr_facesquander_lb:
assumes "g' \<in> set (generatePolygon n v f g)" "inv g"
        "f \<in> set(nonFinals g)" "v \<in> \<V> f" "3 \<le> n"
shows "faceSquanderLowerBound g' \<ge> faceSquanderLowerBound g + \<d> n"
proof -
  from genPoly_new_face[OF assms(1) inv_mgp[OF assms(2)] assms(3-5)] obtain f
    where f: "f \<in> set (finals g') - set(finals g)"
    and size: "|vertices f| = n" by auto
  have g': "g' \<in> set(next_plane0 (n - 3) g)" using assms(5)
    by(rule_tac in_next_plane0I[OF assms(1,3-5)]) simp
  note dist = minGraphProps11'[OF inv_mgp[OF assms(2)]]
  note inv' = invariantE[OF inv_inv_next_plane0, OF g' assms(2)]
  note dist' = minGraphProps11'[OF inv_mgp[OF inv']]
  note subset = next_plane0_finals_subset[OF g']
  have "faceSquanderLowerBound g' \<ge>
        faceSquanderLowerBound g + \<d> |vertices f|"
  proof(unfold faceSquanderLowerBound_def)
    have "(\<Sum>\<^bsub>f\<in>finals g\<^esub> \<d> |vertices f| ) + \<d> |vertices f| =
          (\<Sum>f\<in>set(finals g). \<d> |vertices f| ) + \<d> |vertices f|"
      using dist by(simp add:finals_def ListSum_conv_sum)
    also have "\<dots> = (\<Sum>f\<in>set(finals g) \<union> {f}. \<d> |vertices f| )"
      using f by simp
    also have "\<dots> \<le> (\<Sum>f\<in>set(finals g'). \<d> |vertices f| )"
      using f subset by(fastforce intro!: sum_mono2)
    also have "\<dots> = (\<Sum>\<^bsub>f\<in>finals g'\<^esub> \<d> |vertices f| )"
      using dist' by(simp add:finals_def ListSum_conv_sum)
    finally show "(\<Sum>\<^bsub>f\<in>finals g\<^esub> \<d> |vertices f| ) + \<d> |vertices f|
          \<le> (\<Sum>\<^bsub>f\<in>finals g'\<^esub> \<d> |vertices f| )" .
  qed
  with size show ?thesis by blast
qed

definition close :: "graph \<Rightarrow> vertex \<Rightarrow> vertex \<Rightarrow> bool" where
"close g u v \<equiv>
 \<exists>f \<in> set(facesAt g u). if |vertices f| = 4 then v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u)
                        else v = f \<bullet> u"

(* FIXME This should be the def of delAround *)
lemma delAround_def: "deleteAround g u ps = [p \<leftarrow> ps. \<not> close g u (fst p)]"
by (induct ps) (auto simp: deleteAroundCons close_def)

lemma close_sym: assumes mgp: "minGraphProps g" and ug: "u : \<V> g" and cl: "close g u v"
shows "close g v u"
proof -
  obtain f where f: "f \<in> set(facesAt g u)" and
    "if": "if |vertices f| = 4 then v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u) else v = f \<bullet> u"
    using cl by (unfold close_def) blast
  note uf = minGraphProps6[OF mgp ug f]
  note distf = minGraphProps3[OF mgp minGraphProps5[OF mgp ug f]]
  show ?thesis
  proof cases
    assume 4: "|vertices f| = 4"
    hence "v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u)" using "if" by simp
    thus ?thesis
    proof
      assume "v = f \<bullet> u"
      then obtain f' where "f' \<in> set(facesAt g v)" "f' \<bullet> v = u"
        using mgp_nextVertex_face_ex2[OF mgp ug f] by blast
      thus ?thesis by(auto simp:close_def)
    next
      assume v: "v = f \<bullet> (f \<bullet> u)"
      hence "f \<bullet> (f \<bullet> v) = u" using quad_next4_id[OF 4 distf uf] by simp
      moreover have "f \<in> set(facesAt g v)" using v uf
        by(simp add: minGraphProps7[OF mgp minGraphProps5[OF mgp ug f]])
      ultimately show ?thesis using 4 by(auto simp:close_def)
    qed
  next
    assume "|vertices f| \<noteq> 4"
    hence "v = f \<bullet> u" using "if" by simp
    then obtain f' where "f' \<in> set(facesAt g v)" "f' \<bullet> v = u"
      using mgp_nextVertex_face_ex2[OF mgp ug f] by blast
    thus ?thesis by(auto simp:close_def)
  qed
qed

lemma sep_conv:
assumes mgp: "minGraphProps g" and "V \<subseteq> \<V> g"
shows "separated g V = (\<forall>u\<in>V.\<forall>v\<in>V. u \<noteq> v \<longrightarrow> \<not> close g u v)" (is "?P = ?Q")
proof
  assume sep: ?P
  show ?Q
  proof(clarify)
    fix u v assume uv: "u \<in> V" "v \<in> V" "u \<noteq> v" and cl: "close g u v"
    from cl obtain f where f: "f \<in> set(facesAt g u)" and
      "if": "if |vertices f| = 4 then (v = f \<bullet> u) \<or> (v = f \<bullet> (f \<bullet> u))
                               else (v = f \<bullet> u)"
      by (unfold close_def) blast
    have "u : \<V> g" using \<open>u : V\<close> \<open>V \<subseteq> \<V> g\<close> by blast
    note uf = minGraphProps6[OF mgp \<open>u : \<V> g\<close> f]
    show False
    proof cases
      assume 4: "|vertices f| = 4"
      hence "v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u)" using "if" by simp
      thus False
      proof
        assume "v = f \<bullet> u"
        thus False using sep f uv
          by(simp add:separated_def separated\<^sub>2_def separated\<^sub>3_def)
      next
        assume "v = f \<bullet> (f \<bullet> u)"
        moreover hence "v \<in> \<V> f" using \<open>u \<in> \<V> f\<close> by simp
        moreover have "|vertices f| \<le> 4" using 4 by arith
        ultimately show False using sep f uv \<open>u \<in> \<V> f\<close>
          apply(unfold separated_def separated\<^sub>2_def separated\<^sub>3_def)
(* why does blast get stuck? *)
          apply(subgoal_tac "f \<bullet> (f \<bullet> u) \<in> \<V> f \<inter> V")
          prefer 2 apply blast
          by simp
      qed
    next
      assume 4: "|vertices f| \<noteq> 4"
      hence "v = f \<bullet> u" using "if" by simp
      thus False using sep f uv
        by(simp add:separated_def separated\<^sub>2_def separated\<^sub>3_def)
    qed
  qed
next
  assume not_cl: ?Q
  show ?P
  proof(simp add:separated_def, rule conjI)
    show "separated\<^sub>2 g V"
    proof (clarsimp simp:separated\<^sub>2_def)
      fix v f assume a: "v \<in> V" "f \<in> set (facesAt g v)" "f \<bullet> v \<in> V"
      have "v : \<V> g" using a(1) \<open>V \<subseteq> \<V> g\<close> by blast
      show False using a not_cl mgp_facesAt_no_loop[OF mgp \<open>v : \<V> g\<close> a(2)]
        by(fastforce simp: close_def split:if_split_asm)
    qed
    show "separated\<^sub>3 g V"
    proof (clarsimp simp:separated\<^sub>3_def)
      fix v f
      assume "v \<in> V" and f: "f \<in> set (facesAt g v)" and len: "|vertices f| \<le> 4"
      have vg: "v : \<V> g" using \<open>v : V\<close> \<open>V \<subseteq> \<V> g\<close> by blast
      note distf = minGraphProps3[OF mgp minGraphProps5[OF mgp vg f]]
      note vf = minGraphProps6[OF mgp vg f]
      { fix u assume "u \<in> \<V> f" and "u \<in> V"
        have "u = v"
        proof cases
          assume 3: "|vertices f| = 3"
          hence "\<V> f = {v, f \<bullet> v, f \<bullet> (f \<bullet> v)}"
            using vertices_triangle[OF _ vf distf] by simp
          moreover
          { assume "u = f \<bullet> v"
            hence "u = v"
              using not_cl f \<open>u \<in> V\<close> \<open>v \<in> V\<close> 3
              by(force simp:close_def split:if_split_asm)
          }
          moreover
          { assume "u = f \<bullet> (f \<bullet> v)"
            hence fu: "f \<bullet> u = v"
              by(simp add: tri_next3_id[OF 3 distf \<open>v \<in> \<V> f\<close>])
            hence "(u,v) \<in> \<E> f" using nextVertex_in_edges[OF \<open>u \<in> \<V> f\<close>]
              by(simp add:fu)
            then obtain f' where "f' \<in> set(facesAt g v)" "(v,u) \<in>  \<E> f'"
              using mgp_edge_face_ex[OF mgp vg f] by blast
            hence "u = v" using not_cl \<open>u \<in> V\<close> \<open>v \<in> V\<close> 3
              by(force simp:close_def edges_face_eq split:if_split_asm)
          }
          ultimately show "u=v" using \<open>u \<in> \<V> f\<close> by blast
        next
          assume 3: "|vertices f| \<noteq> 3"
          hence 4: "|vertices f| = 4"
            using len mgp_vertices3[OF mgp minGraphProps5[OF mgp vg f]] by arith
          hence "\<V> f = {v, f \<bullet> v, f \<bullet> (f \<bullet> v), f \<bullet> (f \<bullet> (f \<bullet> v))}"
            using vertices_quad[OF _ vf distf] by simp
          moreover
          { assume "u = f \<bullet> v"
            hence "u = v"
              using not_cl f \<open>u \<in> V\<close> \<open>v \<in> V\<close> 4
              by(force simp:close_def split:if_split_asm)
          }
          moreover
          { assume "u = f \<bullet> (f \<bullet> v)"
            hence "u = v"
              using not_cl f \<open>u \<in> V\<close> \<open>v \<in> V\<close> 4
              by(force simp:close_def split:if_split_asm)
          }
          moreover
          { assume "u = f \<bullet> (f \<bullet> (f \<bullet> v))"
            hence fu: "f \<bullet> u = v"
              by(simp add: quad_next4_id[OF 4 distf \<open>v \<in> \<V> f\<close>])
            hence "(u,v) \<in> \<E> f" using nextVertex_in_edges[OF \<open>u \<in> \<V> f\<close>]
              by(simp add:fu)
            then obtain f' where "f' \<in> set(facesAt g v)" "(v,u) \<in>  \<E> f'"
              using mgp_edge_face_ex[OF mgp vg f] by blast
            hence "u = v" using not_cl \<open>u \<in> V\<close> \<open>v \<in> V\<close> 4
              by(force simp:close_def edges_face_eq split:if_split_asm)
          }
          ultimately show "u=v" using \<open>u \<in> \<V> f\<close> by blast
        qed
      }
      thus "\<V> f \<inter> V = {v}" using \<open>v \<in> V\<close> vf by blast
    qed
  qed
qed

lemma sep_ne: "\<exists>P \<subseteq> M. separated g (fst ` P)"
by(unfold separated_def separated\<^sub>2_def separated\<^sub>3_def) blast

lemma ExcessNotAtRec_conv_Max:
assumes mgp: "minGraphProps g"
shows "set(map fst ps) \<subseteq> \<V> g \<Longrightarrow> distinct(map fst ps) \<Longrightarrow>
  ExcessNotAtRec ps g =
  Max{ \<Sum>p\<in>P. snd p |P. P \<subseteq> set ps \<and> separated g (fst ` P)}"
  (is "_ \<Longrightarrow> _ \<Longrightarrow> _ = Max(?M ps)" is "_ \<Longrightarrow> _ \<Longrightarrow> _ = Max{_ |P. ?S ps P}")
proof(induct ps rule: length_induct)
  case (1 ps0)
  note IH = 1(1) and subset = 1(2) and dist = 1(3)
  show ?case
  proof (cases ps0)
    case Nil thus ?thesis by simp
  next
    case (Cons p ps)
    let ?ps = "deleteAround g (fst p) ps"
    have le: "|?ps| \<le> |ps|" by(simp add:delAround_def)
    have dist': "distinct(map fst ?ps)" using dist Cons
      apply (clarsimp simp:delAround_def)
      apply(drule distinct_filter[where P = "Not \<circ> close g (fst p)"])
      apply(simp add: filter_map o_def)
      done
    have "fst p : \<V> g" and "fst ` set ps \<subseteq> \<V> g"
      using subset Cons by auto
    have sub1: "\<And>P Q. P \<subseteq> {x : set ps. Q x} \<Longrightarrow> fst ` P \<subseteq> \<V> g"
      using subset Cons by auto
    have sub2: "\<And>P Q. P \<subseteq> insert p {x : set ps. Q x} \<Longrightarrow> fst ` P \<subseteq> \<V> g"
      using subset Cons by auto
    have sub3: "\<And>P. P \<subseteq> insert p (set ps) \<Longrightarrow> fst ` P \<subseteq> \<V> g"
      using subset Cons by auto
    have "\<And>a. set (map fst (deleteAround g a ps)) \<subseteq> \<V> g"
      using deleteAround_subset[of g _ ps] subset Cons
      by auto
    hence "ExcessNotAtRec ps0 g = max (Max(?M ps)) (Max(?M ?ps) + snd p)"
      using Cons IH subset le dist dist' by (cases p) simp
    also have "Max (?M ?ps) + snd p =
      Max {(\<Sum>p\<in>P. snd p) + snd p | P. ?S ?ps P}"
      by (auto simp add:setcompr_eq_image Max_add_commute[symmetric] sep_ne intro!: arg_cong [where f=Max])
    also have "{(\<Sum>p\<in>P. snd p) + snd p |P. ?S ?ps P} =
      {sum snd (insert p P) |P. ?S ?ps P}"
      using dist Cons
      apply (auto simp:delAround_def)
      apply(rule_tac x=P in exI)
      apply(fastforce intro!: sum.insert[THEN trans,symmetric] elim: finite_subset)
      apply(rule_tac x=P in exI)
      apply(fastforce intro!: sum.insert[THEN trans] elim: finite_subset)
      done
    also have "\<dots> = {sum snd P |P.
            P \<subseteq> insert p (set ?ps) \<and> p \<in> P \<and> separated g (fst ` P)}"
      apply(auto simp add:sep_conv[OF mgp] sub1 sub2 delAround_def cong: conj_cong)
      apply(rule_tac x = "insert p P" in exI)
      apply simp
      apply(rule conjI) apply blast
      using \<open>image fst (set ps) \<subseteq> \<V> g\<close> \<open>fst p : \<V> g\<close>
      apply (blast intro:close_sym[OF mgp])
      apply(rule_tac x = "P-{p}" in exI)
      apply (simp add:insert_absorb)
      apply blast
      done
    also have "\<dots> = {sum snd P |P.
            P \<subseteq> insert p (set ps) \<and> p \<in> P \<and> separated g (fst ` P)}"
      using Cons dist
      apply(auto simp add:sep_conv[OF mgp] sub2 sub3 delAround_def cong: conj_cong)
      apply(rule_tac x = "P" in exI)
      apply simp
      apply auto
      done
    also have "max (Max(?M ps)) (Max \<dots>) = Max(?M ps \<union> {sum snd P |P.
            P \<subseteq> insert p (set ps) \<and> p \<in> P \<and> separated g (fst ` P)})"
      (is "_ = Max ?U")
    proof -
      have "{sum snd P |P.
            P \<subseteq> insert p (set ps) \<and> p \<in> P \<and> separated g (fst ` P)} \<noteq> {}"
        apply simp
        apply(rule_tac x="{p}" in exI)
        using \<open>fst p : \<V> g\<close> by(simp add:sep_conv[OF mgp])
      thus ?thesis by(simp add: Max_Un sep_ne)
    qed
    also have "?U = ?M ps0" using Cons by simp blast
    finally show ?thesis .
  qed
qed

lemma dist_ExcessTab: "distinct (map fst (ExcessTable g (vertices g)))"
by(simp add:ExcessTable_def vertices_graph o_def)

lemma mono_ExcessTab: "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g \<rbrakk> \<Longrightarrow>
  set(ExcessTable g (vertices g)) \<subseteq> set(ExcessTable g' (vertices g'))"
apply(clarsimp simp:ExcessTable_def image_def)
apply(rule conjI)
 apply(blast dest:next_plane0_vertices_subset inv_mgp)
apply (clarsimp simp:ExcessAt_def split:if_split_asm)
apply(frule (3) next_plane0_finalVertex_mono)
apply(simp add: next_plane0_len_filter_eq tri_def quad_def except_def)
done

lemma close_antimono:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g; u \<in> \<V> g; finalVertex g u \<rbrakk> \<Longrightarrow>
  close g' u v \<Longrightarrow> close g u v"
by(simp add:close_def next_plane0_finalVertex_facesAt_eq)

lemma ExcessTab_final:
 "p \<in> set(ExcessTable g (vertices g)) \<Longrightarrow> finalVertex g (fst p)"
by(clarsimp simp:ExcessTable_def image_def ExcessAt_def split:if_split_asm)

lemma ExcessTab_vertex:
 "p \<in> set(ExcessTable g (vertices g)) \<Longrightarrow> fst p \<in> \<V> g"
by(clarsimp simp:ExcessTable_def image_def ExcessAt_def split:if_split_asm)

lemma fst_set_ExcessTable_subset:
 "fst ` set (ExcessTable g (vertices g)) \<subseteq> \<V> g"
by(clarsimp simp:ExcessTable_def image_def ExcessAt_def split:if_split_asm)

lemma next_plane0_incr_ExcessNotAt:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g \<rbrakk> \<Longrightarrow>
  ExcessNotAt g None \<le> ExcessNotAt g' None"
apply(frule (1) invariantE[OF inv_inv_next_plane0])
apply(frule (1) mono_ExcessTab)
apply(simp add: ExcessNotAt_def ExcessNotAtRec_conv_Max[OF _ _ dist_ExcessTab]
  fst_set_ExcessTable_subset)
apply(rule Max_mono)
  prefer 2 apply (simp add: sep_ne)
 prefer 2 apply (simp)
apply auto
apply(rule_tac x=P in exI)
apply auto
apply(subgoal_tac "fst ` P \<subseteq> \<V> g'")
 prefer 2 apply (blast dest: ExcessTab_vertex)
apply(subgoal_tac "fst ` P \<subseteq> \<V> g")
 prefer 2 apply (blast dest: ExcessTab_vertex)
apply(simp add:sep_conv)
apply (blast intro:close_antimono ExcessTab_final ExcessTab_vertex)
done
(* close -> in neibhood ?? *)

lemma next_plane0_incr_squander_lb:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g \<rbrakk> \<Longrightarrow>
  squanderLowerBound g \<le> squanderLowerBound g'"
apply(simp add:squanderLowerBound_def)
apply(frule (1) next_plane0_incr_ExcessNotAt)
apply(clarsimp simp add:next_plane0_def split:if_split_asm)
apply(drule (4) genPoly_incr_facesquander_lb)
apply arith
done

lemma inv_notame:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g; notame7 g\<rbrakk>
  \<Longrightarrow> notame7 g'"
apply(simp add:notame_def notame7_def tame11b_def is_tame13a_def tame10ub_def del:disj_not1)
apply(frule inv_mgp)
apply(frule (1) next_plane0_vertices_subset)
apply(erule disjE)
 apply(simp add:vertices_graph)
apply(rule disjI2)
apply(erule disjE)
 apply clarify
 apply(frule (2) next_plane0_incr_degree)
 apply(frule (2) next_plane0_incr_except)
 apply (force split:if_split_asm)
apply(frule (1) next_plane0_incr_squander_lb)
apply(arith)
done

lemma inv_inv_notame:
 "invariant(\<lambda>g. inv g \<and> notame7 g) next_plane\<^bsub>p\<^esub>"
apply(simp add:invariant_def)
apply(blast intro: inv_notame mgp_next_plane0_if_next_plane[OF inv_mgp]
       invariantE[OF inv_inv_next_plane])
done

lemma untame_notame:
 "untame (\<lambda>g. inv g \<and> notame7 g)"
proof(clarsimp simp add: notame_def notame7_def untame_def tame11b_def is_tame13a_def tame10ub_def
                         linorder_not_le linorder_not_less)
  fix g assume "final g" "inv g" "tame g"
    and cases: "15 < countVertices g \<or>
                (\<exists>v\<in>\<V> g. (except g v = 0 \<longrightarrow> 7 < degree g v) \<and>
                            (0 < except g v \<longrightarrow> 6 < degree g v))
                \<or> squanderTarget \<le> squanderLowerBound g"
                (is "?A \<or> ?B \<or> ?C" is "_ \<or> (\<exists>v\<in>\<V> g. ?B' v) \<or> _")
  from cases show False
  proof(elim disjE)
    assume ?B
    then obtain v where v: "v \<in>\<V> g" "?B' v" by auto
    show False
    proof cases
      assume "except g v = 0"
      thus False using \<open>tame g\<close> v by(auto simp: tame_def tame11b_def)
    next
      assume "except g v \<noteq> 0"
      thus False using \<open>tame g\<close> v
        by(auto simp: except_def filter_empty_conv tame_def tame11b_def
          minGraphProps_facesAt_eq[OF inv_mgp[OF \<open>inv g\<close>]] split:if_split_asm)
    qed
  next
    assume ?A
    thus False using \<open>tame g\<close>  by(simp add:tame_def tame10_def)
  next
    assume ?C
    thus False using total_weight_lowerbound[OF \<open>inv g\<close> \<open>final g\<close> \<open>tame g\<close>]
      \<open>tame g\<close>  by(force simp add:tame_def tame13a_def)
  qed
qed

lemma polysizes_tame:
 "\<lbrakk> g' \<in> set (generatePolygon n v f g); inv g; f \<in> set(nonFinals g);
   v \<in> \<V> f; 3 \<le> n; n < 4+p; n \<notin> set(polysizes p g) \<rbrakk>
 \<Longrightarrow> notame7 g'"
apply(frule (4) in_next_plane0I)
apply(frule (4) genPoly_incr_facesquander_lb)
apply(frule (1) next_plane0_incr_ExcessNotAt)
apply(simp add: notame_def notame7_def is_tame13a_def faceSquanderLowerBound_def
           polysizes_def squanderLowerBound_def)
done

lemma genPolyTame_notame:
 "\<lbrakk> g' \<in> set (generatePolygon n v f g); g' \<notin> set (generatePolygonTame n v f g);
    inv g; 3 \<le> n \<rbrakk>
  \<Longrightarrow> notame7 g'"
by(fastforce simp:generatePolygon_def generatePolygonTame_def enum_enumerator
                 notame_def notame7_def)

declare upt_Suc[simp del] (* FIXME global? *)
lemma excess_notame:
 "\<lbrakk> inv g; g' \<in> set (next_plane\<^bsub>p\<^esub> g); g' \<notin> set (next_tame0 p g) \<rbrakk>
       \<Longrightarrow> notame7 g'"
apply(frule (1) mgp_next_plane0_if_next_plane[OF inv_mgp])
apply(auto simp add:next_tame0_def next_plane_def split:if_split_asm)
apply(rename_tac n)
apply(case_tac "n \<in> set(polysizes p g)")
 apply(drule bspec) apply assumption
 apply(simp add:genPolyTame_notame)
apply(subgoal_tac "minimalFace (nonFinals g) \<in> set(nonFinals g)")
 prefer 2 apply(simp add:minimalFace_def)
apply(subgoal_tac "minimalVertex g (minimalFace (nonFinals g)) \<in> \<V>(minimalFace (nonFinals g))")
 apply(blast intro:polysizes_tame)
apply(simp add:minimalVertex_def)
apply(rule minimal_in_set)
apply(erule mgp_vertices_nonempty[OF inv_mgp])
apply(simp add:nonFinals_def)
done
declare upt_Suc[simp]

lemma next_tame0_comp: "\<lbrakk> Seed\<^bsub>p\<^esub> [next_plane p]\<rightarrow>* g; final g; tame g \<rbrakk>
 \<Longrightarrow> Seed\<^bsub>p\<^esub> [next_tame0 p]\<rightarrow>* g"
apply(rule filterout_untame_succs[OF inv_inv_next_plane inv_inv_notame
  untame_notame])
    apply(blast intro:excess_notame)
   apply assumption
  apply(rule inv_Seed)
 apply assumption
apply assumption
done

lemma inv_inv_next_tame0: "invariant inv (next_tame0 p)"
by(rule inv_subset[OF inv_inv_next_plane next_tame0_subset_plane])

lemma inv_inv_next_tame: "invariant inv next_tame\<^bsub>p\<^esub>"
apply(simp add:next_tame_def)
apply(rule inv_subset[OF inv_inv_next_tame0])
apply auto
done

lemma mgp_TameEnum: "g \<in> TameEnum\<^bsub>p\<^esub> \<Longrightarrow> minGraphProps g"
by (unfold TameEnumP_def)
   (blast intro: RTranCl_inv[OF inv_inv_next_tame] inv_Seed inv_mgp)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Composition\<close>
theory SFunctions_Composition
  imports SFunctions_Lambda
begin

lemma comp_mem_dep_functionsI:
  assumes f_mem: "f \<in> (x \<in> B) \<rightarrow>s (C x)"
  and g_mem: "g \<in> A \<rightarrow>s B"
  shows "f \<circ> g \<in> (x \<in> A) \<rightarrow>s (C (g`x))"
proof
  show "f \<circ> g \<subseteq> \<Sum>x \<in> A. (C (g`x))"
  proof
    fix p assume "p \<in> f \<circ> g"
    then obtain x y z where "\<langle>x, y\<rangle> \<in> g" "\<langle>y, z\<rangle> \<in> f" "p = \<langle>x, z\<rangle>" by auto
    moreover with assms have "x \<in> A" "z \<in> C (g`x)" by auto
    ultimately show "p \<in> \<Sum>x \<in> A. (C (g`x))" by auto
  qed
next
  show "set_right_unique_on A (f \<circ> g)"
  proof (subst set_right_unique_on_set_iff_set_right_unique_on,
    intro set_right_unique_on_compI)
    let ?C = "rng g\<restriction>\<^bsub>\<lambda>x. x \<in> A\<^esub> \<inter> dom f"
    from f_mem have "mem_of ?C \<le> mem_of B" by auto
    moreover have "set_right_unique_on (mem_of B) f" using f_mem by blast
    ultimately have "set_right_unique_on (mem_of ?C) f"
      using antimonoD[OF antimono_set_right_unique_on_pred] by auto
    then show "set_right_unique_on ?C f" by simp
  qed (insert g_mem, auto)
  from g_mem have "rng g \<subseteq> B" by auto
  then show "set_left_total_on A (f \<circ> g)"
    using assms by (subst set_left_total_on_set_iff_set_left_total_on,
      intro set_left_total_on_compI)
    auto
qed

lemma comp_eval_eq_if_mem_dep_functions [simp]:
  assumes f_mem: "f \<in> (x \<in> B) \<rightarrow>s (C x)"
  and g_mem: "g \<in> A \<rightarrow>s B"
  and x_mem: "x \<in> A"
  shows "(f \<circ> g)`x = f`(g`x)"
proof -
  have "f \<circ> g \<in> (x \<in> A) \<rightarrow>s (C (g`x))"
    using f_mem g_mem comp_mem_dep_functionsI by auto
  with x_mem have "\<langle>x, (f \<circ> g)`x\<rangle> \<in> f \<circ> g"
    using pair_eval_mem_if_mem_if_mem_dep_functions by auto
   then show "(f \<circ> g)`x = f`(g`x)" using g_mem f_mem by auto
qed

definition "set_id A \<equiv> \<lambda>x \<in> A. x"

lemma set_id_eq [simp]: "set_id A = \<lambda>x \<in> A. x"
  unfolding set_id_def by simp

lemma set_id_mem_dep_functions [iff]: "set_id A \<in> (x \<in> A) \<rightarrow>s {x}"
  by auto

lemma comp_set_id_eq [simp]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  shows "f \<circ> set_id A = f"
proof -
  from assms have "f \<circ> set_id A \<in> (x \<in> A) \<rightarrow>s (B((set_id A)`x))"
    by (elim comp_mem_dep_functionsI) auto
  then have "f \<circ> set_id A \<in> (x \<in> A) \<rightarrow>s (B x)"
    by (rule mem_dep_functions_covariant_codom) auto
  from this assms show ?thesis
    by (rule dep_functions_ext, subst comp_eval_eq_if_mem_dep_functions) auto
qed

lemma set_id_comp_eq [simp]:
  assumes "f \<in> A \<rightarrow>s B"
  shows "set_id B \<circ> f = f"
proof -
  have "set_id B \<circ> f \<in> A \<rightarrow>s B"
    by (rule comp_mem_dep_functionsI[OF _ assms]) auto
  from this assms show ?thesis
    by (rule dep_functions_ext, subst comp_eval_eq_if_mem_dep_functions)
    (auto intro: eval_lambda_eq)
qed

end


(*
  File: SetSum.thy
  Author: Bohua Zhan

  Sum of two sets. Corresponds to Sum.thy in Isabelle/ZF.
*)

theory SetSum
  imports Nat
begin

section \<open>Booleans\<close>

definition bool :: "i" where
  "bool = {0,1}"

(* Conditional on the first argument, which is a boolean. *)
definition cond :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where
  "cond(b,c,d) = (if b = 1 then c else d)"

definition not :: "i \<Rightarrow> i" where
  "not(b) = cond(b,0,1)"

definition "and" :: "i \<Rightarrow> i \<Rightarrow> i"  (infixl "and" 70) where
  "a and b = cond(a,b,0)"

definition "or"  :: "i \<Rightarrow> i \<Rightarrow> i" (infixl "or" 65) where
  "a or b  = cond(a,1,b)"

definition "xor" :: "i \<Rightarrow> i \<Rightarrow> i" (infixl "xor" 65) where
  "a xor b = cond(a,not(b),b)"

setup {* add_rewrite_rule @{thm bool_def} *}
lemma bool_1I [resolve]: "1 \<in> bool" by auto2
lemma bool_0I [resolve]: "0 \<in> bool" by auto2

lemma boolE [forward]: "a \<in> bool \<Longrightarrow> a = 0 \<or> a = 1" by auto2
setup {* del_prfstep_thm @{thm bool_def} *}

setup {* add_rewrite_rule @{thm cond_def} *}
lemma cond_1 [rewrite]: "cond(1,c,d) = c" by auto2
lemma cond_0 [rewrite]: "cond(0,c,d) = d" by auto2
lemma cond_simple_type: "b \<in> bool \<Longrightarrow> c \<in> A \<Longrightarrow> d \<in> A \<Longrightarrow> cond(b,c,d) \<in> A" by auto2
setup {* del_prfstep_thm @{thm cond_def} *}

setup {* add_rewrite_rule @{thm not_def} *}
lemma not_type: "a \<in> bool \<Longrightarrow> not(a) \<in> bool" by auto2

setup {* add_rewrite_rule @{thm and_def} *}
lemma and_type: "a \<in> bool \<Longrightarrow> b \<in> bool \<Longrightarrow> a and b \<in> bool" by auto2

setup {* add_rewrite_rule @{thm or_def} *}
lemma or_type: "a \<in> bool \<Longrightarrow> b \<in> bool \<Longrightarrow> a or b \<in> bool" by auto2

setup {* add_rewrite_rule @{thm xor_def} *}
lemma xor_type: "a \<in> bool \<Longrightarrow> b \<in> bool \<Longrightarrow> a xor b \<in> bool" by auto2

definition bool_of_o :: "o \<Rightarrow> i" where
  "bool_of_o(P) = (if P then 1 else 0)"
setup {* add_rewrite_rule @{thm bool_of_o_def} *}

lemma bool_of_True [rewrite]: "bool_of_o(True) = 1" by auto2
lemma bool_of_False [rewrite]: "bool_of_o(False) = 0" by auto2
lemma bool_of_o_type [resolve]: "bool_of_o(P) \<in> bool" by auto2
lemma bool_of_P_is_1 [rewrite]: "(bool_of_o(P) = 1) \<longleftrightarrow> P" by auto2
lemma bool_of_P_is_0 [rewrite]: "(bool_of_o(P) = 0) \<longleftrightarrow> \<not>P" by auto2

section \<open>Disjoint sum\<close>

definition sum :: "i \<Rightarrow> i \<Rightarrow> i" (infixr "+" 65) where
  "A + B = {0} \<times> A \<union> {1} \<times> B"

definition Inl :: "i \<Rightarrow> i" where
  "Inl(a) = \<langle>0,a\<rangle>"

definition Inr :: "i \<Rightarrow> i" where
  "Inr(b) = \<langle>1,b\<rangle>"

definition "case" :: "[i\<Rightarrow>i, i\<Rightarrow>i, i] \<Rightarrow> i" where
  "case(c,d,p) = cond(fst(p), d(snd(p)), c(snd(p)))"

subsection \<open>Rules for disjoint sums\<close>

setup {* add_rewrite_rule @{thm sum_def} *}
setup {* add_rewrite_rule @{thm Inl_def} *}
setup {* add_rewrite_rule @{thm Inr_def} *}

lemma Sigma_bool: "Sigma(bool,C) = C(0) + C(1)" by auto2
lemma InlI_type [rewrite]: "Inl(a) \<in> A + B \<longleftrightarrow> a \<in> A" by auto2
lemma InrI_type [rewrite]: "Inr(b) \<in> A + B \<longleftrightarrow> b \<in> B" by auto2

lemma sum_iff [forward]:
  "u \<in> A + B \<Longrightarrow> (\<exists>x\<in>A. u = Inl(x)) \<or> (\<exists>y\<in>B. u = Inr(y))" by auto2

lemma Inl_inj [forward]: "Inl(a) = Inl(b) \<Longrightarrow> a = b" by auto2
lemma Inr_inj [forward]: "Inr(a) = Inr(b) \<Longrightarrow> a = b" by auto2
lemma Inl_Inr_neq [resolve]: "Inl(a) \<noteq> Inr(b)" by auto2
lemma sum_empty: "\<emptyset> + \<emptyset> = \<emptyset>" by auto2

lemma sum_subset_iff [rewrite]: "A + B \<subseteq> C + D \<longleftrightarrow> A \<subseteq> C \<and> B \<subseteq> D"
@proof
  @case "A + B \<subseteq> C + D" @with
    @have "\<forall>x\<in>A. x \<in> C" @with @have "Inl(x) \<in> A + B" @end
    @have "\<forall>y\<in>B. y \<in> D" @with @have "Inr(y) \<in> A + B" @end @end
@qed

lemma sum_equal [forward]: "A + B = C + D \<Longrightarrow> A = C \<and> B = D"
@proof @have "A + B \<subseteq> C + D" @have "C + D \<subseteq> A + B" @qed

section \<open>Case\<close>

setup {* add_rewrite_rule @{thm case_def} *}

lemma case_Inl [rewrite]: "case(c, d, Inl(a)) = c(a)" by auto2
lemma case_Inr [rewrite]: "case(c, d, Inr(b)) = d(b)" by auto2

setup {* del_prfstep_thm @{thm case_def} *}

end


(*  Title:      ZF/ex/Ramsey.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Ramsey's Theorem (finite exponent 2 version)

Based upon the article
    D Basin and M Kaufmann,
    The Boyer-Moore Prover and Nuprl: An Experimental Comparison.
    In G Huet and G Plotkin, editors, Logical Frameworks.
    (CUP, 1991), pages 89-119

See also
    M Kaufmann,
    An example in NQTHM: Ramsey's Theorem
    Internal Note, Computational Logic, Inc., Austin, Texas 78703
    Available from the author: kaufmann@cli.com

This function compute Ramsey numbers according to the proof given below
(which, does not constrain the base case values at all.

fun ram 0 j = 1
  | ram i 0 = 1
  | ram i j = ram (i-1) j + ram i (j-1)
*)

theory Ramsey imports ZF begin

definition
  Symmetric :: "i=>o" where
    "Symmetric(E) == (\<forall>x y. <x,y>:E \<longrightarrow> <y,x>:E)"

definition
  Atleast :: "[i,i]=>o" where \<comment> \<open>not really necessary: ZF defines cardinality\<close>
    "Atleast(n,S) == (\<exists>f. f \<in> inj(n,S))"

definition
  Clique  :: "[i,i,i]=>o" where
    "Clique(C,V,E) == (C \<subseteq> V) & (\<forall>x \<in> C. \<forall>y \<in> C. x\<noteq>y \<longrightarrow> <x,y> \<in> E)"

definition
  Indept  :: "[i,i,i]=>o" where
    "Indept(I,V,E) == (I \<subseteq> V) & (\<forall>x \<in> I. \<forall>y \<in> I. x\<noteq>y \<longrightarrow> <x,y> \<notin> E)"

definition
  Ramsey  :: "[i,i,i]=>o" where
    "Ramsey(n,i,j) == \<forall>V E. Symmetric(E) & Atleast(n,V) \<longrightarrow>
         (\<exists>C. Clique(C,V,E) & Atleast(i,C)) |
         (\<exists>I. Indept(I,V,E) & Atleast(j,I))"

(*** Cliques and Independent sets ***)

lemma Clique0 [intro]: "Clique(0,V,E)"
by (unfold Clique_def, blast)

lemma Clique_superset: "[| Clique(C,V',E);  V'<=V |] ==> Clique(C,V,E)"
by (unfold Clique_def, blast)

lemma Indept0 [intro]: "Indept(0,V,E)"
by (unfold Indept_def, blast)

lemma Indept_superset: "[| Indept(I,V',E);  V'<=V |] ==> Indept(I,V,E)"
by (unfold Indept_def, blast)

(*** Atleast ***)

lemma Atleast0 [intro]: "Atleast(0,A)"
by (unfold Atleast_def inj_def Pi_def function_def, blast)

lemma Atleast_succD:
    "Atleast(succ(m),A) ==> \<exists>x \<in> A. Atleast(m, A-{x})"
apply (unfold Atleast_def)
apply (blast dest: inj_is_fun [THEN apply_type] inj_succ_restrict)
done

lemma Atleast_superset:
    "[| Atleast(n,A);  A \<subseteq> B |] ==> Atleast(n,B)"
by (unfold Atleast_def, blast intro: inj_weaken_type)

lemma Atleast_succI:
    "[| Atleast(m,B);  b\<notin> B |] ==> Atleast(succ(m), cons(b,B))"
apply (unfold Atleast_def succ_def)
apply (blast intro: inj_extend elim: mem_irrefl)
done

lemma Atleast_Diff_succI:
     "[| Atleast(m, B-{x});  x \<in> B |] ==> Atleast(succ(m), B)"
by (blast intro: Atleast_succI [THEN Atleast_superset])

(*** Main Cardinality Lemma ***)

(*The #-succ(0) strengthens the original theorem statement, but precisely
  the same proof could be used!!*)
lemma pigeon2 [rule_format]:
     "m \<in> nat ==>
          \<forall>n \<in> nat. \<forall>A B. Atleast((m#+n) #- succ(0), A \<union> B) \<longrightarrow>
                           Atleast(m,A) | Atleast(n,B)"
apply (induct_tac "m")
apply (blast intro!: Atleast0, simp)
apply (rule ballI)
apply (rename_tac m' n) (*simplifier does NOT preserve bound names!*)
apply (induct_tac "n", auto)
apply (erule Atleast_succD [THEN bexE])
apply (rename_tac n' A B z)
apply (erule UnE)
(**case z \<in> B.  Instantiate the '\<forall>A B' induction hypothesis. **)
apply (drule_tac [2] x1 = A and x = "B-{z}" in spec [THEN spec])
apply (erule_tac [2] mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [3] asm_rl notE Atleast_Diff_succI)+
(*proving the condition*)
prefer 2 apply (blast intro: Atleast_superset)
(**case z \<in> A.  Instantiate the '\<forall>n \<in> nat. \<forall>A B' induction hypothesis. **)
apply (drule_tac x2="succ(n')" and x1="A-{z}" and x=B
       in bspec [THEN spec, THEN spec])
apply (erule nat_succI)
apply (erule mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [2] asm_rl Atleast_Diff_succI notE)+
(*proving the condition*)
apply simp
apply (blast intro: Atleast_superset)
done

(**** Ramsey's Theorem ****)

(** Base cases of induction; they now admit ANY Ramsey number **)

lemma Ramsey0j: "Ramsey(n,0,j)"
by (unfold Ramsey_def, blast)

lemma Ramseyi0: "Ramsey(n,i,0)"
by (unfold Ramsey_def, blast)

(** Lemmas for induction step **)

(*The use of succ(m) here, rather than #-succ(0), simplifies the proof of
  Ramsey_step_lemma.*)
lemma Atleast_partition: "[| Atleast(m #+ n, A);  m \<in> nat;  n \<in> nat |]
      ==> Atleast(succ(m), {x \<in> A. ~P(x)}) | Atleast(n, {x \<in> A. P(x)})"
apply (rule nat_succI [THEN pigeon2], assumption+)
apply (rule Atleast_superset, auto)
done

(*For the Atleast part, proves ~(a \<in> I) from the second premise!*)
lemma Indept_succ:
    "[| Indept(I, {z \<in> V-{a}. <a,z> \<notin> E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,I) |] ==>
     Indept(cons(a,I), V, E) & Atleast(succ(j), cons(a,I))"
apply (unfold Symmetric_def Indept_def)
apply (blast intro!: Atleast_succI)
done

lemma Clique_succ:
    "[| Clique(C, {z \<in> V-{a}. <a,z>:E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,C) |] ==>
     Clique(cons(a,C), V, E) & Atleast(succ(j), cons(a,C))"
apply (unfold Symmetric_def Clique_def)
apply (blast intro!: Atleast_succI)
done

(** Induction step **)

(*Published proofs gloss over the need for Ramsey numbers to be POSITIVE.*)
lemma Ramsey_step_lemma:
   "[| Ramsey(succ(m), succ(i), j);  Ramsey(n, i, succ(j));
       m \<in> nat;  n \<in> nat |] ==> Ramsey(succ(m#+n), succ(i), succ(j))"
apply (unfold Ramsey_def, clarify)
apply (erule Atleast_succD [THEN bexE])
apply (erule_tac P1 = "%z.<x,z>:E" in Atleast_partition [THEN disjE],
       assumption+)
(*case m*)
apply (fast dest!: Indept_succ elim: Clique_superset)
(*case n*)
apply (fast dest!: Clique_succ elim: Indept_superset)
done

(** The actual proof **)

(*Again, the induction requires Ramsey numbers to be positive.*)
lemma ramsey_lemma: "i \<in> nat ==> \<forall>j \<in> nat. \<exists>n \<in> nat. Ramsey(succ(n), i, j)"
apply (induct_tac "i")
apply (blast intro!: Ramsey0j)
apply (rule ballI)
apply (induct_tac "j")
apply (blast intro!: Ramseyi0)
apply (blast intro!: add_type Ramsey_step_lemma)
done

(*Final statement in a tidy form, without succ(...) *)

end


theory Language_Lift
  imports Security_Policy
begin

text \<open>
Link a language definition to the deeply embedded predicate language,
to enable reasoning about the language's operations within the logic.
The language is assumed to consist of expressions over one type of values
and boolean operations over these same values.
Additionally, the boolean operations must support negation.
Moreover, the operations are assumed to be deterministic.
\<close>

datatype ('var, 'aexp, 'bexp) Action =
  Assign "'var" "'aexp"  (infix "\<leftarrow>" 999)
  | Guard "'bexp" ("\<lbrace>_\<rbrace>" [0] 999)
  | CAS "'var" "'aexp" "'aexp"
  | NCAS "'var" "'aexp" "'aexp"
  | Store "'var list" "'aexp" "'aexp"
  | Load "'var" "'var list" "'aexp"
  | Nop
  | Stop

locale language_lift =
  security_policy all_vars
  for all_vars :: "'Var list" +
  fixes eval\<^sub>A :: "('Var, nat) Mem \<Rightarrow> 'Aexp \<Rightarrow> nat"
  fixes eval\<^sub>B :: "('Var, nat) Mem \<Rightarrow> 'Bexp \<Rightarrow> bool"
  fixes lift\<^sub>A :: "'Aexp \<Rightarrow> ('Var,nat) exp"
  fixes lift\<^sub>B :: "'Bexp \<Rightarrow> ('Var,nat) pred"
  fixes vars\<^sub>A :: "'Aexp \<Rightarrow> 'Var list"
  fixes vars\<^sub>B :: "'Bexp \<Rightarrow> 'Var list"
  fixes not :: "'Bexp \<Rightarrow> 'Bexp"
  assumes lift\<^sub>A_correct[simp]: "\<And>e mem. eval mem (lift\<^sub>A e) = eval\<^sub>A mem e"
  assumes lift\<^sub>B_correct[simp]: "\<And>e mem \<Gamma>. test mem \<Gamma> (lift\<^sub>B e) = eval\<^sub>B mem e"
  assumes not_correct [simp]: "\<And>e mem. eval\<^sub>B mem (not e) = (\<not> eval\<^sub>B mem e)"
  assumes not_vars [simp]: "vars\<^sub>B (not b) = vars\<^sub>B b"
  assumes vars\<^sub>A_correct [simp]: "\<And>e. set (vars\<^sub>A e) = vars\<^sub>e (lift\<^sub>A e)"
  assumes vars\<^sub>B_correct [simp]: "\<And>e. set (vars\<^sub>B e) = vars\<^sub>p (lift\<^sub>B e)"

context language_lift
begin

lemma eval\<^sub>A_det:
  assumes "\<forall>x \<in> vars\<^sub>e (lift\<^sub>A e). mem\<^sub>1 x = mem\<^sub>2 x" (is "\<forall>x \<in> vars\<^sub>e ?e. ?eq x")
  shows "eval\<^sub>A mem\<^sub>1 e = eval\<^sub>A mem\<^sub>2 e"
proof -
  have "eval\<^sub>A mem\<^sub>1 e = eval mem\<^sub>1 ?e" "eval\<^sub>A mem\<^sub>2 e = eval mem\<^sub>2 ?e"
    using lift\<^sub>A_correct by auto
  moreover have "eval mem\<^sub>1 ?e = eval mem\<^sub>2 ?e" using assms
    by (auto simp del: lift\<^sub>A_correct intro!: eval_vars_det)
  ultimately show ?thesis by auto
qed

lemma eval\<^sub>B_det:
  assumes "\<forall>x \<in> vars\<^sub>p (lift\<^sub>B e). mem\<^sub>1 x = mem\<^sub>2 x" (is "\<forall>x \<in> vars\<^sub>p ?e. ?eq x")
  shows "eval\<^sub>B mem\<^sub>1 e = eval\<^sub>B mem\<^sub>2 e"
proof -
  have "\<forall>\<Gamma>. eval\<^sub>B mem\<^sub>1 e = test mem\<^sub>1 \<Gamma> ?e" "\<forall>\<Gamma>. eval\<^sub>B mem\<^sub>2 e = test mem\<^sub>2 \<Gamma> ?e"
    using lift\<^sub>B_correct by auto
  moreover obtain \<Gamma> where "test mem\<^sub>1 \<Gamma> ?e = test mem\<^sub>2 \<Gamma> ?e" using assms
    by (auto simp del: lift\<^sub>B_correct intro!: test_vars_det)
  ultimately show ?thesis by blast
qed

fun update :: "('Var, 'Aexp, 'Bexp) Action \<Rightarrow> ('Var, nat) Mem rel"
  where
  "update (\<lbrace>b\<rbrace>) = {(m,m'). m' = m \<and> eval\<^sub>B m b}" |
  "update (x \<leftarrow> e) = {(m,m'). m' = m(x := eval\<^sub>A m e)}" |
  "update (CAS x e\<^sub>1 e\<^sub>2) = {(m,m'). m x = eval\<^sub>A m e\<^sub>1 \<and> m' = m(x := eval\<^sub>A m e\<^sub>2)}" |
  "update (NCAS x e\<^sub>1 e\<^sub>2) = {(m,m'). m x \<noteq> eval\<^sub>A m e\<^sub>1 \<and> m' = m}" |
  "update Nop = {(m,m'). m = m'}" |
  "update Stop = {}" |
  "update (Store x i e) = {(m,m'). set x \<inter> set (vars\<^sub>A i) = {} \<and> length x > (eval\<^sub>A m i) \<and> m' = m((x ! (eval\<^sub>A m i)) := eval\<^sub>A m e)}" |
  "update (Load r x i) = {(m,m'). length x > (eval\<^sub>A m i) \<and> m' = m(r := (m (x ! (eval\<^sub>A m i))))}"

fun negate :: "('Var, 'Aexp, 'Bexp) Action \<Rightarrow> ('Var, 'Aexp, 'Bexp) Action"
  where
  "negate (\<lbrace>b\<rbrace>) = (\<lbrace>not b\<rbrace>)" |
  "negate Stop = Nop" |
  "negate (CAS x e\<^sub>1 e\<^sub>2) = (NCAS x e\<^sub>1 e\<^sub>2)" |
  "negate (NCAS x e\<^sub>1 e\<^sub>2) = (CAS x e\<^sub>1 e\<^sub>2)" |
  "negate _ = Stop"

lemma update_det:
  "(m,m') \<in> update \<alpha> \<longrightarrow> (m,m'') \<in> update \<alpha> \<longrightarrow> m' = m''"
  by (cases \<alpha>) auto

end

end