theory Tensor_LValues
  imports LValues_Typed Complex_Main
begin

section Matrices

(* TODO: make non-square *)
typedef ('row,'col) matrix = "UNIV::('row\<Rightarrow>'col\<Rightarrow>complex) set" by simp
setup_lifting type_definition_matrix
type_synonym 'a square = "('a,'a) matrix"

lift_definition tensor :: "('ar,'ac) matrix \<Rightarrow> ('br,'bc) matrix \<Rightarrow> ('ar*'br,'ac*'bc) matrix" is
  "%A B. \<lambda>(r1,r2) (c1,c2). A r1 c1 * B r2 c2" .

(* TODO associator *)
(* TODO swapper *)

instantiation matrix :: (type, type) ab_group_add begin
lift_definition plus_matrix :: "('r,'c) matrix \<Rightarrow> ('r,'c) matrix \<Rightarrow> ('r,'c) matrix" is "%A B i j. A i j + B i j".
lift_definition minus_matrix :: "('r,'c) matrix \<Rightarrow> ('r,'c) matrix \<Rightarrow> ('r,'c) matrix" is "%A B i j. A i j - B i j".
lift_definition uminus_matrix :: "('r,'c) matrix \<Rightarrow> ('r,'c) matrix" is "%A i j. - A i j".
lift_definition zero_matrix :: "('r,'c) matrix" is "\<lambda>i j. 0".
instance sorry
end

lift_definition mat_mul :: "('a,'b) matrix \<Rightarrow> ('b,'c) matrix \<Rightarrow> ('a,'c) matrix" is "%A B i k. (\<Sum>j\<in>UNIV. A i j * B j k)".
lift_definition mat_one :: "'a square" is "\<lambda>i j. if i=j then 1 else 0".

abbreviation "delta x y == (if x=y then 1 else 0)"

(*
lift_definition matrix_on :: "('br,'bc) matrix \<Rightarrow> ('a,'br) lvalue \<Rightarrow> ('a,'bc) lvalue \<Rightarrow> 'a square" is
  "\<lambda>B xr xc (r::'a) (c::'a). B (fst (split_memory xr r)) (fst (split_memory xc c))
  * delta (snd (split_memory xr r)) (snd (split_memory xc c))" .

lemma matrix_on_lift_left:
  fixes xc :: "('a,'bc) lvalue" and xr :: "('a,'br) lvalue"
  assumes compatc[simp]: "compatible_lvalues xc y"
  assumes compatr[simp]: "compatible_lvalues xr y"
  defines "xyr == lvalue_pair xr y"
  defines "xyc == lvalue_pair xc y"
  shows "matrix_on A xr xc = matrix_on (tensor A mat_one) xyr xyc"
proof (transfer fixing: xr xc y xyc xyr, rule ext, rule ext)
  fix A :: "'br \<Rightarrow> 'bc \<Rightarrow> complex" and r c

  define xcrest xrrest yrest xycrest xyrrest
    where "xcrest m = snd (split_memory xc m)"
      and "xrrest m = snd (split_memory xr m)"
      and "yrest m = snd (split_memory y m)"
      and "xycrest m = snd (split_memory xyc m)"
      and "xyrrest m = snd (split_memory xyr m)" for m

  have [simp]: "valid_lvalue xyc"
    unfolding xyc_def by simp
  have [simp]: "valid_lvalue xyr"
    unfolding xyr_def by simp
  have [simp]: "valid_lvalue xc"
    using LValues_Typed.compatible_valid1 compatc by blast
  have [simp]: "valid_lvalue xr"
    using LValues_Typed.compatible_valid1 compatr by blast
  have [simp]: "valid_lvalue y"
    using LValues_Typed.compatible_valid2 compatc by blast

  have [simp]: "fst (split_memory xc r) = getter xc r" for r
    by simp
  have [simp]: "fst (split_memory xr r) = getter xr r" for r
    by simp
  have [simp]: "fst (split_memory y r) = getter y r" for r
    by simp

  have [simp]: "fst (split_memory xyc r) = (getter xc r, getter y r)" for r
    apply (subst fst_split_memory)
    unfolding xyc_def by simp_all
  have [simp]: "fst (split_memory xyr r) = (getter xr r, getter y r)" for r
    apply (subst fst_split_memory)
    unfolding xyr_def by simp_all

  (* TODO: not true without extra assumptions *)
  have [simp]: "xycrest m = xyrrest m" for m
    sorry

  have [simp]: "xrrest a = xrrest b \<longleftrightarrow> xyrrest a = xyrrest b \<and> getter y a = getter y b" for a b
    unfolding xrrest_def xyrrest_def xyr_def
    apply (rule split_pair_eq_typed)
    by (rule compatr)
  have [simp]: "xcrest a = xcrest b \<longleftrightarrow> xycrest a = xycrest b \<and> getter y a = getter y b" for a b
    unfolding xcrest_def xycrest_def xyc_def
    apply (rule split_pair_eq_typed)
    by (rule compatc)

  show "A (fst (split_memory xr r)) (fst (split_memory xc c)) *
           delta (xrrest r) (xcrest c)
        =
          (\<lambda>(r1, r2) (c1, c2). A r1 c1 * delta r2 c2)
              (fst (split_memory xyr r))
              (fst (split_memory xyc c))
           *
           delta (xyrrest r) (xycrest c)"

    apply simp
    apply auto

    by simp
qed
*)

end


theory Ex028
  imports Main
begin

lemma "\<not>(A \<and> B) \<longleftrightarrow> (\<not>A \<or> \<not>B)"
proof -
  {

    assume a:"\<not>(A \<and> B)"
    {
      assume b:"\<not>(\<not>A \<or> \<not>B)"
      {
        assume "\<not>A"
        hence "\<not>A \<or> \<not>B" by (rule disjI1)
        with b have False by contradiction
      }
      hence "\<not>\<not>A" by (rule notI)
      hence c:A by (rule notnotD)
      {
        assume "\<not>B"
        hence "\<not>A \<or> \<not>B" by (rule disjI2)
        with b have False by contradiction
      }
      hence "\<not>\<not>B" by (rule notI)
      hence B by (rule notnotD)
      with c have "A \<and> B" by (rule conjI)
      with a have False by contradiction
    }
    hence "\<not>\<not>(\<not>A \<or> \<not>B)" by (rule notI)
    hence "\<not>A \<or> \<not>B" by (rule notnotD)
  }
  moreover
  {
    assume a:"\<not>A \<or> \<not>B"
    {
      assume b:"A \<and> B"
      hence c:A by (rule conjE)
      from b have d:B by (rule conjE)
      {
        assume "\<not>A"
        with c have False by contradiction
      }
      note e=this
      {
        assume "\<not>B"
        with d have False by contradiction
      }
      with a and e have False by (rule disjE)
    }
    hence "\<not>(A \<and> B)" by (rule notI)
  }
  ultimately show ?thesis by (rule iffI)
qed


theory Section2_6
  imports Main
begin

primrec sum :: "nat \<Rightarrow> nat" where
  "sum 0 = 0" |
  "sum (Suc n) = Suc n + sum n"

lemma "sum n + sum n = n*(Suc n)"
  apply (induct_tac n)
  apply auto
  done

lemma "\<lbrakk>\<not> m < n; m < n + (1::nat)\<rbrakk> \<Longrightarrow> m = n"
  apply arith
  done

lemma "m \<noteq> (n::nat) \<Longrightarrow> m < n \<or> n < m"
  apply arith
  done

lemma "min i (max j (k*k)) = max (min (k*k) i) (min i (j::nat))"
  apply arith
  done

end


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

Lists are partially ordered by Charpentier's Generalized Prefix Relation
   (xs,ys) : genPrefix(r)
     if ys = xs' @ zs where length xs = length xs'
     and corresponding elements of xs, xs' are pairwise related by r

Also overloads <= and < for lists!
*)

section \<open>The Prefix Ordering on Lists\<close>

theory ListOrder
imports Main
begin

