(*  Title:      HOL/ex/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge
*)

section \<open>Ackermann's Function and the Primitive Recursive Functions\<close>

theory Primrec imports MainRLT begin

text \<open>
  Proof adopted from

  Nora Szasz, A Machine Checked Proof that Ackermann's Function is not
  Primitive Recursive, In: Huet \& Plotkin, eds., Logical Environments
  (CUP, 1993), 317-338.

  See also E. Mendelson, Introduction to Mathematical Logic.  (Van
  Nostrand, 1964), page 250, exercise 11.
  \medskip
\<close>

subsection\<open>Ackermann's Function\<close>

fun ack :: "[nat,nat] \<Rightarrow> nat" where
  "ack 0 n =  Suc n"
| "ack (Suc m) 0 = ack m 1"
| "ack (Suc m) (Suc n) = ack m (ack (Suc m) n)"

text \<open>PROPERTY A 4\<close>

lemma less_ack2 [iff]: "j < ack i j"
  by (induct i j rule: ack.induct) simp_all

text \<open>PROPERTY A 5-, the single-step lemma\<close>

lemma ack_less_ack_Suc2 [iff]: "ack i j < ack i (Suc j)"
  by (induct i j rule: ack.induct) simp_all

text \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>

lemma ack_less_mono2: "j < k \<Longrightarrow> ack i j < ack i k"
  by (simp add: lift_Suc_mono_less)

text \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>

lemma ack_le_mono2: "j \<le> k \<Longrightarrow> ack i j \<le> ack i k"
  by (simp add: ack_less_mono2 less_mono_imp_le_mono)

text \<open>PROPERTY A 6\<close>

lemma ack2_le_ack1 [iff]: "ack i (Suc j) \<le> ack (Suc i) j"
proof (induct j)
  case 0 show ?case by simp
next
  case (Suc j) show ?case
    by (metis Suc ack.simps(3) ack_le_mono2 le_trans less_ack2 less_eq_Suc_le)
qed

text \<open>PROPERTY A 7-, the single-step lemma\<close>

lemma ack_less_ack_Suc1 [iff]: "ack i j < ack (Suc i) j"
  by (blast intro: ack_less_mono2 less_le_trans)

text \<open>PROPERTY A 4'? Extra lemma needed for \<^term>\<open>CONSTANT\<close> case, constant functions\<close>

lemma less_ack1 [iff]: "i < ack i j"
proof (induct i)
  case 0
  then show ?case
    by simp
next
  case (Suc i)
  then show ?case
    using less_trans_Suc by blast
qed

text \<open>PROPERTY A 8\<close>

lemma ack_1 [simp]: "ack (Suc 0) j = j + 2"
  by (induct j) simp_all

text \<open>PROPERTY A 9.  The unary \<open>1\<close> and \<open>2\<close> in \<^term>\<open>ack\<close> is essential for the rewriting.\<close>

lemma ack_2 [simp]: "ack (Suc (Suc 0)) j = 2 * j + 3"
  by (induct j) simp_all

text \<open>PROPERTY A 7, monotonicity for \<open><\<close> [not clear why
  @{thm [source] ack_1} is now needed first!]\<close>

lemma ack_less_mono1_aux: "ack i k < ack (Suc (i +i')) k"
proof (induct i k rule: ack.induct)
  case (1 n) show ?case
    using less_le_trans by auto
next
  case (2 m) thus ?case by simp
next
  case (3 m n) thus ?case
    using ack_less_mono2 less_trans by fastforce
qed

lemma ack_less_mono1: "i < j \<Longrightarrow> ack i k < ack j k"
  using ack_less_mono1_aux less_iff_Suc_add by auto

text \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>

lemma ack_le_mono1: "i \<le> j \<Longrightarrow> ack i k \<le> ack j k"
  using ack_less_mono1 le_eq_less_or_eq by auto

text \<open>PROPERTY A 10\<close>

lemma ack_nest_bound: "ack i1 (ack i2 j) < ack (2 + (i1 + i2)) j"
proof -
  have "ack i1 (ack i2 j) < ack (i1 + i2) (ack (Suc (i1 + i2)) j)"
    by (meson ack_le_mono1 ack_less_mono1 ack_less_mono2 le_add1 le_trans less_add_Suc2 not_less)
  also have "... = ack (Suc (i1 + i2)) (Suc j)"
    by simp
  also have "... \<le> ack (2 + (i1 + i2)) j"
    using ack2_le_ack1 add_2_eq_Suc by presburger
  finally show ?thesis .
qed

text \<open>PROPERTY A 11\<close>

lemma ack_add_bound: "ack i1 j + ack i2 j < ack (4 + (i1 + i2)) j"
proof -
  have "ack i1 j \<le> ack (i1 + i2) j" "ack i2 j \<le> ack (i1 + i2) j"
    by (simp_all add: ack_le_mono1)
  then have "ack i1 j + ack i2 j < ack (Suc (Suc 0)) (ack (i1 + i2) j)"
    by simp
  also have "... < ack (4 + (i1 + i2)) j"
    by (metis ack_nest_bound add.assoc numeral_2_eq_2 numeral_Bit0)
  finally show ?thesis .
qed

text \<open>PROPERTY A 12.  Article uses existential quantifier but the ALF proof
  used \<open>k + 4\<close>.  Quantified version must be nested \<open>\<exists>k'. \<forall>i j. ...\<close>\<close>

lemma ack_add_bound2:
  assumes "i < ack k j" shows "i + j < ack (4 + k) j"
proof -
  have "i + j < ack k j + ack 0 j"
    using assms by auto
  also have "... < ack (4 + k) j"
    by (metis ack_add_bound add.right_neutral)
  finally show ?thesis .
qed

subsection\<open>Primitive Recursive Functions\<close>

primrec hd0 :: "nat list \<Rightarrow> nat" where
  "hd0 [] = 0"
| "hd0 (m # ms) = m"

text \<open>Inductive definition of the set of primitive recursive functions of type \<^typ>\<open>nat list \<Rightarrow> nat\<close>.\<close>

definition SC :: "nat list \<Rightarrow> nat"
  where "SC l = Suc (hd0 l)"

definition CONSTANT :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
  where "CONSTANT k l = k"

definition PROJ :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
  where "PROJ i l = hd0 (drop i l)"

definition COMP :: "[nat list \<Rightarrow> nat, (nat list \<Rightarrow> nat) list, nat list] \<Rightarrow> nat"
  where "COMP g fs l = g (map (\<lambda>f. f l) fs)"

fun PREC :: "[nat list \<Rightarrow> nat, nat list \<Rightarrow> nat, nat list] \<Rightarrow> nat"
  where
    "PREC f g [] = 0"
  | "PREC f g (x # l) = rec_nat (f l) (\<lambda>y r. g (r # y # l)) x"
    \<comment> \<open>Note that \<^term>\<open>g\<close> is applied first to \<^term>\<open>PREC f g y\<close> and then to \<^term>\<open>y\<close>!\<close>

inductive PRIMREC :: "(nat list \<Rightarrow> nat) \<Rightarrow> bool" where
  SC: "PRIMREC SC"
| CONSTANT: "PRIMREC (CONSTANT k)"
| PROJ: "PRIMREC (PROJ i)"
| COMP: "PRIMREC g \<Longrightarrow> \<forall>f \<in> set fs. PRIMREC f \<Longrightarrow> PRIMREC (COMP g fs)"
| PREC: "PRIMREC f \<Longrightarrow> PRIMREC g \<Longrightarrow> PRIMREC (PREC f g)"

text \<open>Useful special cases of evaluation\<close>

lemma SC [simp]: "SC (x # l) = Suc x"
  by (simp add: SC_def)

lemma PROJ_0 [simp]: "PROJ 0 (x # l) = x"
  by (simp add: PROJ_def)

lemma COMP_1 [simp]: "COMP g [f] l = g [f l]"
  by (simp add: COMP_def)

lemma PREC_0: "PREC f g (0 # l) = f l"
  by simp

lemma PREC_Suc [simp]: "PREC f g (Suc x # l) = g (PREC f g (x # l) # x # l)"
  by auto

subsection \<open>MAIN RESULT\<close>

lemma SC_case: "SC l < ack 1 (sum_list l)"
  unfolding SC_def
  by (induct l) (simp_all add: le_add1 le_imp_less_Suc)

lemma CONSTANT_case: "CONSTANT k l < ack k (sum_list l)"
  by (simp add: CONSTANT_def)

lemma PROJ_case: "PROJ i l < ack 0 (sum_list l)"
  unfolding PROJ_def
proof (induct l arbitrary: i)
  case Nil
  then show ?case
    by simp
