theory ex_2_2
  imports Main
begin
fun add::"nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 m = m" |
"add (Suc n) m = Suc (add n m)"

theorem add_assoc: "add x (add y z) = add (add x y) z"
  apply (induction x)
  by (auto)

lemma add_suc_r[simp]: "add n (Suc m) = Suc (add n m)"
  apply (induction n)
  by (auto)

lemma add_id_r[simp]: "add y 0 = y"
  apply (induction y)
  by (auto)

theorem add_comm: "add x y = add y x"
  apply (induction x)
  by (auto)

fun double::"nat \<Rightarrow> nat" where
"double 0 = 0" |
"double (Suc n) = Suc(Suc(double n))"

theorem double_add: "double m = add m m"
  apply (induction m)
  by (auto)
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 Main
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>Core data structures\<close>
theory Data
imports Main
begin

subsection \<open>Data types\<close>

subsubsection \<open>Unique identifier\<close>

text \<open>Every node of a BDD is uniquely identified by its label and a level-identifer. The prior is
      the input variable in \<open>'l\<close> that it represents, while the second is supposed to induce a total
      ordering within a level.\<close>

datatype 'l uid = U (label:\<open>'l\<close>) (id:\<open>nat\<close>)

text \<open>All algorithms are based on a level-by-level processing of all nodes. This requires nodes to
      be topologically ordered. Secondly, these algorithms need to know when they are going to see
      a node within the level, so secondarily they are sorted on the identifier.

      Hence, the uid is sorted lexicographically on the above tuple.\<close>

instantiation uid :: (linorder) linorder
begin
definition less_uid where
   \<open>less_uid \<equiv> \<lambda>(U i1 id1) \<Rightarrow> \<lambda>(U i2 id2) \<Rightarrow> (i1 < i2 \<or> (i1 = i2 \<and> id1 < id2))\<close>

definition less_eq_uid where
   \<open>less_eq_uid \<equiv> \<lambda>(U i1 id1) \<Rightarrow> \<lambda>(U i2 id2) \<Rightarrow> (i1 < i2 \<or> (i1 = i2 \<and> id1 \<le> id2))\<close>

instance
  by standard (auto simp: less_uid_def less_eq_uid_def split: uid.splits)

end

lemma less_uid_simp[simp]:
  \<open>(U i1 id1) < (U i2 id2) = (i1 < i2 \<or> (i1 = i2 \<and> id1 < id2))\<close>
  unfolding less_uid_def by simp

lemma less_eq_uid_simp[simp]:
  \<open>(U i1 id1) \<le> (U i2 id2) = (i1 < i2 \<or> (i1 = i2 \<and> id1 \<le> id2))\<close>
  unfolding less_eq_uid_def by simp

subsubsection \<open>Pointer\<close>

text \<open>The above encapsulates identification of an internal node of a BDD. We also need nodes to be
      able to reference leaves in the BDD, i.e. the True and the False Boolean values.

      Hence, a pointer can either refer to a leaf or to an internal node. To this end, we lift the
      ordering from both the ordering of Boolean values (\<open>False < True\<close>) and the ordering of uids up
      to pointers.\<close>

datatype 'l ptr = Leaf \<open>bool\<close> | Node \<open>'l uid\<close>

instantiation ptr :: (linorder) linorder
begin
definition less_ptr where
   \<open>less_ptr \<equiv> \<lambda>ptr1 \<Rightarrow> \<lambda>ptr2 \<Rightarrow> (case (ptr1, ptr2) of
      (Node u1, Node u2) \<Rightarrow> u1 < u2
    | (Node _, Leaf _) \<Rightarrow> True
    | (Leaf _, Node _) \<Rightarrow> False
    | (Leaf b1, Leaf b2) \<Rightarrow> b1 < b2)\<close>

definition less_eq_ptr where
   \<open>less_eq_ptr \<equiv> \<lambda>ptr1 \<Rightarrow> \<lambda>ptr2 \<Rightarrow> (case (ptr1, ptr2) of
      (Node u1, Node u2) \<Rightarrow> u1 \<le> u2
    | (Node _, Leaf _) \<Rightarrow> True
    | (Leaf _, Node _) \<Rightarrow> False
    | (Leaf b1, Leaf b2) \<Rightarrow> b1 \<le> b2
)\<close>

instance
  by standard (auto simp: less_ptr_def less_eq_ptr_def split: ptr.splits)
end

text \<open>And a simple rule to simplify case distinction on pointers within our proofs.\<close>

lemma ptr_cases:
  fixes ptr :: "'a ptr"
  obtains
    (True)  "ptr = Leaf True"
  | (False) "ptr = Leaf False"
  | (Node)  u :: "'a uid" where "ptr = Node u"
  by (cases ptr) auto

subsubsection \<open>Node data type\<close>

text \<open>A node is a triple that consists of its unique identifier, i.e. its label and its
      level-identifier, together with a pointer to its high child, i.e. where to go to in the 'then'
      case on the input variable, and finally the pointer to its low child, i.e. where to go to when
      the input variable evaluates to false.\<close>

datatype 'l node = N (uid:\<open>'l uid\<close>) (high:\<open>'l ptr\<close>) (low:\<open>'l ptr\<close>)

text \<open>Nodes are sorted lexicographically on the above triple. This makes nodes first and foremost
      sorted by their unique identifiers, which makes them topologically ordered.

      At this point, we are not (yet) going to use the ordering on children. See Reduce.thy for how
      we actually can guarantee this ordering is fully satisfied.\<close>

instantiation node :: (linorder) linorder
begin
definition less_node where
  \<open>less_node \<equiv> \<lambda>(N i1 t1 e1) \<Rightarrow> \<lambda>(N i2 t2 e2) \<Rightarrow>
    (i1 < i2 \<or> i1 = i2 \<and> t1 < t2 \<or> i1 = i2 \<and> t1 = t2 \<and> e1 < e2)\<close>

definition less_eq_node where
  \<open>less_eq_node \<equiv> \<lambda>(N i1 t1 e1) \<Rightarrow> \<lambda>(N i2 t2 e2) \<Rightarrow>
    (i1 < i2 \<or> i1 = i2 \<and> t1 < t2 \<or> i1 = i2 \<and> t1 = t2 \<and> e1 \<le> e2)\<close>

instance
  by standard (auto simp: less_node_def less_eq_node_def split: node.splits)

end

lemma less_node_simp[simp]:
  \<open>(N i1 t1 e1) < (N i2 t2 e2) =
    (i1 < i2 \<or> i1 = i2 \<and> t1 < t2 \<or> i1 = i2 \<and> t1 = t2 \<and> e1 < e2)\<close>
  unfolding less_node_def by simp

lemma less_eq_node_simp[simp]:
  \<open>(N i1 t1 e1) \<le> (N i2 t2 e2) \<longleftrightarrow>
    (i1 < i2 \<or> i1 = i2 \<and> t1 < t2 \<or> i1 = i2 \<and> t1 = t2 \<and> e1 \<le> e2)\<close>
  unfolding less_eq_node_def by simp

subsection \<open>Binary Decision Diagram\<close>

text \<open>A BDD is then either immediately a leaf, thereby representing a constant function. Otherwise,
      it a (non-empty) stream of nodes, where the first node is to be interpreted as the root.\<close>

datatype 'l bdd = Constant \<open>bool\<close> | Nodes \<open>'l node list\<close>

text \<open>All algorithms rely on the nodes in the Binary Decision Diagram are well-formed in some way.
      Specifically, we need them to

      (a) be 'closed', i.e. every node mentioned actually exists,
      (b) be sorted
      (c) the levels are always (strictly) increasing, i.e. a node may not mention any other node on
          the same level or above.
      (d) the node list is non-empty

      TODO: (e) Every node mentioned is transitively reachable from the root?\<close>

fun closed :: \<open>'l node list \<Rightarrow> bool\<close> where
  \<open>closed []             = True\<close>
| \<open>closed (N i t e # ns) = (closed ns
                          \<and> (case t of Leaf b \<Rightarrow> True | Node l_uid \<Rightarrow> \<exists>n \<in> set ns . uid n = l_uid)
                          \<and> (case e of Leaf b \<Rightarrow> True | Node h_uid \<Rightarrow> \<exists>n \<in> set ns . uid n = h_uid))\<close>

definition
  "ptr_lb i \<equiv> \<lambda>Node n \<Rightarrow> i < label n | _ \<Rightarrow> True"