inductive_set
  genPrefix :: "('a * 'a)set => ('a list * 'a list)set"
  for r :: "('a * 'a)set"
 where
   Nil:     "([],[]) : genPrefix(r)"

 | prepend: "[| (xs,ys) : genPrefix(r);  (x,y) : r |] ==>
             (x#xs, y#ys) : genPrefix(r)"

 | append:  "(xs,ys) : genPrefix(r) ==> (xs, ys@zs) : genPrefix(r)"

instantiation list :: (type) ord
begin

definition
  prefix_def:        "xs <= zs \<longleftrightarrow>  (xs, zs) : genPrefix Id"

definition
  strict_prefix_def: "xs < zs  \<longleftrightarrow>  xs \<le> zs \<and> \<not> zs \<le> (xs :: 'a list)"

instance ..

(*Constants for the <= and >= relations, used below in translations*)

end

definition Le :: "(nat*nat) set" where
    "Le == {(x,y). x <= y}"

definition  Ge :: "(nat*nat) set" where
    "Ge == {(x,y). y <= x}"

abbreviation
  pfixLe :: "[nat list, nat list] => bool"  (infixl "pfixLe" 50)  where
  "xs pfixLe ys == (xs,ys) : genPrefix Le"

abbreviation
  pfixGe :: "[nat list, nat list] => bool"  (infixl "pfixGe" 50)  where
  "xs pfixGe ys == (xs,ys) : genPrefix Ge"

subsection\<open>preliminary lemmas\<close>

lemma Nil_genPrefix [iff]: "([], xs) : genPrefix r"
by (cut_tac genPrefix.Nil [THEN genPrefix.append], auto)

lemma genPrefix_length_le: "(xs,ys) : genPrefix r ==> length xs <= length ys"
by (erule genPrefix.induct, auto)

lemma cdlemma:
     "[| (xs', ys'): genPrefix r |]
      ==> (ALL x xs. xs' = x#xs --> (EX y ys. ys' = y#ys & (x,y) : r & (xs, ys) : genPrefix r))"
apply (erule genPrefix.induct, blast, blast)
apply (force intro: genPrefix.append)
done

(*As usual converting it to an elimination rule is tiresome*)
lemma cons_genPrefixE [elim!]:
     "[| (x#xs, zs): genPrefix r;
         !!y ys. [| zs = y#ys;  (x,y) : r;  (xs, ys) : genPrefix r |] ==> P
      |] ==> P"
by (drule cdlemma, simp, blast)

lemma Cons_genPrefix_Cons [iff]:
     "((x#xs,y#ys) : genPrefix r) = ((x,y) : r & (xs,ys) : genPrefix r)"
by (blast intro: genPrefix.prepend)

subsection\<open>genPrefix is a partial order\<close>

lemma refl_genPrefix: "refl r ==> refl (genPrefix r)"
apply (unfold refl_on_def, auto)
apply (induct_tac "x")
prefer 2 apply (blast intro: genPrefix.prepend)
apply (blast intro: genPrefix.Nil)
done

lemma genPrefix_refl [simp]: "refl r ==> (l,l) : genPrefix r"
by (erule refl_onD [OF refl_genPrefix UNIV_I])

lemma genPrefix_mono: "r<=s ==> genPrefix r <= genPrefix s"
apply clarify
apply (erule genPrefix.induct)
apply (auto intro: genPrefix.append)
done

(** Transitivity **)

(*A lemma for proving genPrefix_trans_O*)
lemma append_genPrefix:
     "(xs @ ys, zs) : genPrefix r \<Longrightarrow> (xs, zs) : genPrefix r"
  by (induct xs arbitrary: zs) auto

(*Lemma proving transitivity and more*)
lemma genPrefix_trans_O:
  assumes "(x, y) : genPrefix r"
  shows "\<And>z. (y, z) : genPrefix s \<Longrightarrow> (x, z) : genPrefix (r O s)"
  apply (atomize (full))
  using assms
  apply induct
    apply blast
   apply (blast intro: genPrefix.prepend)
  apply (blast dest: append_genPrefix)
  done

lemma genPrefix_trans:
  "(x, y) : genPrefix r \<Longrightarrow> (y, z) : genPrefix r \<Longrightarrow> trans r
    \<Longrightarrow> (x, z) : genPrefix r"
  apply (rule trans_O_subset [THEN genPrefix_mono, THEN subsetD])
   apply assumption
  apply (blast intro: genPrefix_trans_O)
  done

lemma prefix_genPrefix_trans:
  "[| x<=y;  (y,z) : genPrefix r |] ==> (x, z) : genPrefix r"
apply (unfold prefix_def)
apply (drule genPrefix_trans_O, assumption)
apply simp
done

lemma genPrefix_prefix_trans:
  "[| (x,y) : genPrefix r;  y<=z |] ==> (x,z) : genPrefix r"
apply (unfold prefix_def)
apply (drule genPrefix_trans_O, assumption)
apply simp
done

lemma trans_genPrefix: "trans r ==> trans (genPrefix r)"
by (blast intro: transI genPrefix_trans)

(** Antisymmetry **)

lemma genPrefix_antisym:
  assumes 1: "(xs, ys) : genPrefix r"
    and 2: "antisym r"
    and 3: "(ys, xs) : genPrefix r"
  shows "xs = ys"
  using 1 3
proof induct
  case Nil
  then show ?case by blast
next
  case prepend
  then show ?case using 2 by (simp add: antisym_def)
next
  case (append xs ys zs)
  then show ?case
    apply -
    apply (subgoal_tac "length zs = 0", force)
    apply (drule genPrefix_length_le)+
    apply (simp del: length_0_conv)
    done
qed

lemma antisym_genPrefix: "antisym r ==> antisym (genPrefix r)"
  by (blast intro: antisymI genPrefix_antisym)

subsection\<open>recursion equations\<close>

lemma genPrefix_Nil [simp]: "((xs, []) : genPrefix r) = (xs = [])"
  by (induct xs) auto

lemma same_genPrefix_genPrefix [simp]:
    "refl r ==> ((xs@ys, xs@zs) : genPrefix r) = ((ys,zs) : genPrefix r)"
  by (induct xs) (simp_all add: refl_on_def)

lemma genPrefix_Cons:
     "((xs, y#ys) : genPrefix r) =
      (xs=[] | (EX z zs. xs=z#zs & (z,y) : r & (zs,ys) : genPrefix r))"
  by (cases xs) auto

lemma genPrefix_take_append:
     "[| refl r;  (xs,ys) : genPrefix r |]
      ==>  (xs@zs, take (length xs) ys @ zs) : genPrefix r"
apply (erule genPrefix.induct)
apply (frule_tac [3] genPrefix_length_le)
apply (simp_all (no_asm_simp) add: diff_is_0_eq [THEN iffD2])
done

lemma genPrefix_append_both:
     "[| refl r;  (xs,ys) : genPrefix r;  length xs = length ys |]
      ==>  (xs@zs, ys @ zs) : genPrefix r"
apply (drule genPrefix_take_append, assumption)
apply simp
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_eq: "xs @ y # ys = (xs @ [y]) @ ys"
by auto

lemma aolemma:
     "[| (xs,ys) : genPrefix r;  refl r |]
      ==> length xs < length ys --> (xs @ [ys ! length xs], ys) : genPrefix r"
apply (erule genPrefix.induct)
  apply blast
 apply simp
txt\<open>Append case is hardest\<close>
apply simp
apply (frule genPrefix_length_le [THEN le_imp_less_or_eq])
apply (erule disjE)
apply (simp_all (no_asm_simp) add: neq_Nil_conv nth_append)
apply (blast intro: genPrefix.append, auto)
apply (subst append_cons_eq, fast intro: genPrefix_append_both genPrefix.append)
done

lemma append_one_genPrefix:
     "[| (xs,ys) : genPrefix r;  length xs < length ys;  refl r |]
      ==> (xs @ [ys ! length xs], ys) : genPrefix r"
by (blast intro: aolemma [THEN mp])

(** Proving the equivalence with Charpentier's definition **)

lemma genPrefix_imp_nth:
    "i < length xs \<Longrightarrow> (xs, ys) : genPrefix r \<Longrightarrow> (xs ! i, ys ! i) : r"
  apply (induct xs arbitrary: i ys)
   apply auto
  apply (case_tac i)
   apply auto
  done

lemma nth_imp_genPrefix:
  "length xs <= length ys \<Longrightarrow>
     (\<forall>i. i < length xs --> (xs ! i, ys ! i) : r) \<Longrightarrow>
     (xs, ys) : genPrefix r"
  apply (induct xs arbitrary: ys)
   apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib)
  apply (case_tac ys)
   apply (force+)
  done

lemma genPrefix_iff_nth:
     "((xs,ys) : genPrefix r) =
      (length xs <= length ys & (ALL i. i < length xs --> (xs!i, ys!i) : r))"
apply (blast intro: genPrefix_length_le genPrefix_imp_nth nth_imp_genPrefix)
done

subsection\<open>The type of lists is partially ordered\<close>

declare refl_Id [iff]
        antisym_Id [iff]
        trans_Id [iff]

lemma prefix_refl [iff]: "xs <= (xs::'a list)"
by (simp add: prefix_def)

lemma prefix_trans: "!!xs::'a list. [| xs <= ys; ys <= zs |] ==> xs <= zs"
apply (unfold prefix_def)
apply (blast intro: genPrefix_trans)
done

lemma prefix_antisym: "!!xs::'a list. [| xs <= ys; ys <= xs |] ==> xs = ys"
apply (unfold prefix_def)
apply (blast intro: genPrefix_antisym)
done

lemma prefix_less_le_not_le: "!!xs::'a list. (xs < zs) = (xs <= zs & \<not> zs \<le> xs)"
by (unfold strict_prefix_def, auto)

instance list :: (type) order
  by (intro_classes,
      (assumption | rule prefix_refl prefix_trans prefix_antisym
                     prefix_less_le_not_le)+)

(*Monotonicity of "set" operator WRT prefix*)
lemma set_mono: "xs <= ys ==> set xs <= set ys"
apply (unfold prefix_def)
apply (erule genPrefix.induct, auto)
done

(** recursion equations **)

lemma Nil_prefix [iff]: "[] <= xs"
by (simp add: prefix_def)

lemma prefix_Nil [simp]: "(xs <= []) = (xs = [])"
by (simp add: prefix_def)

lemma Cons_prefix_Cons [simp]: "(x#xs <= y#ys) = (x=y & xs<=ys)"
by (simp add: prefix_def)

lemma same_prefix_prefix [simp]: "(xs@ys <= xs@zs) = (ys <= zs)"
by (simp add: prefix_def)

lemma append_prefix [iff]: "(xs@ys <= xs) = (ys <= [])"
by (insert same_prefix_prefix [of xs ys "[]"], simp)

lemma prefix_appendI [simp]: "xs <= ys ==> xs <= ys@zs"
apply (unfold prefix_def)
apply (erule genPrefix.append)
done

lemma prefix_Cons:
   "(xs <= y#ys) = (xs=[] | (? zs. xs=y#zs & zs <= ys))"
by (simp add: prefix_def genPrefix_Cons)

lemma append_one_prefix:
  "[| xs <= ys; length xs < length ys |] ==> xs @ [ys ! length xs] <= ys"
apply (unfold prefix_def)
apply (simp add: append_one_genPrefix)
done

lemma prefix_length_le: "xs <= ys ==> length xs <= length ys"
apply (unfold prefix_def)
apply (erule genPrefix_length_le)
done

lemma splemma: "xs<=ys ==> xs~=ys --> length xs < length ys"
apply (unfold prefix_def)
apply (erule genPrefix.induct, auto)
done

lemma strict_prefix_length_less: "xs < ys ==> length xs < length ys"
apply (unfold strict_prefix_def)
apply (blast intro: splemma [THEN mp])
done

lemma mono_length: "mono length"
by (blast intro: monoI prefix_length_le)

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff: "(xs <= zs) = (EX ys. zs = xs@ys)"
apply (unfold prefix_def)
apply (auto simp add: genPrefix_iff_nth nth_append)
apply (rule_tac x = "drop (length xs) zs" in exI)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append)
done

lemma prefix_snoc [simp]: "(xs <= ys@[y]) = (xs = ys@[y] | xs <= ys)"
apply (simp add: prefix_iff)
apply (rule iffI)
 apply (erule exE)
 apply (rename_tac "zs")
 apply (rule_tac xs = zs in rev_exhaust)
  apply simp
 apply clarify
 apply (simp del: append_assoc add: append_assoc [symmetric], force)
done

lemma prefix_append_iff:
     "(xs <= ys@zs) = (xs <= ys | (? us. xs = ys@us & us <= zs))"
apply (rule_tac xs = zs in rev_induct)
 apply force
apply (simp del: append_assoc add: append_assoc [symmetric], force)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear:
  fixes xs ys zs :: "'a list"
  shows "xs <= zs \<Longrightarrow> ys <= zs \<Longrightarrow> xs <= ys | ys <= xs"
  by (induct zs rule: rev_induct) auto

subsection\<open>pfixLe, pfixGe: properties inherited from the translations\<close>

(** pfixLe **)

lemma refl_Le [iff]: "refl Le"
by (unfold refl_on_def Le_def, auto)

lemma antisym_Le [iff]: "antisym Le"
by (unfold antisym_def Le_def, auto)

lemma trans_Le [iff]: "trans Le"
by (unfold trans_def Le_def, auto)

lemma pfixLe_refl [iff]: "x pfixLe x"
by simp

lemma pfixLe_trans: "[| x pfixLe y; y pfixLe z |] ==> x pfixLe z"
by (blast intro: genPrefix_trans)

lemma pfixLe_antisym: "[| x pfixLe y; y pfixLe x |] ==> x = y"
by (blast intro: genPrefix_antisym)

lemma prefix_imp_pfixLe: "xs<=ys ==> xs pfixLe ys"
apply (unfold prefix_def Le_def)
apply (blast intro: genPrefix_mono [THEN [2] rev_subsetD])
done

lemma refl_Ge [iff]: "refl Ge"
by (unfold refl_on_def Ge_def, auto)

lemma antisym_Ge [iff]: "antisym Ge"
by (unfold antisym_def Ge_def, auto)

lemma trans_Ge [iff]: "trans Ge"
by (unfold trans_def Ge_def, auto)

lemma pfixGe_refl [iff]: "x pfixGe x"
by simp

lemma pfixGe_trans: "[| x pfixGe y; y pfixGe z |] ==> x pfixGe z"
by (blast intro: genPrefix_trans)

lemma pfixGe_antisym: "[| x pfixGe y; y pfixGe x |] ==> x = y"
by (blast intro: genPrefix_antisym)

lemma prefix_imp_pfixGe: "xs<=ys ==> xs pfixGe ys"
apply (unfold prefix_def Ge_def)
apply (blast intro: genPrefix_mono [THEN [2] rev_subsetD])
done

end


theory FiniteListGraph
imports
  FiniteGraph
  "../../Transitive-Closure/Transitive_Closure_List_Impl"
begin

section {*Specification of a finite graph, implemented by lists*}

text{* A graph @{text "G=(V,E)"} consits of a list of vertices @{term V}, also called nodes,
       and a list of edges @{term E}. The edges are tuples of vertices.
       Using lists instead of sets, code can be easily created. *}

  record 'v list_graph =
    nodesL :: "'v list"
    edgesL :: "('v \<times>'v) list"

text{*Correspondence the FiniteGraph*}
  definition list_graph_to_graph :: "'v list_graph \<Rightarrow> 'v graph" where
    "list_graph_to_graph G = \<lparr> nodes = set (nodesL G), edges = set (edgesL G) \<rparr>"

  definition valid_list_graph_axioms :: "'v list_graph \<Rightarrow> bool" where
    "valid_list_graph_axioms G \<longleftrightarrow> fst` set (edgesL G) \<subseteq> set (nodesL G) \<and> snd` set (edgesL G) \<subseteq> set (nodesL G)"

  lemma valid_list_graph_iff_valid_graph: "valid_graph (list_graph_to_graph G) \<longleftrightarrow> valid_list_graph_axioms G"
  unfolding list_graph_to_graph_def valid_graph_def valid_list_graph_axioms_def
  by simp

  text{*We say a @{typ "'v list_graph"} is valid if it fulfills the graph axioms and its lists are distinct*}
  definition valid_list_graph::"('v) list_graph \<Rightarrow> bool" where
   "valid_list_graph G = (distinct (nodesL G) \<and> distinct (edgesL G) \<and> valid_list_graph_axioms G)"

section{*FiniteListGraph operations*}

  text {* Adds a node to a graph. *}
  definition add_node :: "'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
    "add_node v G = \<lparr> nodesL = (if v \<in> set (nodesL G) then nodesL G else v#nodesL G), edgesL=edgesL G \<rparr>"

  text {* Adds an edge to a graph. *}
  definition add_edge :: "'v \<Rightarrow> 'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
    "add_edge v v' G = (add_node v (add_node v' G)) \<lparr>edgesL := (if (v, v') \<in> set (edgesL G) then edgesL G else (v, v')#edgesL G) \<rparr>"

  text {* Deletes a node from a graph. Also deletes all adjacent edges. *}
  definition delete_node :: "'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
  "delete_node v G = \<lparr>
    nodesL = remove1 v (nodesL G), edgesL = [(e1,e2) \<leftarrow> (edgesL G). e1 \<noteq> v \<and> e2 \<noteq> v]
    \<rparr>"

  text {* Deletes an edge from a graph. *}
  definition delete_edge :: "'v \<Rightarrow> 'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
    "delete_edge v v' G = \<lparr>nodesL = nodesL G, edgesL = [(e1,e2) \<leftarrow> edgesL G. e1 \<noteq> v \<or> e2 \<noteq> v'] \<rparr>"

  fun delete_edges::"'v list_graph \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> 'v list_graph" where
    "delete_edges G [] = G"|
    "delete_edges G ((v,v')#es) = delete_edges (delete_edge v v' G) es"

text {* extended graph operations *}
   text {* Reflexive transitive successors of a node. Or: All reachable nodes for v including v. *}
    definition succ_rtran :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> 'v list" where
      "succ_rtran G v = rtrancl_list_impl (edgesL G) [v]"

   text {* Transitive successors of a node. Or: All reachable nodes for v. *}
    definition succ_tran :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> 'v list" where
      "succ_tran G v = trancl_list_impl (edgesL G) [v]"

   text {* The number of reachable nodes from v *}
    definition num_reachable :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> nat" where
      "num_reachable G v = length (succ_tran G v)"

    definition num_reachable_norefl :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> nat" where
      "num_reachable_norefl G v = length ([ x \<leftarrow> succ_tran G v. x \<noteq> v])"

subsection{*undirected graph simulation*}
  text {* Create undirected graph from directed graph by adding backward links *}
  fun backlinks :: "('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list" where
    "backlinks [] = []" |
    "backlinks ((e1, e2)#es) = (e2, e1)#(backlinks es)"

  definition undirected :: "'v list_graph \<Rightarrow> 'v list_graph"
    where "undirected G \<equiv> \<lparr> nodesL = nodesL G, edgesL = remdups (edgesL G @ backlinks (edgesL G)) \<rparr>"

section{*Correctness lemmata*}

  -- "add node"
  lemma add_node_valid: "valid_list_graph G \<Longrightarrow> valid_list_graph (add_node v G)"
  unfolding valid_list_graph_def valid_list_graph_axioms_def add_node_def
  by auto

  lemma add_node_set_nodes: "set (nodesL (add_node v G)) = set (nodesL G) \<union> {v}"
  unfolding add_node_def
  by auto

  lemma add_node_set_edges: "set (edgesL (add_node v G)) = set (edgesL G)"
  unfolding add_node_def
  by auto

  lemma add_node_correct: "FiniteGraph.add_node v (list_graph_to_graph G) = list_graph_to_graph (add_node v G)"
  unfolding FiniteGraph.add_node_def list_graph_to_graph_def
  by (simp add: add_node_set_edges add_node_set_nodes)

  lemma add_node_valid2: "valid_graph (list_graph_to_graph G) \<Longrightarrow> valid_graph (list_graph_to_graph (add_node v G))"
  by (subst add_node_correct[symmetric]) simp

  -- "add edge"
  lemma add_edge_valid: "valid_list_graph G \<Longrightarrow> valid_list_graph (add_edge v v' G)"
  unfolding valid_list_graph_def add_edge_def add_node_def valid_list_graph_axioms_def
  by auto

  lemma add_edge_set_nodes: "set (nodesL (add_edge v v' G)) = set (nodesL G) \<union> {v,v'}"
  unfolding add_edge_def add_node_def
  by auto

  lemma add_edge_set_edges: "set (edgesL (add_edge v v' G)) = set (edgesL G) \<union> {(v,v')}"
  unfolding add_edge_def add_node_def
  by auto

  lemma add_edge_correct: "FiniteGraph.add_edge v v' (list_graph_to_graph G) = list_graph_to_graph (add_edge v v' G)"
  unfolding FiniteGraph.add_edge_def add_edge_def list_graph_to_graph_def
  by (auto simp: add_node_set_nodes)

  lemma add_edge_valid2: "valid_graph (list_graph_to_graph G) \<Longrightarrow> valid_graph (list_graph_to_graph (add_edge v v' G))"
  by (subst add_edge_correct[symmetric]) simp

  -- "delete node"
  lemma delete_node_valid: "valid_list_graph G \<Longrightarrow> valid_list_graph (delete_node v G)"
  unfolding valid_list_graph_def delete_node_def valid_list_graph_axioms_def
  by auto

  lemma delete_node_set_edges:
    "set (edgesL (delete_node v G)) = {(a,b). (a, b) \<in> set (edgesL G) \<and> a \<noteq> v \<and> b \<noteq> v}"
  unfolding delete_node_def
  by auto

  lemma delete_node_correct:
    assumes "valid_list_graph G"
    shows "FiniteGraph.delete_node v (list_graph_to_graph G) = list_graph_to_graph (delete_node v G)"
  using assms
  unfolding FiniteGraph.delete_node_def delete_node_def list_graph_to_graph_def valid_list_graph_def
  by auto

  -- "delete edge"
  lemma delete_edge_set_nodes: "set (nodesL (delete_edge v v' G)) = set (nodesL G)"
  unfolding delete_edge_def
  by simp

  lemma delete_edge_set_edges:
    "set (edgesL (delete_edge v v' G)) = {(a,b). (a,b) \<in> set (edgesL G) \<and> (a,b) \<noteq> (v,v')}"
  unfolding delete_edge_def
  by auto

  lemma delete_edge_valid: "valid_list_graph G \<Longrightarrow> valid_list_graph (delete_edge v v' G)"
  unfolding valid_list_graph_def delete_edge_def valid_list_graph_axioms_def
  by auto

  lemma delete_edge_commute: "delete_edge a1 a2 (delete_edge b1 b2 G) = delete_edge b1 b2 (delete_edge a1 a2 G)"
  unfolding delete_edge_def
  by simp metis (* auto doesn't seem to like filter_cong *)

  lemma delete_edge_correct: "FiniteGraph.delete_edge v v' (list_graph_to_graph G) = list_graph_to_graph (delete_edge v v' G)"
  unfolding FiniteGraph.delete_edge_def delete_edge_def list_graph_to_graph_def
  by auto

  lemma delete_edge_valid2: "valid_graph (list_graph_to_graph G) \<Longrightarrow> valid_graph (list_graph_to_graph (delete_edge v v' G))"
  by (subst delete_edge_correct[symmetric]) simp

  -- "delete edges"
  lemma delete_edges_valid: "valid_list_graph G \<Longrightarrow> valid_list_graph (delete_edges G E)"
  by (induction E arbitrary: G) (auto simp: delete_edge_valid)

  lemma delete_edges_set_nodes: "set (nodesL (delete_edges G E)) = set (nodesL G)"
  by (induction E arbitrary: G) (auto simp: delete_edge_set_nodes)

  lemma delete_edges_nodes: "nodesL (delete_edges G es) = nodesL G"
  by (induction es arbitrary: G) (auto simp: delete_edge_def)

  lemma delete_edges_set_edges: "set (edgesL (delete_edges G E)) = set (edgesL G) - set E"
  by (induction E arbitrary: G) (auto simp: delete_edge_def delete_edge_set_nodes)

  lemma delete_edges_set_edges2:
    "set (edgesL (delete_edges G E)) = {(a,b). (a,b) \<in> set (edgesL G) \<and> (a,b) \<notin> set E}"
  by (auto simp: delete_edges_set_edges)

  lemma delete_edges_length: "length (edgesL (delete_edges G f)) \<le> length (edgesL G)"
  proof (induction f arbitrary:G)
    case (Cons f fs)
    thus ?case
      apply (cases f, hypsubst)
      apply (subst delete_edges.simps(2))
      apply (metis delete_edge_length le_trans)
      done
  qed simp

  lemma delete_edges_chain: "delete_edges G (as @ bs) = delete_edges (delete_edges G as) bs"
  proof (induction as arbitrary: bs G)
    case (Cons f fs)
    thus ?case
      by (cases f) auto
  qed simp

  lemma delete_edges_delete_edge_commute:
    "delete_edges (delete_edge a1 a2 G) as = delete_edge a1 a2 (delete_edges G as)"
  proof (induction as arbitrary: G a1 a2)
    case (Cons f fs)
    thus ?case
      by (cases f) (simp add: delete_edge_commute)
  qed simp

  lemma delete_edges_commute:
    "delete_edges (delete_edges G as) bs = delete_edges (delete_edges G bs) as"
  proof (induction as arbitrary: bs G)
    case (Cons f fs)
    thus ?case
      by (cases f) (simp add: delete_edges_delete_edge_commute)
  qed simp

  lemma delete_edges_as_filter:
    "delete_edges G l = \<lparr> nodesL = nodesL G,  edgesL = [x \<leftarrow> edgesL G. x \<notin> set l] \<rparr>"
  proof (induction l)
    case (Cons f fs)
    thus ?case
      apply (cases f)
      apply (simp add: delete_edges_delete_edge_commute)
      apply (simp add: delete_edge_def)
      apply (metis (lifting, full_types) prod.exhaust splitI split_conv)
      done
  qed simp

  declare delete_edges.simps[simp del] (*do not automatically expand definition*)

  lemma delete_edges_correct:
    "FiniteGraph.delete_edges (list_graph_to_graph G) (set E) = list_graph_to_graph (delete_edges G E)"
  unfolding list_graph_to_graph_def FiniteGraph.delete_edges_def
  by (auto simp add: delete_edges_as_filter )

  lemma delete_edges_valid2:
    "valid_graph (list_graph_to_graph G) \<Longrightarrow> valid_graph (list_graph_to_graph (delete_edges G E))"
  by (subst delete_edges_correct[symmetric]) simp

  -- "helper about reflexive transitive closure impl"
  lemma distinct_relpow_impl:
    "distinct L \<Longrightarrow> distinct new \<Longrightarrow> distinct have \<Longrightarrow> distinct (new@have) \<Longrightarrow>
     distinct (relpow_impl (\<lambda>as. remdups (map snd [(a, b)\<leftarrow>L . a \<in> set as])) (\<lambda>xs ys. [x\<leftarrow>xs . x \<notin> set ys] @ ys) (\<lambda>x xs. x \<in> set xs) new have M)"
  proof (induction M arbitrary: "new" "have")
    case Suc
    hence
      "distinct ([x\<leftarrow>new . x \<notin> set have] @ have)"
      "set ([n\<leftarrow>remdups (map snd [(a, b)\<leftarrow>L . a \<in> set new]) . (n \<in> set new \<longrightarrow> n \<in> set have) \<and> n \<notin> set have]) \<inter> set ([x\<leftarrow>new . x \<notin> set have] @ have) = {}"
      by auto

    with Suc show ?case
      by auto
  qed auto

  lemma distinct_rtrancl_list_impl: "distinct L \<Longrightarrow> distinct ls \<Longrightarrow> distinct (rtrancl_list_impl L ls)"
  unfolding rtrancl_list_impl_def rtrancl_impl_def
  by (simp add:distinct_relpow_impl)

  lemma distinct_trancl_list_impl: "distinct L \<Longrightarrow> distinct ls \<Longrightarrow> distinct (trancl_list_impl L ls)"
  unfolding trancl_list_impl_def trancl_impl_def
  by (simp add:distinct_relpow_impl)

  -- "succ rtran"
  value "succ_rtran \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> 1"

  lemma succ_rtran_correct: "FiniteGraph.succ_rtran (list_graph_to_graph G) v = set (succ_rtran G v)"
  unfolding FiniteGraph.succ_rtran_def succ_rtran_def list_graph_to_graph_def
  by (simp add: rtrancl_list_impl)

  lemma distinct_succ_rtran: "valid_list_graph G \<Longrightarrow> distinct (succ_rtran G v)"
  unfolding succ_rtran_def valid_list_graph_def
  by (auto intro: distinct_rtrancl_list_impl)

  -- "succ tran"
  lemma distinct_succ_tran: "valid_list_graph G \<Longrightarrow> distinct (succ_tran G v)"
  unfolding succ_tran_def valid_list_graph_def
  by (auto intro: distinct_trancl_list_impl)

  lemma succ_tran_set: "set (succ_tran G v) = {e2. (v,e2) \<in> (set (edgesL G))\<^sup>+}"
  unfolding succ_tran_def
  by (simp add: trancl_list_impl)

  value "succ_tran \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> 1"

  lemma succ_tran_correct: "FiniteGraph.succ_tran (list_graph_to_graph G) v = set (succ_tran G v)"
  unfolding FiniteGraph.succ_tran_def succ_tran_def list_graph_to_graph_def
  by (simp add:trancl_list_impl)

  --"num_reachable"
  lemma num_reachable_correct:
    "valid_list_graph G \<Longrightarrow> FiniteGraph.num_reachable (list_graph_to_graph G) v = num_reachable G v"
  unfolding num_reachable_def FiniteGraph.num_reachable_def
  by (metis List.distinct_card distinct_succ_tran succ_tran_correct)

  --"num_reachable_norefl"
  lemma num_reachable_norefl_correct:
    "valid_list_graph G \<Longrightarrow>
     FiniteGraph.num_reachable_norefl (list_graph_to_graph G) v = num_reachable_norefl G v"
 unfolding num_reachable_norefl_def FiniteGraph.num_reachable_norefl_def
 by (metis (full_types) List.distinct_card distinct_filter distinct_succ_tran set_minus_filter_out succ_tran_correct)

  -- "backlinks, i.e. backflows in formal def"
  lemma backlinks_alt: "backlinks E = [(snd e, fst e). e \<leftarrow> E]"
  by (induction E) auto

  lemma backlinks_set: "set (backlinks E) = {(e2, e1). (e1, e2) \<in> set E}"
  by (induction E) auto

  lemma undirected_nodes_set: "set (edgesL (undirected G)) = set (edgesL G) \<union> {(e2, e1). (e1, e2) \<in> set (edgesL G)}"
  unfolding undirected_def
  by (simp add: backlinks_set)

  lemma undirected_succ_tran_set: "set (succ_tran (undirected G) v) = {e2. (v,e2) \<in> (set (edgesL (undirected G)))\<^sup>+}"
  by (fact succ_tran_set)

  lemma backlinks_in_nodes_G: "\<lbrakk> fst ` set (edgesL G) \<subseteq> set (nodesL G); snd ` set (edgesL G) \<subseteq> set (nodesL G) \<rbrakk> \<Longrightarrow>
    fst` set (edgesL (undirected G)) \<subseteq> set (nodesL (undirected G)) \<and> snd` set (edgesL (undirected G)) \<subseteq> set (nodesL (undirected G))"
  unfolding undirected_def
  by(auto simp: backlinks_set)

  lemma backlinks_distinct: "distinct E \<Longrightarrow> distinct (backlinks E)"
  by (induction E) (auto simp: backlinks_alt)

  lemma backlinks_subset: "set (backlinks X) \<subseteq> set (backlinks Y) <-> set X \<subseteq> set Y"
  by (auto simp: backlinks_set)

  lemma backlinks_correct: "FiniteGraph.backflows (set E) = set (backlinks E)"
  unfolding backflows_def
  by(simp add: backlinks_set)

  -- "undirected"
  lemma undirected_valid: "valid_list_graph G \<Longrightarrow> valid_list_graph (undirected G)"
  unfolding valid_list_graph_def valid_list_graph_axioms_def
  by (simp add:backlinks_in_nodes_G) (simp add: undirected_def)

  lemma undirected_correct:
    "FiniteGraph.undirected (list_graph_to_graph G) = list_graph_to_graph (undirected G)"
  unfolding FiniteGraph.undirected_def undirected_def list_graph_to_graph_def
  by (simp add: backlinks_set)

lemmas valid_list_graph_valid =
  add_node_valid
  add_edge_valid
  delete_node_valid
  delete_edge_valid
  delete_edges_valid
  undirected_valid

lemmas list_graph_correct =
  add_node_correct
  add_edge_correct
  delete_node_correct
  delete_edge_correct
  delete_edges_correct
  succ_rtran_correct
  succ_tran_correct
  num_reachable_correct
  undirected_correct

end


section \<open>Example: First-Order Logic\<close>

theory %visible First_Order_Logic
imports Base  (* FIXME Pure!? *)
begin

text \<open>
  \noindent In order to commence a new object-logic within
  Isabelle/Pure we introduce abstract syntactic categories @{text "i"}
  for individuals and @{text "o"} for object-propositions.  The latter
  is embedded into the language of Pure propositions by means of a
  separate judgment.
\<close>

typedecl i
typedecl o

judgment
  Trueprop :: "o \<Rightarrow> prop"    ("_" 5)

text \<open>
  \noindent Note that the object-logic judgment is implicit in the
  syntax: writing @{prop A} produces @{term "Trueprop A"} internally.
  From the Pure perspective this means ``@{prop A} is derivable in the
  object-logic''.
\<close>

subsection \<open>Equational reasoning \label{sec:framework-ex-equal}\<close>

text \<open>
  Equality is axiomatized as a binary predicate on individuals, with
  reflexivity as introduction, and substitution as elimination
  principle.  Note that the latter is particularly convenient in a
  framework like Isabelle, because syntactic congruences are
  implicitly produced by unification of @{term "B x"} against
  expressions containing occurrences of @{term x}.
\<close>

axiomatization
  equal :: "i \<Rightarrow> i \<Rightarrow> o"  (infix "=" 50)
where
  refl [intro]: "x = x" and
  subst [elim]: "x = y \<Longrightarrow> B x \<Longrightarrow> B y"

text \<open>
  \noindent Substitution is very powerful, but also hard to control in
  full generality.  We derive some common symmetry~/ transitivity
  schemes of @{term equal} as particular consequences.
\<close>

theorem sym [sym]:
  assumes "x = y"
  shows "y = x"
proof -
  have "x = x" ..
  with \<open>x = y\<close> show "y = x" ..
qed

theorem forw_subst [trans]:
  assumes "y = x" and "B x"
  shows "B y"
proof -
  from \<open>y = x\<close> have "x = y" ..
  from this and \<open>B x\<close> show "B y" ..
qed

theorem back_subst [trans]:
  assumes "B x" and "x = y"
  shows "B y"
proof -
  from \<open>x = y\<close> and \<open>B x\<close>
  show "B y" ..
qed

theorem trans [trans]:
  assumes "x = y" and "y = z"
  shows "x = z"
proof -
  from \<open>y = z\<close> and \<open>x = y\<close>
  show "x = z" ..
qed

subsection \<open>Basic group theory\<close>

text \<open>
  As an example for equational reasoning we consider some bits of
  group theory.  The subsequent locale definition postulates group
  operations and axioms; we also derive some consequences of this
  specification.
\<close>

locale group =
  fixes prod :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<circ>" 70)
    and inv :: "i \<Rightarrow> i"  ("(_\<inverse>)" [1000] 999)
    and unit :: i  ("1")
  assumes assoc: "(x \<circ> y) \<circ> z = x \<circ> (y \<circ> z)"
    and left_unit:  "1 \<circ> x = x"
    and left_inv: "x\<inverse> \<circ> x = 1"
begin

theorem right_inv: "x \<circ> x\<inverse> = 1"
proof -
  have "x \<circ> x\<inverse> = 1 \<circ> (x \<circ> x\<inverse>)" by (rule left_unit [symmetric])
  also have "\<dots> = (1 \<circ> x) \<circ> x\<inverse>" by (rule assoc [symmetric])
  also have "1 = (x\<inverse>)\<inverse> \<circ> x\<inverse>" by (rule left_inv [symmetric])
  also have "\<dots> \<circ> x = (x\<inverse>)\<inverse> \<circ> (x\<inverse> \<circ> x)" by (rule assoc)
  also have "x\<inverse> \<circ> x = 1" by (rule left_inv)
  also have "((x\<inverse>)\<inverse> \<circ> \<dots>) \<circ> x\<inverse> = (x\<inverse>)\<inverse> \<circ> (1 \<circ> x\<inverse>)" by (rule assoc)
  also have "1 \<circ> x\<inverse> = x\<inverse>" by (rule left_unit)
  also have "(x\<inverse>)\<inverse> \<circ> \<dots> = 1" by (rule left_inv)
  finally show "x \<circ> x\<inverse> = 1" .
qed

theorem right_unit: "x \<circ> 1 = x"
proof -
  have "1 = x\<inverse> \<circ> x" by (rule left_inv [symmetric])
  also have "x \<circ> \<dots> = (x \<circ> x\<inverse>) \<circ> x" by (rule assoc [symmetric])
  also have "x \<circ> x\<inverse> = 1" by (rule right_inv)
  also have "\<dots> \<circ> x = x" by (rule left_unit)
  finally show "x \<circ> 1 = x" .
qed

text \<open>
  \noindent Reasoning from basic axioms is often tedious.  Our proofs
  work by producing various instances of the given rules (potentially
  the symmetric form) using the pattern ``@{command have}~@{text
  eq}~@{command "by"}~@{text "(rule r)"}'' and composing the chain of
  results via @{command also}/@{command finally}.  These steps may
  involve any of the transitivity rules declared in
  \secref{sec:framework-ex-equal}, namely @{thm trans} in combining
  the first two results in @{thm right_inv} and in the final steps of
  both proofs, @{thm forw_subst} in the first combination of @{thm
  right_unit}, and @{thm back_subst} in all other calculational steps.

  Occasional substitutions in calculations are adequate, but should
  not be over-emphasized.  The other extreme is to compose a chain by
  plain transitivity only, with replacements occurring always in
  topmost position. For example:
\<close>

(*<*)
theorem "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
  assume [symmetric, defn]: "\<And>x y. (x \<equiv> y) \<equiv> Trueprop (x = y)"
  fix x
(*>*)
  have "x \<circ> 1 = x \<circ> (x\<inverse> \<circ> x)" unfolding left_inv ..
  also have "\<dots> = (x \<circ> x\<inverse>) \<circ> x" unfolding assoc ..
  also have "\<dots> = 1 \<circ> x" unfolding right_inv ..
  also have "\<dots> = x" unfolding left_unit ..
  finally have "x \<circ> 1 = x" .
(*<*)
qed
(*>*)

text \<open>
  \noindent Here we have re-used the built-in mechanism for unfolding
  definitions in order to normalize each equational problem.  A more
  realistic object-logic would include proper setup for the Simplifier
  (\secref{sec:simplifier}), the main automated tool for equational
  reasoning in Isabelle.  Then ``@{command unfolding}~@{thm
  left_inv}~@{command ".."}'' would become ``@{command "by"}~@{text
  "(simp only: left_inv)"}'' etc.
\<close>

end

subsection \<open>Propositional logic \label{sec:framework-ex-prop}\<close>

text \<open>
  We axiomatize basic connectives of propositional logic: implication,
  disjunction, and conjunction.  The associated rules are modeled
  after Gentzen's system of Natural Deduction @{cite "Gentzen:1935"}.
\<close>

axiomatization
  imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25) where
  impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B" and
  impD [dest]: "(A \<longrightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"

axiomatization
  disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30) where
  disjI\<^sub>1 [intro]: "A \<Longrightarrow> A \<or> B" and
  disjI\<^sub>2 [intro]: "B \<Longrightarrow> A \<or> B" and
  disjE [elim]: "A \<or> B \<Longrightarrow> (A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C"

axiomatization
  conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35) where
  conjI [intro]: "A \<Longrightarrow> B \<Longrightarrow> A \<and> B" and
  conjD\<^sub>1: "A \<and> B \<Longrightarrow> A" and
  conjD\<^sub>2: "A \<and> B \<Longrightarrow> B"

text \<open>
  \noindent The conjunctive destructions have the disadvantage that
  decomposing @{prop "A \<and> B"} involves an immediate decision which
  component should be projected.  The more convenient simultaneous
  elimination @{prop "A \<and> B \<Longrightarrow> (A \<Longrightarrow> B \<Longrightarrow> C) \<Longrightarrow> C"} can be derived as
  follows:
\<close>

theorem conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> show A by (rule conjD\<^sub>1)
  from \<open>A \<and> B\<close> show B by (rule conjD\<^sub>2)
qed

text \<open>
  \noindent Here is an example of swapping conjuncts with a single
  intermediate elimination step:
\<close>

(*<*)
lemma "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
(*>*)
  assume "A \<and> B"
  then obtain B and A ..
  then have "B \<and> A" ..
(*<*)
qed
(*>*)

text \<open>
  \noindent Note that the analogous elimination rule for disjunction
  ``@{text "\<ASSUMES> A \<or> B \<OBTAINS> A \<BBAR> B"}'' coincides with
  the original axiomatization of @{thm disjE}.

  \medskip We continue propositional logic by introducing absurdity
  with its characteristic elimination.  Plain truth may then be
  defined as a proposition that is trivially true.
\<close>

axiomatization
  false :: o  ("\<bottom>") where
  falseE [elim]: "\<bottom> \<Longrightarrow> A"

definition
  true :: o  ("\<top>") where
  "\<top> \<equiv> \<bottom> \<longrightarrow> \<bottom>"

theorem trueI [intro]: \<top>
  unfolding true_def ..

text \<open>
  \medskip\noindent Now negation represents an implication towards
  absurdity:
\<close>

definition
  not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40) where
  "\<not> A \<equiv> A \<longrightarrow> \<bottom>"