next
  case (Cons a l)
  then show ?case
    by (metis ack.simps(1) add.commute drop_Cons' hd0.simps(2) leD leI lessI not_less_eq sum_list.Cons trans_le_add2)
qed

text \<open>\<^term>\<open>COMP\<close> case\<close>

lemma COMP_map_aux: "\<forall>f \<in> set fs. PRIMREC f \<and> (\<exists>kf. \<forall>l. f l < ack kf (sum_list l))
  \<Longrightarrow> \<exists>k. \<forall>l. sum_list (map (\<lambda>f. f l) fs) < ack k (sum_list l)"
proof (induct fs)
  case Nil
  then show ?case
    by auto
next
  case (Cons a fs)
  then show ?case
    by simp (blast intro: add_less_mono ack_add_bound less_trans)
qed

lemma COMP_case:
  assumes 1: "\<forall>l. g l < ack kg (sum_list l)"
      and 2: "\<forall>f \<in> set fs. PRIMREC f \<and> (\<exists>kf. \<forall>l. f l < ack kf (sum_list l))"
  shows "\<exists>k. \<forall>l. COMP g fs  l < ack k (sum_list l)"
  unfolding COMP_def
  using 1 COMP_map_aux [OF 2] by (meson ack_less_mono2 ack_nest_bound less_trans)

text \<open>\<^term>\<open>PREC\<close> case\<close>

lemma PREC_case_aux:
  assumes f: "\<And>l. f l + sum_list l < ack kf (sum_list l)"
      and g: "\<And>l. g l + sum_list l < ack kg (sum_list l)"
  shows "PREC f g l + sum_list l < ack (Suc (kf + kg)) (sum_list l)"
proof (cases l)
  case Nil
  then show ?thesis
    by (simp add: Suc_lessD)
next
  case (Cons m l)
  have "rec_nat (f l) (\<lambda>y r. g (r # y # l)) m + (m + sum_list l) < ack (Suc (kf + kg)) (m + sum_list l)"
  proof (induct m)
    case 0
    then show ?case
      using ack_less_mono1_aux f less_trans by fastforce
  next
    case (Suc m)
    let ?r = "rec_nat (f l) (\<lambda>y r. g (r # y # l)) m"
    have "\<not> g (?r # m # l) + sum_list (?r # m # l) < g (?r # m # l) + (m + sum_list l)"
      by force
    then have "g (?r # m # l) + (m + sum_list l) < ack kg (sum_list (?r # m # l))"
      by (meson assms(2) leI less_le_trans)
    moreover
    have "... < ack (kf + kg) (ack (Suc (kf + kg)) (m + sum_list l))"
      using Suc.hyps by simp (meson ack_le_mono1 ack_less_mono2 le_add2 le_less_trans)
    ultimately show ?case
      by auto
  qed
  then show ?thesis
    by (simp add: local.Cons)
qed

proposition PREC_case:
  "\<lbrakk>\<And>l. f l < ack kf (sum_list l); \<And>l. g l < ack kg (sum_list l)\<rbrakk>
  \<Longrightarrow> \<exists>k. \<forall>l. PREC f g l < ack k (sum_list l)"
  by (metis le_less_trans [OF le_add1 PREC_case_aux] ack_add_bound2)

lemma ack_bounds_PRIMREC: "PRIMREC f \<Longrightarrow> \<exists>k. \<forall>l. f l < ack k (sum_list l)"
  by (erule PRIMREC.induct) (blast intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)+

theorem ack_not_PRIMREC:
  "\<not> PRIMREC (\<lambda>l. case l of [] \<Rightarrow> 0 | x # l' \<Rightarrow> ack x x)"
proof
  assume *: "PRIMREC (\<lambda>l. case l of [] \<Rightarrow> 0 | x # l' \<Rightarrow> ack x x)"
  then obtain m where m: "\<And>l. (case l of [] \<Rightarrow> 0 | x # l' \<Rightarrow> ack x x) < ack m (sum_list l)"
    using ack_bounds_PRIMREC by metis
  show False
    using m [of "[m]"] by simp
qed

end


(* License: LGPL *)
(*
Author: Julian Parsert <julian.parsert@gmail.com>
Author: Cezary Kaliszyk
*)

theory Common
  imports
    "../Preferences"
    "../Utility_Functions"
    "../Argmax"
begin

section \<open> Pareto Ordering \<close>

text \<open> Allows us to define a Pareto Ordering. \<close>

locale pareto_ordering =
  fixes agents :: "'i set"
  fixes U :: "'i \<Rightarrow> 'a \<Rightarrow> real"
begin
notation U ("U[_]")

definition pareto_dominating (infix "\<succ>Pareto"  60)
  where
    "X \<succ>Pareto Y \<longleftrightarrow>
      (\<forall>i \<in> agents. U[i] (X i) \<ge> U[i] (Y i)) \<and>
      (\<exists>i \<in> agents. U[i] (X i) > U[i] (Y i))"

lemma trans_strict_pareto: "X \<succ>Pareto Y \<Longrightarrow> Y \<succ>Pareto Z \<Longrightarrow> X \<succ>Pareto Z"
proof -
  assume a1: "X \<succ>Pareto Y"
  assume "Y \<succ>Pareto Z"
  then have f3: "\<forall>i \<in> agents. U[i] (Z i) \<le> U[i] (X i)"
    by (meson a1 order_trans pareto_dominating_def)
  moreover have "\<exists>i \<in> agents. \<not> U[i] (X i) \<le> U[i] (Y i)"
    using a1 pareto_dominating_def by fastforce
  ultimately show ?thesis
    by (metis \<open>Y \<succ>Pareto Z\<close> less_eq_real_def pareto_dominating_def)
qed

lemma anti_sym_strict_pareto: "X \<succ>Pareto Y \<Longrightarrow> \<not>Y \<succ>Pareto X"
  using pareto_dominating_def by auto

end

subsection \<open> Budget constraint\<close>

text \<open> Definition returns all afforedable bundles given wealth W \<close>
text \<open> f is a function that computes the value given a bundle\<close>
definition budget_constraint
  where
    "budget_constraint f S W = {x \<in> S. f x \<le> W}"

subsection \<open> Feasiblity \<close>

definition feasible_private_ownership
  where
    "feasible_private_ownership A F \<E> Cs Ps X Y \<longleftrightarrow>
      (\<Sum>i\<in>A. X i) \<le> (\<Sum>i\<in>A. \<E> i) + (\<Sum>j\<in>F. Y j) \<and>
      (\<forall>i\<in>A. X i \<in> Cs) \<and> (\<forall>j\<in>F. Y j \<in> Ps j)"

lemma feasible_private_ownershipD:
  assumes "feasible_private_ownership A F \<E> Cs Ps X Y"
  shows "(\<Sum>i\<in>A. X i) \<le> (\<Sum>i\<in>A. \<E> i) + (\<Sum>j\<in>F. Y j)"
    and "(\<forall>i\<in>A. X i \<in> Cs)" and "(\<forall>j\<in>F. Y j \<in> Ps j)"
  using assms feasible_private_ownership_def apply blast
  by (meson assms feasible_private_ownership_def)
    (meson assms feasible_private_ownership_def)

end


(*  Title:      HOL/Isar_Examples/Group.thy
    Author:     Markus Wenzel, TU Muenchen
*)

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

theory Group
imports Main
begin

subsection \<open>Groups and calculational reasoning\<close>

text \<open>Groups over signature $({\times} :: \alpha \To \alpha \To
  \alpha, \idt{one} :: \alpha, \idt{inverse} :: \alpha \To \alpha)$
  are defined as an axiomatic type class as follows.  Note that the
  parent class $\idt{times}$ is provided by the basic HOL theory.\<close>

class group = times + one + inverse +
  assumes group_assoc: "(x * y) * z = x * (y * z)"
    and group_left_one: "1 * x = x"
    and group_left_inverse: "inverse x * x = 1"

text \<open>The group axioms only state the properties of left one and
  inverse, the right versions may be derived as follows.\<close>

theorem (in group) group_right_inverse: "x * inverse x = 1"
proof -
  have "x * inverse x = 1 * (x * inverse x)"
    by (simp only: group_left_one)
  also have "\<dots> = 1 * x * inverse x"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * inverse x * x * inverse x"
    by (simp only: group_left_inverse)
  also have "\<dots> = inverse (inverse x) * (inverse x * x) * inverse x"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * 1 * inverse x"
    by (simp only: group_left_inverse)
  also have "\<dots> = inverse (inverse x) * (1 * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * inverse x"
    by (simp only: group_left_one)
  also have "\<dots> = 1"
    by (simp only: group_left_inverse)
  finally show ?thesis .
qed

text \<open>With \name{group-right-inverse} already available,
  \name{group-right-one}\label{thm:group-right-one} is now established
  much easier.\<close>

theorem (in group) group_right_one: "x * 1 = x"
proof -
  have "x * 1 = x * (inverse x * x)"
    by (simp only: group_left_inverse)
  also have "\<dots> = x * inverse x * x"
    by (simp only: group_assoc)
  also have "\<dots> = 1 * x"
    by (simp only: group_right_inverse)
  also have "\<dots> = x"
    by (simp only: group_left_one)
  finally show ?thesis .
qed

text \<open>\medskip The calculational proof style above follows typical
  presentations given in any introductory course on algebra.  The
  basic technique is to form a transitive chain of equations, which in
  turn are established by simplifying with appropriate rules.  The
  low-level logical details of equational reasoning are left implicit.

  Note that ``$\dots$'' is just a special term variable that is bound
  automatically to the argument\footnote{The argument of a curried
  infix expression happens to be its right-hand side.} of the last
  fact achieved by any local assumption or proven statement.  In
  contrast to $\var{thesis}$, the ``$\dots$'' variable is bound
  \emph{after} the proof is finished, though.

  There are only two separate Isar language elements for calculational
  proofs: ``\isakeyword{also}'' for initial or intermediate
  calculational steps, and ``\isakeyword{finally}'' for exhibiting the
  result of a calculation.  These constructs are not hardwired into
  Isabelle/Isar, but defined on top of the basic Isar/VM interpreter.
  Expanding the \isakeyword{also} and \isakeyword{finally} derived
  language elements, calculations may be simulated by hand as
  demonstrated below.\<close>

theorem (in group) "x * 1 = x"
proof -
  have "x * 1 = x * (inverse x * x)"
    by (simp only: group_left_inverse)

  note calculation = this
    -- \<open>first calculational step: init calculation register\<close>

  have "\<dots> = x * inverse x * x"
    by (simp only: group_assoc)

  note calculation = trans [OF calculation this]
    -- \<open>general calculational step: compose with transitivity rule\<close>

  have "\<dots> = 1 * x"
    by (simp only: group_right_inverse)

  note calculation = trans [OF calculation this]
    -- \<open>general calculational step: compose with transitivity rule\<close>

  have "\<dots> = x"
    by (simp only: group_left_one)

  note calculation = trans [OF calculation this]
    -- \<open>final calculational step: compose with transitivity rule \dots\<close>
  from calculation
    -- \<open>\dots\ and pick up the final result\<close>

  show ?thesis .
qed

text \<open>Note that this scheme of calculations is not restricted to
  plain transitivity.  Rules like anti-symmetry, or even forward and
  backward substitution work as well.  For the actual implementation
  of \isacommand{also} and \isacommand{finally}, Isabelle/Isar
  maintains separate context information of ``transitivity'' rules.
  Rule selection takes place automatically by higher-order
  unification.\<close>

subsection \<open>Groups as monoids\<close>

text \<open>Monoids over signature $({\times} :: \alpha \To \alpha \To
  \alpha, \idt{one} :: \alpha)$ are defined like this.\<close>

class monoid = times + one +
  assumes monoid_assoc: "(x * y) * z = x * (y * z)"
    and monoid_left_one: "1 * x = x"
    and monoid_right_one: "x * 1 = x"

text \<open>Groups are \emph{not} yet monoids directly from the
  definition.  For monoids, \name{right-one} had to be included as an
  axiom, but for groups both \name{right-one} and \name{right-inverse}
  are derivable from the other axioms.  With \name{group-right-one}
  derived as a theorem of group theory (see
  page~\pageref{thm:group-right-one}), we may still instantiate
  $\idt{group} \subseteq \idt{monoid}$ properly as follows.\<close>

instance group < monoid
  by intro_classes
    (rule group_assoc,
      rule group_left_one,
      rule group_right_one)

text \<open>The \isacommand{instance} command actually is a version of
  \isacommand{theorem}, setting up a goal that reflects the intended
  class relation (or type constructor arity).  Thus any Isar proof
  language element may be involved to establish this statement.  When
  concluding the proof, the result is transformed into the intended
  type signature extension behind the scenes.\<close>

subsection \<open>More theorems of group theory\<close>

text \<open>The one element is already uniquely determined by preserving
  an \emph{arbitrary} group element.\<close>

theorem (in group) group_one_equality:
  assumes eq: "e * x = x"
  shows "1 = e"
proof -
  have "1 = x * inverse x"
    by (simp only: group_right_inverse)
  also have "\<dots> = (e * x) * inverse x"
    by (simp only: eq)
  also have "\<dots> = e * (x * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = e * 1"
    by (simp only: group_right_inverse)
  also have "\<dots> = e"
    by (simp only: group_right_one)
  finally show ?thesis .
qed

text \<open>Likewise, the inverse is already determined by the cancel property.\<close>

theorem (in group) group_inverse_equality:
  assumes eq: "x' * x = 1"
  shows "inverse x = x'"
proof -
  have "inverse x = 1 * inverse x"
    by (simp only: group_left_one)
  also have "\<dots> = (x' * x) * inverse x"
    by (simp only: eq)
  also have "\<dots> = x' * (x * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = x' * 1"
    by (simp only: group_right_inverse)
  also have "\<dots> = x'"
    by (simp only: group_right_one)
  finally show ?thesis .
qed

text \<open>The inverse operation has some further characteristic properties.\<close>

theorem (in group) group_inverse_times: "inverse (x * y) = inverse y * inverse x"
proof (rule group_inverse_equality)
  show "(inverse y * inverse x) * (x * y) = 1"
  proof -
    have "(inverse y * inverse x) * (x * y) =
        (inverse y * (inverse x * x)) * y"
      by (simp only: group_assoc)
    also have "\<dots> = (inverse y * 1) * y"
      by (simp only: group_left_inverse)
    also have "\<dots> = inverse y * y"
      by (simp only: group_right_one)
    also have "\<dots> = 1"
      by (simp only: group_left_inverse)
    finally show ?thesis .
  qed
qed

theorem (in group) inverse_inverse: "inverse (inverse x) = x"
proof (rule group_inverse_equality)
  show "x * inverse x = one"
    by (simp only: group_right_inverse)
qed

theorem (in group) inverse_inject:
  assumes eq: "inverse x = inverse y"
  shows "x = y"
proof -
  have "x = x * 1"
    by (simp only: group_right_one)
  also have "\<dots> = x * (inverse y * y)"
    by (simp only: group_left_inverse)
  also have "\<dots> = x * (inverse x * y)"
    by (simp only: eq)
  also have "\<dots> = (x * inverse x) * y"
    by (simp only: group_assoc)
  also have "\<dots> = 1 * y"
    by (simp only: group_right_inverse)
  also have "\<dots> = y"
    by (simp only: group_left_one)
  finally show ?thesis .
qed

end


header {* Solutions to Chapter 3 of "Concrete Semantics" *}

theory Chap_three imports Main begin

declare [[names_short]]

(* 3.1 *)

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N a) s = a" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N a) = N a" |
"asimp_const (V x) = V x" |
"asimp_const (Plus p q) =
 (case (asimp_const p, asimp_const q) of
  (N a, N b) \<Rightarrow> N (a+b) |
  (x, y) \<Rightarrow> Plus x y)"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N a) (N b) = N (a+b)" |
"plus p (N i) = (if i = 0 then p else Plus p (N i))" |
"plus (N i) p = (if i = 0 then p else Plus (N i) p)" |
"plus p q = (Plus p q)"

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N a) = N a" |
"asimp (V x) = V x" |
"asimp (Plus p q) = plus (asimp p) (asimp q)"

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N a) = True" |
"optimal (V x) = True" |
"optimal (Plus (N a) (N b)) = False" |
"optimal (Plus x y) = ((optimal x) \<and> (optimal y))"

theorem asimp_const_optimal: "optimal (asimp_const a)"
apply (induction a)
apply (auto split: aexp.split)
done

(* 3.2 *)

fun plus_ex :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus_ex (N a) (N b) = N (a+b)" |
"plus_ex (Plus p (N a)) (N b) = Plus p (N (a+b))" |
"plus_ex (N b) (Plus p (N a)) = Plus p (N (a+b))" |
"plus_ex (Plus p (N a)) q = Plus (Plus p q) (N a)" |
"plus_ex q (Plus p (N a)) = Plus (Plus p q) (N a)" |
"plus_ex p (N i) = (if i = 0 then p else Plus p (N i))" |
"plus_ex (N i) p = (if i = 0 then p else Plus p (N i))" |
"plus_ex p q = (Plus p q)"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N a) = N a" |
"full_asimp (V x) = V x" |
"full_asimp (Plus p q) = plus_ex (full_asimp p) (full_asimp q)"

value "full_asimp (Plus (Plus ((Plus (V ''x'') (N 7))) (V ''x'')) (N 5))"

lemma aval_plus_ex: "aval (plus_ex p q) s = aval p s + aval q s"
apply (induction rule:plus_ex.induct)
apply (auto)
done

theorem "aval (full_asimp p) s = aval p s"
apply (induction p)
apply (auto simp add:aval_plus_ex)
done

(* 3.3 *)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N k) = (N k)" |
"subst x a (V y) = (if x = y then a else (V y))" |
"subst x a (Plus p q) = Plus (subst x a p) (subst x a q)"

theorem aval_subst[simp]:  "aval (subst x a e) s = aval e (s(x:=aval a s))"
apply (induction e)
apply (auto)
done

theorem "aval a s = aval b s \<Longrightarrow> aval (subst x a e) s = aval (subst x b e) s"
apply (auto)
done

(* 3.4 *)