fun inc_labels :: \<open>('l::linorder) node list \<Rightarrow> bool\<close> where
  \<open>inc_labels []             \<longleftrightarrow> True\<close>
| \<open>inc_labels (N i t e # ns) \<longleftrightarrow> inc_labels ns \<and> ptr_lb (label i) t \<and> ptr_lb (label i) e\<close>

definition
  "well_formed_nl ns \<equiv> closed ns \<and> inc_labels ns \<and> sorted ns"

lemma closed_if_well_formed_nl[intro,simp]:
  "closed ns" if "well_formed_nl ns"
  using that unfolding well_formed_nl_def ..

lemma inc_labels_if_well_formed_nl[intro,simp]:
  "inc_labels ns" if "well_formed_nl ns"
  using that unfolding well_formed_nl_def by (elim conjE)

lemma sorted_if_well_formed_nl[intro,simp]:
  "sorted ns" if "well_formed_nl ns"
  using that unfolding well_formed_nl_def by (elim conjE)

fun well_formed :: \<open>('l::linorder) bdd \<Rightarrow> bool\<close> where
  \<open>well_formed (Constant _) = True\<close>
| \<open>well_formed (Nodes [])   = False\<close>
| \<open>well_formed (Nodes ns)   = well_formed_nl ns\<close>

lemma well_formed_nl_ConsD[intro?]:
  \<open>well_formed_nl ns\<close> if \<open>well_formed_nl (n # ns)\<close>
  using that unfolding well_formed_nl_def by (cases n, simp)

lemma high_lb:
  "ptr_lb (label (uid n)) (high n)" if "inc_labels (n # ns)"
  using that by (cases n; simp)

lemma low_lb:
  "ptr_lb (label (uid n)) (low n)" if "inc_labels (n # ns)"
  using that by (cases n; simp)

lemma ptr_lb_trans:
  "ptr_lb l n" if "ptr_lb k n" "(l :: 'a :: order) \<le> k"
  using that unfolding ptr_lb_def by (auto split: ptr.splits)

text \<open>Finally we have here a few ease-of-life lemmas for later proofs.\<close>

lemma nl_induct[case_names Nil Cons]:
  fixes P :: "'a node list \<Rightarrow> bool"
    and ns :: "'a node list"
  assumes "P []"
    and "\<And>i t e ns. P ns \<Longrightarrow> P (N i t e # ns)"
  shows "P ns"
  using assms by (rule closed.induct)

fun bdd_cases where
  Const: "bdd_cases (Constant b) = undefined"
| Empty: "bdd_cases (Nodes [])   = undefined"
| Nodes: "bdd_cases (Nodes (N i t e # ns)) = undefined"

lemma bdd_cases:
  fixes bdd :: "'c bdd"
  obtains
      (Const) b :: "bool" where "bdd = Constant b"
    | (Empty) "bdd = Nodes []"
    | (Nodes) i :: "'c uid" and t :: "'c ptr" and e :: "'c ptr" and ns :: "'c node list"
    where "bdd = Nodes (N i t e # ns)"
  by (rule bdd_cases.cases)

subsection \<open>Assignment\<close>

text \<open>For assignments we are going to reuse the definition from @{cite Michaelis2016} of a function
      from the set of labels to the Boolean values they were assigned.

      While this is not (yet) reflective of the definition in Adiar it is planned to implement it
      exactly like this (cf. Issue #147 on 'github.com/SSoelvsten/adiar/').\<close>

type_synonym 'l assignment = \<open>'l \<Rightarrow> bool\<close>

end


(*  Title:      HOL/HOLCF/Porder.thy
    Author:     Franz Regensburger and Brian Huffman
*)

section {* Partial orders *}

theory Porder
imports Main
begin

subsection {* Type class for partial orders *}

class below =
  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

notation
  below (infix "<<" 50)

notation (xsymbols)
  below (infix "\<sqsubseteq>" 50)

abbreviation
  not_below :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "~<<" 50)
  where "not_below x y \<equiv> \<not> below x y"

notation (xsymbols)
  not_below (infix "\<notsqsubseteq>" 50)

lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
  by (rule subst)

lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
  by (rule ssubst)

end

class po = below +
  assumes below_refl [iff]: "x \<sqsubseteq> x"
  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
begin

lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
  by simp

lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
  by (rule below_trans [OF below_trans])

lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
  by (fast intro!: below_antisym)

lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
  by (rule below_trans)

lemma not_below2not_eq: "x \<notsqsubseteq> y \<Longrightarrow> x \<noteq> y"
  by auto

end

lemmas HOLCF_trans_rules [trans] =
  below_trans
  below_antisym
  below_eq_trans
  eq_below_trans

context po
begin

subsection {* Upper bounds *}

definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
  "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"

lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
  by (simp add: is_ub_def)

lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  by (simp add: is_ub_def)

lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
  unfolding is_ub_def by fast

lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
  unfolding is_ub_def by fast

lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
  unfolding is_ub_def by fast

lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
  unfolding is_ub_def by fast

lemma is_ub_empty [simp]: "{} <| u"
  unfolding is_ub_def by fast

lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
  unfolding is_ub_def by fast

lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
  unfolding is_ub_def by (fast intro: below_trans)

subsection {* Least upper bounds *}

definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"

definition lub :: "'a set \<Rightarrow> 'a" where
  "lub S = (THE x. S <<| x)"

end

syntax
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)

syntax (xsymbols)
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)

translations
  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"

context po
begin

abbreviation
  Lub  (binder "LUB " 10) where
  "LUB n. t n == lub (range t)"

notation (xsymbols)
  Lub  (binder "\<Squnion> " 10)

text {* access to some definition as inference rule *}

lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
  unfolding is_lub_def by fast

lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  unfolding is_lub_def by fast

lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
  unfolding is_lub_def by fast

lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
  unfolding is_lub_def is_ub_def by (metis below_trans)

text {* lubs are unique *}

lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)

text {* technical lemmas about @{term lub} and @{term is_lub} *}

lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
  unfolding lub_def by (rule theI [OF _ is_lub_unique])

lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
  by (rule is_lub_unique [OF is_lub_lub])

lemma is_lub_singleton: "{x} <<| x"
  by (simp add: is_lub_def)

lemma lub_singleton [simp]: "lub {x} = x"
  by (rule is_lub_singleton [THEN lub_eqI])

lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
  by (simp add: is_lub_def)

lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
  by (rule is_lub_bin [THEN lub_eqI])

lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
  by (erule is_lubI, erule (1) is_ubD)

lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
  by (rule is_lub_maximal [THEN lub_eqI])

subsection {* Countable chains *}

definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  -- {* Here we use countable chains and I prefer to code them as functions! *}
  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"

lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
  unfolding chain_def by fast

lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
  unfolding chain_def by fast

text {* chains are monotone functions *}

lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (erule less_Suc_induct, erule chainE, erule below_trans)

lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (cases "i = j", simp, simp add: chain_mono_less)

lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
  by (rule chainI, simp, erule chainE)

text {* technical lemmas about (least) upper bounds of chains *}

lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
  by (rule is_lubD1 [THEN ub_rangeD])

lemma is_ub_range_shift:
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
apply (rule iffI)
apply (rule ub_rangeI)
apply (rule_tac y="S (i + j)" in below_trans)
apply (erule chain_mono)
apply (rule le_add1)
apply (erule ub_rangeD)
apply (rule ub_rangeI)
apply (erule ub_rangeD)
done

lemma is_lub_range_shift:
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
  by (simp add: is_lub_def is_ub_range_shift)

text {* the lub of a constant chain is the constant *}

lemma chain_const [simp]: "chain (\<lambda>i. c)"
  by (simp add: chainI)

lemma is_lub_const: "range (\<lambda>x. c) <<| c"
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)

lemma lub_const [simp]: "(\<Squnion>i. c) = c"
  by (rule is_lub_const [THEN lub_eqI])

subsection {* Finite chains *}

definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  -- {* finite chains, needed for monotony of continuous functions *}
  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"

definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"

text {* results about finite chains *}

lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
  unfolding max_in_chain_def by fast

lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
  unfolding max_in_chain_def by fast

lemma finite_chainI:
  "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
  unfolding finite_chain_def by fast

lemma finite_chainE:
  "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding finite_chain_def by fast

lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
apply (rule is_lubI)
apply (rule ub_rangeI, rename_tac j)
apply (rule_tac x=i and y=j in linorder_le_cases)
apply (drule (1) max_in_chainD, simp)
apply (erule (1) chain_mono)
apply (erule ub_rangeD)
done

lemma lub_finch2:
  "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
apply (erule finite_chainE)
apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
apply (erule (1) lub_finch1)
done

lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
 apply (erule finite_chainE)
 apply (rule_tac B="Y ` {..i}" in finite_subset)
  apply (rule subsetI)
  apply (erule rangeE, rename_tac j)
  apply (rule_tac x=i and y=j in linorder_le_cases)
   apply (subgoal_tac "Y j = Y i", simp)
   apply (simp add: max_in_chain_def)
  apply simp
 apply simp
done

lemma finite_range_has_max:
  fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
  assumes finite_range: "finite (range f)"
  shows "\<exists>k. \<forall>i. r (f i) (f k)"
proof (intro exI allI)
  fix i :: nat
  let ?j = "LEAST k. f k = f i"
  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
  have "?j \<le> ?k"
  proof (rule Max_ge)
    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
      using finite_range by (rule finite_imageI)
    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
      by (intro imageI rangeI)
  qed
  hence "r (f ?j) (f ?k)"
    by (rule mono)
  also have "f ?j = f i"
    by (rule LeastI, rule refl)
  finally show "r (f i) (f ?k)" .
qed

lemma finite_range_imp_finch:
  "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
 apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
  apply (erule exE)
  apply (rule finite_chainI, assumption)
  apply (rule max_in_chainI)
  apply (rule below_antisym)
   apply (erule (1) chain_mono)
  apply (erule spec)
 apply (rule finite_range_has_max)
  apply (erule (1) chain_mono)
 apply assumption
done

lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
  by (rule chainI, simp)

lemma bin_chainmax:
  "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
  unfolding max_in_chain_def by simp

lemma is_lub_bin_chain:
  "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
apply (frule bin_chain)
apply (drule bin_chainmax)
apply (drule (1) lub_finch1)
apply simp
done

text {* the maximal element in a chain is its lub *}

lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)

end

end


theory BDD
    imports
Main begin

text \<open>
Boolean functions (in finitely many variables) can be represented by so-called
{\it binary decision diagrams} (BDDs), which are given by the following data
type:
\<close>

datatype bdd = Leaf bool | Branch bdd bdd

text \<open>
A constructor @{term "Branch b1 b2"} that is $i$ steps away from the root of
the tree corresponds to a case distinction based on the value of the variable
$v_i$.  If the value of $v_i$ is @{term "False"}, the left subtree @{term "b1"}
is evaluated, otherwise the right subtree @{term "b2"} is evaluated.  The
following figure shows a Boolean function and the corresponding BDD.
\begin{center}
\begin{minipage}{8cm}
\begin{tabular}{|c|c|c|c|} \hline
$v_0$ & $v_1$ & $v_2$ & $f(v_0,v_1,v_2)$ \\ \hline
@{term "False"} & @{term "False"} & *               & @{term "True"} \\
@{term "False"} & @{term "True"}  & *               & @{term "False"} \\
@{term "True"}  & @{term "False"} & *               & @{term "False"} \\
@{term "True"}  & @{term "True"}  & @{term "False"} & @{term "False"} \\
@{term "True"}  & @{term "True"}  & @{term "True"}  & @{term "True"} \\ \hline
\end{tabular}
\end{minipage}
\begin{minipage}{7cm}
\begin{picture}(0,0)%
\includegraphics[scale=0.5]{bdd}%
\end{picture}%
\setlength{\unitlength}{2072sp}%
\begin{picture}(6457,3165)(1329,-4471)
\put(1351,-3571){\makebox(0,0)[b]{@{term "True"}}}%
\put(3151,-3571){\makebox(0,0)[b]{@{term "False"}}}%
\put(4951,-3571){\makebox(0,0)[b]{@{term "False"}}}%
\put(5851,-4471){\makebox(0,0)[b]{@{term "False"}}}%
\put(7651,-4471){\makebox(0,0)[b]{@{term "True"}}}%
\put(7786,-3301){\makebox(0,0)[lb]{$v_2$}}%
\put(7786,-2401){\makebox(0,0)[lb]{$v_1$}}%
\put(7786,-1501){\makebox(0,0)[lb]{$v_0$}}%
\end{picture}
\end{minipage}
\end{center}

