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

  Random permutations and folding over them.
  This provides the basic theory for the concept of doing something
  in a random order, e.g. inserting elements from a fixed set into a
  data structure in random order.
*)

section \<open>Random Permutations\<close>

theory Random_Permutations
imports
  "~~/src/HOL/Probability/Probability_Mass_Function"
  "HOL-Library.Multiset_Permutations"
begin

text \<open>
  Choosing a set permutation (i.e. a distinct list with the same elements as the set)
  uniformly at random is the same as first choosing the first element of the list
  and then choosing the rest of the list as a permutation of the remaining set.
\<close>
lemma random_permutation_of_set:
  assumes "finite A" "A \<noteq> {}"
  shows   "pmf_of_set (permutations_of_set A) =
             do {
               x \<leftarrow> pmf_of_set A;
               xs \<leftarrow> pmf_of_set (permutations_of_set (A - {x}));
               return_pmf (x#xs)
             }" (is "?lhs = ?rhs")
proof -
  from assms have "permutations_of_set A = (\<Union>x\<in>A. (#) x ` permutations_of_set (A - {x}))"
    by (simp add: permutations_of_set_nonempty)
  also from assms have "pmf_of_set \<dots> = ?rhs"
    by (subst pmf_of_set_UN[where n = "fact (card A - 1)"])
       (auto simp: card_image disjoint_family_on_def map_pmf_def [symmetric] map_pmf_of_set_inj)
  finally show ?thesis .
qed

text \<open>
  A generic fold function that takes a function, an initial state, and a set
  and chooses a random order in which it then traverses the set in the same
  fashion as a left fold over a list.
    We first give a recursive definition.
\<close>
function fold_random_permutation :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b pmf" where
  "fold_random_permutation f x {} = return_pmf x"
| "\<not>finite A \<Longrightarrow> fold_random_permutation f x A = return_pmf x"
| "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
     fold_random_permutation f x A =
       pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}))"
by (force, simp_all)
termination proof (relation "Wellfounded.measure (\<lambda>(_,_,A). card A)")
  fix A :: "'a set" and f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b and y :: 'a
  assume A: "finite A" "A \<noteq> {}" "y \<in> set_pmf (pmf_of_set A)"
  then have "card A > 0" by (simp add: card_gt_0_iff)
  with A show "((f, f y x, A - {y}), f, x, A) \<in> Wellfounded.measure (\<lambda>(_, _, A). card A)"
    by simp
qed simp_all

text \<open>
  We can now show that the above recursive definition is equivalent to
  choosing a random set permutation and folding over it (in any direction).
\<close>
lemma fold_random_permutation_foldl:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set A))"
using assms
proof (induction f x A rule: fold_random_permutation.induct [case_names empty infinite remove])
  case (remove A f x)
  from remove
    have "fold_random_permutation f x A =
            pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}))" by simp
  also from remove
    have "\<dots> = pmf_of_set A \<bind> (\<lambda>a. map_pmf (foldl (\<lambda>x y. f y x) x)
                 (map_pmf ((#) a) (pmf_of_set (permutations_of_set (A - {a})))))"
      by (intro bind_pmf_cong) (simp_all add: pmf.map_comp o_def)
  also from remove have "\<dots> = map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set A))"
    by (simp_all add: random_permutation_of_set map_bind_pmf map_pmf_def [symmetric])
  finally show ?case .
qed (simp_all add: pmf_of_set_singleton)

lemma fold_random_permutation_foldr:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (\<lambda>xs. foldr f xs x) (pmf_of_set (permutations_of_set A))"
proof -
  have "fold_random_permutation f x A =
          map_pmf (foldl (\<lambda>x y. f y x) x \<circ> rev) (pmf_of_set (permutations_of_set A))"
    using assms by (subst fold_random_permutation_foldl [OF assms])
                   (simp_all add: pmf.map_comp [symmetric] map_pmf_of_set_inj)
  also have "foldl (\<lambda>x y. f y x) x \<circ> rev = (\<lambda>xs. foldr f xs x)"
    by (intro ext) (simp add: foldl_conv_foldr)
  finally show ?thesis .
qed

lemma fold_random_permutation_fold:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (\<lambda>xs. fold f xs x) (pmf_of_set (permutations_of_set A))"
  by (subst fold_random_permutation_foldl [OF assms], intro map_pmf_cong)
     (simp_all add: foldl_conv_fold)

lemma fold_random_permutation_code [code]:
  "fold_random_permutation f x (set xs) =
     map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set (set xs)))"
  by (simp add: fold_random_permutation_foldl)

text \<open>
  We now introduce a slightly generalised version of the above fold
  operation that does not simply return the result in the end, but applies
  a monadic bind to it.
    This may seem somewhat arbitrary, but it is a common use case, e.g.
  in the Social Decision Scheme of Random Serial Dictatorship, where
  voters narrow down a set of possible winners in a random order and
  the winner is chosen from the remaining set uniformly at random.
\<close>
function fold_bind_random_permutation
    :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c pmf) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'c pmf" where
  "fold_bind_random_permutation f g x {} = g x"