datatype aexpm = Nm int | Vm vname | Plusm aexpm aexpm | Timesm aexpm aexpm

fun avalm :: "aexpm \<Rightarrow> state \<Rightarrow> val" where
"avalm (Nm a) s = a" |
"avalm (Vm x) s = s x" |
"avalm (Plusm a b) s = avalm a s + avalm b s" |
"avalm (Timesm a b) s = avalm a s * avalm b s"

fun plusm :: "aexpm \<Rightarrow> aexpm \<Rightarrow> aexpm" where
"plusm (Nm a) (Nm b) = Nm (a+b)" |
"plusm p (Nm i) = (if i = 0 then p else Plusm p (Nm i))" |
"plusm (Nm i) p = (if i = 0 then p else Plusm (Nm i) p)" |
"plusm p q = (Plusm p q)"

fun timesm :: "aexpm \<Rightarrow> aexpm \<Rightarrow> aexpm" where
"timesm (Nm a) (Nm b) = Nm (a*b)" |
"timesm p (Nm i) = (if i = 0 then (Nm 0) else if i = 1 then p else Timesm p (Nm i))" |
"timesm (Nm i) p = (if i = 0 then (Nm 0) else if i = 1 then p else Timesm p (Nm i))" |
"timesm p q = (Timesm p q)"

fun asimpm :: "aexpm \<Rightarrow> aexpm" where
"asimpm (Nm a) = Nm a" |
"asimpm (Vm x) = Vm x" |
"asimpm (Plusm p q) = plusm (asimpm p) (asimpm q)" |
"asimpm (Timesm p q) = timesm (asimpm p) (asimpm q)"

lemma avalm_plus[simp]: "avalm (plusm p q) s = avalm p s + avalm q s"
apply (induction rule:plusm.induct)
apply (auto)
done

lemma avalm_times[simp]: "avalm (timesm p q) s = avalm p s * avalm q s"
apply (induction rule:timesm.induct)
apply (auto)
done

theorem "avalm (asimpm p) s = avalm p s"
apply (induction p)
apply (auto)
done

(*  3.5 *)

datatype aexp2 = N2 int | V2 vname | PlusPlus2 vname | Plus2 aexp2 aexp2 |
 Times2 aexp2 aexp2 | Div2 aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval2 (N2 a) s = Some (a, s)" |
"aval2 (V2 x) s = Some (s x, s)" |
"aval2 (PlusPlus2 x) s = Some (s x, s(x:= 1 + (s x)))" |
"aval2 (Plus2 a b) s =
 (case (aval2 a s, aval2 b s) of
  (None, Some q) \<Rightarrow> None |
  (Some p, None) \<Rightarrow> None |
  (Some p, Some q) \<Rightarrow> Some ((fst p + fst q), (\<lambda>x.((snd p) x) + ((snd q) x) - (s x))))" |
"aval2 (Times2 a b) s =
 (case (aval2 a s, aval2 b s) of
  (None, Some q) \<Rightarrow> None |
  (Some p, None) \<Rightarrow> None |
  (Some p, Some q) \<Rightarrow> Some ((fst p * fst q), (\<lambda>x.((snd p) x) + ((snd q) x) - (s x))))" |
"aval2 (Div2 a b) s =
 (case (aval2 a s, aval2 b s) of
  (None, Some q) \<Rightarrow> None |
  (Some p, None) \<Rightarrow> None |
  (Some p, Some q) \<Rightarrow>
   (if fst q = 0 then
    None
   else Some ((fst p div fst q), (\<lambda>x.((snd p) x) + ((snd q) x) - (s x)))))"

(* 3.6 *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl a) s = a" |
"lval (Vl x) s = s x" |
"lval (Plusl p q) s = lval p s + lval q s" |
"lval (LET x a e) s = lval e (s(x:=lval a s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl a) = (N a)" |
"inline (Vl x) = (V x)" |
"inline (Plusl p q) = Plus (inline p) (inline q)" |
"inline (LET x a e) = subst x (inline a) (inline e)"

theorem "aval (inline e) s = lval e s"
apply (induction e arbitrary:s)
apply (auto)
done

(* 3.7 *)

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And a b) s = (bval a s \<and> bval b s)" |
"bval (Less a b) s = (aval a s < aval b s)"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n) (N m) = Bc(n < m)" |
"less a b = Less a b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and a b = And a b"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And a b) = and (bsimp a) (bsimp b)" |
"bsimp (Less a b) = less (asimp a) (asimp b)"

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq p q = And (Not (Less p q)) (Not (Less q p))"

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le p q = Not (Less q p)"

theorem "bval (Eq p q) s = (aval p s = aval q s)"
apply (auto simp add:Eq_def)
done

theorem "bval (Le p q) s = (aval p s \<le> aval q s)"
apply (auto simp add:Le_def)
done

(* 3.8 *)

definition or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"or p q = Not (And (Not p) (Not q))"

definition implies :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"implies p q = or (Not p) q"

definition bIf :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"bIf a b c = And (implies a b) (implies (Not a) c)"

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 b) s = b" |
"ifval (If a b c) s = (if (ifval a s) then (ifval b s) else (ifval c s))" |
"ifval (Less2 x y) s = (aval x s < aval y s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc b) = Bc2 b" |
"b2ifexp (Not b) = (If (b2ifexp b) (Bc2 False) (Bc2 True))" |
"b2ifexp (And a b) = (If (b2ifexp a) (b2ifexp b) (Bc2 False))" |
"b2ifexp (Less x y) = (Less2 x y)"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 b) = Bc b" |
"if2bexp (If a b c) = bIf (if2bexp a) (if2bexp b) (if2bexp c)" |
"if2bexp (Less2 x y) = (Less x y)"

theorem "bval (if2bexp p) s = ifval p s"
apply (induction p)
apply (auto simp add:bIf_def implies_def or_def)
done

theorem "ifval (b2ifexp p) s = bval p s"
apply (induction p)
apply (auto)
done

(* 3.9 *)

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x" |
"pbval (NOT a) s = (\<not>pbval a s)" |
"pbval (AND a b) s = (pbval a s \<and> pbval b s)" |
"pbval (OR a b) s = (pbval a s \<or> pbval b s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR x) = True" |
"is_nnf (NOT (VAR x)) = True" |
"is_nnf (NOT p) = False" |
"is_nnf (AND p q) = (is_nnf p \<and> is_nnf q)" |
"is_nnf (OR p q) = (is_nnf p \<and> is_nnf q)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR x) = (VAR x)" |
"nnf (NOT (VAR p)) = (NOT (VAR p))" |
"nnf (NOT (NOT p)) = nnf p" |
"nnf (NOT (AND p q)) = OR (nnf (NOT p)) (nnf (NOT q))" |
"nnf (NOT (OR p q)) = AND (nnf (NOT p)) (nnf (NOT q))" |
"nnf (AND p q) = AND (nnf p) (nnf q)" |
"nnf (OR p q) = OR (nnf p) (nnf q)"

lemma not_nnf[simp]: "pbval (nnf (NOT p)) s = (\<not> (pbval (nnf p) s))"
apply (induction p)
apply (auto)
done

theorem "pbval (nnf p) s = pbval p s"
apply (induction p)
apply (auto)
done

lemma nnf_n: "is_nnf (nnf p)"
apply (induction p rule:nnf.induct)
apply (auto)
done

fun andb :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"andb p (OR h t) = OR (andb p h) (andb p t)" |
"andb (OR h t) p = OR (andb h p) (andb t p)" |
"andb p q = AND p q"

lemma pbval_andb: "pbval (andb a b) s = pbval (AND a b) s"
apply (induction a b rule:andb.induct)
apply (auto)
done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR x) = VAR x" |
"dnf_of_nnf (NOT p) = NOT p" |
"dnf_of_nnf (OR p q) = OR (dnf_of_nnf p) (dnf_of_nnf q)" |
"dnf_of_nnf (AND p q) = andb (dnf_of_nnf p) (dnf_of_nnf q)"

theorem "pbval (dnf_of_nnf p) s = pbval p s"
apply (induction p)
apply (auto simp add: pbval_andb)
done

fun is_no_or :: "pbexp \<Rightarrow> bool" where
"is_no_or (VAR x) = True" |
"is_no_or (NOT p) = True" |
"is_no_or (AND p q) = ((is_no_or p) \<and> (is_no_or q))" |
"is_no_or (OR p q) = False"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf (VAR x) = True" |
"is_dnf (NOT p) = True" |
"is_dnf (AND p q) = ((is_no_or p) \<and> (is_no_or q))" |
"is_dnf (OR p q) = ((is_dnf p) \<and> (is_dnf q))"

lemma isdnf_andb: "is_dnf p \<Longrightarrow> is_dnf q \<Longrightarrow> is_dnf (andb p q)"
apply (induction p q rule:andb.induct)
apply (auto)
done

theorem "is_nnf p \<Longrightarrow> is_dnf (dnf_of_nnf p)"
apply (induction p)
apply (auto simp add: isdnf_andb)
done

(* 3.10 *)

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

abbreviation hd2 where
"hd2 xs \<equiv> hd (tl xs)"

abbreviation tl2 where
"tl2 xs \<equiv> tl (tl xs)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 (LOAD x) s stk = Some (s(x) # stk)" |
"exec1 ADD _ stk =
 (case stk of
  (x # y # xs) \<Rightarrow> Some ((hd2 stk + hd stk) # tl2 stk) |
  (xs) \<Rightarrow> None)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk =
 (case (exec1 i s stk) of
  Some res \<Rightarrow> exec is s res |
  None \<Rightarrow> None)"

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

lemma exec_append: "exec is1 s stk = Some new_stk \<Longrightarrow> exec (is1 @ is2) s stk = exec is2 s new_stk"
apply (induction is1 arbitrary:stk)
apply (auto split:option.split)
done

lemma "exec (comp a) s stk = Some (aval a s # stk)"
apply (induction a arbitrary:stk)
apply (auto simp add: exec_append)
done

(* 3.11 *)

type_synonym reg = nat

datatype rinstr = LDI val reg | LD vname reg | ADD reg reg

fun rexec1 :: "rinstr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"rexec1 (LDI n r) s rs = rs(r:=n)" |
"rexec1 (LD v r) s rs = rs(r:=(s v))" |
"rexec1 (ADD r q) s rs = rs(r:=(rs r)+(rs q))"

fun rexec :: "rinstr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"rexec [] s rs = rs" |
"rexec (x # xs) s rs = rexec xs s (rexec1 x s rs)"

fun rcomp :: "aexp \<Rightarrow> reg \<Rightarrow> rinstr list" where
"rcomp (N n) r = [LDI n r]" |
"rcomp (V x) r = [LD x r]" |
"rcomp (Plus p q) r = (rcomp p r) @ (rcomp q (r+1)) @ ([ADD r (r+1)])"

lemma rexec_app[simp]: "rexec (xs @ ys) s rs = rexec ys s (rexec xs s rs)"
apply (induction xs arbitrary: rs)
apply (auto)
done

lemma rcomp_respects: "r < q \<Longrightarrow> rexec (rcomp a q) s rs r = rs r"
apply (induction a arbitrary: rs r q)
apply (auto)
done

theorem "rexec (rcomp a r) s rs r = aval a s"
apply (induction a arbitrary:rs r)
apply (auto simp add: rcomp_respects)
done

(* 3.12 *)

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec10 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec10 (LDI0 n) s rs = rs(0:=n)" |
"exec10 (LD0 v) s rs = rs(0:=(s v))" |
"exec10 (MV0 r) s rs = rs(r:=(rs 0))" |
"exec10 (ADD0 r) s rs = rs(0:=(rs 0)+(rs r))"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec0 [] s rs = rs" |
"exec0 (x # xs) s rs = exec0 xs s (exec10 x s rs)"

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (N n) r = [LDI0 n]" |
"comp0 (V x) r = [LD0 x]" |
"comp0 (Plus p q) r = (comp0 p (r+1)) @ [MV0 (r+1)] @ (comp0 q (r+2)) @ [ADD0 (r+1)]"

lemma exec0_app[simp]: "exec0 (xs @ ys) s rs = exec0 ys s (exec0 xs s rs)"
apply (induction xs arbitrary: rs)
apply (auto)
done

lemma comp0_respects: "(0 < r) \<and> (r \<le> q) \<Longrightarrow> exec0 (comp0 a q) s rs r = rs r"
apply (induction a arbitrary: rs r q)
apply (auto)
done

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
apply (induction a arbitrary:rs r)
apply (auto simp add:comp0_respects)
done

end


theory exercises_3
  imports Main "../My_IMP/Exp"
begin
text \<open>Exercise 3.1\<close>

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N n) = True" |
"optimal (V v) = True" |
"optimal (Plus (N n1) (N n2)) = False" |
"optimal (Plus e1 e2) = ((optimal e1) \<and> (optimal e2))"

lemma "optimal (asimp_const e)"
  apply(induct e)
  by(auto split: aexp.split)