{\bf Exercise 1:} Define a function
\<close>

primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool"
  where
"eval _ _ (Leaf b) = b" |
"eval val i (Branch b1 b2) = (if (val i)
                             then (eval val (Suc i) b2)
                             else (eval val (Suc i) b1))"

text \<open>
that evaluates a BDD under a given variable assignment, beginning at a variable
with a given index.
\<close>

text \<open>
{\bf Exercise 2:} Define two functions
\<close>

primrec  bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd"
  where
"bdd_unop f (Leaf b) = Leaf (f b)" |
"bdd_unop f (Branch b1 b2) = Branch (bdd_unop f b1) (bdd_unop f b2)"

lemma bdd_unop_correct:"eval val i (bdd_unop f b) = f (eval val i b)"
  apply (induction b arbitrary: i) by auto

primrec bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd"
  where
"bdd_binop f (Leaf x) b = bdd_unop (f x) b" |
"bdd_binop f (Branch b1\<^sub>1 b2\<^sub>1) b =
   (case b of
   Leaf x          \<Rightarrow> Branch (bdd_binop f b1\<^sub>1 b) (bdd_binop f b2\<^sub>1 b) |
   Branch b1\<^sub>2 b2\<^sub>2  \<Rightarrow> Branch (bdd_binop f b1\<^sub>1 b1\<^sub>2) (bdd_binop f b2\<^sub>1 b2\<^sub>2))"

lemma bdd_binop_correct:"eval val i (bdd_binop f b1 b2) = f (eval val i b1) (eval val i b2)"
  apply (induction b1 arbitrary: i b2)
  by (auto simp add: bdd_unop_correct split: bdd.split)

text \<open>
for the application of unary and binary operators to BDDs, and prove their
correctness.
\<close>

text \<open>
Now use @{term "bdd_unop"} and @{term "bdd_binop"} to define
\<close>

definition bdd_and :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"
  where
"bdd_and b1 b2 = bdd_binop (\<and>) b1 b2"

definition bdd_or :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"
  where
"bdd_or b1 b2 = bdd_binop (\<or>) b1 b2"

definition  bdd_not :: "bdd \<Rightarrow> bdd"
  where
"bdd_not b = bdd_unop (\<lambda>x. \<not>x) b"

definition xor:: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "\<oplus>" 60)
  where
"xor a b = ((a \<and> \<not>b) \<or> (\<not>a \<and> b))"

definition bdd_xor :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"
  where
"bdd_xor b1 b2 = bdd_binop (\<oplus>) b1 b2"

lemma bdd_and_correct:"eval val i (bdd_and b1 b2) = ((eval val i b1) \<and> (eval val i b2))"
  by (simp add: bdd_and_def bdd_binop_correct)

lemma bdd_or_correct:"eval val i (bdd_or b1 b2) = ((eval val i b1) \<or> (eval val i b2))"
  by (simp add: bdd_or_def bdd_binop_correct)

lemma bdd_not_correct:"eval val i (bdd_not b) = (\<not>(eval val i b))"
  by (simp add: bdd_not_def bdd_unop_correct)

lemma bdd_xor_correct:"eval val i (bdd_xor b1 b2) = (eval val i b1) \<oplus> (eval val i b2)"
  by (simp add: bdd_xor_def bdd_binop_correct)

text \<open>
and show correctness.
\<close>

text \<open>
Finally, define a function
\<close>

primrec bdd_var :: "nat \<Rightarrow> bdd"
  where
"bdd_var 0 = (Branch (Leaf False) (Leaf True))" |
"bdd_var (Suc n) = (Branch (bdd_var n) (bdd_var n))"

text \<open>
to create a BDD that evaluates to @{term "True"} if and only if the variable
with the given index evaluates to @{term "True"}.  Again prove a suitable
correctness theorem.

{\bf Hint:} If a lemma cannot be proven by induction because in the inductive
step a different value is used for a (non-induction) variable than in the
induction hypothesis, it may be necessary to strengthen the lemma by universal
quantification over that variable (cf.\ Section 3.2 in the Tutorial on
Isabelle/HOL).
\<close>

lemma bdd_var_correct:"eval val j (bdd_var i) = val (i + j)"
  apply (induction i arbitrary: j) by auto

text_raw \<open> \begin{minipage}[t]{0.45\textwidth} \<close>

text\<open>
{\bf Example:} instead of
\<close>

lemma "P (b::bdd) x"
apply (induct b) (*<*) oops (*>*)

text_raw \<open> \end{minipage} \<close>
text_raw \<open> \begin{minipage}[t]{0.45\textwidth} \<close>

text \<open> Strengthening: \<close>

lemma "\<forall>x. P (b::bdd) x"
apply (induct b) (*<*) oops (*>*)

text_raw \<open> \end{minipage} \\[0.5cm]\<close>

text \<open>
{\bf Exercise 3:} Recall the following data type of propositional formulae
(cf.\ the exercise on ``Representation of Propositional Formulae by
Polynomials'')
\<close>

datatype form = T | Var nat | And form form | Xor form form

text \<open>
together with the evaluation function @{text "evalf"}:
\<close>

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
  "evalf e T = True"
| "evalf e (Var i) = e i"
| "evalf e (And f1 f2) = (evalf e f1 \<and> evalf e f2)"
| "evalf e (Xor f1 f2) = xor (evalf e f1) (evalf e f2)"

text \<open>
Define a function
\<close>

primrec mk_bdd :: "form \<Rightarrow> bdd"
  where
"mk_bdd T = (Leaf True)" |
"mk_bdd (Var n) = bdd_var n" |
"mk_bdd (And f1 f2) = bdd_and (mk_bdd f1) (mk_bdd f2)" |
"mk_bdd (Xor f1 f2) = bdd_xor (mk_bdd f1) (mk_bdd f2)"

text \<open>
that transforms a propositional formula of type @{typ "form"} into a BDD.
Prove the correctness theorem
\<close>

theorem mk_bdd_correct: "eval e 0 (mk_bdd f) = evalf e f"
  apply (induction f arbitrary: e)
    by (auto simp add: bdd_var_correct bdd_and_correct bdd_xor_correct)

(*<*) end (*>*)


theory Support
  imports "../Nominal"
begin

text {*
  An example showing that in general

  x\<sharp>(A \<union> B) does not imply  x\<sharp>A and  x\<sharp>B

  For this we set A to the set of even atoms and B to
  the set of odd atoms. Then A \<union> B, that is the set of
  all atoms, has empty support. The sets A, respectively B,
  however have the set of all atoms as their support.
*}

atom_decl atom

text {* The set of even atoms. *}
abbreviation
  EVEN :: "atom set"
where
  "EVEN \<equiv> {atom n | n. \<exists>i. n=2*i}"

text {* The set of odd atoms: *}
abbreviation
  ODD :: "atom set"
where
  "ODD \<equiv> {atom n | n. \<exists>i. n=2*i+1}"

text {* An atom is either even or odd. *}
lemma even_or_odd:
  fixes n :: nat
  shows "\<exists>i. (n = 2*i) \<or> (n=2*i+1)"
  by (induct n) (presburger)+

text {*
  The union of even and odd atoms is the set of all atoms.
  (Unfortunately I do not know a simpler proof of this fact.) *}
lemma EVEN_union_ODD:
  shows "EVEN \<union> ODD = UNIV"
  using even_or_odd
proof -
  have "EVEN \<union> ODD = (\<lambda>n. atom n) ` {n. \<exists>i. n = 2*i} \<union> (\<lambda>n. atom n) ` {n. \<exists>i. n = 2*i+1}" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` ({n. \<exists>i. n = 2*i} \<union> {n. \<exists>i. n = 2*i+1})" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` ({n. \<exists>i. n = 2*i \<or> n = 2*i+1})" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` (UNIV::nat set)" using even_or_odd by auto
  also have "\<dots> = (UNIV::atom set)" using atom.exhaust
    by (auto simp add: surj_def)
  finally show "EVEN \<union> ODD = UNIV" by simp
qed

text {* The sets of even and odd atoms are disjunct. *}
lemma EVEN_intersect_ODD:
  shows "EVEN \<inter> ODD = {}"
  using even_or_odd
  by (auto) (presburger)

text {*
  The preceeding two lemmas help us to prove
  the following two useful equalities: *}

lemma UNIV_subtract:
  shows "UNIV - EVEN = ODD"
  and   "UNIV - ODD  = EVEN"
  using EVEN_union_ODD EVEN_intersect_ODD
  by (blast)+

text {* The sets EVEN and ODD are infinite. *}
lemma EVEN_ODD_infinite:
  shows "infinite EVEN"
  and   "infinite ODD"
unfolding infinite_iff_countable_subset
proof -
  let ?f = "\<lambda>n. atom (2*n)"
  have "inj ?f \<and> range ?f \<subseteq> EVEN" by (auto simp add: inj_on_def)
  then show "\<exists>f::nat\<Rightarrow>atom. inj f \<and> range f \<subseteq> EVEN" by (rule_tac exI)
next
  let ?f = "\<lambda>n. atom (2*n+1)"
  have "inj ?f \<and> range ?f \<subseteq> ODD" by (auto simp add: inj_on_def)
  then show "\<exists>f::nat\<Rightarrow>atom. inj f \<and> range f \<subseteq> ODD" by (rule_tac exI)
qed

text {*
  A general fact about a set S of atoms that is both infinite and
  coinfinite. Then S has all atoms as its support. Steve Zdancewic
  helped with proving this fact. *}

lemma supp_infinite_coinfinite:
  fixes S::"atom set"
  assumes asm1: "infinite S"
  and     asm2: "infinite (UNIV-S)"
  shows "(supp S) = (UNIV::atom set)"