| "\<not>finite A \<Longrightarrow> fold_bind_random_permutation f g x A = g x"
| "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
     fold_bind_random_permutation f g x A =
       pmf_of_set A \<bind> (\<lambda>a. fold_bind_random_permutation f g (f a x) (A - {a}))"
by (force, simp_all)
termination proof (relation "Wellfounded.measure (\<lambda>(_,_,_,A). card A)")
  fix A :: "'a set" and f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b
    and y :: 'a and g :: "'b \<Rightarrow> 'c pmf"
  assume A: "finite A" "A \<noteq> {}" "y \<in> set_pmf (pmf_of_set A)"
  then have "card A > 0" by (simp add: card_gt_0_iff)
  with A show "((f, g, f y x, A - {y}), f, g, x, A) \<in> Wellfounded.measure (\<lambda>(_, _, _, A). card A)"
    by simp
qed simp_all

text \<open>
  We now show that the recursive definition is equivalent to
  a random fold followed by a monadic bind.
\<close>
lemma fold_bind_random_permutation_altdef [code]:
  "fold_bind_random_permutation f g x A = fold_random_permutation f x A \<bind> g"
proof (induction f x A rule: fold_random_permutation.induct [case_names empty infinite remove])
  case (remove A f x)
  from remove have "pmf_of_set A \<bind> (\<lambda>a. fold_bind_random_permutation f g (f a x) (A - {a})) =
                      pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}) \<bind> g)"
    by (intro bind_pmf_cong) simp_all
  with remove show ?case by (simp add: bind_return_pmf bind_assoc_pmf)
qed (simp_all add: bind_return_pmf)

text \<open>
  We can now derive the following nice monadic representations of the
  combined fold-and-bind:
\<close>
lemma fold_bind_random_permutation_foldl:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (foldl (\<lambda>x y. f y x) x xs)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_foldl bind_return_pmf map_pmf_def)

lemma fold_bind_random_permutation_foldr:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (foldr f xs x)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_foldr bind_return_pmf map_pmf_def)

lemma fold_bind_random_permutation_fold:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (fold f xs x)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_fold bind_return_pmf map_pmf_def)

text \<open>
  The following useful lemma allows us to swap partitioning a set w.\,r.\,t.\ a
  predicate and drawing a random permutation of that set.
\<close>
lemma partition_random_permutations:
  assumes "finite A"
  shows   "map_pmf (partition P) (pmf_of_set (permutations_of_set A)) =
             pair_pmf (pmf_of_set (permutations_of_set {x\<in>A. P x}))
                      (pmf_of_set (permutations_of_set {x\<in>A. \<not>P x}))" (is "?lhs = ?rhs")