theorem notI [intro]:
  assumes "A \<Longrightarrow> \<bottom>"
  shows "\<not> A"
unfolding not_def
proof
  assume A
  then show \<bottom> by (rule \<open>A \<Longrightarrow> \<bottom>\<close>)
qed

theorem notE [elim]:
  assumes "\<not> A" and A
  shows B
proof -
  from \<open>\<not> A\<close> have "A \<longrightarrow> \<bottom>" unfolding not_def .
  from \<open>A \<longrightarrow> \<bottom>\<close> and \<open>A\<close> have \<bottom> ..
  then show B ..
qed

subsection \<open>Classical logic\<close>

text \<open>
  Subsequently we state the principle of classical contradiction as a
  local assumption.  Thus we refrain from forcing the object-logic
  into the classical perspective.  Within that context, we may derive
  well-known consequences of the classical principle.
\<close>

locale classical =
  assumes classical: "(\<not> C \<Longrightarrow> C) \<Longrightarrow> C"
begin

theorem double_negation:
  assumes "\<not> \<not> C"
  shows C
proof (rule classical)
  assume "\<not> C"
  with \<open>\<not> \<not> C\<close> show C ..
qed

theorem tertium_non_datur: "C \<or> \<not> C"
proof (rule double_negation)
  show "\<not> \<not> (C \<or> \<not> C)"
  proof
    assume "\<not> (C \<or> \<not> C)"
    have "\<not> C"
    proof
      assume C then have "C \<or> \<not> C" ..
      with \<open>\<not> (C \<or> \<not> C)\<close> show \<bottom> ..
    qed
    then have "C \<or> \<not> C" ..
    with \<open>\<not> (C \<or> \<not> C)\<close> show \<bottom> ..
  qed