proof -
  have "\<forall>(x::atom). x\<in>(supp S)"
  proof
    fix x::"atom"
    show "x\<in>(supp S)"
    proof (cases "x\<in>S")
      case True
      have "x\<in>S" by fact
      hence "\<forall>b\<in>(UNIV-S). [(x,b)]\<bullet>S\<noteq>S" by (auto simp add: perm_set_def calc_atm)
      with asm2 have "infinite {b\<in>(UNIV-S). [(x,b)]\<bullet>S\<noteq>S}" by (rule infinite_Collection)
      hence "infinite {b. [(x,b)]\<bullet>S\<noteq>S}" by (rule_tac infinite_super, auto)
      then show "x\<in>(supp S)" by (simp add: supp_def)
    next
      case False
      have "x\<notin>S" by fact
      hence "\<forall>b\<in>S. [(x,b)]\<bullet>S\<noteq>S" by (auto simp add: perm_set_def calc_atm)
      with asm1 have "infinite {b\<in>S. [(x,b)]\<bullet>S\<noteq>S}" by (rule infinite_Collection)
      hence "infinite {b. [(x,b)]\<bullet>S\<noteq>S}" by (rule_tac infinite_super, auto)
      then show "x\<in>(supp S)" by (simp add: supp_def)
    qed
  qed
  then show "(supp S) = (UNIV::atom set)" by auto
qed

text {* As a corollary we get that EVEN and ODD have infinite support. *}
lemma EVEN_ODD_supp:
  shows "supp EVEN = (UNIV::atom set)"
  and   "supp ODD  = (UNIV::atom set)"
  using supp_infinite_coinfinite UNIV_subtract EVEN_ODD_infinite
  by simp_all

text {*
  The set of all atoms has empty support, since any swappings leaves
  this set unchanged. *}

lemma UNIV_supp:
  shows "supp (UNIV::atom set) = ({}::atom set)"
proof -
  have "\<forall>(x::atom) (y::atom). [(x,y)]\<bullet>UNIV = (UNIV::atom set)"
    by (auto simp add: perm_set_def calc_atm)
  then show "supp (UNIV::atom set) = ({}::atom set)" by (simp add: supp_def)
qed

text {* Putting everything together. *}
theorem EVEN_ODD_freshness:
  fixes x::"atom"
  shows "x\<sharp>(EVEN \<union> ODD)"
  and   "\<not>x\<sharp>EVEN"
  and   "\<not>x\<sharp>ODD"
  by (auto simp only: fresh_def EVEN_union_ODD EVEN_ODD_supp UNIV_supp)

text {* Moral: support is a sublte notion. *}

end


section \<open>Various examples for transfer procedure\<close>

theory Transfer_Ex
imports Main Transfer_Int_Nat
begin

lemma ex1: "(x::nat) + y = y + x"
  by auto

lemma "0 \<le> (y::int) \<Longrightarrow> 0 \<le> (x::int) \<Longrightarrow> x + y = y + x"
  by (fact ex1 [transferred])

(* Using new transfer package *)
lemma "0 \<le> (x::int) \<Longrightarrow> 0 \<le> (y::int) \<Longrightarrow> x + y = y + x"
  by (fact ex1 [untransferred])

lemma ex2: "(a::nat) div b * b + a mod b = a"
  by (rule div_mult_mod_eq)

lemma "0 \<le> (b::int) \<Longrightarrow> 0 \<le> (a::int) \<Longrightarrow> a div b * b + a mod b = a"
  by (fact ex2 [transferred])

(* Using new transfer package *)
lemma "0 \<le> (a::int) \<Longrightarrow> 0 \<le> (b::int) \<Longrightarrow> a div b * b + a mod b = a"
  by (fact ex2 [untransferred])

lemma ex3: "ALL (x::nat). ALL y. EX z. z >= x + y"
  by auto

lemma "\<forall>x\<ge>0::int. \<forall>y\<ge>0. \<exists>z\<ge>0. x + y \<le> z"
  by (fact ex3 [transferred nat_int])

(* Using new transfer package *)
lemma "\<forall>x::int\<in>{0..}. \<forall>y\<in>{0..}. \<exists>z\<in>{0..}. x + y \<le> z"
  by (fact ex3 [untransferred])

lemma ex4: "(x::nat) >= y \<Longrightarrow> (x - y) + y = x"
  by auto

lemma "0 \<le> (x::int) \<Longrightarrow> 0 \<le> (y::int) \<Longrightarrow> y \<le> x \<Longrightarrow> tsub x y + y = x"
  by (fact ex4 [transferred])

(* Using new transfer package *)
lemma "0 \<le> (y::int) \<Longrightarrow> 0 \<le> (x::int) \<Longrightarrow> y \<le> x \<Longrightarrow> tsub x y + y = x"
  by (fact ex4 [untransferred])

lemma ex5: "(2::nat) * \<Sum>{..n} = n * (n + 1)"
  by (induct n rule: nat_induct, auto)

lemma "0 \<le> (n::int) \<Longrightarrow> 2 * \<Sum>{0..n} = n * (n + 1)"
  by (fact ex5 [transferred])

(* Using new transfer package *)
lemma "0 \<le> (n::int) \<Longrightarrow> 2 * \<Sum>{0..n} = n * (n + 1)"
  by (fact ex5 [untransferred])

lemma "0 \<le> (n::nat) \<Longrightarrow> 2 * \<Sum>{0..n} = n * (n + 1)"
  by (fact ex5 [transferred, transferred])

(* Using new transfer package *)
lemma "0 \<le> (n::nat) \<Longrightarrow> 2 * \<Sum>{..n} = n * (n + 1)"
  by (fact ex5 [untransferred, Transfer.transferred])

end


theory Exercises2_09
  imports Main
begin

(*---------------- Exercise 2.9----------------*)
(* add function *)
fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 y = y" |
"add (Suc x) y = Suc(add x y)"

(* tail recursive add function *)
fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 y = y" |
"itadd (Suc x) y = itadd x (Suc y)"

lemma suc_add : "add x (Suc y) = add (Suc x) y"
  apply(induction x)
   apply(auto)
  done

theorem itadd_add : "itadd x y = add x y"
  apply(induction x arbitrary: y)
  apply(auto)
   apply(simp add: suc_add)
  done

end


theory Chapter2
  imports Main
begin

(* Exercise 2.1  *)

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

(* Exercise 2.2  *)

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where "add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

lemma add_assoc [simp] : "add (add p q) r  = add p (add q r)"
  apply(induction p)
   apply(auto)
  done

lemma add_02 [simp] : "add m 0 = m" apply(induction m)
apply(auto)
done

lemma add_plus1 [simp] : "Suc (add q p) = add q (Suc p)"
  apply(induction q)
   apply(auto)
  done

lemma add_comm [simp] : "add p q = add q p"
  apply(induction p)
   apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0"
| "double (Suc n) = 2 + (double n)"

lemma double_correct [simp] : "double n = add n n"
  apply(induction n)
   apply(auto)
  done