text \<open>Exercise 3.2\<close>
fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = (N n)" |
"full_asimp (V v) = (V v)" |
"full_asimp (Plus e1 e2) =
  (case (full_asimp e1, full_asimp e2) of
    (N n1, N n2) \<Rightarrow> (N (n1 + n2)) |
    (N n1, (Plus e1' (N n2))) \<Rightarrow> (Plus e1' (N (n1 + n2))) |
    (N n1, (Plus (N n2) e2')) \<Rightarrow> (Plus (N (n1 + n2)) e2') |
    ((Plus e1' (N n1)), N n2) \<Rightarrow> (Plus e1' (N (n1 + n2))) |
    ((Plus (N n1) e2'), N n2) \<Rightarrow> (Plus (N (n1 + n2)) e2') |
    (a, b) \<Rightarrow> (Plus a b))"

lemma "aval (full_asimp a) s = aval a s"
  apply (induct a)
  by(auto split: aexp.split)

text \<open>Exercise 3.3\<close>
fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = (N n)" |
"subst x a (V v) = (if v=x then a else (V v))" |
"subst x a (Plus e1 e2) = (Plus (subst x a e1) (subst x a e2))"

value "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')"

lemma "aval (subst x a e) s = aval e (s (x := aval a s))"
  apply(induct e)
  by simp_all

text \<open>Exercise 3.4\<close>
datatype aexp = N int | V vname | Plus aexp aexp | Times aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V v) s = s v" |
"aval (Plus e1 e2) s = aval e1 s + aval e2 s" |
"aval (Times e1 e2) s = aval e1 s * aval e2 s"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N n1) (N n2) = N (n1 + n2)" |
"plus (N n1) e = (if n1=0 then e else Plus (N n1) e)" |
"plus e (N n2) = (if n2=0 then e else Plus e (N n2))" |
"plus e1 e2 = Plus e1 e2"

lemma aval_plus[simp]:
  "aval (plus e1 e2) s = aval e1 s + aval e2 s"
  apply (induction e1 e2 rule: plus.induct)
  by simp_all

fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"times (N n1) (N n2) = N (n1 * n2)" |
"times (N n1) e = (if n1=0
                   then (N 0)
                   else if n1=1
                        then e
                        else (Times (N n1) e))" |
"times e (N n2) = (if n2=0
                   then (N 0)
                   else if n2=1
                        then e
                        else (Times e (N n2)))" |
"times e1 e2 = (Times e1 e2)"

value "times (plus (N 0) (N 0)) (V ''x'')"

lemma aval_times[simp]:
  "aval (times e1 e2) s = aval e1 s * aval e2 s"
  apply (induction e1 e2 rule: times.induct)
  by simp_all

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V v) = V v" |
"asimp (Plus e1 e2) = plus (asimp e1) (asimp e2)" |
"asimp (Times e1 e2) = times (asimp e1) (asimp e2)"

value "asimp (Plus (N 1) (Times (Plus (N 0) (V ''y'')) (V ''x'')))"

lemma "aval (asimp a) s = aval a s"
  apply(induction a)
  by simp_all

text \<open>Exercise 3.5\<close>
datatype aexp2 = N int
  | V vname
  | Plus aexp2 aexp2
  | Times aexp2 aexp2
  | Div aexp2 aexp2
  | Self_inc vname