qed

text \<open>
  \noindent These examples illustrate both classical reasoning and
  non-trivial propositional proofs in general.  All three rules
  characterize classical logic independently, but the original rule is
  already the most convenient to use, because it leaves the conclusion
  unchanged.  Note that @{prop "(\<not> C \<Longrightarrow> C) \<Longrightarrow> C"} fits again into our
  format for eliminations, despite the additional twist that the
  context refers to the main conclusion.  So we may write @{thm
  classical} as the Isar statement ``@{text "\<OBTAINS> \<not> thesis"}''.
  This also explains nicely how classical reasoning really works:
  whatever the main @{text thesis} might be, we may always assume its
  negation!
\<close>

end

subsection \<open>Quantifiers \label{sec:framework-ex-quant}\<close>

text \<open>
  Representing quantifiers is easy, thanks to the higher-order nature
  of the underlying framework.  According to the well-known technique
  introduced by Church @{cite "church40"}, quantifiers are operators on
  predicates, which are syntactically represented as @{text "\<lambda>"}-terms
  of type @{typ "i \<Rightarrow> o"}.  Binder notation turns @{text "All (\<lambda>x. B
  x)"} into @{text "\<forall>x. B x"} etc.
\<close>

axiomatization
  All :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10) where
  allI [intro]: "(\<And>x. B x) \<Longrightarrow> \<forall>x. B x" and
  allD [dest]: "(\<forall>x. B x) \<Longrightarrow> B a"