(* Exercise 2.3 *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x Nil = 0"
| "count x (Cons t ts) = 1 + (count x ts)"

lemma leq_count_length : "count x xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

(* Exercise 2.4 *)

fun snoc :: " 'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc Nil x = [x]"
|"snoc (Cons t ts) x = Cons t (snoc ts x)"

fun reverse :: " 'a list \<Rightarrow> 'a list" where
"reverse Nil = Nil"
|"reverse (Cons t ts) = snoc (reverse ts) t"

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

lemma snoc_add1 [simp] : "snoc xs x = xs @ [x]"
  apply(induction xs)
   apply(auto)
  done

lemma rev_app_distr [simp] : "reverse (xs @ ys) = (reverse ys) @ reverse(xs)"
  apply(induction xs)
   apply(auto)
  done

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

(* Exercise 2.5 *)

fun sum_upto  :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0"
| "sum_upto (Suc n) = (n + (sum_upto n)) + 1"

lemma sum_upto_correct : "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
  apply(auto)
  done

(* Exercise 2.6 *)

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

fun contents :: " 'a tree \<Rightarrow> 'a list " where
" contents Tip = Nil "
| " contents (Node l a r) =  a # ((contents l) @ (contents r))"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
" sum_tree Tip = 0 "
| " sum_tree (Node l a r) = a + (sum_tree l) + (sum_tree r)"

lemma sum_tree_correct : "sum_tree t = sum_list(contents t)"
  apply(induction t)
   apply(auto)
  done

(* Exercise 2.7 *)

datatype 'a tree2 = Tip2 'a | Node " 'a tree2" 'a " 'a tree2"

fun mirror2 :: " 'a tree2 \<Rightarrow> 'a tree2 " where
 "mirror2 (Tip2 a) = Tip2 a"
| "mirror2 (Node l a r) = Node (mirror2 r) a (mirror2 l)"

fun pre_order :: " 'a tree2 \<Rightarrow> 'a list" where
"pre_order (Tip2 a) = [a]"
| "pre_order (Node l a r) = a # ((pre_order l) @ (pre_order r))"

fun post_order :: " 'a tree2 \<Rightarrow> 'a list" where
"post_order (Tip2 a) = [a]"
| "post_order (Node l a r) = (post_order l) @ (post_order r) @ [a] "

lemma tree2_orders_correct : "pre_order(mirror2 t) = rev(post_order t)"
  apply(induction t)
   apply(auto)
  done

(* Exercise 2.8 *)

fun intersperse :: " 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a Nil = [a]"
| "intersperse a (Cons x Nil) = [x]"
| "intersperse a (Cons x xs) = [x, a] @ (intersperse a xs)"

lemma intersperse_correct : " map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction a xs rule: intersperse.induct)
    apply(auto)
  done

(* Exercise 2.9 *)

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
 "itadd 0 m  = m"
| "itadd (Suc 0) m = Suc m"
| "itadd (Suc n) m = itadd (Suc 0) (itadd n m)"

lemma add_suc0 : "Suc m = add m (Suc 0)"
  apply(induction m)
   apply(auto)
  done

lemma itadd_correct : "itadd n m = add n m"
  apply(induction n m rule: itadd.induct)
    apply(auto)
  apply (rule add_suc0)
  done

(* Exercise 2.10 *)

datatype tree0 = Tip0 | Node0 "tree0" "tree0"

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Tip0 = 1"
| "nodes (Node0 l r) = nodes l + nodes r + 1"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t"
|"explode (Suc n) t = explode n (Node0 t t)"

lemma exploded_tree_size: "nodes(explode n t) = (2^n)*(nodes t) + (2^n) - 1"
apply(induct n arbitrary: t)
apply(auto simp add: algebra_simps)
  done

(* Exercise 2.11 *)

datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x"
| "eval (Const k) x = k"
| "eval (Add u v) x = (eval u x) + (eval v x)"
| "eval (Mult u v) x = (eval u x) * (eval v x)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp Nil k = 0"
| "evalp (Cons x xs) k = x + (k * (evalp xs k))"

fun coeffs_add :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"coeffs_add Nil ys = ys"
| "coeffs_add xs Nil = xs"
| "coeffs_add (Cons x xs) (Cons y ys) = (x + y) # (coeffs_add xs ys)"

value "coeffs_add [0,1,4,5] [1,0,5]"

fun MultByC :: "int \<Rightarrow> int list \<Rightarrow> int list" where
"MultByC c Nil = Nil"
| "MultByC c (Cons x xs) = (c * x) # (MultByC c xs)"

fun coeffs_mult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"coeffs_mult Nil ys = Nil"
| "coeffs_mult (Cons x xs) ys = coeffs_add (MultByC x ys) (0 # (coeffs_mult xs ys))"

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs Var = [0,1]"
| "coeffs (Const k) = [k]"
| "coeffs (Add e1 e2) = coeffs_add (coeffs e1) (coeffs e2)"
| "coeffs (Mult e1 e2) = coeffs_mult (coeffs e1) (coeffs e2)"

lemma coeffs_add_correct [simp] : "evalp (coeffs_add xs ys) x = (evalp xs x) + (evalp ys x)"
  apply(induction xs ys arbitrary: x rule: coeffs_add.induct)
    apply(auto simp add: algebra_simps)
  done

lemma factor_by_const_prop : " evalp (MultByC a ys) x = a * evalp ys x"
  apply(induction ys)
   apply(auto simp add: algebra_simps)
  done

lemma coeffs_mult_correct [simp] : "evalp (coeffs_mult xs ys) x = (evalp xs x) * (evalp ys x)"
  apply(induction xs arbitrary: ys  x)
   apply(auto simp add: algebra_simps)
  apply(rule factor_by_const_prop)
  done

lemma coeffs_correct : "evalp (coeffs e) x = eval e x"
  apply(induction e arbitrary: x)
     apply(auto simp add: algebra_simps)
  done

end


(*  Title:       Infinite Sequences
    Author:      Christian Sternagel <c-sterna@jaist.ac.jp>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2012 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
header {* Infinite Sequences *}
theory Seq
imports
  Main
  "~~/src/HOL/Library/Infinite_Set"
begin

text {*Infinite sequences are represented by functions of type @{typ "nat \<Rightarrow> 'a"}.*}
type_synonym 'a seq = "nat \<Rightarrow> 'a"

subsection {*Operations on Infinite Sequences*}

text {*An infinite sequence is \emph{linked} by a binary predicate @{term P} if every two
consecutive elements satisfy it. Such a sequence is called a \emph{@{term P}-chain}. *}
abbreviation (input) chainp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>'a seq \<Rightarrow> bool" where
  "chainp P S \<equiv> \<forall>i. P (S i) (S (Suc i))"

text {*Special version for relations.*}
abbreviation (input) chain :: "'a rel \<Rightarrow> 'a seq \<Rightarrow> bool" where
  "chain r S \<equiv> chainp (\<lambda>x y. (x, y) \<in> r) S"

text {*Extending a chain at the front.*}
lemma cons_chainp:
  assumes "P x (S 0)" and "chainp P S"
  shows "chainp P (case_nat x S)" (is "chainp P ?S")
proof
  fix i show "P (?S i) (?S (Suc i))" using assms by (cases i) simp_all
qed

text {*Special version for relations.*}
lemma cons_chain:
  assumes "(x, S 0) \<in> r" and "chain r S" shows "chain r (case_nat x S)"
  using cons_chainp[of "\<lambda>x y. (x, y) \<in> r", OF assms] .

text {*A chain admits arbitrary transitive steps.*}
lemma chainp_imp_relpowp:
  assumes "chainp P S" shows "(P^^j) (S i) (S (i + j))"
proof (induct "i + j" arbitrary: j)
  case (Suc n) thus ?case using assms by (cases j) auto
qed simp

lemma chain_imp_relpow:
  assumes "chain r S" shows "(S i, S (i + j)) \<in> r^^j"
proof (induct "i + j" arbitrary: j)
  case (Suc n) thus ?case using assms by (cases j) auto
qed simp

lemma chainp_imp_tranclp:
  assumes "chainp P S" and "i < j" shows "P^++ (S i) (S j)"
proof -
  from less_imp_Suc_add[OF assms(2)] obtain n where "j = i + Suc n" by auto
  with chainp_imp_relpowp[of P S "Suc n" i, OF assms(1)]
    show ?thesis
      unfolding trancl_power[of "(S i, S j)", to_pred]
      by force
qed

lemma chain_imp_trancl:
  assumes "chain r S" and "i < j" shows "(S i, S j) \<in> r^+"
proof -
  from less_imp_Suc_add[OF assms(2)] obtain n where "j = i + Suc n" by auto
  with chain_imp_relpow[OF assms(1), of i "Suc n"]
    show ?thesis unfolding trancl_power by force
qed

text {*A chain admits arbitrary reflexive and transitive steps.*}
lemma chainp_imp_rtranclp:
  assumes "chainp P S" and "i \<le> j" shows "P^** (S i) (S j)"
proof -
  from assms(2) obtain n where "j = i + n" by (induct "j - i" arbitrary: j) force+
  with chainp_imp_relpowp[of P S, OF assms(1), of n i] show ?thesis
    by (simp add: relpow_imp_rtrancl[of "(S i, S (i + n))", to_pred])
qed

lemma chain_imp_rtrancl:
  assumes "chain r S" and "i \<le> j" shows "(S i, S j) \<in> r^*"
proof -
  from assms(2) obtain n where "j = i + n" by (induct "j - i" arbitrary: j) force+
  with chain_imp_relpow[OF assms(1), of i n] show ?thesis by (simp add: relpow_imp_rtrancl)
qed

text {*If for every @{term i} there is a later index @{term "f i"} such that the
corresponding elements satisfy the predicate @{term P}, then there is a @{term P}-chain.*}
lemma stepfun_imp_chainp':
  assumes "\<forall>i\<ge>n::nat. f i \<ge> i \<and> P (S i) (S (f i))"
  shows "chainp P (\<lambda>i. S ((f ^^ i) n))" (is "chainp P ?T")
proof
  fix i
  from assms have "(f ^^ i) n \<ge> n" by (induct i) auto
  with assms[THEN spec[of _ "(f ^^ i) n"]]
    show "P (?T i) (?T (Suc i))" by simp
qed

lemma stepfun_imp_chainp:
  assumes "\<forall>i\<ge>n::nat. f i > i \<and> P (S i) (S (f i))"
  shows "chainp P (\<lambda>i. S ((f ^^ i) n))" (is "chainp P ?T")
  using stepfun_imp_chainp'[of n f P S] and assms by force

lemma subchain:
  assumes "\<forall>i::nat>n. \<exists>j>i. P (f i) (f j)"
  shows "\<exists>\<phi>. (\<forall>i j. i < j \<longrightarrow> \<phi> i < \<phi> j) \<and> (\<forall>i. P (f (\<phi> i)) (f (\<phi> (Suc i))))"
proof -
  from assms have "\<forall>i\<in>{i. i > n}. \<exists>j>i. P (f i) (f j)" by simp
  from bchoice [OF this] obtain g
    where *: "\<forall>i>n. g i > i"
    and **: "\<forall>i>n. P (f i) (f (g i))" by auto
  def [simp]: \<phi> \<equiv> "\<lambda>i. (g ^^ i) (Suc n)"
  from * have ***: "\<And>i. \<phi> i > n" by (induct_tac i) auto
  then have "\<And>i. \<phi> i < \<phi> (Suc i)" using * by (induct_tac i) auto
  then have "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j" by (rule lift_Suc_mono_less)
  moreover have "\<And>i. P (f (\<phi> i)) (f (\<phi> (Suc i)))" using ** and *** by simp
  ultimately show ?thesis by blast
qed

text {*If for every @{term i} there is a later index @{term j} such that the
corresponding elements satisfy the predicate @{term P}, then there is a @{term P}-chain.*}
lemma steps_imp_chainp':
  assumes "\<forall>i\<ge>n::nat. \<exists>j\<ge>i. P (S i) (S j)" shows "\<exists>T. chainp P T"
proof -
  from assms have "\<forall>i\<in>{i. i \<ge> n}. \<exists>j\<ge>i. P (S i) (S j)" by auto
  from bchoice [OF this] (*choice could be replaced by an application of Least_Enum.infinitely_many2*)
    obtain f where "\<forall>i\<ge>n. f i \<ge> i \<and> P (S i) (S (f i))" by auto
  from stepfun_imp_chainp'[of n f P S, OF this] show ?thesis by fast
qed

lemma steps_imp_chainp:
  assumes "\<forall>i\<ge>n::nat. \<exists>j>i. P (S i) (S j)" shows "\<exists>T. chainp P T"
  using steps_imp_chainp' [of n P S] and assms by force

subsection {* Predicates on Natural Numbers *}

text {*If some property holds for infinitely many natural numbers, obtain
an index function that points to these numbers in increasing order.*}

locale infinitely_many =
  fixes p :: "nat \<Rightarrow> bool"
  assumes infinite: "INFM j. p j"
begin

lemma inf: "\<exists>j\<ge>i. p j" using infinite[unfolded INFM_nat_le] by auto

fun index :: "nat seq" where
  "index 0 = (LEAST n. p n)"
| "index (Suc n) = (LEAST k. p k \<and> k > index n)"

lemma index_p: "p (index n)"
proof (induct n)
  case 0
  from inf obtain j where "p j" by auto
  with LeastI[of p j] show ?case by auto
next
  case (Suc n)
  from inf obtain k where "k \<ge> Suc (index n) \<and> p k" by auto
  with LeastI[of "\<lambda> k. p k \<and> k > index n" k] show ?case by auto
qed

lemma index_ordered: "index n < index (Suc n)"
proof -
  from inf obtain k where "k \<ge> Suc (index n) \<and> p k" by auto
  with LeastI[of "\<lambda> k. p k \<and> k > index n" k] show ?thesis by auto
qed

lemma index_not_p_between:
  assumes i1: "index n < i"
    and i2: "i < index (Suc n)"
  shows "\<not> p i"
proof -
  from not_less_Least[OF i2[simplified]] i1 show ?thesis by auto
qed

lemma index_ordered_le:
  assumes "i \<le> j" shows "index i \<le> index j"
proof -
  from assms have "j = i + (j - i)" by auto
  then obtain k where j: "j = i + k" by auto
  have "index i \<le> index (i + k)"
  proof (induct k)
    case (Suc k)
    with index_ordered[of "i + k"]
    show ?case by auto
  qed simp
  thus ?thesis unfolding j .
qed

lemma index_surj:
  assumes "k \<ge> index l"
  shows "\<exists>i j. k = index i + j \<and> index i + j < index (Suc i)"
proof -
  from assms have "k = index l + (k - index l)" by auto
  then obtain u where k: "k = index l + u" by auto
  show ?thesis unfolding k
  proof (induct u)
    case 0
    show ?case
      by (intro exI conjI, rule refl, insert index_ordered[of l], simp)
  next
    case (Suc u)
    then obtain i j
      where lu: "index l + u = index i + j" and lt: "index i + j < index (Suc i)" by auto
    hence "index l + u < index (Suc i)" by auto
    show ?case
    proof (cases "index l + (Suc u) = index (Suc i)")
      case False
      show ?thesis
        by (rule exI[of _ i], rule exI[of _ "Suc j"], insert lu lt False, auto)
    next
      case True
      show ?thesis
        by (rule exI[of _ "Suc i"], rule exI[of _ 0], insert True index_ordered[of "Suc i"], auto)
    qed
  qed
qed

lemma index_ordered_less:
  assumes "i < j" shows "index i < index j"
proof -
  from assms have "Suc i \<le> j" by auto
  from index_ordered_le[OF this]
  have "index (Suc i) \<le> index j" .
  with index_ordered[of i] show ?thesis by auto
qed

lemma index_not_p_start: assumes i: "i < index 0" shows "\<not> p i"
proof -
  from i[simplified index.simps] have "i < Least p" .
  from not_less_Least[OF this] show ?thesis .
qed

end

subsection {* Assembling Infinite Words from Finite Words *}

text {*Concatenate infinitely many non-empty words to an infinite word.*}

fun inf_concat_simple :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat)" where
  "inf_concat_simple f 0 = (0, 0)"
| "inf_concat_simple f (Suc n) = (
    let (i, j) = inf_concat_simple f n in
    if Suc j < f i then (i, Suc j)
    else (Suc i, 0))"