proof (rule pmf_eqI, clarify, goal_cases)
  case (1 xs ys)
  show ?case
  proof (cases "xs \<in> permutations_of_set {x\<in>A. P x} \<and> ys \<in> permutations_of_set {x\<in>A. \<not>P x}")
    case True
    let ?n1 = "card {x\<in>A. P x}" and ?n2 = "card {x\<in>A. \<not>P x}"
    have card_eq: "card A = ?n1 + ?n2"
    proof -
      have "?n1 + ?n2 = card ({x\<in>A. P x} \<union> {x\<in>A. \<not>P x})"
        using assms by (intro card_Un_disjoint [symmetric]) auto
      also have "{x\<in>A. P x} \<union> {x\<in>A. \<not>P x} = A" by blast
      finally show ?thesis ..
    qed

    from True have lengths [simp]: "length xs = ?n1" "length ys = ?n2"
      by (auto intro!: length_finite_permutations_of_set)
    have "pmf ?lhs (xs, ys) =
            real (card (permutations_of_set A \<inter> partition P -` {(xs, ys)})) / fact (card A)"
      using assms by (auto simp: pmf_map measure_pmf_of_set)
    also have "partition P -` {(xs, ys)} = shuffles xs ys"
      using True by (intro inv_image_partition) (auto simp: permutations_of_set_def)
    also have "permutations_of_set A \<inter> shuffles xs ys = shuffles xs ys"
      using True distinct_disjoint_shuffles[of xs ys]
      by (auto simp: permutations_of_set_def dest: set_shuffles)
    also have "card (shuffles xs ys) = length xs + length ys choose length xs"
      using True by (intro card_disjoint_shuffles) (auto simp: permutations_of_set_def)
    also have "length xs + length ys = card A" by (simp add: card_eq)
    also have "real (card A choose length xs) = fact (card A) / (fact ?n1 * fact (card A - ?n1))"
      by (subst binomial_fact) (auto intro!: card_mono assms)
    also have "\<dots> / fact (card A) = 1 / (fact ?n1 * fact ?n2)"
      by (simp add: field_split_simps card_eq)
    also have "\<dots> = pmf ?rhs (xs, ys)" using True assms by (simp add: pmf_pair)
    finally show ?thesis .
  next
    case False
    hence *: "xs \<notin> permutations_of_set {x\<in>A. P x} \<or> ys \<notin> permutations_of_set {x\<in>A. \<not>P x}" by blast
    hence eq: "permutations_of_set A \<inter> (partition P -` {(xs, ys)}) = {}"
      by (auto simp: o_def permutations_of_set_def)
    from * show ?thesis
      by (elim disjE) (insert assms eq, simp_all add: pmf_pair pmf_map measure_pmf_of_set)
  qed
qed

end


(*  Author: Tobias Nipkow, 2007 *)

section \<open>Lists as vectors\<close>

theory ListVector
imports List Main
begin

text\<open>\noindent
A vector-space like structure of lists and arithmetic operations on them.
Is only a vector space if restricted to lists of the same length.\<close>

text\<open>Multiplication with a scalar:\<close>

abbreviation scale :: "('a::times) \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "*\<^sub>s" 70)
where "x *\<^sub>s xs \<equiv> map (op * x) xs"

lemma scale1[simp]: "(1::'a::monoid_mult) *\<^sub>s xs = xs"
by (induct xs) simp_all

subsection \<open>\<open>+\<close> and \<open>-\<close>\<close>

fun zipwith0 :: "('a::zero \<Rightarrow> 'b::zero \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
where
"zipwith0 f [] [] = []" |
"zipwith0 f (x#xs) (y#ys) = f x y # zipwith0 f xs ys" |
"zipwith0 f (x#xs) [] = f x 0 # zipwith0 f xs []" |
"zipwith0 f [] (y#ys) = f 0 y # zipwith0 f [] ys"

instantiation list :: ("{zero, plus}") plus
begin

definition
  list_add_def: "op + = zipwith0 (op +)"

instance ..

end

instantiation list :: ("{zero, uminus}") uminus
begin

definition
  list_uminus_def: "uminus = map uminus"

instance ..

end

instantiation list :: ("{zero,minus}") minus
begin

definition
  list_diff_def: "op - = zipwith0 (op -)"

instance ..

end

lemma zipwith0_Nil[simp]: "zipwith0 f [] ys = map (f 0) ys"
by(induct ys) simp_all

lemma list_add_Nil[simp]: "[] + xs = (xs::'a::monoid_add list)"
by (induct xs) (auto simp:list_add_def)

lemma list_add_Nil2[simp]: "xs + [] = (xs::'a::monoid_add list)"
by (induct xs) (auto simp:list_add_def)

lemma list_add_Cons[simp]: "(x#xs) + (y#ys) = (x+y)#(xs+ys)"
by(auto simp:list_add_def)

lemma list_diff_Nil[simp]: "[] - xs = -(xs::'a::group_add list)"
by (induct xs) (auto simp:list_diff_def list_uminus_def)

lemma list_diff_Nil2[simp]: "xs - [] = (xs::'a::group_add list)"
by (induct xs) (auto simp:list_diff_def)

lemma list_diff_Cons_Cons[simp]: "(x#xs) - (y#ys) = (x-y)#(xs-ys)"
by (induct xs) (auto simp:list_diff_def)

lemma list_uminus_Cons[simp]: "-(x#xs) = (-x)#(-xs)"
by (induct xs) (auto simp:list_uminus_def)

lemma self_list_diff:
  "xs - xs = replicate (length(xs::'a::group_add list)) 0"
by(induct xs) simp_all

lemma list_add_assoc: fixes xs :: "'a::monoid_add list"
shows "(xs+ys)+zs = xs+(ys+zs)"
apply(induct xs arbitrary: ys zs)
 apply simp
apply(case_tac ys)
 apply(simp)
apply(simp)
apply(case_tac zs)
 apply(simp)
apply(simp add: add.assoc)
done

subsection "Inner product"

definition iprod :: "'a::ring list \<Rightarrow> 'a list \<Rightarrow> 'a" ("\<langle>_,_\<rangle>") where
"\<langle>xs,ys\<rangle> = (\<Sum>(x,y) \<leftarrow> zip xs ys. x*y)"

lemma iprod_Nil[simp]: "\<langle>[],ys\<rangle> = 0"
by(simp add: iprod_def)

lemma iprod_Nil2[simp]: "\<langle>xs,[]\<rangle> = 0"
by(simp add: iprod_def)

lemma iprod_Cons[simp]: "\<langle>x#xs,y#ys\<rangle> = x*y + \<langle>xs,ys\<rangle>"
by(simp add: iprod_def)

lemma iprod0_if_coeffs0: "\<forall>c\<in>set cs. c = 0 \<Longrightarrow> \<langle>cs,xs\<rangle> = 0"
apply(induct cs arbitrary:xs)
 apply simp
apply(case_tac xs) apply simp
apply auto
done

lemma iprod_uminus[simp]: "\<langle>-xs,ys\<rangle> = -\<langle>xs,ys\<rangle>"
by(simp add: iprod_def uminus_sum_list_map o_def split_def map_zip_map list_uminus_def)

lemma iprod_left_add_distrib: "\<langle>xs + ys,zs\<rangle> = \<langle>xs,zs\<rangle> + \<langle>ys,zs\<rangle>"
apply(induct xs arbitrary: ys zs)
apply (simp add: o_def split_def)
apply(case_tac ys)
apply simp
apply(case_tac zs)
apply (simp)
apply(simp add: distrib_right)
done

lemma iprod_left_diff_distrib: "\<langle>xs - ys, zs\<rangle> = \<langle>xs,zs\<rangle> - \<langle>ys,zs\<rangle>"
apply(induct xs arbitrary: ys zs)
apply (simp add: o_def split_def)
apply(case_tac ys)
apply simp
apply(case_tac zs)
apply (simp)
apply(simp add: left_diff_distrib)
done

lemma iprod_assoc: "\<langle>x *\<^sub>s xs, ys\<rangle> = x * \<langle>xs,ys\<rangle>"
apply(induct xs arbitrary: ys)
apply simp
apply(case_tac ys)
apply (simp)
apply (simp add: distrib_left mult.assoc)
done

end


(* ---------------------------------------------------------------------------- *)
subsection \<open>Library Aditions for Set Cardinality\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>In this sections some additional simple lemmas about set cardinality are proved.\<close>

theory More_Set
imports Main
begin

text \<open>Every infinite set has at least two different elements\<close>
lemma infinite_contains_2_elems:
  assumes "infinite A"
  shows "\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
proof(rule ccontr)
  assume *: " \<nexists>x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
  have "\<exists> x. x \<in> A "
    using assms
    by (simp add: ex_in_conv infinite_imp_nonempty)
  hence "card A = 1"
    using *
    by (metis assms ex_in_conv finite_insert infinite_imp_nonempty insertCI mk_disjoint_insert)
  thus False
    using assms
    by simp
qed

text \<open>Every infinite set has at least three different elements\<close>
lemma infinite_contains_3_elems:
  assumes "infinite A"
  shows "\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
proof(rule ccontr)
  assume " \<nexists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
  hence "card A = 2"
    by (smt DiffE assms finite_insert infinite_contains_2_elems insert_Diff insert_iff)
  thus False
    using assms
    by simp
qed

text \<open>Every set with cardinality greater than 1 has at least two different elements\<close>
lemma card_geq_2_iff_contains_2_elems:
  shows "card A \<ge> 2 \<longleftrightarrow> finite A \<and> (\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A)"
proof
  assume *: "finite A \<and> (\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A)"
  thus "card A \<ge> 2"
  proof -
    obtain a :: 'a and b :: 'a where
      f1: "a \<noteq> b \<and> a \<in> A \<and> b \<in> A"
      using *
      by blast
    then have "0 < card (A - {b})"
      by (metis * card_eq_0_iff ex_in_conv finite_insert insertE insert_Diff neq0_conv)
    then show ?thesis
      using f1 by (simp add: *)
  qed
next
  assume *: " 2 \<le> card A"
  hence "finite A"
    using card_infinite
    by force
  moreover
  have "\<exists>x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
  proof(rule ccontr)
    assume " \<nexists>x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
    hence "card A \<le> 1"
      by (metis One_nat_def card.empty card.insert card_mono finite.emptyI finite_insert insertCI le_SucI subsetI)
    thus False
      using *
      by auto
  qed
  ultimately
  show "finite A \<and> (\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A)"
    by simp
qed

text \<open>Set cardinality is at least 3 if and only if it contains three different elements\<close>
lemma card_geq_3_iff_contains_3_elems:
  shows "card A \<ge> 3 \<longleftrightarrow> finite A \<and> (\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A)"
proof
  assume *: "card A \<ge> 3"
  hence "finite A"
    using card_infinite
    by force
  moreover
  have "\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
  proof(rule ccontr)
    assume "\<nexists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
    hence "card A \<le> 2"
      by (smt DiffE Suc_leI card.remove card_geq_2_iff_contains_2_elems insert_iff le_cases not_le)
    thus False
      using *
      by auto
  qed
  ultimately
  show "finite A \<and> (\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A)"
    by simp
next
  assume *: "finite A \<and> (\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A)"
  thus "card A \<ge> 3"
    by (smt "*" Suc_eq_numeral Suc_le_mono card.remove card_geq_2_iff_contains_2_elems finite_insert insert_Diff insert_iff pred_numeral_simps(3))
qed

text \<open>Set cardinality of A is equal to 2 if and only if A={x, y} for two different elements x and y\<close>
lemma card_eq_2_iff_doubleton: "card A = 2 \<longleftrightarrow> (\<exists> x y. x \<noteq> y \<and> A = {x, y})"
  using card_geq_2_iff_contains_2_elems[of A]
  using card_geq_3_iff_contains_3_elems[of A]
  by auto (rule_tac x=x in exI, rule_tac x=y in exI, auto)

lemma card_eq_2_doubleton:
  assumes "card A = 2" and "x \<noteq> y" and "x \<in> A" and "y \<in> A"
  shows "A = {x, y}"
  using assms
  using card_eq_2_iff_doubleton[of A]
  by auto

text \<open>Bijections map singleton to singleton sets\<close>

lemma bij_image_singleton:
  shows "\<lbrakk>f ` A = {b}; f a = b; bij f\<rbrakk> \<Longrightarrow> A = {a}"
  by (metis (mono_tags) bij_betw_imp_inj_on image_empty image_insert inj_vimage_image_eq)

end


theory Playground
  imports Main
begin

(*
datatype boolean = True | False

fun conjuction :: "boolean \<Rightarrow> boolean \<Rightarrow> boolean" where
"conjuction True True = True" |
"conjuction _    _    = False"
*)

(*
fun double :: "nat \<Rightarrow> nat" where
"double x = x + x"
*)

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

lemma add_0: "add m 0 = m"
apply(induction m) (* Do the induction on m, thus splitting initial goal into two subgoals *)
apply(auto)        (* Try to prove subgoals automatically - i.e. using simplification *)
done

(* NB Natural numbers and arithmetic operators are overloaded. *)

(* thm add_02: add 10 0 = 10 done *)

(* Don't qualify ambiguous names when printing, i.e. print "lst" constructors unqualified *)
declare [[names_short]]

(* NB can omit quotes around variables, e.g. datatype 'a lst = Nil | Cons 'a "'a lst" *)
datatype 'a lst = Nil | Cons "'a" "'a lst"

thm lst.rec
thm lst.rec[no_vars]
print_theorems

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

fun reverse_go :: "'a lst \<Rightarrow> 'a lst \<Rightarrow> 'a lst" where
"reverse_go Nil         ys = ys" |
"reverse_go (Cons x xs) ys = reverse_go xs (Cons x ys)"

fun reverse :: "'a lst \<Rightarrow> 'a lst" where
"reverse xs = reverse_go xs Nil"

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

(* The "value" command evaluates a term *)
value "add 1 (add 2 0)"

value "reverse (Cons False (Cons True (Cons True Nil)))"

(* Can also work symbolically *)
value "reverse (Cons (a + 1) (Cons b Nil))"

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

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

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

(* Define new theorem (can be a lemma, all the same). The [simp] annotation means that it will
   be automatically applied when using simplification to prove new theorems. *)
theorem rev'_rev' [simp] : "rev' (rev' xs) = xs"
apply(induction xs)
apply(simp)
apply(simp)
done

value "rev (rev xs)"

(* Predefined lists:
   []                - empty list
   x # xs            - cons x onto xs
   [x1, x2, ..., xn] = x1 # x2 # ... # xn # []
   xs @ ys           - append xs and ys

   List library:
   length :: 'a list \<Rightarrow> nat
   map    :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list
   hd     :: 'a list \<Rightarrow> 'a
   tl     :: 'a list \<Rightarrow> 'a list
   sum_list :: 'a list \<Rightarrow> 'a
   *)

(* HOL is a logic of total functions, the head function (as well as hd) has some result on
   empty list, but we don't know what it is.

   Thus (head []) is underdefined rather than undefined. This means that head [] will not be
   simplified (reduced).
   *)

fun head :: "'a lst \<Rightarrow> 'a" where
"head (Cons x xs) = x"

value "head Nil"

value "f \<circ> g"

(* Exercises 2.2 *)

(* 2.1 *)

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

(* 2.2 *)

theorem add_associative : "add (add x y) z = add x (add y z)"
apply(induction x)
apply(auto)
done

theorem add0 [simp] : "add x 0 = x"
apply(induction x)
apply(auto)
done

theorem add_nonzero_snd [simp] : "add x (Suc y) = Suc (add x y)"
apply(induction x)
apply(auto)
done

theorem add_commutative : "add x y = add y x"
apply(induction x)
apply(auto)
done

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

theorem double_eq_add [simp] : "double x = add x x"
apply(induction x)
apply(simp)
apply(simp)
(*apply(auto)*)
done

(* 2.3 *)

fun cond :: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"cond True  t _ = t" |
"cond False _ f = f"

(*
theorem cond_nonzero_left [simp] : "(x \<le> y) \<and> (cond c (Suc x) x \<le> Suc y)"
apply(induction c)
apply(auto)
done
*)

lemma cond_distribute [simp] : "cond c t f \<le> x = cond c (t \<le> x) (f \<le> x)"
apply(induction c)
apply(auto)
done

lemma cond_same_opt_branches [simp] : "cond c x x = x"
apply(induction c)
apply(auto)
done

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x []       = 0" |
"count x (y # ys) = cond (x = y) (Suc (count x ys)) (count x ys)"

value "equal 1 1 :: bool"
value "(1 :: nat) = 1"
value "(\<le>)"
(* value "op \<le>" *)

value "equal"
value "op = x y"

theorem count_lt_length : "count x xs \<le> length xs"
apply(induction xs)
apply(simp)
apply(simp)
done

(* 2.4 *)

fun snoc :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"snoc x []       = [x]" |
"snoc x (y # ys) = y # snoc x ys"

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

lemma reverse_snoc [simp] : "reverse' (snoc x xs) = x # reverse' xs"
apply(induction xs)
apply(auto)
done

value "reverse' (snoc x (a # xs)) = reverse' (a # snoc x xs)"
value "reverse' (a # snoc x xs)   = snoc a (reverse' (snoc x xs))"
(* by IH *)
value "snoc a (reverse' (snoc x xs)) = snoc a (x # reverse' xs)"
value "snoc a (x # reverse' xs)      = x # snoc a (reverse' xs)"

theorem reverse'_reverse' : "reverse' (reverse' xs) = xs"
apply(induction xs)
apply(auto)
done

(* 2.5 *)

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

value "sum_up_to 3"

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

lemma add_into_div [simp] : "add n (x div 2) = (add n (add n x)) div 2"
apply(induction n)
apply(auto)
done

lemma add_commutative2 [simp] : "add x (add y z) = add y (add x z)"
apply(induction x)
apply(auto)
done

lemma add_mul [simp] : "add n (mul n m) = mul n (Suc m)"
apply(induction n)
apply(auto)
done

theorem sum_up_to_n : "sum_up_to n = mul n (Suc n) div 2"
apply(induction n)
apply(auto)
done

(* 2.3 Type and Function Definitions *)

type_synonym string = "char list"

datatype ('a, 'b) three =
    One "'a"
  | Two "'b"
  | Three

(* case expressions are supported *)

fun three_to_nat :: "('a, 'b) three \<Rightarrow> nat" where
"three_to_nat x = (case x of
    One _ \<Rightarrow> 1
  | Two _ \<Rightarrow> 2
  | Three \<Rightarrow> 3
  )"

datatype 'a option = None | Some 'a

(* NB Tuples are simulated by pairs nested to the right.
      I.e. (a * b * c) is a shorthand for (a * (b * c)).

   Can also use pretty version of *, namely \<times>. Enter it as \<times>.
 *)

fun lookup :: "('a * 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup []             _  = None" |
"lookup ((k, v) # kvs) k' = (if k = k' then Some v else lookup kvs k')"

value "lookup [(1, 2), (2, 3)] (2 :: nat) :: nat option"

(* Definitions are non-recursive functions that are not allowed to pattern-match *)

definition sq :: "nat \<Rightarrow> nat" where
"sq x = x + x"

(* Can also define abbreviations, which are similar to definitions but are expanded upon parsing
   and folded back on prettyprinting.
 *)

(* NB to enter \<equiv> either leave == in ascii, enter == and complete or enter \<equiv> and complete *)

abbreviation sq' :: "nat \<Rightarrow> nat" where
"sq' x \<equiv> x * x"

(* Recursive functions are defined with fun keyword. They must be total and must always
   terminate.

   Every function defines it's own customized induction rule, e.g. see div2 below
 *)

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

thm div2.induct

lemma div2_is_div : "div2 n = n div 2"
(* apply customized induction rule *)
apply(induction n rule: div2.induct)
apply(auto)
done

(* Customized induction rule is more convenient for proving properties of non-trivial functions,
   where there's more than one equation for each constructor of input.
 *)

(* If function takes several arguments then induction rule is applied like this:
   apply(induction x1, x2, ..., xN rule: f.induct)
  *)

(* Exercises 2.3 *)

(* 2.6 *)

datatype 'a tree =
    Leaf
  | Branch "'a" "'a tree" "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Leaf = []" |
"contents (Branch x left right) = contents left @ x # contents right"

fun treesum :: "nat tree \<Rightarrow> nat" where
"treesum Leaf = 0" |
"treesum (Branch x left right) = treesum left + treesum right + x"

theorem treesum_is_listsum : "treesum t = sum_list (contents t)"
apply(induction t)
apply(auto)
done

(* Try to find out which theorems about addition were used to prove treesum_is_listsum *)
(*
fun my_add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"my_add 0       m = m" |
"my_add (Suc n) m = Suc (my_add n m)"

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

fun my_treesum :: "nat tree \<Rightarrow> nat" where
"my_treesum Leaf = 0" |
"my_treesum (Branch x left right) = my_add x (my_add (my_treesum left) (my_treesum right))"

lemma my_listsum_distributes_over_append [simp] : "my_listsum (xs @ ys) = my_add (my_listsum xs) (my_listsum ys)"
apply(induction xs)
apply(auto)
apply(induction ys)
apply(auto)
done

theorem my_treesum_is_my_listsum : "my_treesum t = my_listsum (contents t)"
apply(induction t)
apply(auto)
done

*)

(* 2.7 *)

datatype 'a tree2 =
    Leaf 'a
  | Branch 'a "'a tree2" "'a tree2"

fun mirror2 :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror2 (Leaf x)              = Leaf x" |
"mirror2 (Branch x left right) = Branch x (mirror2 right) (mirror2 left)"

(* NB Function is an involution if it is its own inverse, i.e. it cancels itself *)
lemma mirror2_is_involution : "mirror2 (mirror2 t) = t"
apply(induction t)
apply(auto)
done

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order (Leaf x)              = [x]" |
"pre_order (Branch x left right) = x # pre_order left @ pre_order right"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
"post_order (Leaf x)              = [x]" |
"post_order (Branch x left right) = post_order left @ post_order right @ [x]"

value "rev [1, 2, 3] :: int list"

theorem pre_post_order : "pre_order (mirror2 t) = rev (post_order t)"
apply(induction t)
apply(auto)
done

(* 2.8 *)

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse x []       = []" |
"intersperse x (y # ys) = y # concat (map (\<lambda> z. [x, z]) ys)"

lemma map_over_concat [simp] : "map f (concat xs) = concat (map (map f) xs)"
apply(induction xs)
apply(auto)
done

lemma map_f_comp_list_valued_lambda [simp] : "map f \<circ> (\<lambda>y. [x, y]) = (\<lambda>y. [f x, y]) \<circ> f"
apply(auto)
done

theorem intersperse_distributes_over_map : "map f (intersperse x xs) = intersperse (f x) (map f xs)"
apply(induction xs)
apply(auto)
done

fun itrev_helper :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev_helper []       ys = ys" |
"itrev_helper (x # xs) ys = itrev_helper xs (x # ys)"

fun itrev :: "'a list \<Rightarrow> 'a list" where
(*definition itrev :: "'a list \<Rightarrow> 'a list" where*)
"itrev xs = itrev_helper xs []"

(* Cannot prove weaker statement, "itrev_helper xs [] = rev xs", by induction - IH would be too
   weak to prove the step.

   Can, and sometimes must, further strengthen IH by universally quantifying over free variables
   that we're not inducting over.
 *)
lemma itrev_helper_reverses [simp] : "itrev_helper xs ys = rev xs @ ys"
apply(induction xs arbitrary: ys)
apply(auto)
done

lemma itrev_helper_reverses_alt : "\<forall> ys. itrev_helper xs ys = rev xs @ ys"
apply(induction xs)
apply(auto)
done

theorem itrev_reverses : "itrev xs = rev xs"
apply(auto)
done

(* Exercise 2.9 *)

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

theorem itadd_sums : "itadd n m = add n m"
apply(induction n arbitrary: m)
apply(auto)
done

(* 2.5 Simplification rules *)

(* Definitions do not automatically become simplification rules.
   OTOH functions and datatypes automatically produce some rules.

   Functions produce a rule for every equation.

   Datatypes produce injectivity and distinctness (of constructors) rules.

   NB only real simplifications should become automatic rules - e.g.
   distributivity should remain manual.

   Simplification rules can be conditional, e.g. p(n) \<Rightarrow> f(n) = g(n).
   This way f(n) will be substituted by g(n) only when p(n) is provable.

   Right-hand side should always simpler than left-hand side to ensure termination.
   Termination check is undecidable and cannot be performed automatically.

   For conditional rules the precondition is proved first, therefore it must be simpler
   than rhs.
 *)

(* Definitions are intended for abstract concepts, but can be expanded with

     apply(simp add: definition_name_def)

   for some definition definition_name.

   Simplification can be temporarily undone by

     apply(simp del: rule_name)
 *)

(* Exercise 2.10 *)

datatype tree0 = Leaf0 | Branch0 tree0 tree0

fun tree0_size :: "tree0 \<Rightarrow> nat" where
"tree0_size Leaf0                = 1" |
"tree0_size (Branch0 left right) = 1 + tree0_size left + tree0_size right"

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

theorem exploded_size : "tree0_size (explode n t) = 2^n * (tree0_size t + 1) - 1"
apply(induction n arbitrary: t)
apply(auto)
apply(simp add: algebra_simps) (* Standard arithmetic operations properties *)
done

thm algebra[no_vars]
thm algebra_simps[no_vars]

(* Exercise 2.11 *)

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

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var       v = v" |
"eval (Const n) _ = n" |
"eval (Add x y) v = eval x v + eval y v" |
"eval (Mul x y) v = eval x v * eval y v"

(* List of coefficients *)
type_synonym polynomial = "int list"

fun evalp_helper :: "polynomial \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
"evalp_helper []       _ _ = 0" |
"evalp_helper (c # cs) v n = c * v^n + evalp_helper cs v (n + 1)"

fun evalp :: "polynomial \<Rightarrow> int \<Rightarrow> int" where
"evalp cs v = evalp_helper cs v 0"

fun poly_add :: "polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial" where
"poly_add []       []       = []"     |
"poly_add (x # xs) []       = x # xs" |
"poly_add []       (y # ys) = y # ys" |
"poly_add (x # xs) (y # ys) = (x + y) # poly_add xs ys"

fun poly_shift :: "nat \<Rightarrow> polynomial \<Rightarrow> polynomial" where
"poly_shift 0       xs = xs" |
"poly_shift (Suc n) xs = poly_shift n (0 # xs)"

fun poly_scale :: "int \<Rightarrow> polynomial \<Rightarrow> polynomial" where
"poly_scale c xs = map (( *) c) xs"

fun poly_mul :: "polynomial \<Rightarrow> nat \<Rightarrow> polynomial \<Rightarrow> polynomial" where
"poly_mul []       _ _  = []" |
"poly_mul (x # xs) n ys = poly_add (poly_scale x (poly_shift n ys)) (poly_mul xs (Suc n) ys)"
(*"poly_mul (x # xs) ys = poly_add (poly_scale x ys) (poly_mul xs (poly_shift ys))"*)

lemma eval_shifted_poly [simp] : "evalp_helper (poly_shift n xs) v m = evalp_helper xs v (n + m)"
apply(induction n xs rule: poly_shift.induct)
apply(auto)
done

fun coeffs :: "exp \<Rightarrow> polynomial" where
"coeffs Var       = [0, 1]"                         |
"coeffs (Const n) = [n]"                            |
"coeffs (Add x y) = poly_add (coeffs x) (coeffs y)" |
"coeffs (Mul x y) = poly_mul (coeffs x) 0 (coeffs y)"

theorem poly_add_sums [simp] : "evalp_helper (poly_add xs ys) v n = evalp_helper xs v n + evalp_helper ys v n"
apply(induction xs ys arbitrary: n rule: poly_add.induct)
apply(auto simp add: algebra_simps)
done

lemma poly_scale_scales [simp] : "evalp_helper (map (( *) c) xs) v n = c * evalp_helper xs v n"
apply(induction xs arbitrary: n)
apply(auto simp add: algebra_simps)
done

(*
value "poly_mul [-1] 0 [-1]"
value "let xs = [-1]; ys = xs; zs = poly_mul xs ys; v = -2; n = 1 in (zs, evalp_helper zs v n, evalp_helper xs v n, evalp_helper ys v n, evalp_helper xs v n * evalp_helper ys v n)"
*)

lemma evalp_helper_nonzero_power : "evalp_helper xs v (Suc n) = v * evalp_helper xs v n"
apply(induction xs arbitrary: n)
apply(auto simp add: algebra_simps)
done

lemma evalp_helper_composite_power : "evalp_helper xs v (m + n) = v^m * evalp_helper xs v n"
apply(induction m (*arbitrary: n*))
apply(auto simp add: evalp_helper_nonzero_power)
done

theorem poly_mul_multiplies [simp] : "evalp_helper (poly_mul xs m ys) v n = evalp_helper xs v m * evalp_helper ys v n"
apply(induction xs arbitrary: m)
apply(simp)
apply(simp)
apply(simp add: algebra_simps evalp_helper_composite_power)
done

theorem poly_conversion_preserves_value : "evalp (coeffs exp) v = eval exp v"
apply(induction exp (*arbitrary: v*))
apply(auto)
(*apply(simp add: algebra_simps)*)
done

notepad
begin
  fix A B :: bool
  have "A \<and> B \<longrightarrow> B \<and> A"
  proof(rule impI)
    assume it: "A \<and> B"
    show "B \<and> A"
    proof(rule conjI)
      from it show B by(rule conjunct2)
      from it show A by(rule conjunct1)
    qed
  qed
end

(* print_theorems rule impI*)
thm impI conjunct1 conjunct2

value "1 # 2 # (3 :: int) # []"

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "[+]" 35) where
  "xor x y \<equiv> x \<and> \<not> y \<or> \<not> x \<and> y"

class number =
  fixes add     :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<oplus>" 70)
    and add_inv :: "'a \<Rightarrow> 'a"       ("\<ominus>_" 20)
    and add_id  :: "'a"             ("\<zero>")

    and mul     :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 60)
    and mul_inv :: "'a \<Rightarrow> 'a"       ("_\<^sup>-\<^sup>1" 20)
    and mul_id  :: "'a"             ("\<one>")

    and is_pos  :: "'a \<Rightarrow> bool"     ("_ \<in> \<P>" 20)

  assumes add_assoc:          "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
      and add_identity:       "x \<oplus> \<zero> = x"
      and add_inverse:        "x \<oplus> (\<ominus> x) = \<zero>"
      and add_commutativity:  "x \<oplus> y = y \<oplus> x"

      and mul_assoc:          "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
      and mul_identity:       "x \<otimes> \<one> = x"
      and mul_inverse:        "x \<otimes> (x\<^sup>-\<^sup>1) = \<one>"
      and mul_commutativity:  "x \<otimes> y = y \<otimes> x"

      and distributive_law:   "x \<otimes> (y \<oplus> z) = x \<otimes> y \<oplus> x \<otimes> z"

      and pos_trichotomy:        "x = \<zero> [+] (x \<in> \<P>) [+] \<not> (x \<in> \<P>)"
      and pos_closure_under_add: "(x \<in> \<P>) \<Longrightarrow> (y \<in> \<P>) \<Longrightarrow> (x \<oplus> y \<in> \<P>)"
      and pos_closure_under_mul: "(x \<in> \<P>) \<Longrightarrow> (y \<in> \<P>) \<Longrightarrow> (x \<otimes> y \<in> \<P>)"

begin
end

lemma nonzero_either_pos_or_neg: "x \<noteq> \<zero> \<Longrightarrow> (x \<in> \<P>) [+] \<not> (x \<in> \<P>)"
  sorry

end