(*
definition get_val :: "(val \<times> state) option \<Rightarrow> val option" where
"get_val x = (if Option.is_none x then None else Some (fst (the x)))"
(* How to prove the correctness of  get_val?*)
*)

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval2 (N n) s = Some (n, s)" |
"aval2 (V v) s = Some (s v, s)" |
"aval2 (Self_inc v) s = Some (s v, (s (v := (s v + 1))))" |
"aval2 (Plus e1 e2) s = (case (aval2 e1 s, aval2 e2 s) of
                          (None, None) \<Rightarrow> None|
                          (None, e2') \<Rightarrow> None |
                          (e1', None) \<Rightarrow> None |
                          (e1', e2') \<Rightarrow> Some ((fst (the e1')) + (fst (the e2')), s))" |
"aval2 (Times e1 e2) s = (case (aval2 e1 s, aval2 e2 s) of
                          (None, None) \<Rightarrow> None|
                          (None, e2') \<Rightarrow> None |
                          (e1', None) \<Rightarrow> None |
                          (e1', e2') \<Rightarrow> Some (fst (the e1') * fst (the e2'), s))" |
"aval2 (Div e1 e2) s = (case (aval2 e1 s, aval2 e2 s) of
                          (None, None) \<Rightarrow> None|
                          (None, e2') \<Rightarrow> None |
                          (e1', None) \<Rightarrow> None |
                          (e1', e2') \<Rightarrow> (if fst (the e2') = 0 then None else Some (fst (the e1') div fst (the e2'), s)))"

value "fst (the (Some (1::int, 2::int)))"
value "((4::int) div 2)"

value "aval2 (N 1) (\<lambda>x. 0)"
value "aval2 (V ''x'') (\<lambda>x. 0)"
value "aval2 (V ''x'') (snd (the (aval2 (Self_inc ''x'') (\<lambda>x. 1))))"
value "aval2 (Plus (N 1) (N 2)) (\<lambda>x. 0)"
value "aval2 (Plus (V ''x'') (N 1)) (\<lambda>x. 0)"
definition "now_x_state = snd (the (aval2 (Plus (Self_inc ''x'') (Plus (Self_inc ''x'') (N 0))) (\<lambda>x. 0)))"

text \<open>There is a problem: how maintain the state after self_inc\<close>
value "aval2 (Plus (Self_inc ''x'') (N 0)) (\<lambda>x. 0)"

text \<open>Exercise 3.6\<close>
datatype lexp = Nl int | Vl vname | Plusl lexp lexp | Let vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> val" where
"lval (Nl n) s = n" |
"lval (Vl v) s = (s v)" |
"lval (Plusl e1 e2) s = (lval e1 s) + (lval e2 s)" |
"lval (Let v e1 e2) s = (lval e2 (s (v := lval e1 s)))"

value "lval (Let ''x'' (Plusl (Nl 1) (Nl 2)) (Plusl (Vl ''x'') (Vl ''x''))) (\<lambda>x. 0)"

fun inline :: "lexp \<Rightarrow> Exp.aexp" where
"inline (Nl n) = (Exp.aexp.N n)" |
"inline (Vl v) = (Exp.aexp.V v)" |
"inline (Plusl e1 e2) = (Exp.aexp.Plus (inline e1) (inline e2))" |
"inline (Let v e1 e2) = (subst v (inline e1) (inline e2))"

lemma "Exp.aval (inline e) s = lval e s"
apply(induction e arbitrary: s)
     apply(auto split: lexp.split)
  sorry

text \<open>Exercise 3.7\<close>
fun eq :: "Exp.aexp \<Rightarrow> Exp.aexp \<Rightarrow> bexp" where
"eq a1 a2 = and (not (less a1 a2)) (not (less a2 a1))"

lemma correctness_eq[simp]:
  "bval (eq a1 a2) s = ((Exp.aval a1 s) = (Exp.aval a2 s))"
  by auto

fun le :: "Exp.aexp \<Rightarrow> Exp.aexp \<Rightarrow> bexp" where
"le a1 a2 = not (less a2 a1)"

lemma correctness_le[simp]:
  "bval (le a1 a2) s = ((Exp.aval a1 s) \<le> (Exp.aval a2 s))"
  by auto

text \<open>Exercise 3.8\<close>
datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 Exp.aexp Exp.aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 c) s = c" |
"ifval (If i1 i2 i3) s = (if (ifval i1 s) then (ifval i2 s) else (ifval i3 s))" |
"ifval (Less2 a1 a2) s = ((Exp.aval a1 s) < (Exp.aval a2 s))"

value "ifval (Bc2 True) (\<lambda>x. 0)"
value "ifval (If (Bc2 True) (Bc2 False) (Bc2 True)) (\<lambda>x. 0)"
value "ifval (If (Bc2 False) (Bc2 False) (Bc2 True)) (\<lambda>x. 0)"
value "ifval (Less2 (Exp.N 1) (Exp.N 0)) (\<lambda>x. 0)"
value "Bc2 True = Bc2 False"

fun b_ifexp :: "bexp \<Rightarrow> ifexp" where
"b_ifexp (Bc c) = Bc2 c" |
"b_ifexp (Not b) = (If (b_ifexp b) (Bc2 False) (Bc2 True))" |
"b_ifexp (And b1 b2) = (If (b_ifexp b1) (b_ifexp b2) (Bc2 False))" |
"b_ifexp (Less a1 a2) = (Less2 a1 a2)"

lemma corectness_b_ifexp[simp]:
  "ifval (b_ifexp b) s = bval b s"
  apply (induct b)
  by auto

fun ifexp_bexp :: "ifexp \<Rightarrow> bexp" where
"ifexp_bexp (Bc2 c) = (Bc c)" |
"ifexp_bexp (If i1 i2 i3) = (or (And (ifexp_bexp i1) (ifexp_bexp i2)) (And (Not (ifexp_bexp i1)) (ifexp_bexp i3)))" |
"ifexp_bexp (Less2 a1 a2) = (Less a1 a2)"

lemma correctness_ifexp_bexp[simp]:
  "bval (ifexp_bexp ie) s = ifval ie s"
  apply (induct ie)
  by auto

text \<open>Exercise 3.9\<close>
type_synonym bval = bool
datatype pbexp = Pvar vname | Pnot pbexp | Pand pbexp pbexp | Por pbexp pbexp
type_synonym bstate = "vname \<Rightarrow> bval"

fun pbval :: "pbexp \<Rightarrow> bstate \<Rightarrow> bval" where
"pbval (Pvar v) s = s v" |
"pbval (Pnot b) s = (\<not> (pbval b s))" |
"pbval (Pand b1 b2) s = ((pbval b1 s) \<and> (pbval b2 s))" |
"pbval (Por b1 b2) s = ((pbval b1 s) \<or> (pbval b2 s))"

lemma "pbval (Pnot (Pand b1 b2)) s = pbval (Por (Pnot b1) (Pnot b2)) s"
  by auto

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (Pvar v) = True" |
(*
"is_nnf (Pnot b) = (case b of
                      Pvar _ \<Rightarrow> True |
                      _ \<Rightarrow> False)" |
*)
"is_nnf (Pnot (Pvar _)) = True" |
"is_nnf (Pnot _) = False" |
"is_nnf (Pand b1 b2) = (is_nnf b1 \<and> is_nnf b2)" |
"is_nnf (Por b1 b2) = (is_nnf b1 \<and> is_nnf b2)"

value "is_nnf (Pvar ''x'')"
value "is_nnf (Pnot (Pvar ''x''))"
value "is_nnf (Pnot (Pnot (Pvar ''x'')))"
value "is_nnf (Pand (Pnot (Pvar ''x'')) (Pnot (Pvar ''y'')))"
value "is_nnf (Pnot (Pand (Pnot (Pvar ''x'')) (Pnot (Pvar ''y''))))"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (Pvar v) = (Pvar v)" |
(* What's wrong?
"nnf (Pnot b) = (case b of
                  Pvar v \<Rightarrow> (Pnot (Pvar v)) |
                  Pnot b' \<Rightarrow> (nnf b') |
                  Pand b1 b2 \<Rightarrow> (Por (nnf (Pnot b1)) (nnf (Pnot b2))) |
                  Por b1 b2 \<Rightarrow> (Pand (nnf (Pnot b1)) (nnf (Pnot b2))))" |
*)
"nnf (Pnot (Pvar v)) = (Pnot (Pvar v))" |
"nnf (Pnot (Pnot b)) = nnf b" |
"nnf (Pnot (Pand b1 b2)) = (Por (nnf (Pnot b1)) (nnf (Pnot b2)))" |
"nnf (Pnot (Por b1 b2)) = (Pand (nnf (Pnot b1)) (nnf (Pnot b2)))" |
"nnf (Pand b1 b2) = (Pand (nnf b1) (nnf b2))" |
"nnf (Por b1 b2) = (Por (nnf b1) (nnf b2))"

value "nnf (Pvar ''x'')"
value "nnf (Pnot (Pnot (Pnot (Pvar ''x''))))"
value "nnf (Pnot (Pand (Pnot (Pnot (Pvar ''x''))) (Pnot (Pvar ''y''))))"
value "is_nnf (nnf (Pvar ''x''))"
value "is_nnf(nnf (Pnot (Pand (Pnot (Pvar ''x'')) (Pnot (Pvar ''y'')))))"
value "is_nnf(nnf (Pand (Pnot (Pnot (Pvar ''x''))) (Pvar ''y'')))"

lemma pbval_nnf[simp]:
  "pbval (nnf b) s = pbval b s"
  apply(induction b rule: nnf.induct)
  by auto

lemma correctness_nnf[simp]:
  "is_nnf (nnf pb)"
  apply (induction pb rule: nnf.induct)
  by auto

fun is_dnf_nnf :: "pbexp \<Rightarrow> bool" where
"is_dnf_nnf (Pvar v) = True" |
"is_dnf_nnf (Pnot b) = True" |
"is_dnf_nnf (Por b1 b2) = True" |
"is_dnf_nnf (Pand (Por b11 b12) b2) = False" |
"is_dnf_nnf (Pand b1 (Por b21 b22)) = False" |
"is_dnf_nnf (Pand b1 b2) = True"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf b =  (if is_nnf b
              then is_dnf_nnf (nnf b)
              else False)"

text \<open>assume it is a nnf\<close>
fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (Pvar v) = (Pvar v)" |
"dnf_of_nnf (Pnot b) = (Pnot b)" |
"dnf_of_nnf (Por b1 b2) = (Por (dnf_of_nnf b1) (dnf_of_nnf b2))" |
(*
"dnf_of_nnf (Pand b1 b2) = (case (dnf_of_nnf b1, dnf_of_nnf b2) of
                            ((Por b11 b12), b2') \<Rightarrow> (Por (Pand b11 b2) (Pand b12 b2)) |
                            (b1', (Por b21 b22)) \<Rightarrow> (Por (Pand b1' b21) (Pand b1' b22)))"
*)
"dnf_of_nnf (Pand (Por b11 b12) b2) = (Por (Pand (dnf_of_nnf b11) (dnf_of_nnf b2))
                                          (Pand (dnf_of_nnf b12) (dnf_of_nnf b2)))" |
"dnf_of_nnf (Pand b1 (Por b21 b22)) = (Por (Pand (dnf_of_nnf b1) (dnf_of_nnf b21))
                                          (Pand (dnf_of_nnf b1) (dnf_of_nnf b22)))" |
"dnf_of_nnf (Pand b1 b2) = (Pand b1 b2)"

lemma pbval_dnf_of_nnf[simp]:
  "pbval (dnf_of_nnf b) s = pbval b s"
  apply (induction b rule: dnf_of_nnf.induct)
  by auto

lemma correctness_convert[simp]:
  "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply (induction b rule: dnf_of_nnf.induct)
  apply (simp_all)
  using is_nnf.elims(2) apply fastforce
           apply meson
  apply metis
  apply presburger
        apply metis
  apply meson
  using is_nnf.elims(2) apply fastforce
  using is_nnf.elims(2) apply fastforce
  apply (metis is_dnf_nnf.simps(12) is_nnf.elims(2) nnf.simps(2) pbexp.distinct(1) pbexp.distinct(7) pbexp.distinct(9))
  using is_nnf.elims(2) apply fastforce
  using is_nnf.elims(2) by force

text \<open>Exercise 3.10\<close>
datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = (Some (n # stk))" |
"exec1 (LOAD x) s stk = (Some (s(x) # stk))" |
"exec1 ADD _ (j # i # stk) = (Some ((i + j) # stk))" |
"exec1 ADD _ _ = None "
(*
"exec1 ADD _ stk = (if length stk < 2 then None else (case stk of (j # i # xs) \<Rightarrow> (Some ((i+j) # xs))))"
*)

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i # is) s stk = (case (exec1 i s stk) of
                          None \<Rightarrow> None |
                          Some stk' \<Rightarrow> exec is s stk')"

fun comp :: "Exp.aexp \<Rightarrow> instr list" where
"comp (Exp.N n) = [LOADI n]" |
"comp (Exp.V x) = [LOAD x]" |
"comp (Exp.Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma exec_append[simp]:
  "(exec is1 s stk = Some stk1) \<Longrightarrow> (exec (is1 @ is2) s stk) = (exec is2 s stk1)"
  apply(induction is1 arbitrary: stk)
   apply(simp_all)
  by (metis option.case_eq_if option.simps(3))

lemma correctness_asm[simp]:
  "exec (comp a) s stk = Some ((Exp.aval a s) # stk)"
  apply(induction a arbitrary: stk)
  by auto

text \<open>Exercise 3.11\<close>
type_synonym reg = nat
datatype instr_reg = LDI int reg | LD vname reg | ADD reg reg
type_synonym reg_state = "reg \<Rightarrow> int"

fun exec_reg1 :: "instr_reg \<Rightarrow> state \<Rightarrow> reg_state \<Rightarrow> reg_state" where
"exec_reg1 (LDI n r) _ reg_s = reg_s (r := n)" |
"exec_reg1 (LD x r) s reg_s = reg_s (r := (s x))" |
"exec_reg1 (ADD r1 r2) _ reg_s = reg_s (r1 := (reg_s r1 + reg_s r2))"

fun exec_reg :: "instr_reg list \<Rightarrow> state \<Rightarrow> reg_state \<Rightarrow> reg_state" where
"exec_reg [] _ reg_s = reg_s" |
"exec_reg (i # is) s reg_s = exec_reg is s (exec_reg1 i s reg_s)"

value "(exec_reg [(LDI 1 1), (LDI 2 2), (LDI 3 3), (ADD 2 3), (ADD 1 2)] (\<lambda>x. 0) (\<lambda>r. 0)) 1"

fun comp_reg :: "Exp.aexp \<Rightarrow> reg \<Rightarrow> instr_reg list" where
"comp_reg (Exp.N n) r = [LDI n r]" |
"comp_reg (Exp.V v) r = [LD v r]" |
"comp_reg (Exp.Plus e1 e2) r = (comp_reg e1 r) @ (comp_reg e2 (Suc r)) @ [ADD r (Suc r)]"

lemma l0[simp]:
  "exec_reg (i1 @ i2) s rs = exec_reg i2 s (exec_reg i1 s rs)"
  apply (induction i1 arbitrary: s rs)
  by simp_all

lemma left_alone[simp]:
  "r1 < r2 \<Longrightarrow> (exec_reg (comp_reg a r2) s rs) r1 = rs r1 "
  apply (induction a arbitrary: rs r2)
  by simp_all

lemma correctness_comp[simp]:
  "exec_reg (comp_reg a r) s rs r = Exp.aval a s"
  apply (induction a arbitrary: r rs)
  by simp_all

text \<open>Exercise 3.12\<close>
datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> reg_state \<Rightarrow> reg_state" where
"exec01 (LDI0 n) s rs = rs (0 := n)" |
"exec01 (LD0 v) s rs = rs (0 := (s v))" |
"exec01 (MV0 r) s rs = rs (r := (rs 0))" |
"exec01 (ADD0 r) s rs = rs (0 := (rs r + rs 0))"

value "(exec01 (ADD0 1) <> <0 := 3, 1 := 2>) 0"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> reg_state \<Rightarrow> reg_state" where
"exec0 [] _ rs = rs" |
"exec0 (i # is) s rs = exec0 is s (exec01 i s rs)"

lemma exec0_append[simp]:
  "exec0 (i1 @ i2) s rs = exec0 i2 s (exec0 i1 s rs)"
  apply (induction i1 arbitrary: s rs)
  by auto

fun comp0 :: "Exp.aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (Exp.N n) _ = [LDI0 n]" |
"comp0 (Exp.V v) _ = [LD0 v]" |
"comp0 (Exp.Plus a1 a2) r = (comp0 a2 (Suc r)) @ [MV0 (Suc r)] @ (comp0 a1 (Suc (Suc r))) @ [ADD0 (Suc r)]"

lemma left_alone2[simp]:
  "0 < r1 \<Longrightarrow> r1 < r2 \<Longrightarrow> exec0 (comp0 a r2) s rs r1 = rs r1"
  apply (induct a arbitrary: rs r2)
  by simp_all

lemma correctness_comp0[simp]:
  "exec0 (comp0 a r) s rs 0 = Exp.aval a s"
  apply (induction a arbitrary: r s rs)
  by simp_all

value "if (1::int)=2 then (3::int) else 4"
value "let x=1::int in (x + 1)"
datatype N = One | Suc N
fun case_test :: "N \<Rightarrow> bool" where
"case_test t = (case t of
                  One \<Rightarrow> True |
                  _ \<Rightarrow> False)"
value "case_test One"
value "case_test (Suc One)"
value "[(1::int)..6]"

end


theory ex2_10 imports Main begin

datatype tree0 = Tip | Node tree0 tree0

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

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

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

end


section \<open>Parity of a list permutation\<close>

theory Parity_Swap
imports "../lib/Lib"
begin

text \<open>Define the parity of a list @{term xs} as the evenness of the number of inversions.
      Count an inversion for every pair of indices @{term i} and @{term j}, such that
      @{text "i < j"}, but @{text "xs!i > xs!j"}.\<close>

primrec
  parity :: "nat list \<Rightarrow> bool"
where
  "parity [] = True"
| "parity (x # ys) = (parity ys = even (length [y \<leftarrow> ys. x > y]))"

text \<open>In a list that is sufficiently distinct, swapping any two elements inverts
      the @{term parity}.\<close>

lemma parity_swap_adj:
  "b \<noteq> c \<Longrightarrow> parity (as @ b # c # ds) \<longleftrightarrow> \<not> parity (as @ c # b # ds)"
  by (induct as) auto

lemma parity_swap:
  assumes "b \<noteq> d \<and> b \<notin> set cs \<and> d \<notin> set cs"
  shows "parity (as @ b # cs @ d # es) \<longleftrightarrow> \<not> parity (as @ d # cs @ b # es)"
  using assms
  proof (induct cs arbitrary: as)
    case Nil thus ?case using parity_swap_adj[of b d as es] by simp
  next
    case (Cons c cs) show ?case
      using parity_swap_adj[of b c as "cs @ d # es"]
            parity_swap_adj[of d c as "cs @ b # es"]
            Cons(1)[where as="as @ [c]"] Cons(2)
      by simp
  qed

end


theory Height
  imports "../Nominal"
begin

text {*
  A small problem suggested by D. Wang. It shows how
  the height of a lambda-terms behaves under substitution.
*}

atom_decl name

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text {* Definition of the height-function on lambda-terms. *}

nominal_primrec
  height :: "lam \<Rightarrow> int"
where
  "height (Var x) = 1"
| "height (App t1 t2) = (max (height t1) (height t2)) + 1"
| "height (Lam [a].t) = (height t) + 1"
  apply(finite_guess add: perm_int_def)+
  apply(rule TrueI)+
  apply(simp add: fresh_int)
  apply(fresh_guess add: perm_int_def)+
  done

text {* Definition of capture-avoiding substitution. *}

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

text{* The next lemma is needed in the Var-case of the theorem below. *}

lemma height_ge_one:
  shows "1 \<le> (height e)"
by (nominal_induct e rule: lam.strong_induct) (simp_all)

text {*
  Unlike the proplem suggested by Wang, however, the
  theorem is here formulated entirely by using functions.
*}

theorem height_subst:
  shows "height (e[x::=e']) \<le> ((height e) - 1) + (height e')"
proof (nominal_induct e avoiding: x e' rule: lam.strong_induct)
  case (Var y)
  have "1 \<le> height e'" by (rule height_ge_one)
  then show "height (Var y[x::=e']) \<le> height (Var y) - 1 + height e'" by simp
next
  case (Lam y e1)
  hence ih: "height (e1[x::=e']) \<le> ((height e1) - 1) + (height e')" by simp
  moreover
  have vc: "y\<sharp>x" "y\<sharp>e'" by fact+ (* usual variable convention *)
  ultimately show "height ((Lam [y].e1)[x::=e']) \<le> height (Lam [y].e1) - 1 + height e'" by simp
next
  case (App e1 e2)
  hence ih1: "height (e1[x::=e']) \<le> ((height e1) - 1) + (height e')"
    and ih2: "height (e2[x::=e']) \<le> ((height e2) - 1) + (height e')" by simp_all
  then show "height ((App e1 e2)[x::=e']) \<le> height (App e1 e2) - 1 + height e'"  by simp
qed

end


chapter {* R5: Eliminación de duplicados *}

theory R5_Eliminacion_de_duplicados
imports Main
begin

text {*
  ---------------------------------------------------------------------
  Ejercicio 1. Definir la funcion primitiva recursiva
     estaEn :: 'a \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (estaEn x xs) se verifica si el elemento x está en la lista
  xs. Por ejemplo,
     estaEn (2::nat) [3,2,4] = True
     estaEn (1::nat) [3,2,4] = False
  ---------------------------------------------------------------------
*}

fun estaEn :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "estaEn _ [] = False"
| "estaEn x (y#xs) = ((x = y) \<or> (estaEn x xs))"

value "estaEn (2::nat) [3,2,4] = True"
value "estaEn (1::nat) [3,2,4] = False"

text {*
  ---------------------------------------------------------------------
  Ejercicio 2. Definir la función primitiva recursiva
     sinDuplicados :: 'a list \<Rightarrow> bool
  tal que (sinDuplicados xs) se verifica si la lista xs no contiene
  duplicados. Por ejemplo,
     sinDuplicados [1::nat,4,2]   = True
     sinDuplicados [1::nat,4,2,4] = False
  ---------------------------------------------------------------------
*}

fun sinDuplicados :: "'a list \<Rightarrow> bool" where
  "sinDuplicados [] = True"
| "sinDuplicados (x#xs) = (\<not>estaEn x xs \<and> sinDuplicados xs)"

value "sinDuplicados [1::nat,4,2]   = True"
value "sinDuplicados [1::nat,4,2,4] = False"

text {*
  ---------------------------------------------------------------------
  Ejercicio 3. Definir la función primitiva recursiva
     borraDuplicados :: 'a list \<Rightarrow> bool
  tal que (borraDuplicados xs) es la lista obtenida eliminando los
  elementos duplicados de la lista xs. Por ejemplo,
     borraDuplicados [1::nat,2,4,2,3] = [1,4,2,3]

  Nota: La función borraDuplicados es equivalente a la predefinida
  remdups.
  ---------------------------------------------------------------------
*}

fun borraDuplicados :: "'a list \<Rightarrow> 'a list" where
  "borraDuplicados[] = []"
| "borraDuplicados (x#xs) = (if estaEn x xs then borraDuplicados xs  else x # borraDuplicados xs)"

value "borraDuplicados [1::nat,2,4,2,3] = [1,4,2,3]"

text {*
  ---------------------------------------------------------------------
  Ejercicio 4.1. Demostrar o refutar automáticamente
     length (borraDuplicados xs) \<le> length xs
  ---------------------------------------------------------------------
*}

-- "La demostración automática es"
lemma length_borraDuplicados:
  "length (borraDuplicados xs) \<le> length xs"
by (induct xs) auto

text {*
  ---------------------------------------------------------------------
  Ejercicio 4.2. Demostrar o refutar detalladamente
     length (borraDuplicados xs) \<le> length xs
  ---------------------------------------------------------------------
*}

-- "La demostración estructurada es"

lemma length_borraDuplicados_2: "length (borraDuplicados xs) \<le> length xs" (is "?P xs")
proof (induct xs)
  show "?P []" by simp
next
  fix a xs
  assume HI: "?P xs"
  have "length (borraDuplicados (a # xs)) \<le> 1+length (borraDuplicados xs)" by simp
  also have "... \<le> 1+length xs" using HI by simp
  finally show "?P (a # xs)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 5.1. Demostrar o refutar automáticamente
     estaEn a (borraDuplicados xs) = estaEn a xs
  ---------------------------------------------------------------------
*}

-- "La demostración automática es"
lemma estaEn_borraDuplicados:
  "estaEn a (borraDuplicados xs) = estaEn a xs"
by (induct xs) auto

text {*
  ---------------------------------------------------------------------
  Ejercicio 5.2. Demostrar o refutar detalladamente
     estaEn a (borraDuplicados xs) = estaEn a xs
  Nota: Para la demostración de la equivalencia se puede usar
     proof (rule iffI)
  La regla iffI es
     \<lbrakk>P \<Longrightarrow> Q ; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P = Q
  ---------------------------------------------------------------------
*}

-- "La demostración estructurada es"
lemma estaEn_borraDuplicados_2: "estaEn a (borraDuplicados xs) = estaEn a xs" (is "?P a xs")
proof (induct xs)
  show "?P a []" by simp
next
  fix b xs
  assume HI: "?P a xs"
  show "?P a (b#xs)"
  proof (rule iffI)
    assume HII: "?P a (b#xs)"
oops

text {*
  ---------------------------------------------------------------------
  Ejercicio 6.1. Demostrar o refutar automáticamente
     sinDuplicados (borraDuplicados xs)
  ---------------------------------------------------------------------
*}

-- "La demostración automática"
lemma sinDuplicados_borraDuplicados:
  "sinDuplicados (borraDuplicados xs)"
by (induct xs) (auto simp add: estaEn_borraDuplicados)

text {*
  ---------------------------------------------------------------------
  Ejercicio 6.2. Demostrar o refutar detalladamente
     sinDuplicados (borraDuplicados xs)
  ---------------------------------------------------------------------
*}

-- "La demostración estructurada es"
lemma sinDuplicados_borraDuplicados_2:
  "sinDuplicados (borraDuplicados xs)"
proof (induct xs)
  show "sinDuplicados (borraDuplicados [])" by simp
next
  fix x xs
  assume HI: "sinDuplicados (borraDuplicados xs)"
  show "sinDuplicados (borraDuplicados (x # xs))"
  proof (cases)
    assume "estaEn x xs"
    then show "sinDuplicados (borraDuplicados (x # xs))" using HI by simp
  next
    assume "\<not>(estaEn x xs)"
    then show "sinDuplicados (borraDuplicados (x # xs))" using HI by (simp add: estaEn_borraDuplicados)
  qed
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 7. Demostrar o refutar:
    borraDuplicados (rev xs) = rev (borraDuplicados xs)
  ---------------------------------------------------------------------
*}

lemma "borraDuplicados (rev xs) = rev (borraDuplicados xs)"
quickcheck
oops

end


(*
  Title:    Random_Dictatorship.thy
  Author:   Manuel Eberl, TU München

  Definition and basic properties of Random Dictatorship
  (on weak preferences)
*)

section \<open>Random Dictatorship\<close>

theory Random_Dictatorship
imports
  Complex_Main
  Social_Decision_Schemes
begin

text \<open>
  We define Random Dictatorship as a social decision scheme on total preorders
  (i.e. agents are allowed to have ties in their rankings) by first selecting an agent
  uniformly at random and then selecting one of that agents' most preferred alternatives
  uniformly at random. Note that this definition also works for weak preferences.
\<close>
definition random_dictatorship :: "'agent set \<Rightarrow> ('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery" where
  "random_dictatorship agents R =
      do {
        i \<leftarrow> pmf_of_set agents;
        pmf_of_set (favorites R i)
      }"

context election
begin

abbreviation RD :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery" where
  "RD \<equiv> random_dictatorship agents"

lemma random_dictatorship_unique_favorites:
  assumes "is_pref_profile R" "has_unique_favorites R"
  shows   "RD R = map_pmf (favorite R) (pmf_of_set agents)"
proof -
  from assms(1) interpret pref_profile_wf agents alts R .
  from assms(2) interpret pref_profile_unique_favorites agents alts R by unfold_locales
  show ?thesis unfolding random_dictatorship_def map_pmf_def
    by (intro bind_pmf_cong) (auto simp: unique_favorites pmf_of_set_singleton)
qed

lemma random_dictatorship_unique_favorites':
  assumes "is_pref_profile R" "has_unique_favorites R"
  shows   "RD R = pmf_of_multiset (image_mset (favorite R) (mset_set agents))"
  using assms by (simp add: random_dictatorship_unique_favorites map_pmf_of_set)

lemma pmf_random_dictatorship:
  assumes "is_pref_profile R"
  shows "pmf (RD R) x =
           (\<Sum>i\<in>agents. indicator (favorites R i) x /
              real (card (favorites R i))) / real (card agents)"
proof -
  from assms(1) interpret pref_profile_wf agents alts R .
  have "ereal (pmf (RD R) x) =
          ereal ((\<Sum>i\<in>agents. pmf (pmf_of_set (favorites R i)) x) / real (card agents))"
    (is "_ = ereal (?p / _)") unfolding random_dictatorship_def
    by (simp_all add: ereal_pmf_bind nn_integral_pmf_of_set max_def pmf_nonneg)
  also have "?p = (\<Sum>i\<in>agents. indicator (favorites R i) x / real (card (favorites R i)))"
    by (intro setsum.cong) (simp_all add: favorites_nonempty)
  finally show ?thesis by simp
qed

sublocale RD: social_decision_scheme agents alts RD
proof
  fix R assume R_wf: "is_pref_profile R"
  then interpret pref_profile_wf agents alts R .
  from R_wf show "RD R \<in> lotteries"
    using favorites_subset_alts favorites_nonempty
    by (auto simp: lotteries_on_def random_dictatorship_def)
qed

text \<open>
  We now show that Random Dictatorship fulfils anonymity, neutrality,
  and strong strategyproofness.
  At the very least, this shows that the definitions of these notions are
  consistent.
\<close>

subsection \<open>Anonymity\<close>

text \<open>
  The following proof is essentially the following:
  In Random Dictatorship, permuting the agents in the preference profile is the same
  as applying the permutation to the agent that was picked uniformly at random in the
  first step. However, uniform distributions are invariant under permutation, therefore
  the outcome is totally unchanged.
\<close>

sublocale RD: anonymous_sds agents alts RD
proof
  fix R \<pi> assume wf: "is_pref_profile R" and perm: "\<pi> permutes agents"
  have "RD (R \<circ> \<pi>) = map_pmf \<pi> (pmf_of_set agents) \<bind> (\<lambda>i. pmf_of_set (favorites R i))"
    by (simp add: bind_map_pmf random_dictatorship_def o_def favorites_def)
  also from perm have "\<dots> = RD R"
    by (simp add: map_pmf_of_set_inj permutes_inj_on permutes_image random_dictatorship_def)
  finally show "RD (R \<circ> \<pi>) = RD R" .
qed

subsection \<open>Neutrality\<close>

text \<open>
  The proof of neutrality is similar to that of anonymity. We have proven elsewhere
  that the most preferred alternatives of an agent in a profile with permuted alternatives
  are simply the image of the originally preferred alternatives.
  Since we pick one alternative from the most preferred alternatives of the selected agent
  uniformly at random, this means that we effectively pick an agent, then pick on of her
  most preferred alternatives, and then apply the permutation to that alternative,
  which is simply Random Dictatorship transformed with the permutation.
\<close>

sublocale RD: neutral_sds agents alts RD
proof
  fix \<sigma> R
  assume perm: "\<sigma> permutes alts" and R_wf: "is_pref_profile R"
  from R_wf interpret pref_profile_wf agents alts R .
  from perm show "RD (permute_profile \<sigma> R) = map_pmf \<sigma> (RD R)"
    by (auto intro!: bind_pmf_cong simp: random_dictatorship_def map_bind_pmf
          favorites_permute map_pmf_of_set_inj permutes_inj_on favorites_nonempty)
qed

subsection \<open>Strong strategyproofness\<close>

text \<open>
  The argument for strategyproofness is quite simple:
  Since the preferences submitted by an agent @{term i} only influence
  the outcome when that agent is picked in the first process, it suffices
  to focus on this case.
  When the agent @{term i} submits her true preferences, the probability of
  obtaining a result at least as good as @{term x} (for any alternative @{term x})
  is 1, since the outcome will always be one of her most-preferred alternatives.
  Obviously, the probability of obtaining such a result cannot exceed 1 no matter
  what preferences she submits instead, and thus, RD is strategyproof.
\<close>

sublocale RD: strongly_strategyproof_sds agents alts RD
proof (unfold_locales, unfold RD.strongly_strategyproof_profile_def)
  fix R i Ri' assume R_wf: "is_pref_profile R" and i: "i \<in> agents"
                 and Ri'_wf: "total_preorder_on alts Ri'"
  interpret R: pref_profile_wf agents alts R by fact
  from R_wf Ri'_wf i have R'_wf: "is_pref_profile (R(i := Ri'))"
    by (simp add: R.wf_update)
  interpret R': pref_profile_wf agents alts "R(i := Ri')" by fact

  show "SD (R i) (RD (R(i := Ri'))) (RD R)"
  proof (rule R.SD_pref_profileI)
    fix x assume "x \<in> alts"
    hence "emeasure (measure_pmf (RD (R(i := Ri')))) (preferred_alts (R i) x)
             \<le> emeasure (measure_pmf (RD R)) (preferred_alts (R i) x)"
      using Ri'_wf maximal_imp_preferred[of "R i" x]
      by (auto intro!: card_mono nn_integral_mono_AE
               simp: random_dictatorship_def AE_measure_pmf_iff Max_wrt_prefs_finite
                     emeasure_pmf_of_set favorites_def Int_absorb2
                     Max_wrt_prefs_nonempty card_gt_0_iff)
    thus "lottery_prob (RD (R(i := Ri'))) (preferred_alts (R i) x)
            \<le> lottery_prob (RD R) (preferred_alts (R i) x)"
      by (simp add: measure_pmf.emeasure_eq_measure)
  qed (insert R_wf R'_wf, simp_all add: RD.sds_wf i)
qed

end

end


(* Header of theory always looks like this: *)
theory FunProg_Demo (* Theory name, must coincide with filename *)
imports Main "~~/src/HOL/Library/Multiset" (* List of imported theories. Typically only Main. *)
begin

  section \<open>Datatype Examples\<close> (* Section commands have no semantic meaning, only for source structuring. *)
    (* Hint: Use sidekick-panel! *)

  (* First Example: Nat  *)
  (* Data represented as algebraic datatypes: *)
  datatype my_nat = Z | S my_nat
  (* Intuitive reading: A natural number is either *Z*ero, or the *S*uccessor of a natural number *)

  (* Note: Unary representation.
    Not efficient for computation. But very efficient for proving!
  *)

  (* Use the term command to display a term and its type in the Output panel *)
  term "Z" (* In theory text, terms and types always enclosed in "quotes". *)
  term "''This is a string''" (* Do not confuse with strings *)
  term "CHR ''a''" (* Syntax for single character *)

  term "S Z" (* Function application is written: f x\<^sub>1 ... x\<^sub>n *)
  term "S (S (S Z))" (* Note the parentheses! *)

  term "Z"

  term \<open>S (S Z)\<close> (* You may also use cartouches \<open>...\<close>  instead of quotes.
      Type backtick ` and wait for completion menu.
      Hint: Set Plugins>Plugin Options>Isabelle>General>Completion Delay to 0 for smoother typing.
    *)
  (* Hint: Use the Symbols-panel to explore available
    symbols, and methods how to enter them! *)

  datatype 'a my_list = NIL | CONS 'a "'a my_list"
  (* \<open>\<open>'a\<close> is type parameter. May be filled with any type, e.g.: *)
  typ "my_nat my_list" typ "bool my_list"

  datatype bintree = Leaf | Node bintree bintree

  datatype 'a bt = Leaf' | Node' 'a "'a bt" "'a bt"

  section \<open>Functions\<close>

  (* Functions: Recursive functions. For example: *)
  fun add where
    "add Z m = m"
  | "add (S n) m = S (add n m)"

  (* Note: This definition is much simpler than it would be for binary numbers! *)
  (* Also simpler than what you would write in C++ or Java! *)

  value "add (S Z) (S (S Z))" (* Evaluate a term *)
  value "add (S n) (S (S (Z)))" (* Partial evaluation also possible! *)

  fun appnd
    where
    "appnd NIL l = l"
  | "appnd (CONS x l) ll = CONS x (appnd l ll)"

  value "appnd (CONS a (CONS b NIL)) (CONS c (CONS d NIL))"

  (*
      appnd (CONS a (CONS b NIL)) (CONS c (CONS d NIL))
    = CONS a (appnd (CONS b NIL) (CONS c (CONS d NIL)))
    = CONS a (CONS b (appnd NIL (CONS c (CONS d NIL))))
    = CONS a (CONS b (CONS c (CONS d NIL)))

    More examples how evaluation works: [DO ON DOC-CAM IF POSSIBLE]

      add (S (S Z)) (S Z)    -- Match with equation add (S n) m = S (add n m)
    = S (add (S Z) (S Z))    -- Match with equation add (S n) m = S (add n m)
    = S (S (add Z (S Z)))    -- Match with equation add Z m = m
    = S (S (S Z))            -- No more equations to match with

  *)

  section \<open>Types\<close>
  (* Every term in Isabelle must be typeable, e.g., it has a type. *)
  term "Z"
  term "S Z"

  term "S" (* Function type indicated by \<Rightarrow>  *)
  term "add" (* Function with many arguments. Note: \<Rightarrow> is right associative, i.e. "a\<Rightarrow>b\<Rightarrow>c" is same as "a\<Rightarrow>(b\<Rightarrow>c)" *)
  term "add (S Z) (S Z)"
  term "add (S Z)" (* Partial application *)

  (*
    Hint: press Ctrl (Mac: Cmd) and move the mouse over (almost) any item in the editor window.
      A tooltip will show further information. Left-click will move to the definition of the item.
  *)

  (* We may specify type with function definition. If no type specified,
    Isabelle infers most generic one (type inference). *)
  fun numnodes :: "bintree \<Rightarrow> my_nat" where
    "numnodes Leaf = Z"
  | "numnodes (Node t1 t2) = S (add (numnodes t1) (numnodes t2))"

  value "numnodes (Node (Node Leaf Leaf) (Node Leaf (Node Leaf Leaf)))"

  (* Type annotations may be added everywhere in term.
    To influence (restrict) inferred type *)
  term "CONS x xs"
  term "(CONS :: my_nat \<Rightarrow> my_nat my_list \<Rightarrow> my_nat my_list) (x::my_nat) xs"
  term "(CONS x xs)::my_nat my_list"

  (* Note: Variables and constants are displayed in different color! Useful to find typos! *)

  term "CONS x xs"
  term "C0NS x xs"

  (* Also, bound variables get different color. Bound variable:
    Occurs in pattern on left hand side of function equation
  *)
  fun double :: "my_nat \<Rightarrow> my_nat" where
    "double Z = Z"
  | "double (S n) = S (S (double n))"

  (* Don't get confused: The function that is actually being defined is rendered
    as a free variable!
  *)
  term double  (* It only becomes a constant after definition *)

  section \<open>Standard Library\<close>

  (* Of course, Isabelle has data types for natural numbers and lists in
        its standard library. Included by default! With many functions! *)

  typ nat
  term "42::nat"
  term "0::nat"
  term Suc

  typ "int"
  term "42::int"
  term "-42::int"

  term Suc
  (* Note: For numerals, you always have to specify the type *)
  term "Suc 41" (* Unless clear from type inference! *)
  term "(10::int) - 7"

  term "2+3"

  typ bool
  term True term False

  typ "'a\<times>'b"
  term "(True, False)"
  term "(10::nat, True, 5::int, 6::int)"
  term "(10::nat, (True, (5::int, 6::int)))"

  term fst term snd
  value "fst (snd (10::nat, True, 5::int, 6::int))"

  typ "'a list"
  term Nil term Cons
  term "[]" (* Nil *)
  term "x#l" (* Cons *)
  term "[a,b,c]" (* Syntax sugar for a#b#c#Nil *)
  term "l1@l2" (* append *)

  term "l1@l2#x1#x2@l3"

  (* Arithmetic operations overloaded for int and nat *)
  value "(3::int) + 7"
  value "(3::nat) + 7"

  value "(1::int)*3 - 4*5 + 2*6^2" (* Priority and associativity of standard operators is as expected *)

  lemma "x\<ge>y \<Longrightarrow> (x::nat) - y + y = x"  oops

  (* BEWARE: Subtraction on nat saturates at 0 *)
  value "(5::nat) - 10"

  (* BEWARE: Division on int rounds down. In many PLs (such as C), it rounds towards zero! *)
  value "(-3::int) div 2"

  (* Numbers in Isabelle are arbitrary precision! *)
  term "3871637126732613123526352635726456213527813658125817512332323232323::nat"
  (* Warning: Computing with this may be really slow!
    But Isabelle's main purpose is proving, not computing. *)

  value "(100::nat) + 1" (* A standard machine should take a few seconds for numbers around 1000..2000 here! *)

  lemma "(3871637126732613123526352635726456213527813658125817512332323232323::nat) > 0" by simp
    (* However, Isabelle proves this (obvious) lemma within a few milliseconds!
      Note: Proving lemmas will be introduced later!
    *)

  value "
       (77777777777777777777777777777777777777777777777777777::int)
      + 22222222222222222222222222222222222222222222222222222"
    (* It's much better for integers (they use binary representation internally), but still not super-fast! *)

  subsection \<open>Boolean Connectives\<close>

  term "a\<and>b \<or> c\<and>\<not>d    \<longrightarrow>    e"  (* Priority is as expected. Use symbols panel to find out how to type these symbols! *)

  (* Don't use *)
  term "a & b | c & ~d"

  (*
    Priority, from highest to lowest
      \<not>             not
      \<and>             and
      \<or>             or
      \<longrightarrow>, \<longleftrightarrow>      implies, equal
  *)

  (* Beware of using = for Booleans. It binds stronger than \<and>.  *)
  value \<open> let A=True; B=False in (A = B)  =  A\<and>B \<or> \<not>A\<and>\<not>B \<close>
    (* This should output True, shouldn't it? *)

    (* Actually, it means: *)
    declare [[show_brackets]]
    term "(A = B)  =  A\<and>B \<or> \<not>A\<and>\<not>B"
    declare [[show_brackets = false]] (* To not see all these brackets in the following *)

    (* However, we meant *)
    term "A = B \<longleftrightarrow> A\<and>B \<or> \<not>A\<and>\<not>B"

  (* Usually, this is encountered on function definitions: *)
  fun is_a_bit_smaller :: "int \<Rightarrow> int \<Rightarrow> bool" where
    "is_a_bit_smaller a b \<longleftrightarrow> a < b \<and> b-a < 10"

  subsection \<open>Some Simple Examples\<close>
  fun nth_odd :: "nat \<Rightarrow> nat" where
    "nth_odd 0 = 1"
  | "nth_odd (Suc n) = nth_odd n + 2"

  value "int (nth_odd 2)"

  (* YOU! Define nth_even! *)
  fun nth_even :: "nat \<Rightarrow> nat" where
    "nth_even 0 = 0"
  | "nth_even (Suc n) = nth_even n + 2"

  value "int (nth_even 4)"

  (* n\<^sup>2 can be computed as the sum of the first n odd numbers! *)
  fun square :: "nat \<Rightarrow> nat" where
    "square 0 = 0"
  | "square (Suc n) = nth_odd n + square n"

  value "square 2"
  value "int (square 5)" (* Using conversion to int for more readable output *)

  (* YOU: Define function sum :: nat list \<Rightarrow> nat that sums up the elements of a list.
    E.g. sum [3,4,5] = 12 *)

  fun sum :: "nat list \<Rightarrow> nat" where
    "sum [] = 0"
  | "sum (x#xs) = x + sum xs"

  value "int (sum [3,4,5])"

  (* YOU: Define Fibonacchi sequence: fib :: "nat \<Rightarrow> nat" where
    fib 0 = 0, fib 1 = 1, fib n = fib (n-2) + fib (n-1)
  *)

  (* YOU: Define function rep_list :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
    such that "rep_list n l = l @ \<dots> @ l  (n times)"
  *)

  fun rep_list :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "rep_list 0 l = []"
  | "rep_list (Suc n) l = l @ rep_list n l"

  value "rep_list 5 ''Hello World!''" (* Note: Strings are just lists of characters! *)
  typ string

  subsection \<open>Some list functions\<close>

  subsubsection \<open>Map\<close>

  term map
  value "map (\<lambda>x. x+1) [-1,-2,3,4,5::int]"
  (* Apply function to each element in list *)
  (* \<open>\<lambda>\<close> used to create ''anonymous'' function. *)
  term "\<lambda>x y z. Suc (x+y+z)" -- \<open>Multiple arguments\<close>

  (* In Isabelle/HOL, there are no side effects! A term's value will never
    change as the result of evaluating a term!
  *)
  value "let l=[1,2,3::int] in map (\<lambda>x. x+1) l @ map (\<lambda>x. x+1) l"

  subsubsection \<open>Filter\<close>

  definition "f x = (x>0)"
  value "filter f [-3,-6,3,4,-5,9::int]"

  value "filter (\<lambda>x. x>0) [-3,-6,3,4,-5,9::int]"
  (* Filter out elements that do not satisfy condition *)

  section \<open>Quicksort\<close>

  (* We select the first element as pivot.
    Note: Simpler than imperative in-situ implementation, as
      no swapping of array elements is required.
      However: Also less efficient :( But same worst and average case complexity!
  *)

  fun qsort :: "int list \<Rightarrow> int list" where
    "qsort [] = []"
  | "qsort (p#xs) = qsort (filter (\<lambda>x. x\<le>p) xs) @ p # qsort (filter (\<lambda>x. x>p) xs)"

  value "qsort [3,4,1,7,8,4]"

  subsection \<open>Outlook: Correctness proof\<close>

  (* Let's prove that quicksort actually sorts the list.
    We have to show:
      \<^enum> The elements and the number of each element is not altered by sorting
      \<^enum> The resulting list is sorted
  *)

  (* We show that the multiset of the result list is the same
    as the multiset of the original list.

    Multiset (sometimes called bag): Elements with counts, but no order.
  *)
  lemma qsort_pres_mset: "mset (qsort xs) = mset xs"
    apply (induction xs rule: qsort.induct)
    using mset_compl_union[where P="\<lambda>x::int. x\<le>p" for p, unfolded not_le]
    by auto

  (* We use the predicate sorted from the standard library
    to express sortedness of a list:
  *)
  lemma qsort_sorted: "sorted (qsort xs)"
    by (induction xs rule: qsort.induct)
       (auto simp: sorted_append sorted_Cons mset_eq_setD[OF qsort_pres_mset])

  (*For now, just ignore the proofs. After the Isabelle introduction, you'll
    be able to conduct similar proofs easily!*)

end


(*  Title:      HOL/Number_Theory/Residues.thy
    Author:     Jeremy Avigad

An algebraic treatment of residue rings, and resulting proofs of
Euler's theorem and Wilson's theorem.
*)

section {* Residue rings *}

theory Residues
imports
  UniqueFactorization
  Binomial
  MiscAlgebra
begin

(*

  A locale for residue rings

*)

definition residue_ring :: "int => int ring" where
  "residue_ring m == (|
    carrier =       {0..m - 1},
    mult =          (%x y. (x * y) mod m),
    one =           1,
    zero =          0,
    add =           (%x y. (x + y) mod m) |)"

locale residues =
  fixes m :: int and R (structure)
  assumes m_gt_one: "m > 1"
  defines "R == residue_ring m"

context residues
begin

lemma abelian_group: "abelian_group R"
  apply (insert m_gt_one)
  apply (rule abelian_groupI)
  apply (unfold R_def residue_ring_def)
  apply (auto simp add: mod_add_right_eq [symmetric] ac_simps)
  apply (case_tac "x = 0")
  apply force
  apply (subgoal_tac "(x + (m - x)) mod m = 0")
  apply (erule bexI)
  apply auto
  done

lemma comm_monoid: "comm_monoid R"
  apply (insert m_gt_one)
  apply (unfold R_def residue_ring_def)
  apply (rule comm_monoidI)
  apply auto
  apply (subgoal_tac "x * y mod m * z mod m = z * (x * y mod m) mod m")
  apply (erule ssubst)
  apply (subst mod_mult_right_eq [symmetric])+
  apply (simp_all only: ac_simps)
  done

lemma cring: "cring R"
  apply (rule cringI)
  apply (rule abelian_group)
  apply (rule comm_monoid)
  apply (unfold R_def residue_ring_def, auto)
  apply (subst mod_add_eq [symmetric])
  apply (subst mult.commute)
  apply (subst mod_mult_right_eq [symmetric])
  apply (simp add: field_simps)
  done

end

sublocale residues < cring
  by (rule cring)

context residues
begin

(* These lemmas translate back and forth between internal and
   external concepts *)

lemma res_carrier_eq: "carrier R = {0..m - 1}"
  unfolding R_def residue_ring_def by auto

lemma res_add_eq: "x \<oplus> y = (x + y) mod m"
  unfolding R_def residue_ring_def by auto

lemma res_mult_eq: "x \<otimes> y = (x * y) mod m"
  unfolding R_def residue_ring_def by auto

lemma res_zero_eq: "\<zero> = 0"
  unfolding R_def residue_ring_def by auto

lemma res_one_eq: "\<one> = 1"
  unfolding R_def residue_ring_def units_of_def by auto

lemma res_units_eq: "Units R = { x. 0 < x & x < m & coprime x m}"
  apply (insert m_gt_one)
  apply (unfold Units_def R_def residue_ring_def)
  apply auto
  apply (subgoal_tac "x ~= 0")
  apply auto
  apply (metis invertible_coprime_int)
  apply (subst (asm) coprime_iff_invertible'_int)
  apply (auto simp add: cong_int_def mult.commute)
  done

lemma res_neg_eq: "\<ominus> x = (- x) mod m"
  apply (insert m_gt_one)
  apply (unfold R_def a_inv_def m_inv_def residue_ring_def)
  apply auto
  apply (rule the_equality)
  apply auto
  apply (subst mod_add_right_eq [symmetric])
  apply auto
  apply (subst mod_add_left_eq [symmetric])
  apply auto
  apply (subgoal_tac "y mod m = - x mod m")
  apply simp
  apply (metis minus_add_cancel mod_mult_self1 mult.commute)
  done

lemma finite [iff]: "finite (carrier R)"
  by (subst res_carrier_eq, auto)

lemma finite_Units [iff]: "finite (Units R)"
  by (subst res_units_eq) auto

(* The function a -> a mod m maps the integers to the
   residue classes. The following lemmas show that this mapping
   respects addition and multiplication on the integers. *)

lemma mod_in_carrier [iff]: "a mod m : carrier R"
  apply (unfold res_carrier_eq)
  apply (insert m_gt_one, auto)
  done

lemma add_cong: "(x mod m) \<oplus> (y mod m) = (x + y) mod m"
  unfolding R_def residue_ring_def
  apply auto
  apply presburger
  done

lemma mult_cong: "(x mod m) \<otimes> (y mod m) = (x * y) mod m"
  unfolding R_def residue_ring_def
  by auto (metis mod_mult_eq)

lemma zero_cong: "\<zero> = 0"
  unfolding R_def residue_ring_def by auto

lemma one_cong: "\<one> = 1 mod m"
  using m_gt_one unfolding R_def residue_ring_def by auto

(* revise algebra library to use 1? *)
lemma pow_cong: "(x mod m) (^) n = x^n mod m"
  apply (insert m_gt_one)
  apply (induct n)
  apply (auto simp add: nat_pow_def one_cong)
  apply (metis mult.commute mult_cong)
  done

lemma neg_cong: "\<ominus> (x mod m) = (- x) mod m"
  by (metis mod_minus_eq res_neg_eq)

lemma (in residues) prod_cong:
    "finite A \<Longrightarrow> (\<Otimes> i:A. (f i) mod m) = (PROD i:A. f i) mod m"
  by (induct set: finite) (auto simp: one_cong mult_cong)

lemma (in residues) sum_cong:
    "finite A \<Longrightarrow> (\<Oplus> i:A. (f i) mod m) = (SUM i: A. f i) mod m"
  by (induct set: finite) (auto simp: zero_cong add_cong)

lemma mod_in_res_units [simp]: "1 < m \<Longrightarrow> coprime a m \<Longrightarrow>
    a mod m : Units R"
  apply (subst res_units_eq, auto)
  apply (insert pos_mod_sign [of m a])
  apply (subgoal_tac "a mod m ~= 0")
  apply arith
  apply auto
  apply (metis gcd_int.commute gcd_red_int)
  done

lemma res_eq_to_cong: "((a mod m) = (b mod m)) = [a = b] (mod (m::int))"
  unfolding cong_int_def by auto

(* Simplifying with these will translate a ring equation in R to a
   congruence. *)

lemmas res_to_cong_simps = add_cong mult_cong pow_cong one_cong
    prod_cong sum_cong neg_cong res_eq_to_cong

(* Other useful facts about the residue ring *)

lemma one_eq_neg_one: "\<one> = \<ominus> \<one> \<Longrightarrow> m = 2"
  apply (simp add: res_one_eq res_neg_eq)
  apply (metis add.commute add_diff_cancel mod_mod_trivial one_add_one uminus_add_conv_diff
            zero_neq_one zmod_zminus1_eq_if)
  done

end

(* prime residues *)

locale residues_prime =
  fixes p and R (structure)
  assumes p_prime [intro]: "prime p"
  defines "R == residue_ring p"

sublocale residues_prime < residues p
  apply (unfold R_def residues_def)
  using p_prime apply auto
  apply (metis (full_types) int_1 of_nat_less_iff prime_gt_1_nat)
  done

context residues_prime
begin

lemma is_field: "field R"
  apply (rule cring.field_intro2)
  apply (rule cring)
  apply (auto simp add: res_carrier_eq res_one_eq res_zero_eq res_units_eq)
  apply (rule classical)
  apply (erule notE)
  apply (subst gcd_commute_int)
  apply (rule prime_imp_coprime_int)
  apply (rule p_prime)
  apply (rule notI)
  apply (frule zdvd_imp_le)
  apply auto
  done

lemma res_prime_units_eq: "Units R = {1..p - 1}"
  apply (subst res_units_eq)
  apply auto
  apply (subst gcd_commute_int)
  apply (auto simp add: p_prime prime_imp_coprime_int zdvd_not_zless)
  done

end

sublocale residues_prime < field
  by (rule is_field)

(*
  Test cases: Euler's theorem and Wilson's theorem.
*)

subsection{* Euler's theorem *}

(* the definition of the phi function *)

definition phi :: "int => nat"
  where "phi m = card({ x. 0 < x & x < m & gcd x m = 1})"

lemma phi_def_nat: "phi m = card({ x. 0 < x & x < nat m & gcd x (nat m) = 1})"
  apply (simp add: phi_def)
  apply (rule bij_betw_same_card [of nat])
  apply (auto simp add: inj_on_def bij_betw_def image_def)
  apply (metis dual_order.irrefl dual_order.strict_trans leI nat_1 transfer_nat_int_gcd(1))
  apply (metis One_nat_def int_0 int_1 int_less_0_conv int_nat_eq nat_int transfer_int_nat_gcd(1) zless_int)
  done

lemma prime_phi:
  assumes  "2 \<le> p" "phi p = p - 1" shows "prime p"
proof -
  have "{x. 0 < x \<and> x < p \<and> coprime x p} = {1..p - 1}"
    using assms unfolding phi_def_nat
    by (intro card_seteq) fastforce+
  then have cop: "\<And>x. x \<in> {1::nat..p - 1} \<Longrightarrow> coprime x p"
    by blast
  { fix x::nat assume *: "1 < x" "x < p" and "x dvd p"
    have "coprime x p"
      apply (rule cop)
      using * apply auto
      done
    with `x dvd p` `1 < x` have "False" by auto }
  then show ?thesis
    using `2 \<le> p`
    by (simp add: prime_def)
       (metis One_nat_def dvd_pos_nat nat_dvd_not_less nat_neq_iff not_gr0
              not_numeral_le_zero one_dvd)
qed

lemma phi_zero [simp]: "phi 0 = 0"
  apply (subst phi_def)
(* Auto hangs here. Once again, where is the simplification rule
   1 == Suc 0 coming from? *)
  apply (auto simp add: card_eq_0_iff)
(* Add card_eq_0_iff as a simp rule? delete card_empty_imp? *)
  done

lemma phi_one [simp]: "phi 1 = 0"
  by (auto simp add: phi_def card_eq_0_iff)

lemma (in residues) phi_eq: "phi m = card(Units R)"
  by (simp add: phi_def res_units_eq)

lemma (in residues) euler_theorem1:
  assumes a: "gcd a m = 1"
  shows "[a^phi m = 1] (mod m)"
proof -
  from a m_gt_one have [simp]: "a mod m : Units R"
    by (intro mod_in_res_units)
  from phi_eq have "(a mod m) (^) (phi m) = (a mod m) (^) (card (Units R))"
    by simp
  also have "\<dots> = \<one>"
    by (intro units_power_order_eq_one, auto)
  finally show ?thesis
    by (simp add: res_to_cong_simps)
qed

(* In fact, there is a two line proof!

lemma (in residues) euler_theorem1:
  assumes a: "gcd a m = 1"
  shows "[a^phi m = 1] (mod m)"
proof -
  have "(a mod m) (^) (phi m) = \<one>"
    by (simp add: phi_eq units_power_order_eq_one a m_gt_one)
  then show ?thesis
    by (simp add: res_to_cong_simps)
qed

*)

(* outside the locale, we can relax the restriction m > 1 *)

lemma euler_theorem:
  assumes "m >= 0" and "gcd a m = 1"
  shows "[a^phi m = 1] (mod m)"
proof (cases)
  assume "m = 0 | m = 1"
  then show ?thesis by auto
next
  assume "~(m = 0 | m = 1)"
  with assms show ?thesis
    by (intro residues.euler_theorem1, unfold residues_def, auto)
qed

lemma (in residues_prime) phi_prime: "phi p = (nat p - 1)"
  apply (subst phi_eq)
  apply (subst res_prime_units_eq)
  apply auto
  done

lemma phi_prime: "prime p \<Longrightarrow> phi p = (nat p - 1)"
  apply (rule residues_prime.phi_prime)
  apply (erule residues_prime.intro)
  done

lemma fermat_theorem:
  fixes a::int
  assumes "prime p" and "~ (p dvd a)"
  shows "[a^(p - 1) = 1] (mod p)"
proof -
  from assms have "[a^phi p = 1] (mod p)"
    apply (intro euler_theorem)
    apply (metis of_nat_0_le_iff)
    apply (metis gcd_int.commute prime_imp_coprime_int)
    done
  also have "phi p = nat p - 1"
    by (rule phi_prime, rule assms)
  finally show ?thesis
    by (metis nat_int)
qed

lemma fermat_theorem_nat:
  assumes "prime p" and "~ (p dvd a)"
  shows "[a^(p - 1) = 1] (mod p)"
using fermat_theorem [of p a] assms
by (metis int_1 of_nat_power transfer_int_nat_cong zdvd_int)

subsection {* Wilson's theorem *}

lemma (in field) inv_pair_lemma: "x : Units R \<Longrightarrow> y : Units R \<Longrightarrow>
    {x, inv x} ~= {y, inv y} \<Longrightarrow> {x, inv x} Int {y, inv y} = {}"
  apply auto
  apply (metis Units_inv_inv)+
  done

lemma (in residues_prime) wilson_theorem1:
  assumes a: "p > 2"
  shows "[fact (p - 1) = - 1] (mod p)"
proof -
  let ?InversePairs = "{ {x, inv x} | x. x : Units R - {\<one>, \<ominus> \<one>}}"
  have UR: "Units R = {\<one>, \<ominus> \<one>} Un (Union ?InversePairs)"
    by auto
  have "(\<Otimes>i: Units R. i) =
    (\<Otimes>i: {\<one>, \<ominus> \<one>}. i) \<otimes> (\<Otimes>i: Union ?InversePairs. i)"
    apply (subst UR)
    apply (subst finprod_Un_disjoint)
    apply (auto intro: funcsetI)
    apply (metis Units_inv_inv inv_one inv_neg_one)+
    done
  also have "(\<Otimes>i: {\<one>, \<ominus> \<one>}. i) = \<ominus> \<one>"
    apply (subst finprod_insert)
    apply auto
    apply (frule one_eq_neg_one)
    apply (insert a, force)
    done
  also have "(\<Otimes>i:(Union ?InversePairs). i) =
      (\<Otimes>A: ?InversePairs. (\<Otimes>y:A. y))"
    apply (subst finprod_Union_disjoint, auto)
    apply (metis Units_inv_inv)+
    done
  also have "\<dots> = \<one>"
    apply (rule finprod_one, auto)
    apply (subst finprod_insert, auto)
    apply (metis inv_eq_self)
    done
  finally have "(\<Otimes>i: Units R. i) = \<ominus> \<one>"
    by simp
  also have "(\<Otimes>i: Units R. i) = (\<Otimes>i: Units R. i mod p)"
    apply (rule finprod_cong')
    apply (auto)
    apply (subst (asm) res_prime_units_eq)
    apply auto
    done
  also have "\<dots> = (PROD i: Units R. i) mod p"
    apply (rule prod_cong)
    apply auto
    done
  also have "\<dots> = fact (p - 1) mod p"
    apply (subst fact_altdef_nat)
    apply (insert assms)
    apply (subst res_prime_units_eq)
    apply (simp add: int_setprod zmod_int setprod_int_eq)
    done
  finally have "fact (p - 1) mod p = \<ominus> \<one>".
  then show ?thesis
    by (metis Divides.transfer_int_nat_functions(2) cong_int_def res_neg_eq res_one_eq)
qed

lemma wilson_theorem:
  assumes "prime p" shows "[fact (p - 1) = - 1] (mod p)"
proof (cases "p = 2")
  case True
  then show ?thesis
    by (simp add: cong_int_def fact_altdef_nat)
next
  case False
  then show ?thesis
    using assms prime_ge_2_nat
    by (metis residues_prime.wilson_theorem1 residues_prime.intro le_eq_less_or_eq)
qed

end


theory ex3_04 imports Main begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp = N int | V vname | Plus aexp aexp | Times aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s" |
"aval (Times a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s * aval a\<^sub>2 s"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"times (N n) (N m) = N (n*m)" |
"times (N n) a = (if n = 0 then N 0 else if n = 1 then a else Times (N n) a)" |
"times a (N n) = (if n = 0 then N 0 else if n = 1 then a else Times a (N n))" |
"times a b = Times a b"

lemma aval_times[simp]:
  "aval (times a1 a2) s = aval a1 s * aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)" |
"asimp (Times a\<^sub>1 a\<^sub>2) = times (asimp a\<^sub>1) (asimp a\<^sub>2)"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end