lemma inf_concat_simple_add:
  assumes ck: "inf_concat_simple f k = (i, j)"
    and jl: "j + l < f i"
  shows "inf_concat_simple f (k + l) = (i,j + l)"
using jl
proof (induct l)
  case 0
  thus ?case using ck by simp
next
  case (Suc l)
  hence c: "inf_concat_simple f (k + l) = (i, j+ l)" by auto
  show ?case
    by (simp add: c, insert Suc(2), auto)
qed

lemma inf_concat_simple_surj_zero: "\<exists> k. inf_concat_simple f k = (i,0)"
proof (induct i)
  case 0
  show ?case
    by (rule exI[of _ 0], simp)
next
  case (Suc i)
  then obtain k where ck: "inf_concat_simple f k = (i,0)" by auto
  show ?case
  proof (cases "f i")
    case 0
    show ?thesis
      by (rule exI[of _ "Suc k"], simp add: ck 0)
  next
    case (Suc n)
    hence "0 + n < f i" by auto
    from inf_concat_simple_add[OF ck, OF this] Suc
    show ?thesis
      by (intro exI[of _ "k + Suc n"], auto)
  qed
qed

lemma inf_concat_simple_mono:
  assumes "k \<le> k'" shows "fst (inf_concat_simple f k) \<le> fst (inf_concat_simple f k')"
proof -
  from assms have "k' = k + (k' - k)" by auto
  then obtain l where k': "k' = k + l" by auto
  show ?thesis  unfolding k'
  proof (induct l)
    case (Suc l)
    obtain i j where ckl: "inf_concat_simple f (k+l) = (i,j)" by (cases "inf_concat_simple f (k+l)", auto)
    with Suc have "fst (inf_concat_simple f k) \<le> i" by auto
    also have "... \<le> fst (inf_concat_simple f (k + Suc l))"
      by (simp add: ckl)
    finally show ?case .
  qed simp
qed

(* inf_concat assembles infinitely many (possibly empty) words to an infinite word *)
fun inf_concat :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "inf_concat n 0 = (LEAST j. n j > 0, 0)"
| "inf_concat n (Suc k) = (let (i, j) = inf_concat n k in (if Suc j < n i then (i, Suc j) else (LEAST i'. i' > i \<and> n i' > 0, 0)))"

lemma inf_concat_bounds:
  assumes inf: "INFM i. n i > 0"
    and res: "inf_concat n k = (i,j)"
  shows "j < n i"