axiomatization
  Ex :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10) where
  exI [intro]: "B a \<Longrightarrow> (\<exists>x. B x)" and
  exE [elim]: "(\<exists>x. B x) \<Longrightarrow> (\<And>x. B x \<Longrightarrow> C) \<Longrightarrow> C"

text \<open>
  \noindent The statement of @{thm exE} corresponds to ``@{text
  "\<ASSUMES> \<exists>x. B x \<OBTAINS> x \<WHERE> B x"}'' in Isar.  In the
  subsequent example we illustrate quantifier reasoning involving all
  four rules:
\<close>

theorem
  assumes "\<exists>x. \<forall>y. R x y"
  shows "\<forall>y. \<exists>x. R x y"
proof    -- \<open>@{text "\<forall>"} introduction\<close>
  obtain x where "\<forall>y. R x y" using \<open>\<exists>x. \<forall>y. R x y\<close> ..    -- \<open>@{text "\<exists>"} elimination\<close>
  fix y have "R x y" using \<open>\<forall>y. R x y\<close> ..    -- \<open>@{text "\<forall>"} destruction\<close>
  then show "\<exists>x. R x y" ..    -- \<open>@{text "\<exists>"} introduction\<close>
qed

subsection \<open>Canonical reasoning patterns\<close>

text \<open>
  The main rules of first-order predicate logic from
  \secref{sec:framework-ex-prop} and \secref{sec:framework-ex-quant}
  can now be summarized as follows, using the native Isar statement
  format of \secref{sec:framework-stmt}.

  \medskip
  \begin{tabular}{l}
  @{text "impI: \<ASSUMES> A \<Longrightarrow> B \<SHOWS> A \<longrightarrow> B"} \\
  @{text "impD: \<ASSUMES> A \<longrightarrow> B \<AND> A \<SHOWS> B"} \\[1ex]

  @{text "disjI\<^sub>1: \<ASSUMES> A \<SHOWS> A \<or> B"} \\
  @{text "disjI\<^sub>2: \<ASSUMES> B \<SHOWS> A \<or> B"} \\
  @{text "disjE: \<ASSUMES> A \<or> B \<OBTAINS> A \<BBAR> B"} \\[1ex]

  @{text "conjI: \<ASSUMES> A \<AND> B \<SHOWS> A \<and> B"} \\
  @{text "conjE: \<ASSUMES> A \<and> B \<OBTAINS> A \<AND> B"} \\[1ex]

  @{text "falseE: \<ASSUMES> \<bottom> \<SHOWS> A"} \\
  @{text "trueI: \<SHOWS> \<top>"} \\[1ex]

  @{text "notI: \<ASSUMES> A \<Longrightarrow> \<bottom> \<SHOWS> \<not> A"} \\
  @{text "notE: \<ASSUMES> \<not> A \<AND> A \<SHOWS> B"} \\[1ex]

  @{text "allI: \<ASSUMES> \<And>x. B x \<SHOWS> \<forall>x. B x"} \\
  @{text "allE: \<ASSUMES> \<forall>x. B x \<SHOWS> B a"} \\[1ex]

  @{text "exI: \<ASSUMES> B a \<SHOWS> \<exists>x. B x"} \\
  @{text "exE: \<ASSUMES> \<exists>x. B x \<OBTAINS> a \<WHERE> B a"}
  \end{tabular}
  \medskip

  \noindent This essentially provides a declarative reading of Pure
  rules as Isar reasoning patterns: the rule statements tells how a
  canonical proof outline shall look like.  Since the above rules have
  already been declared as @{attribute (Pure) intro}, @{attribute
  (Pure) elim}, @{attribute (Pure) dest} --- each according to its
  particular shape --- we can immediately write Isar proof texts as
  follows:
\<close>