proof (cases k)
  case 0
  with res have i: "i = (LEAST i. n i > 0)" and j: "j = 0" by auto
  from inf[unfolded INFM_nat_le] obtain i' where i': "0 < n i'" by auto
  have "0 < n (LEAST i. n i > 0)"
    by (rule LeastI, rule i')
  with i j show ?thesis by auto
next
  case (Suc k')
  obtain i' j' where res': "inf_concat n k' = (i',j')" by force
  note res = res[unfolded Suc inf_concat.simps res' Let_def split]
  show ?thesis
  proof (cases "Suc j' < n i'")
    case True
    with res show ?thesis by auto
  next
    case False
    with res have i: "i = (LEAST f. i' < f \<and> 0 < n f)" and j: "j = 0" by auto
    from inf[unfolded INFM_nat] obtain f where f: "i' < f \<and> 0 < n f" by auto
    have "0 < n (LEAST f. i' < f \<and> 0 < n f)"
      using LeastI[of "\<lambda> f. i' < f \<and> 0 < n f", OF f]
      by auto
    with i j show ?thesis by auto
  qed
qed

lemma inf_concat_add:
  assumes res: "inf_concat n k = (i,j)"
    and j: "j + m < n i"
  shows "inf_concat n (k + m) = (i,j+m)"
  using j
proof (induct m)
  case 0 show ?case using res by auto
next
  case (Suc m)
  hence "inf_concat n (k + m) = (i, j+m)" by auto
  with Suc(2)
  show ?case by auto
qed

lemma inf_concat_step:
  assumes res: "inf_concat n k = (i,j)"
    and j: "Suc (j + m) = n i"
  shows "inf_concat n (k + Suc m) = (LEAST i'. i' > i \<and> 0 < n i', 0)"
proof -
  from j have "j + m < n i" by auto
  note res = inf_concat_add[OF res, OF this]
  show ?thesis by (simp add: res j)
qed

lemma inf_concat_surj_zero:
  assumes "0 < n i"
  shows "\<exists>k. inf_concat n k = (i, 0)"
proof -
  {
    fix l
    have "\<forall> j. j < l \<and> 0 < n j \<longrightarrow> (\<exists> k. inf_concat n k = (j,0))"
    proof (induct l)
      case 0
      thus ?case by auto
    next
      case (Suc l)
      show ?case
      proof (intro allI impI, elim conjE)
        fix j
        assume j: "j < Suc l" and nj: "0 < n j"
        show "\<exists> k. inf_concat n k = (j, 0)"
        proof (cases "j < l")
          case True
          from Suc[THEN spec[of _ j]] True nj show ?thesis by auto
        next
          case False
          with j have j: "j = l" by auto
          show ?thesis
          proof (cases "\<exists> j'. j' < l \<and> 0 < n j'")
            case False
            have l: "(LEAST i. 0 < n i) = l"
            proof (rule Least_equality, rule nj[unfolded j])
              fix l'
              assume "0 < n l'"
              with False have "\<not> l' < l" by auto
              thus "l \<le> l'" by auto
            qed
            show ?thesis
              by (rule exI[of _ 0], simp add: l j)
          next
            case True
            then obtain lll where lll: "lll < l" and nlll: "0 < n lll" by auto
            then obtain ll where l: "l = Suc ll" by (cases l, auto)
            from lll l have lll: "lll = ll - (ll - lll)" by auto
            let ?l' = "LEAST d. 0 < n (ll - d)"
            have nl': "0 < n (ll - ?l')"
            proof (rule LeastI)
              show "0 < n (ll - (ll - lll))" using lll nlll by auto
            qed
            with Suc[THEN spec[of _ "ll - ?l'"]] obtain k where k:
              "inf_concat n k = (ll - ?l',0)" unfolding l by auto
            from nl' obtain off where off: "Suc (0 + off) = n (ll - ?l')" by (cases "n (ll - ?l')", auto)
            from inf_concat_step[OF k, OF off]
            have id: "inf_concat n (k + Suc off) = (LEAST i'. ll - ?l' < i' \<and> 0 < n i',0)" (is "_ = (?l,0)") .
            have ll: "?l = l" unfolding l
            proof (rule Least_equality)
              show "ll - ?l' < Suc ll \<and> 0 < n (Suc ll)" using nj[unfolded j l] by simp
            next
              fix l'
              assume ass: "ll - ?l' < l' \<and> 0 < n l'"
              show "Suc ll \<le> l'"
              proof (rule ccontr)
                assume not: "\<not> ?thesis"
                hence "l' \<le> ll" by auto
                hence "ll = l' + (ll - l')" by auto
                then obtain k where ll: "ll = l' + k" by auto
                from ass have "l' + k - ?l' < l'" unfolding ll by auto
                hence kl': "k < ?l'" by auto
                have "0 < n (ll - k)" using ass unfolding ll by simp
                from Least_le[of "\<lambda> k. 0 < n (ll - k)", OF this] kl'
                show False by auto
              qed
            qed
            show ?thesis unfolding j
              by (rule exI[of _ "k + Suc off"], unfold id ll, simp)
          qed
        qed
      qed
    qed
  }
  with assms show ?thesis by auto
qed

lemma inf_concat_surj:
  assumes j: "j < n i"
  shows "\<exists>k. inf_concat n k = (i, j)"
proof -
  from j have "0 < n i" by auto
  from inf_concat_surj_zero[of n, OF this]
  obtain k where "inf_concat n k = (i,0)" by auto
  from inf_concat_add[OF this, of j] j
  show ?thesis by auto
qed

lemma inf_concat_mono:
  assumes inf: "INFM i. n i > 0"
    and resk: "inf_concat n k = (i, j)"
    and reskp: "inf_concat n k' = (i', j')"
    and lt: "i < i'"
  shows "k < k'"
proof -
  note bounds = inf_concat_bounds[OF inf]
  {
    assume "k' \<le> k"
    hence "k = k' + (k - k')" by auto
    then obtain l where k: "k = k' + l" by auto
    have "i' \<le> fst (inf_concat n (k' + l))"
    proof (induct l)
      case 0
      with reskp show ?case by auto
    next
      case (Suc l)
      obtain i'' j'' where l: "inf_concat n (k' + l) = (i'',j'')" by force
      with Suc have one: "i' \<le> i''" by auto
      from bounds[OF l] have j'': "j'' < n i''" by auto
      show ?case
      proof (cases "Suc j'' < n i''")
        case True
        show ?thesis by (simp add: l True one)
      next
        case False
        let ?i = "LEAST i'. i'' < i' \<and> 0 < n i'"
        from inf[unfolded INFM_nat] obtain k where "i'' < k \<and> 0 < n k" by auto
        from LeastI[of "\<lambda> k. i'' < k \<and> 0 < n k", OF this]
        have "i'' < ?i" by auto
        with one show ?thesis by (simp add: l False)
      qed
    qed
    with resk k lt have False by auto
  }
  thus ?thesis by arith
qed

lemma inf_concat_Suc:
  assumes inf: "INFM i. n i > 0"
    and f: "\<And> i. f i (n i) = f (Suc i) 0"
    and resk: "inf_concat n k = (i, j)"
    and ressk: "inf_concat n (Suc k) = (i', j')"
  shows "f i' j' = f i (Suc j)"
proof -
  note bounds = inf_concat_bounds[OF inf]
  from bounds[OF resk] have j: "j < n i" .
  show ?thesis
  proof (cases "Suc j < n i")
    case True
    with ressk resk
    show ?thesis by simp
  next
    case False
    let ?p = "\<lambda> i'. i < i' \<and> 0 < n i'"
    let ?i' = "LEAST i'. ?p i'"
    from False j have id: "Suc (j + 0) = n i" by auto
    from inf_concat_step[OF resk, OF id] ressk
    have i': "i' = ?i'" and j': "j' = 0" by auto
    from id have j: "Suc j = n i" by simp
    from inf[unfolded INFM_nat] obtain k where "?p k" by auto
    from LeastI[of ?p, OF this] have "?p ?i'" .
    hence "?i' = Suc i + (?i' - Suc i)" by simp
    then obtain d where ii': "?i' = Suc i + d" by auto
    from not_less_Least[of _ ?p, unfolded ii'] have d': "\<And> d'. d' < d \<Longrightarrow> n (Suc i + d') = 0" by auto
    have "f (Suc i) 0 = f ?i' 0" unfolding ii' using d'
    proof (induct d)
      case 0
      show ?case by simp
    next
      case (Suc d)
      hence "f (Suc i) 0 = f (Suc i + d) 0" by auto
      also have "... = f (Suc (Suc i + d)) 0"
        unfolding f[symmetric]
        using Suc(2)[of d] by simp
      finally show ?case by simp
    qed
    thus ?thesis unfolding i' j' j f by simp
  qed
qed

end


(*  Title:      ZF/ex/Primes.thy
    Author:     Christophe Tabacznyj and Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section\<open>The Divides Relation and Euclid's algorithm for the GCD\<close>

theory Primes imports ZF begin

definition
  divides :: "[i,i]=>o"              (infixl "dvd" 50)  where
    "m dvd n == m \<in> nat & n \<in> nat & (\<exists>k \<in> nat. n = m#*k)"

definition
  is_gcd  :: "[i,i,i]=>o"     \<comment>\<open>definition of great common divisor\<close>  where
    "is_gcd(p,m,n) == ((p dvd m) & (p dvd n))   &
                       (\<forall>d\<in>nat. (d dvd m) & (d dvd n) \<longrightarrow> d dvd p)"

definition
  gcd     :: "[i,i]=>i"       \<comment>\<open>Euclid's algorithm for the gcd\<close>  where
    "gcd(m,n) == transrec(natify(n),
                        %n f. \<lambda>m \<in> nat.
                                if n=0 then m else f`(m mod n)`n) ` natify(m)"

definition
  coprime :: "[i,i]=>o"       \<comment>\<open>the coprime relation\<close>  where
    "coprime(m,n) == gcd(m,n) = 1"

definition
  prime   :: i                \<comment>\<open>the set of prime numbers\<close>  where
   "prime == {p \<in> nat. 1<p & (\<forall>m \<in> nat. m dvd p \<longrightarrow> m=1 | m=p)}"

subsection\<open>The Divides Relation\<close>

lemma dvdD: "m dvd n ==> m \<in> nat & n \<in> nat & (\<exists>k \<in> nat. n = m#*k)"
by (unfold divides_def, assumption)

lemma dvdE:
     "[|m dvd n;  !!k. [|m \<in> nat; n \<in> nat; k \<in> nat; n = m#*k|] ==> P|] ==> P"
by (blast dest!: dvdD)

lemmas dvd_imp_nat1 = dvdD [THEN conjunct1]
lemmas dvd_imp_nat2 = dvdD [THEN conjunct2, THEN conjunct1]

lemma dvd_0_right [simp]: "m \<in> nat ==> m dvd 0"
apply (simp add: divides_def)
apply (fast intro: nat_0I mult_0_right [symmetric])
done

lemma dvd_0_left: "0 dvd m ==> m = 0"
by (simp add: divides_def)

lemma dvd_refl [simp]: "m \<in> nat ==> m dvd m"
apply (simp add: divides_def)
apply (fast intro: nat_1I mult_1_right [symmetric])
done

lemma dvd_trans: "[| m dvd n; n dvd p |] ==> m dvd p"
by (auto simp add: divides_def intro: mult_assoc mult_type)

lemma dvd_anti_sym: "[| m dvd n; n dvd m |] ==> m=n"
apply (simp add: divides_def)
apply (force dest: mult_eq_self_implies_10
             simp add: mult_assoc mult_eq_1_iff)
done

lemma dvd_mult_left: "[|(i#*j) dvd k; i \<in> nat|] ==> i dvd k"
by (auto simp add: divides_def mult_assoc)

lemma dvd_mult_right: "[|(i#*j) dvd k; j \<in> nat|] ==> j dvd k"
apply (simp add: divides_def, clarify)
apply (rule_tac x = "i#*ka" in bexI)
apply (simp add: mult_ac)
apply (rule mult_type)
done

subsection\<open>Euclid's Algorithm for the GCD\<close>

lemma gcd_0 [simp]: "gcd(m,0) = natify(m)"
apply (simp add: gcd_def)
apply (subst transrec, simp)
done

lemma gcd_natify1 [simp]: "gcd(natify(m),n) = gcd(m,n)"
by (simp add: gcd_def)

lemma gcd_natify2 [simp]: "gcd(m, natify(n)) = gcd(m,n)"
by (simp add: gcd_def)

lemma gcd_non_0_raw:
    "[| 0<n;  n \<in> nat |] ==> gcd(m,n) = gcd(n, m mod n)"
apply (simp add: gcd_def)
apply (rule_tac P = "%z. left (z) = right" for left right in transrec [THEN ssubst])
apply (simp add: ltD [THEN mem_imp_not_eq, THEN not_sym]
                 mod_less_divisor [THEN ltD])
done

lemma gcd_non_0: "0 < natify(n) ==> gcd(m,n) = gcd(n, m mod n)"
apply (cut_tac m = m and n = "natify (n) " in gcd_non_0_raw)
apply auto
done

lemma gcd_1 [simp]: "gcd(m,1) = 1"
by (simp (no_asm_simp) add: gcd_non_0)

lemma dvd_add: "[| k dvd a; k dvd b |] ==> k dvd (a #+ b)"
apply (simp add: divides_def)
apply (fast intro: add_mult_distrib_left [symmetric] add_type)
done

lemma dvd_mult: "k dvd n ==> k dvd (m #* n)"
apply (simp add: divides_def)
apply (fast intro: mult_left_commute mult_type)
done

lemma dvd_mult2: "k dvd m ==> k dvd (m #* n)"
apply (subst mult_commute)
apply (blast intro: dvd_mult)
done

(* k dvd (m*k) *)
lemmas dvdI1 [simp] = dvd_refl [THEN dvd_mult]
lemmas dvdI2 [simp] = dvd_refl [THEN dvd_mult2]

lemma dvd_mod_imp_dvd_raw:
     "[| a \<in> nat; b \<in> nat; k dvd b; k dvd (a mod b) |] ==> k dvd a"
apply (case_tac "b=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (blast intro: mod_div_equality [THEN subst]
             elim: dvdE
             intro!: dvd_add dvd_mult mult_type mod_type div_type)
done

lemma dvd_mod_imp_dvd: "[| k dvd (a mod b); k dvd b; a \<in> nat |] ==> k dvd a"
apply (cut_tac b = "natify (b)" in dvd_mod_imp_dvd_raw)
apply auto
apply (simp add: divides_def)
done

(*Imitating TFL*)
lemma gcd_induct_lemma [rule_format (no_asm)]: "[| n \<in> nat;
         \<forall>m \<in> nat. P(m,0);
         \<forall>m \<in> nat. \<forall>n \<in> nat. 0<n \<longrightarrow> P(n, m mod n) \<longrightarrow> P(m,n) |]
      ==> \<forall>m \<in> nat. P (m,n)"
apply (erule_tac i = n in complete_induct)
apply (case_tac "x=0")
apply (simp (no_asm_simp))
apply clarify
apply (drule_tac x1 = m and x = x in bspec [THEN bspec])
apply (simp_all add: Ord_0_lt_iff)
apply (blast intro: mod_less_divisor [THEN ltD])
done

lemma gcd_induct: "!!P. [| m \<in> nat; n \<in> nat;
         !!m. m \<in> nat ==> P(m,0);
         !!m n. [|m \<in> nat; n \<in> nat; 0<n; P(n, m mod n)|] ==> P(m,n) |]
      ==> P (m,n)"
by (blast intro: gcd_induct_lemma)

subsection\<open>Basic Properties of @{term gcd}\<close>

text\<open>type of gcd\<close>
lemma gcd_type [simp,TC]: "gcd(m, n) \<in> nat"
apply (subgoal_tac "gcd (natify (m), natify (n)) \<in> nat")
apply simp
apply (rule_tac m = "natify (m)" and n = "natify (n)" in gcd_induct)
apply auto
apply (simp add: gcd_non_0)
done

text\<open>Property 1: gcd(a,b) divides a and b\<close>

lemma gcd_dvd_both:
     "[| m \<in> nat; n \<in> nat |] ==> gcd (m, n) dvd m & gcd (m, n) dvd n"
apply (rule_tac m = m and n = n in gcd_induct)
apply (simp_all add: gcd_non_0)
apply (blast intro: dvd_mod_imp_dvd_raw nat_into_Ord [THEN Ord_0_lt])
done

lemma gcd_dvd1 [simp]: "m \<in> nat ==> gcd(m,n) dvd m"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_dvd_both)
apply auto
done

lemma gcd_dvd2 [simp]: "n \<in> nat ==> gcd(m,n) dvd n"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_dvd_both)
apply auto
done

text\<open>if f divides a and b then f divides gcd(a,b)\<close>

lemma dvd_mod: "[| f dvd a; f dvd b |] ==> f dvd (a mod b)"
apply (simp add: divides_def)
apply (case_tac "b=0")
 apply (simp add: DIVISION_BY_ZERO_MOD, auto)
apply (blast intro: mod_mult_distrib2 [symmetric])
done

text\<open>Property 2: for all a,b,f naturals,
               if f divides a and f divides b then f divides gcd(a,b)\<close>

lemma gcd_greatest_raw [rule_format]:
     "[| m \<in> nat; n \<in> nat; f \<in> nat |]
      ==> (f dvd m) \<longrightarrow> (f dvd n) \<longrightarrow> f dvd gcd(m,n)"
apply (rule_tac m = m and n = n in gcd_induct)
apply (simp_all add: gcd_non_0 dvd_mod)
done

lemma gcd_greatest: "[| f dvd m;  f dvd n;  f \<in> nat |] ==> f dvd gcd(m,n)"
apply (rule gcd_greatest_raw)
apply (auto simp add: divides_def)
done

lemma gcd_greatest_iff [simp]: "[| k \<in> nat; m \<in> nat; n \<in> nat |]
      ==> (k dvd gcd (m, n)) \<longleftrightarrow> (k dvd m & k dvd n)"
by (blast intro!: gcd_greatest gcd_dvd1 gcd_dvd2 intro: dvd_trans)

subsection\<open>The Greatest Common Divisor\<close>

text\<open>The GCD exists and function gcd computes it.\<close>

lemma is_gcd: "[| m \<in> nat; n \<in> nat |] ==> is_gcd(gcd(m,n), m, n)"
by (simp add: is_gcd_def)

text\<open>The GCD is unique\<close>

lemma is_gcd_unique: "[|is_gcd(m,a,b); is_gcd(n,a,b); m\<in>nat; n\<in>nat|] ==> m=n"
apply (simp add: is_gcd_def)
apply (blast intro: dvd_anti_sym)
done

lemma is_gcd_commute: "is_gcd(k,m,n) \<longleftrightarrow> is_gcd(k,n,m)"
by (simp add: is_gcd_def, blast)

lemma gcd_commute_raw: "[| m \<in> nat; n \<in> nat |] ==> gcd(m,n) = gcd(n,m)"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (rule_tac [3] is_gcd_commute [THEN iffD1])
apply (rule_tac [3] is_gcd, auto)
done

lemma gcd_commute: "gcd(m,n) = gcd(n,m)"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_commute_raw)
apply auto
done

lemma gcd_assoc_raw: "[| k \<in> nat; m \<in> nat; n \<in> nat |]
      ==> gcd (gcd (k, m), n) = gcd (k, gcd (m, n))"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (simp_all add: is_gcd_def)
apply (blast intro: gcd_dvd1 gcd_dvd2 gcd_type intro: dvd_trans)
done

lemma gcd_assoc: "gcd (gcd (k, m), n) = gcd (k, gcd (m, n))"
apply (cut_tac k = "natify (k)" and m = "natify (m)" and n = "natify (n) "
       in gcd_assoc_raw)
apply auto
done

lemma gcd_0_left [simp]: "gcd (0, m) = natify(m)"
by (simp add: gcd_commute [of 0])

lemma gcd_1_left [simp]: "gcd (1, m) = 1"
by (simp add: gcd_commute [of 1])

subsection\<open>Addition laws\<close>

lemma gcd_add1 [simp]: "gcd (m #+ n, n) = gcd (m, n)"
apply (subgoal_tac "gcd (m #+ natify (n), natify (n)) = gcd (m, natify (n))")
apply simp
apply (case_tac "natify (n) = 0")
apply (auto simp add: Ord_0_lt_iff gcd_non_0)
done

lemma gcd_add2 [simp]: "gcd (m, m #+ n) = gcd (m, n)"
apply (rule gcd_commute [THEN trans])
apply (subst add_commute, simp)
apply (rule gcd_commute)
done

lemma gcd_add2' [simp]: "gcd (m, n #+ m) = gcd (m, n)"
by (subst add_commute, rule gcd_add2)

lemma gcd_add_mult_raw: "k \<in> nat ==> gcd (m, k #* m #+ n) = gcd (m, n)"
apply (erule nat_induct)
apply (auto simp add: gcd_add2 add_assoc)
done

lemma gcd_add_mult: "gcd (m, k #* m #+ n) = gcd (m, n)"
apply (cut_tac k = "natify (k)" in gcd_add_mult_raw)
apply auto
done

subsection\<open>Multiplication Laws\<close>

lemma gcd_mult_distrib2_raw:
     "[| k \<in> nat; m \<in> nat; n \<in> nat |]
      ==> k #* gcd (m, n) = gcd (k #* m, k #* n)"
apply (erule_tac m = m and n = n in gcd_induct, assumption)
apply simp
apply (case_tac "k = 0", simp)
apply (simp add: mod_geq gcd_non_0 mod_mult_distrib2 Ord_0_lt_iff)
done

lemma gcd_mult_distrib2: "k #* gcd (m, n) = gcd (k #* m, k #* n)"
apply (cut_tac k = "natify (k)" and m = "natify (m)" and n = "natify (n) "
       in gcd_mult_distrib2_raw)
apply auto
done

lemma gcd_mult [simp]: "gcd (k, k #* n) = natify(k)"
by (cut_tac k = k and m = 1 and n = n in gcd_mult_distrib2, auto)

lemma gcd_self [simp]: "gcd (k, k) = natify(k)"
by (cut_tac k = k and n = 1 in gcd_mult, auto)

lemma relprime_dvd_mult:
     "[| gcd (k,n) = 1;  k dvd (m #* n);  m \<in> nat |] ==> k dvd m"
apply (cut_tac k = m and m = k and n = n in gcd_mult_distrib2, auto)
apply (erule_tac b = m in ssubst)
apply (simp add: dvd_imp_nat1)
done

lemma relprime_dvd_mult_iff:
     "[| gcd (k,n) = 1;  m \<in> nat |] ==> k dvd (m #* n) \<longleftrightarrow> k dvd m"
by (blast intro: dvdI2 relprime_dvd_mult dvd_trans)

lemma prime_imp_relprime:
     "[| p \<in> prime;  ~ (p dvd n);  n \<in> nat |] ==> gcd (p, n) = 1"
apply (simp add: prime_def, clarify)
apply (drule_tac x = "gcd (p,n)" in bspec)
apply auto
apply (cut_tac m = p and n = n in gcd_dvd2, auto)
done

lemma prime_into_nat: "p \<in> prime ==> p \<in> nat"
by (simp add: prime_def)

lemma prime_nonzero: "p \<in> prime \<Longrightarrow> p\<noteq>0"
by (auto simp add: prime_def)

text\<open>This theorem leads immediately to a proof of the uniqueness of
  factorization.  If @{term p} divides a product of primes then it is
  one of those primes.\<close>

lemma prime_dvd_mult:
     "[|p dvd m #* n; p \<in> prime; m \<in> nat; n \<in> nat |] ==> p dvd m \<or> p dvd n"
by (blast intro: relprime_dvd_mult prime_imp_relprime prime_into_nat)

lemma gcd_mult_cancel_raw:
     "[|gcd (k,n) = 1; m \<in> nat; n \<in> nat|] ==> gcd (k #* m, n) = gcd (m, n)"
apply (rule dvd_anti_sym)
 apply (rule gcd_greatest)
  apply (rule relprime_dvd_mult [of _ k])
apply (simp add: gcd_assoc)
apply (simp add: gcd_commute)
apply (simp_all add: mult_commute)
apply (blast intro: dvdI1 gcd_dvd1 dvd_trans)
done

lemma gcd_mult_cancel: "gcd (k,n) = 1 ==> gcd (k #* m, n) = gcd (m, n)"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_mult_cancel_raw)
apply auto
done

subsection\<open>The Square Root of a Prime is Irrational: Key Lemma\<close>

lemma prime_dvd_other_side:
     "\<lbrakk>n#*n = p#*(k#*k); p \<in> prime; n \<in> nat\<rbrakk> \<Longrightarrow> p dvd n"
apply (subgoal_tac "p dvd n#*n")
 apply (blast dest: prime_dvd_mult)
apply (rule_tac j = "k#*k" in dvd_mult_left)
 apply (auto simp add: prime_def)
done

lemma reduction:
     "\<lbrakk>k#*k = p#*(j#*j); p \<in> prime; 0 < k; j \<in> nat; k \<in> nat\<rbrakk>
      \<Longrightarrow> k < p#*j & 0 < j"
apply (rule ccontr)
apply (simp add: not_lt_iff_le prime_into_nat)
apply (erule disjE)
 apply (frule mult_le_mono, assumption+)
apply (simp add: mult_ac)
apply (auto dest!: natify_eqE
            simp add: not_lt_iff_le prime_into_nat mult_le_cancel_le1)
apply (simp add: prime_def)
apply (blast dest: lt_trans1)
done

lemma rearrange: "j #* (p#*j) = k#*k \<Longrightarrow> k#*k = p#*(j#*j)"
by (simp add: mult_ac)

lemma prime_not_square:
     "\<lbrakk>m \<in> nat; p \<in> prime\<rbrakk> \<Longrightarrow> \<forall>k \<in> nat. 0<k \<longrightarrow> m#*m \<noteq> p#*(k#*k)"
apply (erule complete_induct, clarify)
apply (frule prime_dvd_other_side, assumption)
apply assumption
apply (erule dvdE)
apply (simp add: mult_assoc mult_cancel1 prime_nonzero prime_into_nat)
apply (blast dest: rearrange reduction ltD)
done

end