(*<*)
theorem "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
(*>*)

  text_raw \<open>\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<longrightarrow> B"
  proof
    assume A
    show B sorry %noproof
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<longrightarrow> B" and A sorry %noproof
  then have B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have A sorry %noproof
  then have "A \<or> B" ..

  have B sorry %noproof
  then have "A \<or> B" ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<or> B" sorry %noproof
  then have C
  proof
    assume A
    then show C sorry %noproof
  next
    assume B
    then show C sorry %noproof
  qed

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have A and B sorry %noproof
  then have "A \<and> B" ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<and> B" sorry %noproof
  then obtain A and B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<bottom>" sorry %noproof
  then have A ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<top>" ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<not> A"
  proof
    assume A
    then show "\<bottom>" sorry %noproof
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<not> A" and A sorry %noproof
  then have B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<forall>x. B x"
  proof
    fix x
    show "B x" sorry %noproof
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<forall>x. B x" sorry %noproof
  then have "B a" ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<exists>x. B x"
  proof
    show "B a" sorry %noproof
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<exists>x. B x" sorry %noproof
  then obtain a where "B a" ..

  text_raw \<open>\end{minipage}\<close>

(*<*)
qed
(*>*)

text \<open>
  \bigskip\noindent Of course, these proofs are merely examples.  As
  sketched in \secref{sec:framework-subproof}, there is a fair amount
  of flexibility in expressing Pure deductions in Isar.  Here the user
  is asked to express himself adequately, aiming at proof texts of
  literary quality.
\<close>

end %visible


theory Chapter4
imports "HOL-IMP.ASM"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text{*
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
*}

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text{*
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
*}

fun set :: "'a tree \<Rightarrow> 'a set"  where
(* your definition/proof here *)

fun ord :: "int tree \<Rightarrow> bool"  where
(* your definition/proof here *)

text{* Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
*}

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
(* your definition/proof here *)

text{* Prove correctness of @{const ins}: *}

lemma set_ins: "set(ins x t) = {x} \<union> set t"
(* your definition/proof here *)

theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
*}

inductive palindrome :: "'a list \<Rightarrow> bool" where
(* your definition/proof here *)

text {* and prove *}

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
(* your definition/proof here *)

text{*
\endexercise

\exercise
We could also have defined @{const star} as follows:
*}

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

text{*
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
*}

lemma "star' r x y \<Longrightarrow> star r x y"
(* your definition/proof here *)

lemma "star r x y \<Longrightarrow> star' r x y"
(* your definition/proof here *)

text{*
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
*}

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
(* your definition/proof here *)

text{*
Correct and prove the following claim:
*}

lemma "star r x y \<Longrightarrow> iter r n x y"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
*}

datatype alpha = a | b

text{*
If you think of @{const a} and @{const b} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
*}

inductive S :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

inductive T :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

lemma TS: "T w \<Longrightarrow> S w"
(* your definition/proof here *)

lemma ST: "S w \<Longrightarrow> T w"
(* your definition/proof here *)

corollary SeqT: "S w \<longleftrightarrow> T w"
(* your definition/proof here *)

text{*
\endexercise
*}
(* your definition/proof here *)
text{*
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
*}

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* your definition/proof here *)

lemma aval_rel_aval: "aval_rel a s v \<Longrightarrow> aval a s = v"
(* your definition/proof here *)

lemma aval_aval_rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
(* your definition/proof here *)

corollary "aval_rel a s v \<longleftrightarrow> aval a s = v"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
*}

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: *}

lemma "ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
(* your definition/proof here *)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)

text {* Prove that @{text ok} correctly computes the final stack size: *}

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
(* your definition/proof here *)

text {*
Lemma @{thm [source] length_Suc_conv} may come in handy.

Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
*}

end


(*  Title:      HOL/Isar_Examples/Expr_Compiler.thy
    Author:     Makarius

Correctness of a simple expression/stack-machine compiler.
*)

section \<open>Correctness of a simple expression compiler\<close>

theory Expr_Compiler
  imports MainRLT
begin

text \<open>
  This is a (rather trivial) example of program verification. We model a
  compiler for translating expressions to stack machine instructions, and
  prove its correctness wrt.\ some evaluation semantics.
\<close>

subsection \<open>Binary operations\<close>

text \<open>
  Binary operations are just functions over some type of values. This is both
  for abstract syntax and semantics, i.e.\ we use a ``shallow embedding''
  here.
\<close>

type_synonym 'val binop = "'val \<Rightarrow> 'val \<Rightarrow> 'val"

subsection \<open>Expressions\<close>

text \<open>
  The language of expressions is defined as an inductive type, consisting of
  variables, constants, and binary operations on expressions.
\<close>

datatype (dead 'adr, dead 'val) expr =
    Variable 'adr
  | Constant 'val
  | Binop "'val binop" "('adr, 'val) expr" "('adr, 'val) expr"

text \<open>
  Evaluation (wrt.\ some environment of variable assignments) is defined by
  primitive recursion over the structure of expressions.
\<close>

primrec eval :: "('adr, 'val) expr \<Rightarrow> ('adr \<Rightarrow> 'val) \<Rightarrow> 'val"
  where
    "eval (Variable x) env = env x"
  | "eval (Constant c) env = c"
  | "eval (Binop f e1 e2) env = f (eval e1 env) (eval e2 env)"

subsection \<open>Machine\<close>

text \<open>
  Next we model a simple stack machine, with three instructions.
\<close>

datatype (dead 'adr, dead 'val) instr =
    Const 'val
  | Load 'adr
  | Apply "'val binop"

text \<open>
  Execution of a list of stack machine instructions is easily defined as
  follows.
\<close>

primrec exec :: "(('adr, 'val) instr) list \<Rightarrow> 'val list \<Rightarrow> ('adr \<Rightarrow> 'val) \<Rightarrow> 'val list"
  where
    "exec [] stack env = stack"
  | "exec (instr # instrs) stack env =
      (case instr of
        Const c \<Rightarrow> exec instrs (c # stack) env
      | Load x \<Rightarrow> exec instrs (env x # stack) env
      | Apply f \<Rightarrow> exec instrs (f (hd stack) (hd (tl stack)) # (tl (tl stack))) env)"

definition execute :: "(('adr, 'val) instr) list \<Rightarrow> ('adr \<Rightarrow> 'val) \<Rightarrow> 'val"
  where "execute instrs env = hd (exec instrs [] env)"

subsection \<open>Compiler\<close>

text \<open>
  We are ready to define the compilation function of expressions to lists of
  stack machine instructions.
\<close>

primrec compile :: "('adr, 'val) expr \<Rightarrow> (('adr, 'val) instr) list"
  where
    "compile (Variable x) = [Load x]"
  | "compile (Constant c) = [Const c]"
  | "compile (Binop f e1 e2) = compile e2 @ compile e1 @ [Apply f]"

text \<open>
  The main result of this development is the correctness theorem for
  \<open>compile\<close>. We first establish a lemma about \<open>exec\<close> and list append.
\<close>

lemma exec_append:
  "exec (xs @ ys) stack env =
    exec ys (exec xs stack env) env"
proof (induct xs arbitrary: stack)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (induct x)
    case Const
    from Cons show ?case by simp
  next
    case Load
    from Cons show ?case by simp
  next
    case Apply
    from Cons show ?case by simp
  qed
qed

theorem correctness: "execute (compile e) env = eval e env"
proof -
  have "\<And>stack. exec (compile e) stack env = eval e env # stack"
  proof (induct e)
    case Variable
    show ?case by simp
  next
    case Constant
    show ?case by simp
  next
    case Binop
    then show ?case by (simp add: exec_append)
  qed
  then show ?thesis by (simp add: execute_def)
qed

text \<open>
  \<^bigskip>
  In the proofs above, the \<open>simp\<close> method does quite a lot of work behind the
  scenes (mostly ``functional program execution''). Subsequently, the same
  reasoning is elaborated in detail --- at most one recursive function
  definition is used at a time. Thus we get a better idea of what is actually
  going on.
\<close>

lemma exec_append':
  "exec (xs @ ys) stack env = exec ys (exec xs stack env) env"
proof (induct xs arbitrary: stack)
  case (Nil s)
  have "exec ([] @ ys) s env = exec ys s env"
    by simp
  also have "\<dots> = exec ys (exec [] s env) env"
    by simp
  finally show ?case .
next
  case (Cons x xs s)
  show ?case
  proof (induct x)
    case (Const val)
    have "exec ((Const val # xs) @ ys) s env = exec (Const val # xs @ ys) s env"
      by simp
    also have "\<dots> = exec (xs @ ys) (val # s) env"
      by simp
    also from Cons have "\<dots> = exec ys (exec xs (val # s) env) env" .
    also have "\<dots> = exec ys (exec (Const val # xs) s env) env"
      by simp
    finally show ?case .
  next
    case (Load adr)
    from Cons show ?case
      by simp \<comment> \<open>same as above\<close>
  next
    case (Apply fn)
    have "exec ((Apply fn # xs) @ ys) s env =
        exec (Apply fn # xs @ ys) s env" by simp
    also have "\<dots> =
        exec (xs @ ys) (fn (hd s) (hd (tl s)) # (tl (tl s))) env"
      by simp
    also from Cons have "\<dots> =
        exec ys (exec xs (fn (hd s) (hd (tl s)) # tl (tl s)) env) env" .
    also have "\<dots> = exec ys (exec (Apply fn # xs) s env) env"
      by simp
    finally show ?case .
  qed
qed

theorem correctness': "execute (compile e) env = eval e env"
proof -
  have exec_compile: "\<And>stack. exec (compile e) stack env = eval e env # stack"
  proof (induct e)
    case (Variable adr s)
    have "exec (compile (Variable adr)) s env = exec [Load adr] s env"
      by simp
    also have "\<dots> = env adr # s"
      by simp
    also have "env adr = eval (Variable adr) env"
      by simp
    finally show ?case .
  next
    case (Constant val s)
    show ?case by simp \<comment> \<open>same as above\<close>
  next
    case (Binop fn e1 e2 s)
    have "exec (compile (Binop fn e1 e2)) s env =
        exec (compile e2 @ compile e1 @ [Apply fn]) s env"
      by simp
    also have "\<dots> = exec [Apply fn]
        (exec (compile e1) (exec (compile e2) s env) env) env"
      by (simp only: exec_append)
    also have "exec (compile e2) s env = eval e2 env # s"
      by fact
    also have "exec (compile e1) \<dots> env = eval e1 env # \<dots>"
      by fact
    also have "exec [Apply fn] \<dots> env =
        fn (hd \<dots>) (hd (tl \<dots>)) # (tl (tl \<dots>))"
      by simp
    also have "\<dots> = fn (eval e1 env) (eval e2 env) # s"
      by simp
    also have "fn (eval e1 env) (eval e2 env) =
        eval (Binop fn e1 e2) env"
      by simp
    finally show ?case .
  qed

  have "execute (compile e) env = hd (exec (compile e) [] env)"
    by (simp add: execute_def)
  also from exec_compile have "exec (compile e) [] env = [eval e env]" .
  also have "hd \<dots> = eval e env"
    by simp
  finally show ?thesis .
qed

end


section \<open>Basic facts about rings and modules\<close>

theory RingModuleFacts
imports Main
  "HOL-Algebra.Module"
  "HOL-Algebra.Coset"
  (*MonoidSums*)
begin

text \<open>In a field, every nonzero element has an inverse.\<close> (* Add to Ring.*)
lemma (in field) inverse_exists [simp, intro]:
  assumes h1: "a\<in>carrier R"  and h2: "a\<noteq>\<zero>\<^bsub>R\<^esub>"
  shows "inv\<^bsub>R\<^esub> a\<in> carrier R"
proof -
  have 1: "Units R = carrier R - {\<zero>\<^bsub>R\<^esub>} " by (rule field_Units)
  from h1 h2 1 show ?thesis by auto
qed

text \<open>Multiplication by $-1$ is the same as negation. May be useful as a simp rule.\<close>
(*Add to module.*)
lemma (in module) smult_minus_1:
  fixes v
  assumes 0:"v\<in>carrier M"
  shows "(\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v= (\<ominus>\<^bsub>M\<^esub>  v)"
(*(simp add: M.l_neg)*)
proof -
  from 0 have a0: "\<one>\<^bsub>R\<^esub> \<odot>\<^bsub>M\<^esub> v = v" by simp
  from 0 have 1: "((\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)\<oplus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v=\<zero>\<^bsub>M\<^esub>"
    by (simp add:R.l_neg)
  from 0 have 2: "((\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)\<oplus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v=(\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub> \<one>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> v"
    by (simp add: smult_l_distr)
  from 1 2 show ?thesis by (metis M.minus_equality R.add.inv_closed
    a0 assms one_closed smult_closed)
qed

text \<open>The version with equality reversed.\<close>
lemmas (in module)  smult_minus_1_back = smult_minus_1[THEN sym]

text\<open>-1 is not 0\<close>
lemma (in field) neg_1_not_0 [simp]: "\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>"
by (metis minus_minus minus_zero one_closed zero_not_one)

text \<open>Note smult-assoc1 is the wrong way around for simplification.
This is the reverse of smult-assoc1.\<close>(*Add to Module. *)
lemma (in module) smult_assoc_simp:
"[| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      a \<odot>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x) = (a \<otimes> b) \<odot>\<^bsub>M\<^esub> x "
by (auto simp add: smult_assoc1)

(* Add to Ring? *)
lemmas (in abelian_group) show_r_zero= add.l_cancel_one
lemmas (in abelian_group) show_l_zero= add.r_cancel_one

text \<open>A nontrivial ring has $0\neq 1$.\<close>(*Add to Ring.*)
lemma (in ring) nontrivial_ring [simp]:
  assumes "carrier R\<noteq>{\<zero>\<^bsub>R\<^esub>}"
  shows "\<zero>\<^bsub>R\<^esub>\<noteq>\<one>\<^bsub>R\<^esub>"
proof (rule ccontr)
  assume 1: "\<not>(\<zero>\<^bsub>R\<^esub>\<noteq>\<one>\<^bsub>R\<^esub>)"
  {
    fix r
    assume 2: "r\<in>carrier R"
    from 1 2 have 3: "\<one>\<^bsub>R\<^esub>\<otimes>\<^bsub>R\<^esub> r = \<zero>\<^bsub>R\<^esub>\<otimes>\<^bsub>R\<^esub> r" by auto
    from 2 3 have "r = \<zero>\<^bsub>R\<^esub>" by auto
  }
  from this assms show False by auto
qed

text \<open>Use as simp rule. To show $a-b=0$, it suffices to show $a=b$.\<close>(*Add to Ring.*)
lemma (in abelian_group) minus_other_side [simp]:
  "\<lbrakk>a\<in>carrier G; b\<in>carrier G\<rbrakk> \<Longrightarrow> (a\<ominus>\<^bsub>G\<^esub>b = \<zero>\<^bsub>G\<^esub>) = (a=b)"
  by (metis a_minus_def add.inv_closed add.m_comm r_neg r_neg2)

end


theory Exercise2
  imports Main
begin

lemma "
  (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
\<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)
" (is "?EVEN \<or> ?ODD")
proof cases
  assume "2 dvd (length xs)"
  then obtain k
    where even_xs: "length xs = 2*k"
    by auto
  then obtain ys zs
    where ys_def: "ys = take k xs"
      and zs_def: "zs = drop k xs"
    by simp
  hence xs_part: "xs = ys @ zs" by simp
  have "length zs = k"
    using even_xs zs_def
    by simp
  hence ?EVEN using xs_part even_xs by auto
  thus ?thesis by simp
next
  assume "\<not> (2 dvd (length xs))"
  hence "\<exists>k. length xs = (2*k) + 1" by arith
  then obtain k
    where odd_xs: "length xs = (2*k) + 1"
    by auto
  then obtain ys zs
    where ys_def: "ys = take (k+1) xs"
      and zs_def: "zs = drop (k+1) xs"
    by simp
  hence xs_part: "xs = ys @ zs" by simp
  hence "length zs = k"
    using odd_xs zs_def
    by simp
  hence ?ODD using xs_part odd_xs by auto
  thus ?thesis by simp
qed

end


theory MyList
imports Main
begin

datatype 'a list = Nil | Cons 'a " 'a list "

fun app :: " 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list "
  where "app Nil x = x" | "app (Cons x xs) y = Cons x (app xs y) "

fun rev :: " 'a list \<Rightarrow> 'a list "
  where "rev Nil = Nil" | "rev (Cons x xs) = app (rev xs) (Cons x Nil) "

lemma app_Nil2[simp] : "app xs Nil = xs"
  apply(induction xs)
  apply(auto)
done

lemma app_assoc[simp] : "app (app xs ys) zs = app xs (app ys zs)"
  apply(induction xs)
  apply(auto)
done

lemma rev_app_rev[simp] : "rev (app xs ys) = app (rev ys) (rev xs)"
  apply(induction xs)
  apply(auto)
done

theorem rev_rev [simp] : "rev (rev xs) = xs"
  apply(induction xs)
  apply(auto)
done

end


(*  Title:      HOL/Library/Ramsey.thy
    Author:     Tom Ridge.  Converted to structured Isar by L C Paulson
*)

section "Ramsey's Theorem"

theory Ramsey
imports Main Infinite_Set
begin

subsection\<open>Finite Ramsey theorem(s)\<close>

text\<open>To distinguish the finite and infinite ones, lower and upper case
names are used.

This is the most basic version in terms of cliques and independent
sets, i.e. the version for graphs and 2 colours.\<close>

definition "clique V E = (\<forall>v\<in>V. \<forall>w\<in>V. v\<noteq>w \<longrightarrow> {v,w} : E)"
definition "indep V E = (\<forall>v\<in>V. \<forall>w\<in>V. v\<noteq>w \<longrightarrow> \<not> {v,w} : E)"

lemma ramsey2:
  "\<exists>r\<ge>1. \<forall> (V::'a set) (E::'a set set). finite V \<and> card V \<ge> r \<longrightarrow>
  (\<exists> R \<subseteq> V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E)"
  (is "\<exists>r\<ge>1. ?R m n r")
proof(induct k == "m+n" arbitrary: m n)
  case 0
  show ?case (is "EX r. ?R r")
  proof
    show "?R 1" using 0
      by (clarsimp simp: indep_def)(metis card.empty emptyE empty_subsetI)
  qed
next
  case (Suc k)
  { assume "m=0"
    have ?case (is "EX r. ?R r")
    proof
      show "?R 1" using \<open>m=0\<close>
        by (simp add:clique_def)(metis card.empty emptyE empty_subsetI)
    qed
  } moreover
  { assume "n=0"
    have ?case (is "EX r. ?R r")
    proof
      show "?R 1" using \<open>n=0\<close>
        by (simp add:indep_def)(metis card.empty emptyE empty_subsetI)
    qed
  } moreover
  { assume "m\<noteq>0" "n\<noteq>0"
    then have "k = (m - 1) + n" "k = m + (n - 1)" using \<open>Suc k = m+n\<close> by auto
    from Suc(1)[OF this(1)] Suc(1)[OF this(2)]
    obtain r1 r2 where "r1\<ge>1" "r2\<ge>1" "?R (m - 1) n r1" "?R m (n - 1) r2"
      by auto
    then have "r1+r2 \<ge> 1" by arith
    moreover
    have "?R m n (r1+r2)" (is "ALL V E. _ \<longrightarrow> ?EX V E m n")
    proof clarify
      fix V :: "'a set" and E :: "'a set set"
      assume "finite V" "r1+r2 \<le> card V"
      with \<open>r1\<ge>1\<close> have "V \<noteq> {}" by auto
      then obtain v where "v : V" by blast
      let ?M = "{w : V. w\<noteq>v & {v,w} : E}"
      let ?N = "{w : V. w\<noteq>v & {v,w} ~: E}"
      have "V = insert v (?M \<union> ?N)" using \<open>v : V\<close> by auto
      then have "card V = card(insert v (?M \<union> ?N))" by metis
      also have "\<dots> = card ?M + card ?N + 1" using \<open>finite V\<close>
        by(fastforce intro: card_Un_disjoint)
      finally have "card V = card ?M + card ?N + 1" .
      then have "r1+r2 \<le> card ?M + card ?N + 1" using \<open>r1+r2 \<le> card V\<close> by simp
      then have "r1 \<le> card ?M \<or> r2 \<le> card ?N" by arith
      moreover
      { assume "r1 \<le> card ?M"
        moreover have "finite ?M" using \<open>finite V\<close> by auto
        ultimately have "?EX ?M E (m - 1) n" using \<open>?R (m - 1) n r1\<close> by blast
        then obtain R where "R \<subseteq> ?M" "v ~: R" and
          CI: "card R = m - 1 \<and> clique R E \<or>
               card R = n \<and> indep R E" (is "?C \<or> ?I")
          by blast
        have "R <= V" using \<open>R <= ?M\<close> by auto
        have "finite R" using \<open>finite V\<close> \<open>R \<subseteq> V\<close> by (metis finite_subset)
        { assume "?I"
          with \<open>R <= V\<close> have "?EX V E m n" by blast
        } moreover
        { assume "?C"
          then have "clique (insert v R) E" using \<open>R <= ?M\<close>
           by(auto simp:clique_def insert_commute)
          moreover have "card(insert v R) = m"
            using \<open>?C\<close> \<open>finite R\<close> \<open>v ~: R\<close> \<open>m\<noteq>0\<close> by simp
          ultimately have "?EX V E m n" using \<open>R <= V\<close> \<open>v : V\<close> by (metis insert_subset)
        } ultimately have "?EX V E m n" using CI by blast
      } moreover
      { assume "r2 \<le> card ?N"
        moreover have "finite ?N" using \<open>finite V\<close> by auto
        ultimately have "?EX ?N E m (n - 1)" using \<open>?R m (n - 1) r2\<close> by blast
        then obtain R where "R \<subseteq> ?N" "v ~: R" and
          CI: "card R = m \<and> clique R E \<or>
               card R = n - 1 \<and> indep R E" (is "?C \<or> ?I")
          by blast
        have "R <= V" using \<open>R <= ?N\<close> by auto
        have "finite R" using \<open>finite V\<close> \<open>R \<subseteq> V\<close> by (metis finite_subset)
        { assume "?C"
          with \<open>R <= V\<close> have "?EX V E m n" by blast
        } moreover
        { assume "?I"
          then have "indep (insert v R) E" using \<open>R <= ?N\<close>
            by(auto simp:indep_def insert_commute)
          moreover have "card(insert v R) = n"
            using \<open>?I\<close> \<open>finite R\<close> \<open>v ~: R\<close> \<open>n\<noteq>0\<close> by simp
          ultimately have "?EX V E m n" using \<open>R <= V\<close> \<open>v : V\<close> by (metis insert_subset)
        } ultimately have "?EX V E m n" using CI by blast
      } ultimately show "?EX V E m n" by blast
    qed
    ultimately have ?case by blast
  } ultimately show ?case by blast
qed

subsection \<open>Preliminaries\<close>

subsubsection \<open>``Axiom'' of Dependent Choice\<close>

primrec choice :: "('a => bool) => ('a * 'a) set => nat => 'a" where
  \<comment>\<open>An integer-indexed chain of choices\<close>
    choice_0:   "choice P r 0 = (SOME x. P x)"
  | choice_Suc: "choice P r (Suc n) = (SOME y. P y & (choice P r n, y) \<in> r)"

lemma choice_n:
  assumes P0: "P x0"
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
  shows "P (choice P r n)"
proof (induct n)
  case 0 show ?case by (force intro: someI P0)
next
  case Suc then show ?case by (auto intro: someI2_ex [OF Pstep])
qed

lemma dependent_choice:
  assumes trans: "trans r"
      and P0: "P x0"
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
  obtains f :: "nat => 'a" where
    "!!n. P (f n)" and "!!n m. n < m ==> (f n, f m) \<in> r"
proof
  fix n
  show "P (choice P r n)" by (blast intro: choice_n [OF P0 Pstep])
next
  have PSuc: "\<forall>n. (choice P r n, choice P r (Suc n)) \<in> r"
    using Pstep [OF choice_n [OF P0 Pstep]]
    by (auto intro: someI2_ex)
  fix n m :: nat
  assume less: "n < m"
  show "(choice P r n, choice P r m) \<in> r" using PSuc
    by (auto intro: less_Suc_induct [OF less] transD [OF trans])
qed

subsubsection \<open>Partitions of a Set\<close>

definition part :: "nat => nat => 'a set => ('a set => nat) => bool"
  \<comment>\<open>the function @{term f} partitions the @{term r}-subsets of the typically
       infinite set @{term Y} into @{term s} distinct categories.\<close>
where
  "part r s Y f = (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s)"

text\<open>For induction, we decrease the value of @{term r} in partitions.\<close>
lemma part_Suc_imp_part:
     "[| infinite Y; part (Suc r) s Y f; y \<in> Y |]
      ==> part r s (Y - {y}) (%u. f (insert y u))"
  apply(simp add: part_def, clarify)
  apply(drule_tac x="insert y X" in spec)
  apply(force)
  done

lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f"
  unfolding part_def by blast

subsection \<open>Ramsey's Theorem: Infinitary Version\<close>

lemma Ramsey_induction:
  fixes s and r::nat
  shows
  "!!(YY::'a set) (f::'a set => nat).
      [|infinite YY; part r s YY f|]
      ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s &
                  (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
proof (induct r)
  case 0
  then show ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong)
next
  case (Suc r)
  show ?case
  proof -
    from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
    let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
    let ?propr = "%(y,Y,t).
                 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
                 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
    have infYY': "infinite (YY-{yy})" using Suc.prems by auto
    have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
      by (simp add: o_def part_Suc_imp_part yy Suc.prems)
    have transr: "trans ?ramr" by (force simp add: trans_def)
    from Suc.hyps [OF infYY' partf']
    obtain Y0 and t0
    where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
          "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
        by blast
    with yy have propr0: "?propr(yy,Y0,t0)" by blast
    have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr"
    proof -
      fix x
      assume px: "?propr x" then show "?thesis x"
      proof (cases x)
        case (fields yx Yx tx)
        then obtain yx' where yx': "yx' \<in> Yx" using px
               by (blast dest: infinite_imp_nonempty)
        have infYx': "infinite (Yx-{yx'})" using fields px by auto
        with fields px yx' Suc.prems
        have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
          by (simp add: o_def part_Suc_imp_part part_subset [where YY=YY and Y=Yx])
        from Suc.hyps [OF infYx' partfx']
        obtain Y' and t'
        where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
               "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
            by blast
        show ?thesis
        proof
          show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
            using fields Y' yx' px by blast
        qed
      qed
    qed
    from dependent_choice [OF transr propr0 proprstep]
    obtain g where pg: "?propr (g n)" and rg: "n<m ==> (g n, g m) \<in> ?ramr" for n m :: nat
      by blast
    let ?gy = "fst o g"
    let ?gt = "snd o snd o g"
    have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
    proof (intro exI subsetI)
      fix x
      assume "x \<in> range ?gt"
      then obtain n where "x = ?gt n" ..
      with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
    qed
    have "finite (range ?gt)"
      by (simp add: finite_nat_iff_bounded rangeg)
    then obtain s' and n'
      where s': "s' = ?gt n'"
        and infeqs': "infinite {n. ?gt n = s'}"
      by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: infinite_UNIV_nat)
    with pg [of n'] have less': "s'<s" by (cases "g n'") auto
    have inj_gy: "inj ?gy"
    proof (rule linorder_injI)
      fix m m' :: nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
        using rg [OF less] pg [of m] by (cases "g m", cases "g m'") auto
    qed
    show ?thesis
    proof (intro exI conjI)
      show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
        by (auto simp add: Let_def split_beta)
      show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
        by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD)
      show "s' < s" by (rule less')
      show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r
          --> f X = s'"
      proof -
        {fix X
         assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
            and cardX: "finite X" "card X = Suc r"
         then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA"
             by (auto simp add: subset_image_iff)
         with cardX have "AA\<noteq>{}" by auto
         then have AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex)
         have "f X = s'"
         proof (cases "g (LEAST x. x \<in> AA)")
           case (fields ya Ya ta)
           with AAleast Xeq
           have ya: "ya \<in> X" by (force intro!: rev_image_eqI)
           then have "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
           also have "... = ta"
           proof -
             have "X - {ya} \<subseteq> Ya"
             proof
               fix x assume x: "x \<in> X - {ya}"
               then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA"
                 by (auto simp add: Xeq)
               then have "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
               then have lessa': "(LEAST x. x \<in> AA) < a'"
                 using Least_le [of "%x. x \<in> AA", OF a'] by arith
               show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
             qed
             moreover
             have "card (X - {ya}) = r"
               by (simp add: cardX ya)
             ultimately show ?thesis
               using pg [of "LEAST x. x \<in> AA"] fields cardX
               by (clarsimp simp del:insert_Diff_single)
           qed
           also have "... = s'" using AA AAleast fields by auto
           finally show ?thesis .
         qed}
        then show ?thesis by blast
      qed
    qed
  qed
qed

theorem Ramsey:
  fixes s r :: nat and Z::"'a set" and f::"'a set => nat"
  shows
   "[|infinite Z;
      \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
  ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s
            & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
by (blast intro: Ramsey_induction [unfolded part_def])

corollary Ramsey2:
  fixes s::nat and Z::"'a set" and f::"'a set => nat"
  assumes infZ: "infinite Z"
      and part: "\<forall>x\<in>Z. \<forall>y\<in>Z. x\<noteq>y --> f{x,y} < s"
  shows
   "\<exists>Y t. Y \<subseteq> Z & infinite Y & t < s & (\<forall>x\<in>Y. \<forall>y\<in>Y. x\<noteq>y --> f{x,y} = t)"
proof -
  have part2: "\<forall>X. X \<subseteq> Z & finite X & card X = 2 --> f X < s"
    using part by (fastforce simp add: eval_nat_numeral card_Suc_eq)
  obtain Y t
    where *: "Y \<subseteq> Z" "infinite Y" "t < s"
          "(\<forall>X. X \<subseteq> Y & finite X & card X = 2 --> f X = t)"
    by (insert Ramsey [OF infZ part2]) auto
  then have "\<forall>x\<in>Y. \<forall>y\<in>Y. x \<noteq> y \<longrightarrow> f {x, y} = t" by auto
  with * show ?thesis by iprover
qed

subsection \<open>Disjunctive Well-Foundedness\<close>

text \<open>
  An application of Ramsey's theorem to program termination. See
  @{cite "Podelski-Rybalchenko"}.
\<close>

definition disj_wf :: "('a * 'a)set => bool"
  where "disj_wf r = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r = (\<Union>i<n. T i))"

definition transition_idx :: "[nat => 'a, nat => ('a*'a)set, nat set] => nat"
  where
    "transition_idx s T A =
      (LEAST k. \<exists>i j. A = {i,j} & i<j & (s j, s i) \<in> T k)"

lemma transition_idx_less:
    "[|i<j; (s j, s i) \<in> T k; k<n|] ==> transition_idx s T {i,j} < n"
apply (subgoal_tac "transition_idx s T {i, j} \<le> k", simp)
apply (simp add: transition_idx_def, blast intro: Least_le)
done

lemma transition_idx_in:
    "[|i<j; (s j, s i) \<in> T k|] ==> (s j, s i) \<in> T (transition_idx s T {i,j})"
apply (simp add: transition_idx_def doubleton_eq_iff conj_disj_distribR
            cong: conj_cong)
apply (erule LeastI)
done

text\<open>To be equal to the union of some well-founded relations is equivalent
to being the subset of such a union.\<close>
lemma disj_wf:
     "disj_wf(r) = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r \<subseteq> (\<Union>i<n. T i))"
apply (auto simp add: disj_wf_def)
apply (rule_tac x="%i. T i Int r" in exI)
apply (rule_tac x=n in exI)
apply (force simp add: wf_Int1)
done

theorem trans_disj_wf_implies_wf:
  assumes transr: "trans r"
      and dwf:    "disj_wf(r)"
  shows "wf r"
proof (simp only: wf_iff_no_infinite_down_chain, rule notI)
  assume "\<exists>s. \<forall>i. (s (Suc i), s i) \<in> r"
  then obtain s where sSuc: "\<forall>i. (s (Suc i), s i) \<in> r" ..
  have s: "!!i j. i < j ==> (s j, s i) \<in> r"
  proof -
    fix i and j::nat
    assume less: "i<j"
    then show "(s j, s i) \<in> r"
    proof (rule less_Suc_induct)
      show "\<And>i. (s (Suc i), s i) \<in> r" by (simp add: sSuc)
      show "\<And>i j k. \<lbrakk>(s j, s i) \<in> r; (s k, s j) \<in> r\<rbrakk> \<Longrightarrow> (s k, s i) \<in> r"
        using transr by (unfold trans_def, blast)
    qed
  qed
  from dwf
  obtain T and n::nat where wfT: "\<forall>k<n. wf(T k)" and r: "r = (\<Union>k<n. T k)"
    by (auto simp add: disj_wf_def)
  have s_in_T: "\<And>i j. i<j ==> \<exists>k. (s j, s i) \<in> T k & k<n"
  proof -
    fix i and j::nat
    assume less: "i<j"
    then have "(s j, s i) \<in> r" by (rule s [of i j])
    then show "\<exists>k. (s j, s i) \<in> T k & k<n" by (auto simp add: r)
  qed
  have trless: "!!i j. i\<noteq>j ==> transition_idx s T {i,j} < n"
    apply (auto simp add: linorder_neq_iff)
    apply (blast dest: s_in_T transition_idx_less)
    apply (subst insert_commute)
    apply (blast dest: s_in_T transition_idx_less)
    done
  have
   "\<exists>K k. K \<subseteq> UNIV & infinite K & k < n &
          (\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k)"
    by (rule Ramsey2) (auto intro: trless infinite_UNIV_nat)
  then obtain K and k
    where infK: "infinite K" and less: "k < n" and
          allk: "\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k"
    by auto
  have "\<forall>m. (s (enumerate K (Suc m)), s(enumerate K m)) \<in> T k"
  proof
    fix m::nat
    let ?j = "enumerate K (Suc m)"
    let ?i = "enumerate K m"
    have jK: "?j \<in> K" by (simp add: enumerate_in_set infK)
    have iK: "?i \<in> K" by (simp add: enumerate_in_set infK)
    have ij: "?i < ?j" by (simp add: enumerate_step infK)
    have ijk: "transition_idx s T {?i,?j} = k" using iK jK ij
      by (simp add: allk)
    obtain k' where "(s ?j, s ?i) \<in> T k'" "k'<n"
      using s_in_T [OF ij] by blast
    then show "(s ?j, s ?i) \<in> T k"
      by (simp add: ijk [symmetric] transition_idx_in ij)
  qed
  then have "~ wf(T k)" by (force simp add: wf_iff_no_infinite_down_chain)
  then show False using wfT less by blast
qed

end