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

theory Chap_four imports Main begin

declare [[names_short]]

(* 4.1 *)

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

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node l x r) =  {x} \<union> set l \<union> set r"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True" |
"ord (Node l x r) = ((\<forall> y \<in> set l. x \<ge> y) \<and> (\<forall> y \<in> set r. y \<ge> x) \<and> ord l \<and> ord r)"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins a Tip = Node Tip a Tip" |
"ins a (Node r x l) =
 (if a = x then
  Node r x l
 else if x > a then
  Node (ins a r) x l
 else Node r x (ins a l))"

theorem set_ins[simp]: "set (ins x t) = {x} \<union> set t"
apply (induction t)
apply (auto)
done

theorem "ord t \<Longrightarrow> ord (ins i t)"
apply (induction t)
apply (auto)
done

(* 4.2 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
pal0: "palindrome []" |
pal1: "palindrome [x]" |
pal_SS: "palindrome l \<Longrightarrow> palindrome (a # (l @ [a]))"

theorem rev_pal: "palindrome l \<Longrightarrow> rev l = l"
apply (induction rule:palindrome.induct)
apply (auto)
done

(* 4.3 *)

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

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

lemma star_star': "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
apply (induction rule:star.induct)
apply (auto intro: refl step)
done

lemma star'_star: "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"

apply (induction rule:star'.induct)
apply (auto intro: refl' step')
done

theorem "star r x y \<Longrightarrow> star' r x y"
apply (induction rule:star.induct)
apply (auto simp add: refl' intro:  star'_star)
done

theorem "star' r x y \<Longrightarrow> star r x y"
apply (induction rule:star'.induct)
apply (auto simp add: refl intro: star_star')
done

(* 4.4 *)

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
it0: "iter r 0 x x" |
it_SS: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

theorem "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
apply (induction rule:star.induct)
apply (auto intro: it0 it_SS)
done

(* 4.5 *)

datatype alpha = alef | bet | gimel

type_synonym str = "alpha list"

inductive S :: "str \<Rightarrow> bool" where
S_0: "S []" |
S_wrp: "S w \<Longrightarrow> S (a # w @ [b])" |
S_cc: "S w \<Longrightarrow> S u \<Longrightarrow> S (w @ u)"

inductive T :: "str \<Rightarrow> bool" where
T_0: "T []" |
T_intr: "T w \<Longrightarrow> T u \<Longrightarrow> T (w @ [a] @ u @ [b])"

lemma T_comm: "T u \<Longrightarrow> T w \<Longrightarrow> T (w @ u)"
apply (induction  rule:T.induct)
apply (simp)
apply (metis T_intr append_assoc)
done

theorem T_S: "T w \<Longrightarrow> S w"
apply (induction rule:T.induct)
apply (auto intro: S_0 S_cc S_wrp)
done

theorem S_T: "S w \<Longrightarrow> T w"
apply (induction rule:S.induct)
apply (simp add: T_0)
apply (metis T_0 T_intr append_Cons append_Nil)
apply (auto intro: T_comm)
done

theorem "S w = T w"
apply (auto simp add: S_T T_S)
done

(* 4.6 *)

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"

inductive rel_aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
ar_N: "rel_aval (N a) s a" |
ar_V: "rel_aval (V x) s (s x)" |
ar_Plus: "rel_aval p s p_v \<Longrightarrow> rel_aval q s q_v \<Longrightarrow> rel_aval (Plus p q) s (p_v + q_v)"

theorem rel_aval_aval: "rel_aval a s v \<Longrightarrow> aval a s = v"
apply (induction rule: rel_aval.induct)
apply (auto)
done

theorem aval_rel_aval: "aval a s = v \<Longrightarrow> rel_aval a s v"
apply (induction a arbitrary: v)
apply (auto intro: ar_N ar_V ar_Plus)
done

theorem "rel_aval a s v \<longleftrightarrow> aval a s = v"
apply (rule iffI)
apply (auto intro: aval_rel_aval rel_aval_aval)
done

(* 4.7 *)

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" where
"exec1 (LOADI n) _ stk = (n # stk)" |
"exec1 (LOAD x) s stk = (s(x) # stk)" |
"exec1 ADD _ stk = (hd2 stk + hd stk) # tl2 stk"

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

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]"

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
ok_0: "ok n [] n" |
ok_LI: "ok n is n' \<Longrightarrow> ok n (is @ [LOADI k]) (Suc n')" |
ok_L: "ok n is n' \<Longrightarrow> ok n (is @ [LOAD x]) (Suc n')" |
ok_A: "ok n is (Suc (Suc n')) \<Longrightarrow> ok n (is @ [ADD]) (Suc n')"

lemma exec_append: "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
apply (induction is1 arbitrary:stk)
apply (auto split:option.split)
done

theorem "ok n is n' \<Longrightarrow> length stk = n \<Longrightarrow> length (exec is s stk) = n'"
apply (induction arbitrary: stk rule:ok.induct)
apply (auto simp add: exec_append)
done

lemma ok_append: "ok n' b n'' \<Longrightarrow> ok n a n' \<Longrightarrow> ok n (a @ b) n''"
apply (induction  rule: ok.induct)
apply (simp)
apply (metis append_assoc ok_LI)
apply (metis append_assoc ok_L)
apply (metis append_assoc ok_A)
done

theorem "ok n (comp a) (Suc n)"
apply (induction a arbitrary: n)
apply (simp, metis List.append.simps(1) ok_0 ok_LI)
apply (simp, metis List.append.simps(1) ok_0 ok_L)
apply (auto intro: ok_append ok_A)
done

end


theory Permutation
imports Main "HOL-Library.FSet" More_List
begin

text \<open>Permutation type\<close>

lemma distinct_perm [simp]:
  assumes "set p = {0..<length p}"
  shows "distinct p"
  using assms
  by (simp add: card_distinct)

typedef perm = "{p::nat list. set p = {0..<length p}}"
  morphisms perm_list Abs_perm
  by (rule_tac x="[]" in exI, auto)

setup_lifting type_definition_perm

text \<open>Domain of a permutation is always  the set of the form {0..<n}\<close>
lift_definition perm_dom :: "perm \<Rightarrow> nat" is
  "length"
  done

lemma perm_list_set [simp]:
  shows "set (perm_list p) = {0..<perm_dom p}"
  by transfer simp

lemma length_perm_list[simp]:
  shows "length (perm_list p) = perm_dom p"
  by transfer simp

text \<open>Permutation as a function that acts on {0..<n}\<close>

definition perm_fun' :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
  "perm_fun' p = (\<lambda> k. if k < length p then p ! k else undefined)"

lift_definition perm_fun :: "perm \<Rightarrow> nat \<Rightarrow> nat" is perm_fun'
  done

lemma permEqI:
  assumes "perm_dom p1 = n" "perm_dom p2 = n"
          "\<forall> v < n. perm_fun p1 v = perm_fun p2 v"
  shows "p1 = p2"
  using assms
  by transfer (auto simp add: perm_fun'_def nth_equalityI)

lemma perm_fun_inj:
  assumes "perm_dom p = n" "v1 < n" "v2 < n" "perm_fun p v1 = perm_fun p v2"
  shows "v1 = v2"
  using assms
  by (metis distinct_perm nth_eq_iff_index_eq perm_dom.rep_eq perm_fun'_def perm_fun.rep_eq perm_list_set)

definition is_perm_fun :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" where
  "is_perm_fun n p \<longleftrightarrow> bij_betw p {0..<n} {0..<n}"

lemma is_perm_fun [simp]:
  "is_perm_fun (perm_dom p) (perm_fun p)"
proof transfer
  fix p
  assume *: "set p = {0..<length p}"
  let ?f = "\<lambda> k. if k < length p then p ! k else undefined"
  show "is_perm_fun (length p) (perm_fun' p)"
    unfolding is_perm_fun_def perm_fun'_def bij_betw_def
  proof
    show "inj_on ?f {0..<length p}"
      using distinct_perm[OF *]
      by (simp add: nth_eq_iff_index_eq inj_on_def perm_fun'_def)
  next
    show "?f ` {0..<length p} = {0..<length p}"
    proof safe
      fix k
      assume "k \<in> {0..<length p}"
      then show "?f k \<in> {0..<length p}"
        using *
        by (metis atLeastLessThan_iff nth_mem)
    next
      fix k
      assume "k \<in> {0..<length p}"
      then show "k \<in> ?f ` {0..<length p}"
        using *
        by (simp add: nth_image)
    qed
  qed
qed

lemma is_perm_fun_comp [simp]:
  assumes "is_perm_fun n f" "is_perm_fun n g"
  shows "is_perm_fun n (f \<circ> g)"
  using assms
  unfolding is_perm_fun_def
  using bij_betw_trans by blast

definition inv_perm_fun :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "inv_perm_fun n f = (\<lambda> y. (THE x. x < n \<and> f x = y))"

lemma inv_perm_fun:
  assumes "is_perm_fun n f" "x < n" "f x = y"
  shows "inv_perm_fun n f y = x"
proof-
  have "\<exists>! x. x < n \<and> f x = y"
    using assms
    unfolding is_perm_fun_def
    by (metis atLeast0LessThan bij_betw_iff_bijections lessThan_iff)
  then show ?thesis
    using assms(2-3)
    unfolding inv_perm_fun_def
    by (simp add: the1_equality)
qed

lemma inv_perm_fun_perm_fun:
  assumes "is_perm_fun n f"
  shows "is_perm_fun n (inv_perm_fun n f)"
  using assms
  unfolding is_perm_fun_def bij_betw_def
  by (smt (z3) assms atLeastLessThan_iff f_the_inv_into_f image_cong image_iff inj_on_cong inj_on_the_inv_into inv_perm_fun the_inv_into_onto)

lemma perm_list_nth:
  assumes "i < perm_dom p"
  shows "perm_list p ! i = perm_fun p i"
  using assms
  by transfer (simp add: perm_fun'_def)

text \<open>Each bijective function gives rise to a permutation\<close>

definition make_perm' :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat list" where
  "make_perm' n f =
     (if is_perm_fun n f then map f [0..<n] else [])"

lift_definition make_perm :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> perm" is make_perm'
  unfolding make_perm'_def is_perm_fun_def
  by (auto simp add: bij_betw_def)

lemma perm_dom_make_perm[simp]:
  assumes "is_perm_fun n f"
  shows "perm_dom (make_perm n f) = n"
  using assms
  by transfer (simp add: make_perm'_def)

lemma perm_fun_make_perm [simp]:
  assumes "is_perm_fun n f" "x < n"
  shows "perm_fun (make_perm n f) x = f x"
  using assms
  by transfer (simp add: make_perm'_def perm_fun'_def)

lemma make_perm_perm_fun [simp]:
  assumes "perm_dom p = n"
  shows "make_perm n (perm_fun p) = p"
proof-
  have "is_perm_fun n (perm_fun p)"
    using assms is_perm_fun by auto
  thus ?thesis
    using assms
    by transfer (smt (z3) make_perm'_def perm_fun'_def atLeast0LessThan lessThan_iff map_eq_conv map_nth set_upt)
qed

lemma make_perm_cong:
  assumes "\<forall> v < n. f1 v = f2 v" "is_perm_fun n f1" "is_perm_fun n f2"
  shows "make_perm n f1 = make_perm n f2"
  using assms
  by transfer (simp add: make_perm'_def)

subsection \<open>Permutation group\<close>

definition perm_id' :: "nat \<Rightarrow> nat list" where
 "perm_id' n = [0..<n]"

lift_definition perm_id :: "nat \<Rightarrow> perm" is perm_id'
  by (simp add: perm_id'_def)

lemma perm_dom_perm_id [simp]:
  shows "perm_dom (perm_id n) = n"
  by transfer (simp add: perm_id'_def)

lemma perm_fun_perm_id [simp]:
  assumes "x < n"
  shows "perm_fun (perm_id n) x = x"
  using assms
  by transfer (auto simp add: perm_id'_def perm_fun'_def)

definition perm_inv' :: "nat list \<Rightarrow> nat list" where
  "perm_inv' p = map (index_of p) [0..<length p]"

lemma set_perm_inv':
  assumes "set xs = {0..<length xs}"
  shows "set (perm_inv' xs) = {0..<length (perm_inv' xs)}" (is "?lhs = ?rhs")
proof
    show "?lhs \<subseteq> ?rhs"
      using assms index_of_in_set[of _ xs]
      by (auto simp add: perm_inv'_def)
next
    show "?rhs \<subseteq> ?lhs"
      using assms
      by (smt (verit, ccfv_SIG) atLeastLessThan_iff distinct_perm image_iff index_of_in_set length_map map_nth nth_eq_iff_index_eq nth_mem perm_inv'_def set_map set_upt subsetI)
qed

lift_definition perm_inv :: "perm \<Rightarrow> perm" is perm_inv'
  using set_perm_inv'
  by auto

lemma perm_dom_perm_inv [simp]:
  "perm_dom (perm_inv p) = perm_dom p"
  by transfer (auto simp add: perm_inv'_def)

lemma perm_inv_inv [simp]:
  shows "perm_inv (perm_inv p) = p"
proof transfer
  fix p
  assume *: "set p = {0..<length p}"
  show "perm_inv' (perm_inv' p) = p"
  proof (rule nth_equalityI)
    show "length (perm_inv' (perm_inv' p)) = length p"
      unfolding perm_inv'_def
      by auto
  next
    fix i
    assume "i < length (perm_inv' (perm_inv' p))"
    then show "perm_inv' (perm_inv' p) ! i = p ! i"
      using *
      unfolding perm_inv'_def
      by (smt (verit, ccfv_SIG) atLeast0LessThan distinct_Ex1 distinct_perm index_of_in_set length_map lessThan_iff map_nth nth_map nth_mem set_upt)
  qed
qed

lemma perm_inv_perm_id [simp]:
  shows "perm_inv (perm_id n) = perm_id n"
  by (smt (verit, ccfv_SIG) atLeast0LessThan diff_zero index_of_in_set length_upt lessThan_iff nth_map permEqI perm_dom.rep_eq perm_dom_perm_inv perm_fun'_def perm_fun.rep_eq perm_fun_perm_id perm_id'_def perm_id.rep_eq perm_inv'_def perm_inv.rep_eq perm_list_set)

lemma perm_fun_perm_inv_range:
  assumes "perm_dom p = n"
  shows "\<forall> x < n. (perm_fun (perm_inv p)) x < n"
  using assms
  by transfer (auto simp add: perm_fun'_def perm_inv'_def index_of_in_set)

lemma perm_fun_perm_inv1_comp:
  assumes "perm_dom p = n"
  shows "\<forall> x < n. ((perm_fun p) \<circ> (perm_fun (perm_inv p))) x = x"
  using assms
  by transfer (auto simp add: perm_fun'_def perm_inv'_def index_of_in_set)

lemma perm_fun_perm_inv2_comp:
  assumes "perm_dom p = n"
  shows "\<forall> x < n. ((perm_fun (perm_inv p)) \<circ> (perm_fun p)) x = x"
  using assms
  by transfer (smt (verit, ccfv_threshold) add.left_neutral diff_zero distinct_Ex1 distinct_perm index_of_in_set length_map length_upt lessThan_atLeast0 lessThan_iff nth_map nth_mem nth_upt o_def perm_fun'_def perm_inv'_def)

lemma perm_fun_perm_inv1 [simp]:
  assumes "perm_dom p = n" "x < n"
  shows "perm_fun p (perm_fun (perm_inv p) x) = x"
  using assms
  using perm_fun_perm_inv1_comp
  by auto

lemma perm_fun_perm_inv2 [simp]:
  assumes "perm_dom p = n" "x < n"
  shows "perm_fun (perm_inv p) (perm_fun p x) = x"
  using assms
  using perm_fun_perm_inv2_comp
  by auto

lemma perm_inv_make_perm1 [simp]:
  assumes "is_perm_fun n f" "v < n"
  shows "f (perm_fun (perm_inv (make_perm n f)) v) = v"
  using assms
  by (metis perm_dom_make_perm perm_fun_make_perm perm_fun_perm_inv1 perm_fun_perm_inv_range)

lemma perm_inv_make_perm2 [simp]:
  assumes "is_perm_fun n f" "v < n"
  shows "perm_fun (perm_inv (make_perm n f)) (f v) = v"
  using assms
  by (metis perm_dom_make_perm perm_fun_make_perm perm_fun_perm_inv2)

lemma make_perm_inv_perm_fun:
  assumes "is_perm_fun n f"
  shows "make_perm n (inv_perm_fun n f) = perm_inv (make_perm n f)"
  using assms
proof transfer
  fix n f
  assume *: "is_perm_fun n f"
  have "\<forall>x\<in>{0..<n}. inv_perm_fun n f x = index_of (map f [0..<n]) x"
  proof
    fix x
    assume "x \<in> {0..<n}"
    show "inv_perm_fun n f x = index_of (map f [0..<n]) x"
      by (smt (z3) "*" \<open>x \<in> {0..<n}\<close> add.left_neutral bij_betw_def diff_zero index_of_in_set inv_perm_fun is_perm_fun_def length_map length_upt nth_map_upt set_map set_upt)
  qed
  then show "make_perm' n (inv_perm_fun n f) = perm_inv' (make_perm' n f)"
    using *
    by (auto simp add: make_perm'_def inv_perm_fun_perm_fun perm_inv'_def)
qed

definition inv_n :: "nat => (nat => nat) => (nat => nat)" where
  "inv_n n f x = (if x < n then (THE y. y < n \<and> f y = x) else undefined)"

lemma bij_betw_ex1:
  fixes f :: "nat => nat"
  assumes "bij_betw f {0..<n} {0..<n}"
  shows "\<forall> y < n. \<exists>! x. x < n \<and> f x = y"
  using assms
  unfolding bij_betw_def inj_on_def
  by (smt (verit, ccfv_threshold) atLeastLessThan_iff image_iff zero_le)

lemma inv_n_comp:
  assumes "bij_betw f {0..<n} {0..<n}" "x < n"
  shows "(inv_n n f) (f x) = x"
  using assms
  using atLeast0LessThan bij_betw_apply inv_n_def inv_perm_fun inv_perm_fun_def is_perm_fun_def
  by fastforce

lemma comp_inv_n:
  assumes "bij_betw f {0..<n} {0..<n}" "x < n"
  shows "f (inv_n n f x) = x"
  using assms
  by (metis bij_betw_ex1 inv_n_comp)

lemma perm_fun_inv:
  assumes "x < perm_dom p"
  shows "perm_fun (perm_inv p) x = (inv_n (perm_dom p) (perm_fun p)) x"
  using assms
  by (metis inv_n_comp is_perm_fun is_perm_fun_def perm_fun_perm_inv1 perm_fun_perm_inv_range)

definition perm_comp' :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
  "perm_comp' p1 p2 =
     (if length p1 = length p2 then
         map (perm_fun' p1) p2
      else
        [])"

lift_definition perm_comp :: "perm \<Rightarrow> perm \<Rightarrow> perm" is perm_comp'
  apply (auto simp add: perm_comp'_def perm_fun'_def)
  apply (metis IntI atLeast0LessThan imageI in_set_conv_nth lessThan_iff mem_Collect_eq)
  done

lemma perm_dom_perm_comp [simp]:
  assumes "perm_dom p1 = n" "perm_dom p2 = n"
  shows "perm_dom (perm_comp p1 p2) = n"
  using assms
  by transfer (auto simp add: perm_comp'_def)

lemma perm_fun_perm_comp [simp]:
  assumes "perm_dom p1 = n" "perm_dom p2 = n"
  shows "\<forall> x < n. perm_fun (perm_comp p1 p2) x = (perm_fun p1 \<circ> perm_fun p2) x"
  using assms
proof transfer
  fix p1 p2 n
  assume *: "length p1 = n" "length p2 = n" "set p1 = {0..<length p1}" "set p2 = {0..<length p2}"
  then show "\<forall> x < n. perm_fun' (perm_comp' p1 p2) x = (perm_fun' p1 \<circ> perm_fun' p2) x"
    by (auto simp add: perm_fun'_def perm_comp'_def)
qed

lemma perm_comp_assoc:
  assumes "perm_dom p1 = n" "perm_dom p2 = n" "perm_dom p3 = n"
  shows "perm_comp (perm_comp p1 p2) p3 = perm_comp p1 (perm_comp p2 p3)"
  using assms
proof transfer
  fix p1 p2 p3
  assume *: "set p1 = {0..<length p1}" "set p2 = {0..<length p2}" "set p3 = {0..<length p3}"
  then show "perm_comp' (perm_comp' p1 p2) p3 = perm_comp' p1 (perm_comp' p2 p3)"
    unfolding perm_comp'_def perm_fun'_def  by auto
qed

lemma perm_comp_make_perm [simp]:
  assumes "is_perm_fun n p1" "is_perm_fun n p2"
  shows "perm_comp (make_perm n p1) (make_perm n p2) = make_perm n (p1 \<circ> p2)"
  using assms
proof-
  have "is_perm_fun n (p1 \<circ> p2)"
    using assms
    by simp
  then show ?thesis
    using assms
    by transfer (auto simp add: perm_comp'_def make_perm'_def perm_fun'_def is_perm_fun_def bij_betw_def)
qed

lemma perm_comp_perm_id_1 [simp]:
  assumes "perm_dom p = n"
  shows "perm_comp (perm_id n) p = p"
  using assms
  by transfer (metis (mono_tags, lifting) atLeast0LessThan distinct_card distinct_perm eq_onp_same_args length_remdups_card_conv lessThan_iff map_idI perm_comp'_def perm_fun.abs_eq perm_fun_perm_id perm_id'_def perm_id.abs_eq remdups_upt set_upt)

lemma perm_comp_perm_id_2 [simp]:
  assumes "perm_dom p = n"
  shows "perm_comp p (perm_id n) = p"
  using assms
  by transfer (smt (z3) atLeast0LessThan distinct_card distinct_perm length_remdups_card_conv lessThan_iff map_eq_conv map_nth perm_comp'_def perm_fun'_def perm_id'_def remdups_upt set_upt)

lemma perm_comp_perm_inv1 [simp]:
  assumes "perm_dom p = n"
  shows "perm_comp (perm_inv p) p = perm_id n"
  using assms
proof transfer
  fix p n
  assume "set p = {0..<length p}" "length p = n"
  have "map (\<lambda> k. map (index_of p) [0..<length p] ! k) p = [0..<length p]"
  proof-
    let ?f = "(\<lambda> k. map (index_of p) [0..<length p] ! k)"
    let ?g = "\<lambda> i. p ! i"

    have *: "\<forall> x < length p. (?f \<circ> ?g) x = x"
    proof safe
      fix x
      assume "x < length p"
      then show "(?f \<circ> ?g) x = x"
        using \<open>set p = {0..<length p}\<close> index_of_in_set[of "p ! x" p]
        by (metis atLeastLessThan_iff comp_def distinct_perm length_map map_nth nth_eq_iff_index_eq nth_map nth_mem set_upt)
    qed

    have "p = map (\<lambda> i. p ! i) [0..<length p]"
      by (simp add: map_nth)
    then have "map ?f p = map (?f \<circ> (\<lambda> i. p ! i)) [0..<length p]"
      by (metis map_map)
    then show ?thesis
      using *
      by (metis atLeast0LessThan lessThan_iff map_idI set_upt)
  qed

  then show "perm_comp' (perm_inv' p) p = perm_id' n"
    using \<open>length p = n\<close> \<open>set p = {0..<length p}\<close>
    unfolding perm_comp'_def perm_inv'_def perm_id'_def perm_fun'_def
    by (smt (verit, ccfv_SIG) atLeast0LessThan length_map lessThan_iff map_eq_conv)
qed

lemma perm_comp_perm_inv2 [simp]:
  assumes "perm_dom p = n"
  shows "perm_comp p (perm_inv p) = perm_id n"
  by (metis assms perm_comp_perm_inv1 perm_dom_perm_inv perm_inv_inv)

lemma perm_inv_solve:
  assumes "perm_dom p1 = n" "perm_dom p2 = n"  "perm_comp p1 p2 = perm_id n"
  shows "p1 = perm_inv p2"
  using assms
proof transfer
  fix p1 n p2
  assume "set p1 = {0..<length p1}" "length p1 = n" "set p2 = {0..<length p2}" "length p2 = n" "perm_comp' p1 p2 = perm_id' n"
  then show "p1 = perm_inv' p2"
    by (smt (verit, best) Quotient_perm Quotient_rep_abs_eq eq_onp_le_eq eq_onp_same_args perm_comp.abs_eq perm_comp_assoc perm_comp_perm_id_1 perm_comp_perm_id_2 perm_comp_perm_inv2 perm_dom.abs_eq perm_dom_perm_inv perm_id.abs_eq perm_inv.rep_eq)
qed

lemma perm_inv_perm_comp [simp]:
  assumes "perm_dom p1 = n" "perm_dom p2 = n"
  shows "perm_inv (perm_comp p1 p2) = perm_comp (perm_inv p2) (perm_inv p1)"
proof (rule perm_inv_solve[symmetric])
  show "perm_comp (perm_comp (perm_inv p2) (perm_inv p1)) (perm_comp p1 p2) = perm_id n"
    by (metis assms(1) assms(2) perm_comp_assoc perm_comp_perm_id_1 perm_comp_perm_inv1 perm_dom_perm_comp perm_dom_perm_inv)
qed (simp_all add: assms)

subsection \<open>Action on collections (lists, sets, finite sets)\<close>

definition perm_fun_pair :: "perm \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat" where
  "perm_fun_pair p x = (perm_fun p (fst x), perm_fun p (snd x))"

lemma perm_fun_pair [simp]:
  shows "perm_fun_pair p (x, y) = (perm_fun p x, perm_fun p y)"
  unfolding perm_fun_pair_def
  by auto

lemma perm_fun_perm_fun_pair [simp]:
  assumes "\<forall> v < n. perm_fun p1 v = perm_fun p2 v" "x < n" "y < n"
  shows "perm_fun_pair p1 (x, y) = perm_fun_pair p2 (x, y)"
  using assms
  by (simp add: perm_fun_pair_def)

definition perm_fun_list_f :: "(nat \<Rightarrow> nat) \<Rightarrow> nat list \<Rightarrow> nat list" where
  "perm_fun_list_f p xs = map p xs"

definition perm_fun_list :: "perm \<Rightarrow> nat list \<Rightarrow> nat list" where
  "perm_fun_list p xs = map (perm_fun p) xs"

definition perm_fun_set_f :: "(nat \<Rightarrow> nat) \<Rightarrow> nat set \<Rightarrow> nat set" where
  "perm_fun_set_f p S = p ` S"

definition perm_fun_set :: "perm \<Rightarrow> nat set \<Rightarrow> nat set" where
  "perm_fun_set p S = (perm_fun p) ` S"

definition perm_fun_fset_f :: "(nat \<Rightarrow> nat) \<Rightarrow> nat fset \<Rightarrow> nat fset" where
  "perm_fun_fset_f p S = p |`| S"

definition perm_fun_fset :: "perm \<Rightarrow> nat fset \<Rightarrow> nat fset" where
  "perm_fun_fset p S = (perm_fun p) |`| S"

lemma perm_fun_list_Nil [simp]:
  shows "perm_fun_list p [] = []"
  by (simp add: perm_fun_list_def)

lemma perm_fun_list_Cons [simp]:
  shows "perm_fun_list p (x # xs) = (perm_fun p x) # perm_fun_list p xs"
  by (simp add: perm_fun_list_def)

lemma perm_fun_list_snoc [simp]:
  shows "perm_fun_list p (V @ [v']) = perm_fun_list p V @ [perm_fun p v']"
  by (simp add: perm_fun_list_def)

lemma rev_perm_fun_list [simp]:
  shows "rev (perm_fun_list p xs) = perm_fun_list p (rev xs)"
  unfolding perm_fun_list_def
  by (auto simp add: rev_map)

lemma perm_fun_set_Empty [simp]:
  shows "perm_fun_set p {} = {}"
  by (simp add: perm_fun_set_def)

lemma perm_fun_fset_Empty [simp]:
  shows "perm_fun_fset p {||} = {||}"
  by (simp add: perm_fun_fset_def)

lemma perm_fun_set_finite [simp]:
  assumes "finite A"
  shows "finite (perm_fun_set p A)"
  using assms
  unfolding perm_fun_set_def
  by auto

lemma perm_fun_set_card [simp]:
  assumes "A \<subseteq> {0..<perm_dom p}"
  shows "card (perm_fun_set p A) = card A"
  unfolding perm_fun_set_def
proof (rule card_image)
  show "inj_on (perm_fun p) A"
    using assms
    by (meson bij_betw_def inj_on_subset is_perm_fun is_perm_fun_def)
qed

lemma perm_fun_pair_perm_id [simp]:
  assumes "x < n" "y < n"
  shows "perm_fun_pair (perm_id n) (x, y) = (x, y)"
  using assms
  by simp

lemma perm_fun_list_perm_id [simp]:
  assumes "set l \<subseteq> {0..<n}"
  shows "perm_fun_list (perm_id n) l = l"
  using assms
  unfolding perm_fun_list_def
  by (induction l, auto)

lemma perm_fun_set_perm_id [simp]:
  assumes "S \<subseteq> {0..<n}"
  shows "perm_fun_set (perm_id n) S = S"
  using assms
  unfolding perm_fun_set_def
  by force

lemma perm_fun_pair_perm_comp [simp]:
  assumes "perm_dom p1 = n" "perm_dom p2 = n" "x < n" "y < n"
  shows "perm_fun_pair (perm_comp p1 p2) (x, y) =
         perm_fun_pair p1 (perm_fun_pair p2 (x, y))"
  using assms
  by simp

lemma perm_fun_list_perm_comp [simp]:
  assumes "perm_dom p1 = n" "perm_dom p2 = n" "set l \<subseteq> {0..<n}"
  shows "perm_fun_list (perm_comp p1 p2) l = perm_fun_list p1 (perm_fun_list p2 l)"
  using assms
  unfolding perm_fun_list_def
  by (induction l) auto

lemma perm_fun_set_perm_comp [simp]:
  assumes "perm_dom p1 = n" "perm_dom p2 = n" "S \<subseteq> {0..<n}"
  shows "perm_fun_set (perm_comp p1 p2) S = perm_fun_set p1 (perm_fun_set p2 S)"
  using assms
  unfolding perm_fun_set_def
  by force

lemma perm_inv_perm_list [simp]:
  assumes "perm_dom p = n"
  shows "perm_fun_list (perm_inv p) [0..<n] = perm_list (perm_inv p)"
  using assms
  unfolding perm_fun_list_def
  by transfer (auto simp add: perm_fun'_def perm_inv'_def)

lemma perm_fun_list_perm_inv [simp]:
  assumes "perm_dom p = n" "set xs \<subseteq> {0..<n}"
  shows "perm_fun_list (perm_inv p) (perm_fun_list p xs) = xs"
  using assms
  by (metis perm_comp_perm_inv1 perm_dom_perm_inv perm_fun_list_perm_comp perm_fun_list_perm_id)

definition perm_reorder where
  "perm_reorder p xs = map (\<lambda> i. (xs ! perm_fun (perm_inv p) i)) [0..<length xs]"

lemma length_perm_reorder [simp]:
  "length (perm_reorder p xs) = length xs"
  by (simp add: perm_reorder_def)

lemma perm_reorder:
  assumes "length xs = perm_dom p"
  shows "perm_reorder p xs = map ((!) xs) (perm_list (perm_inv p))"
proof (subst list_eq_iff_nth_eq, safe)
  show "length (perm_reorder p xs) = length (map ((!) xs) (perm_list (perm_inv p)))"
    by (simp add: perm_reorder_def assms)
next
  fix i
  assume *: "i < length (perm_reorder p xs)"
  have "map ((!) xs) (perm_list (perm_inv p)) ! i = xs ! (perm_list (perm_inv p) ! i)"
  proof (rule nth_map)
    show "i < length (perm_list (perm_inv p))"
      using * assms
      by simp
  qed

  then show "perm_reorder p xs ! i = map ((!) xs) (perm_list (perm_inv p)) ! i"
    using * assms
    unfolding perm_reorder_def
    by (simp add: perm_list_nth)
qed

lemma perm_reorder_nth [simp]:
  assumes "i < length xs"
  shows "perm_reorder p xs ! i = xs ! perm_fun (perm_inv p) i"
  using assms
  unfolding perm_reorder_def
  by simp

lemma set_perm_reorder:
  assumes "perm_dom p = length xs"
  shows "set (perm_reorder p xs) = set xs"
  using assms
  by (metis list.set_map map_nth perm_dom_perm_inv perm_list_set perm_reorder set_upt)

lemma perm_reorder_comp [simp]:
  assumes "perm_dom p1 = length xs" "perm_dom p2 = length xs"
  shows "perm_reorder p1 (perm_reorder p2 xs) = perm_reorder (perm_comp p1 p2) xs"
  using assms
  unfolding perm_reorder_def
  by (simp add: perm_fun_perm_inv_range)

lemma perm_reorder_id [simp]:
  assumes "n = length xs"
  shows "perm_reorder (perm_id n) xs = xs"
  unfolding perm_reorder_def
  by (simp add: assms map_upt_eqI)

lemma perm_reorder_inj:
  assumes "length xs = perm_dom p" "length xs = perm_dom p"
          "perm_reorder p xs = perm_reorder p ys"
  shows "xs = ys"
  using assms
  unfolding perm_reorder_def
  by (metis (no_types, lifting) assms(3) length_perm_reorder nth_equalityI perm_comp_perm_inv2 perm_dom_perm_inv perm_fun_perm_inv2 perm_fun_perm_inv_range perm_inv_solve perm_reorder_nth)

end


theory Demo2
imports Main
begin

section{*Case distinction and induction*}

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  case Nil thus ?thesis by simp
next
  case Cons thus ?thesis by simp
qed

subsection{*Structural induction*}

lemma "(\<Sum>i\<le>n. i) = n*(n+1::nat) div 2"
by (induct n, simp_all)

lemma "(\<Sum>i\<le>n. i) = n*(n+1::nat) div 2" (is "?P n")
proof (induct n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

lemma "(\<Sum>i\<le>n. i) = n*(n+1::nat) div 2"
proof (induct n)
  case 0 show ?case by simp
next
  case Suc thus ?case by simp
qed

text{* If we want to name the variable in the Suc-case: *}

lemma fixes n::nat shows "n < n*n + 1"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc i)
  hence "i+1 < i*i + 2" by simp
  thus ?case by simp
qed

lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  hence "x = a \<or> x : set xs" by simp
  thus ?case
  proof
    assume "x = a"
    hence "a#xs = [] @ x # xs" by simp
    thus ?thesis by blast
  next
    assume "x : set xs"
    then obtain ys zs where "xs = ys @ x # zs" using Cons by auto
    hence "a#xs = (a#ys) @ x # zs" by simp
    thus ?thesis by blast
  qed
qed

subsection{*Rule induction*}

inductive Ev :: "nat => bool" where
Ev0:  "Ev 0" |
Ev2:  "Ev n \<Longrightarrow> Ev(n+2)"

declare Ev.intros [simp]

lemma "Ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induct rule: Ev.induct)
  case Ev0 thus ?case by simp
next
  case Ev2 thus ?case by arith
qed

lemma assumes n: "Ev n" shows "\<exists>k. n = 2*k"
using n proof induct
  case Ev0 thus ?case by simp
next
  case Ev2 thus ?case by arith
qed

lemma assumes n: "Ev n" shows "\<exists>k. n = 2*k"
using n proof induct
  case Ev0 thus ?case by simp
next
  case (Ev2 m)
  then obtain k where "m = 2*k" by blast
  hence "m+2 = 2*(k+1)" by simp
  thus "\<exists>k. m+2 = 2*k" ..
qed

subsection{*Induction with fun*}

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

lemma "xs \<noteq> [] \<Longrightarrow> rot xs = tl xs @ [hd xs]"
proof (induct xs rule: rot.induct)
  case 1 thus ?case by simp
next
  case 2 show ?case by simp
next
  case (3 a b cs)
  have "rot (a # b # cs) = b # rot(a # cs)" by simp
  also have "\<dots> = b # tl(a # cs) @ [hd(a # cs)]" by(simp add:3)
  also have "\<dots> = tl (a # b # cs) @ [hd (a # b # cs)]" by simp
  finally show ?case . --" proof by assumption"
qed

lemma "xs \<noteq> [] \<Longrightarrow> rot xs = tl xs @ [hd xs]"
by (induct xs rule: rot.induct, simp_all)

subsection{*Chains of (in)equations*}

text{* A little bit of also/finally inside *}

lemma
fixes m :: int
assumes mn: "abs(m*n) = 1"
shows "abs m = 1"
sorry

(* Fill in the proof! *)

lemma
fixes m :: int
assumes mn: "abs(m*n) = 1"
shows "abs m = 1"
proof -
  have "m \<noteq> 0" "n \<noteq> 0" using mn by auto
  have "\<not> (2 \<le> abs m)"
  proof
    assume "2 \<le> abs m"
    hence "2*abs n \<le> abs m * abs n"
      by(simp add: mult_mono)
    also have "\<dots> = 1" using mn
      by(simp add: abs_mult)
    finally show False using `n \<noteq> 0` by simp
  qed
  thus "abs m = 1" using `m \<noteq> 0` by arith
qed

subsection{* Monotonicity reasoning *}

lemma fixes a :: int shows "(a+b)\<twosuperior> \<le> 2*(a\<twosuperior> + b\<twosuperior>)"
proof -
  have "(a+b)\<twosuperior> \<le> (a+b)\<twosuperior> + (a-b)\<twosuperior>" by simp
  also have "(a+b)\<twosuperior> \<le> a\<twosuperior> + b\<twosuperior> + 2*a*b"
    by(simp add:numeral_2_eq_2 algebra_simps)
  also have "(a-b)\<twosuperior> = a\<twosuperior> + b\<twosuperior> - 2*a*b"
    by(simp add:numeral_2_eq_2 algebra_simps)
  finally show ?thesis by simp
qed

subsection{*Accumulating facts*}

thm mono_def

lemma assumes monof: "mono(f::int\<Rightarrow>int)"
          and monog: "mono(g::int\<Rightarrow>int)"
      shows "mono(\<lambda>i. f i + g i)"
proof --"rule monoI used automatically"
  fix i j :: int
  assume A: "i \<le> j"
  have "f i \<le> f j" using A monof by(simp add:mono_def)
  moreover
  have "g i \<le> g j" using A monog by(simp add:mono_def)
  ultimately show "f i + g i \<le> f j + g j" by arith
qed

lemma dvd_minus:
  assumes du: "(d::int) dvd u"
  assumes dv: "d dvd v"
  shows  "d dvd u - v"
proof -
  from du obtain ku where "u = d * ku" by(fastsimp simp: dvd_def)
  moreover
  from dv obtain kv where "v = d * kv" by(fastsimp simp: dvd_def)
  ultimately have "u - v =  d * ku - d * kv" by simp
  also have "\<dots> = d * (ku - kv)" by (simp add: algebra_simps)
  finally show ?thesis by simp
qed

end


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

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

lemma add_right_zero[simp]: "add y 0 = y"
  apply(induction y)
  apply(auto)
  done

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

lemma 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))"

lemma double_add: "double m = add m m"
  apply(induction m)
  apply(auto)
  done


theory Concrete_Semantics_2_5_ex10
imports Main
begin

datatype tree0 = Tip | Node "tree0" "tree0"

(* counts the number of all nodes (inner nodes and leaves) *)
fun nodes :: "tree0 => nat" where
"nodes Tip = 1" |
"nodes (Node a b) = 1 + nodes a + nodes b"

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

(* Find an equation expressing the size of a tree after exploding it *)
(* s : nodes of tree, then
case 0: s
case 1: 2s + 1
case 2: 2(2s + 1) + 1
case 3: 2(4s + 3) + 1
case n: 2^n * s + 2^n - 1
 *)

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

end


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

section \<open>Lattices\<close>

theory Lattice imports Bounds begin

subsection \<open>Lattice operations\<close>

text \<open>
  A \emph{lattice} is a partial order with infimum and supremum of any
  two elements (thus any \emph{finite} number of elements have bounds
  as well).
\<close>

class lattice =
  assumes ex_inf: "\<exists>inf. is_inf x y inf"
  assumes ex_sup: "\<exists>sup. is_sup x y sup"

text \<open>
  The \<open>\<sqinter>\<close> (meet) and \<open>\<squnion>\<close> (join) operations select such
  infimum and supremum elements.
\<close>

definition
  meet :: "'a::lattice \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<sqinter>" 70) where
  "x \<sqinter> y = (THE inf. is_inf x y inf)"
definition
  join :: "'a::lattice \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<squnion>" 65) where
  "x \<squnion> y = (THE sup. is_sup x y sup)"

text \<open>
  Due to unique existence of bounds, the lattice operations may be
  exhibited as follows.
\<close>

lemma meet_equality [elim?]: "is_inf x y inf \<Longrightarrow> x \<sqinter> y = inf"
proof (unfold meet_def)
  assume "is_inf x y inf"
  then show "(THE inf. is_inf x y inf) = inf"
    by (rule the_equality) (rule is_inf_uniq [OF _ \<open>is_inf x y inf\<close>])
qed

lemma meetI [intro?]:
    "inf \<sqsubseteq> x \<Longrightarrow> inf \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> inf) \<Longrightarrow> x \<sqinter> y = inf"
  by (rule meet_equality, rule is_infI) blast+

lemma join_equality [elim?]: "is_sup x y sup \<Longrightarrow> x \<squnion> y = sup"
proof (unfold join_def)
  assume "is_sup x y sup"
  then show "(THE sup. is_sup x y sup) = sup"
    by (rule the_equality) (rule is_sup_uniq [OF _ \<open>is_sup x y sup\<close>])
qed

lemma joinI [intro?]: "x \<sqsubseteq> sup \<Longrightarrow> y \<sqsubseteq> sup \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> sup \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = sup"
  by (rule join_equality, rule is_supI) blast+

text \<open>
  \medskip The \<open>\<sqinter>\<close> and \<open>\<squnion>\<close> operations indeed determine
  bounds on a lattice structure.
\<close>

lemma is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
proof (unfold meet_def)
  from ex_inf obtain inf where "is_inf x y inf" ..
  then show "is_inf x y (THE inf. is_inf x y inf)"
    by (rule theI) (rule is_inf_uniq [OF _ \<open>is_inf x y inf\<close>])
qed

lemma meet_greatest [intro?]: "z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> x \<sqinter> y"
  by (rule is_inf_greatest) (rule is_inf_meet)

lemma meet_lower1 [intro?]: "x \<sqinter> y \<sqsubseteq> x"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_lower2 [intro?]: "x \<sqinter> y \<sqsubseteq> y"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
proof (unfold join_def)
  from ex_sup obtain sup where "is_sup x y sup" ..
  then show "is_sup x y (THE sup. is_sup x y sup)"
    by (rule theI) (rule is_sup_uniq [OF _ \<open>is_sup x y sup\<close>])
qed

lemma join_least [intro?]: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<squnion> y \<sqsubseteq> z"
  by (rule is_sup_least) (rule is_sup_join)

lemma join_upper1 [intro?]: "x \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_upper2 [intro?]: "y \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

subsection \<open>Duality\<close>

text \<open>
  The class of lattices is closed under formation of dual structures.
  This means that for any theorem of lattice theory, the dualized
  statement holds as well; this important fact simplifies many proofs
  of lattice theory.
\<close>

instance dual :: (lattice) lattice
proof
  fix x' y' :: "'a::lattice dual"
  show "\<exists>inf'. is_inf x' y' inf'"
  proof -
    have "\<exists>sup. is_sup (undual x') (undual y') sup" by (rule ex_sup)
    then have "\<exists>sup. is_inf (dual (undual x')) (dual (undual y')) (dual sup)"
      by (simp only: dual_inf)
    then show ?thesis by (simp add: dual_ex [symmetric])
  qed
  show "\<exists>sup'. is_sup x' y' sup'"
  proof -
    have "\<exists>inf. is_inf (undual x') (undual y') inf" by (rule ex_inf)
    then have "\<exists>inf. is_sup (dual (undual x')) (dual (undual y')) (dual inf)"
      by (simp only: dual_sup)
    then show ?thesis by (simp add: dual_ex [symmetric])
  qed
qed

text \<open>
  Apparently, the \<open>\<sqinter>\<close> and \<open>\<squnion>\<close> operations are dual to each
  other.
\<close>

theorem dual_meet [intro?]: "dual (x \<sqinter> y) = dual x \<squnion> dual y"
proof -
  from is_inf_meet have "is_sup (dual x) (dual y) (dual (x \<sqinter> y))" ..
  then have "dual x \<squnion> dual y = dual (x \<sqinter> y)" ..
  then show ?thesis ..
qed

theorem dual_join [intro?]: "dual (x \<squnion> y) = dual x \<sqinter> dual y"
proof -
  from is_sup_join have "is_inf (dual x) (dual y) (dual (x \<squnion> y))" ..
  then have "dual x \<sqinter> dual y = dual (x \<squnion> y)" ..
  then show ?thesis ..
qed

subsection \<open>Algebraic properties \label{sec:lattice-algebra}\<close>

text \<open>
  The \<open>\<sqinter>\<close> and \<open>\<squnion>\<close> operations have the following
  characteristic algebraic properties: associative (A), commutative
  (C), and absorptive (AB).
\<close>

theorem meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
proof
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
  proof
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> y" ..
      finally show ?thesis .
    qed
  qed
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
  proof -
    have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
    also have "\<dots> \<sqsubseteq> z" ..
    finally show ?thesis .
  qed
  fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
  show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
  proof
    show "w \<sqsubseteq> x"
    proof -
      have "w \<sqsubseteq> x \<sqinter> y" by fact
      also have "\<dots> \<sqsubseteq> x" ..
      finally show ?thesis .
    qed
    show "w \<sqsubseteq> y \<sqinter> z"
    proof
      show "w \<sqsubseteq> y"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> z" by fact
    qed
  qed
qed

theorem join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
proof -
  have "dual ((x \<squnion> y) \<squnion> z) = (dual x \<sqinter> dual y) \<sqinter> dual z"
    by (simp only: dual_join)
  also have "\<dots> = dual x \<sqinter> (dual y \<sqinter> dual z)"
    by (rule meet_assoc)
  also have "\<dots> = dual (x \<squnion> (y \<squnion> z))"
    by (simp only: dual_join)
  finally show ?thesis ..
qed

theorem meet_commute: "x \<sqinter> y = y \<sqinter> x"
proof
  show "y \<sqinter> x \<sqsubseteq> x" ..
  show "y \<sqinter> x \<sqsubseteq> y" ..
  fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
  then show "z \<sqsubseteq> y \<sqinter> x" ..
qed

theorem join_commute: "x \<squnion> y = y \<squnion> x"
proof -
  have "dual (x \<squnion> y) = dual x \<sqinter> dual y" ..
  also have "\<dots> = dual y \<sqinter> dual x"
    by (rule meet_commute)
  also have "\<dots> = dual (y \<squnion> x)"
    by (simp only: dual_join)
  finally show ?thesis ..
qed

theorem meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
proof
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> x \<squnion> y" ..
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
proof -
  have "dual x \<sqinter> (dual x \<squnion> dual y) = dual x"
    by (rule meet_join_absorb)
  then have "dual (x \<squnion> (x \<sqinter> y)) = dual x"
    by (simp only: dual_meet dual_join)
  then show ?thesis ..
qed

text \<open>
  \medskip Some further algebraic properties hold as well.  The
  property idempotent (I) is a basic algebraic consequence of (AB).
\<close>

theorem meet_idem: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
  also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
  finally show ?thesis .
qed

theorem join_idem: "x \<squnion> x = x"
proof -
  have "dual x \<sqinter> dual x = dual x"
    by (rule meet_idem)
  then have "dual (x \<squnion> x) = dual x"
    by (simp only: dual_join)
  then show ?thesis ..
qed

text \<open>
  Meet and join are trivial for related elements.
\<close>

theorem meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
proof
  assume "x \<sqsubseteq> y"
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
proof -
  assume "x \<sqsubseteq> y" then have "dual y \<sqsubseteq> dual x" ..
  then have "dual y \<sqinter> dual x = dual y" by (rule meet_related)
  also have "dual y \<sqinter> dual x = dual (y \<squnion> x)" by (simp only: dual_join)
  also have "y \<squnion> x = x \<squnion> y" by (rule join_commute)
  finally show ?thesis ..
qed

subsection \<open>Order versus algebraic structure\<close>

text \<open>
  The \<open>\<sqinter>\<close> and \<open>\<squnion>\<close> operations are connected with the
  underlying \<open>\<sqsubseteq>\<close> relation in a canonical manner.
\<close>

theorem meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_inf x y x" ..
  then show "x \<sqinter> y = x" ..
next
  have "x \<sqinter> y \<sqsubseteq> y" ..
  also assume "x \<sqinter> y = x"
  finally show "x \<sqsubseteq> y" .
qed

theorem join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_sup x y y" ..
  then show "x \<squnion> y = y" ..
next
  have "x \<sqsubseteq> x \<squnion> y" ..
  also assume "x \<squnion> y = y"
  finally show "x \<sqsubseteq> y" .
qed

text \<open>
  \medskip The most fundamental result of the meta-theory of lattices
  is as follows (we do not prove it here).

  Given a structure with binary operations \<open>\<sqinter>\<close> and \<open>\<squnion>\<close>
  such that (A), (C), and (AB) hold (cf.\
  \S\ref{sec:lattice-algebra}).  This structure represents a lattice,
  if the relation \<^term>\<open>x \<sqsubseteq> y\<close> is defined as \<^term>\<open>x \<sqinter> y = x\<close>
  (alternatively as \<^term>\<open>x \<squnion> y = y\<close>).  Furthermore, infimum and
  supremum with respect to this ordering coincide with the original
  \<open>\<sqinter>\<close> and \<open>\<squnion>\<close> operations.
\<close>

subsection \<open>Example instances\<close>

subsubsection \<open>Linear orders\<close>

text \<open>
  Linear orders with \<^term>\<open>minimum\<close> and \<^term>\<open>maximum\<close> operations
  are a (degenerate) example of lattice structures.
\<close>

definition
  minimum :: "'a::linear_order \<Rightarrow> 'a \<Rightarrow> 'a" where
  "minimum x y = (if x \<sqsubseteq> y then x else y)"
definition
  maximum :: "'a::linear_order \<Rightarrow> 'a \<Rightarrow> 'a" where
  "maximum x y = (if x \<sqsubseteq> y then y else x)"

lemma is_inf_minimum: "is_inf x y (minimum x y)"
proof
  let ?min = "minimum x y"
  from leq_linear show "?min \<sqsubseteq> x" by (auto simp add: minimum_def)
  from leq_linear show "?min \<sqsubseteq> y" by (auto simp add: minimum_def)
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  with leq_linear show "z \<sqsubseteq> ?min" by (auto simp add: minimum_def)
qed

lemma is_sup_maximum: "is_sup x y (maximum x y)"      (* FIXME dualize!? *)
proof
  let ?max = "maximum x y"
  from leq_linear show "x \<sqsubseteq> ?max" by (auto simp add: maximum_def)
  from leq_linear show "y \<sqsubseteq> ?max" by (auto simp add: maximum_def)
  fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
  with leq_linear show "?max \<sqsubseteq> z" by (auto simp add: maximum_def)
qed

instance linear_order \<subseteq> lattice
proof
  fix x y :: "'a::linear_order"
  from is_inf_minimum show "\<exists>inf. is_inf x y inf" ..
  from is_sup_maximum show "\<exists>sup. is_sup x y sup" ..
qed

text \<open>
  The lattice operations on linear orders indeed coincide with \<^term>\<open>minimum\<close> and \<^term>\<open>maximum\<close>.
\<close>

theorem meet_mimimum: "x \<sqinter> y = minimum x y"
  by (rule meet_equality) (rule is_inf_minimum)

theorem meet_maximum: "x \<squnion> y = maximum x y"
  by (rule join_equality) (rule is_sup_maximum)

subsubsection \<open>Binary products\<close>

text \<open>
  The class of lattices is closed under direct binary products (cf.\
  \S\ref{sec:prod-order}).
\<close>

lemma is_inf_prod: "is_inf p q (fst p \<sqinter> fst q, snd p \<sqinter> snd q)"
proof
  show "(fst p \<sqinter> fst q, snd p \<sqinter> snd q) \<sqsubseteq> p"
  proof -
    have "fst p \<sqinter> fst q \<sqsubseteq> fst p" ..
    moreover have "snd p \<sqinter> snd q \<sqsubseteq> snd p" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  show "(fst p \<sqinter> fst q, snd p \<sqinter> snd q) \<sqsubseteq> q"
  proof -
    have "fst p \<sqinter> fst q \<sqsubseteq> fst q" ..
    moreover have "snd p \<sqinter> snd q \<sqsubseteq> snd q" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  fix r assume rp: "r \<sqsubseteq> p" and rq: "r \<sqsubseteq> q"
  show "r \<sqsubseteq> (fst p \<sqinter> fst q, snd p \<sqinter> snd q)"
  proof -
    have "fst r \<sqsubseteq> fst p \<sqinter> fst q"
    proof
      from rp show "fst r \<sqsubseteq> fst p" by (simp add: leq_prod_def)
      from rq show "fst r \<sqsubseteq> fst q" by (simp add: leq_prod_def)
    qed
    moreover have "snd r \<sqsubseteq> snd p \<sqinter> snd q"
    proof
      from rp show "snd r \<sqsubseteq> snd p" by (simp add: leq_prod_def)
      from rq show "snd r \<sqsubseteq> snd q" by (simp add: leq_prod_def)
    qed
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
qed

lemma is_sup_prod: "is_sup p q (fst p \<squnion> fst q, snd p \<squnion> snd q)"  (* FIXME dualize!? *)
proof
  show "p \<sqsubseteq> (fst p \<squnion> fst q, snd p \<squnion> snd q)"
  proof -
    have "fst p \<sqsubseteq> fst p \<squnion> fst q" ..
    moreover have "snd p \<sqsubseteq> snd p \<squnion> snd q" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  show "q \<sqsubseteq> (fst p \<squnion> fst q, snd p \<squnion> snd q)"
  proof -
    have "fst q \<sqsubseteq> fst p \<squnion> fst q" ..
    moreover have "snd q \<sqsubseteq> snd p \<squnion> snd q" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  fix r assume "pr": "p \<sqsubseteq> r" and qr: "q \<sqsubseteq> r"
  show "(fst p \<squnion> fst q, snd p \<squnion> snd q) \<sqsubseteq> r"
  proof -
    have "fst p \<squnion> fst q \<sqsubseteq> fst r"
    proof
      from "pr" show "fst p \<sqsubseteq> fst r" by (simp add: leq_prod_def)
      from qr show "fst q \<sqsubseteq> fst r" by (simp add: leq_prod_def)
    qed
    moreover have "snd p \<squnion> snd q \<sqsubseteq> snd r"
    proof
      from "pr" show "snd p \<sqsubseteq> snd r" by (simp add: leq_prod_def)
      from qr show "snd q \<sqsubseteq> snd r" by (simp add: leq_prod_def)
    qed
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
qed

instance prod :: (lattice, lattice) lattice
proof
  fix p q :: "'a::lattice \<times> 'b::lattice"
  from is_inf_prod show "\<exists>inf. is_inf p q inf" ..
  from is_sup_prod show "\<exists>sup. is_sup p q sup" ..
qed

text \<open>
  The lattice operations on a binary product structure indeed coincide
  with the products of the original ones.
\<close>

theorem meet_prod: "p \<sqinter> q = (fst p \<sqinter> fst q, snd p \<sqinter> snd q)"
  by (rule meet_equality) (rule is_inf_prod)

theorem join_prod: "p \<squnion> q = (fst p \<squnion> fst q, snd p \<squnion> snd q)"
  by (rule join_equality) (rule is_sup_prod)

subsubsection \<open>General products\<close>

text \<open>
  The class of lattices is closed under general products (function
  spaces) as well (cf.\ \S\ref{sec:fun-order}).
\<close>

lemma is_inf_fun: "is_inf f g (\<lambda>x. f x \<sqinter> g x)"
proof
  show "(\<lambda>x. f x \<sqinter> g x) \<sqsubseteq> f"
  proof
    fix x show "f x \<sqinter> g x \<sqsubseteq> f x" ..
  qed
  show "(\<lambda>x. f x \<sqinter> g x) \<sqsubseteq> g"
  proof
    fix x show "f x \<sqinter> g x \<sqsubseteq> g x" ..
  qed
  fix h assume hf: "h \<sqsubseteq> f" and hg: "h \<sqsubseteq> g"
  show "h \<sqsubseteq> (\<lambda>x. f x \<sqinter> g x)"
  proof
    fix x
    show "h x \<sqsubseteq> f x \<sqinter> g x"
    proof
      from hf show "h x \<sqsubseteq> f x" ..
      from hg show "h x \<sqsubseteq> g x" ..
    qed
  qed
qed

lemma is_sup_fun: "is_sup f g (\<lambda>x. f x \<squnion> g x)"   (* FIXME dualize!? *)
proof
  show "f \<sqsubseteq> (\<lambda>x. f x \<squnion> g x)"
  proof
    fix x show "f x \<sqsubseteq> f x \<squnion> g x" ..
  qed
  show "g \<sqsubseteq> (\<lambda>x. f x \<squnion> g x)"
  proof
    fix x show "g x \<sqsubseteq> f x \<squnion> g x" ..
  qed
  fix h assume fh: "f \<sqsubseteq> h" and gh: "g \<sqsubseteq> h"
  show "(\<lambda>x. f x \<squnion> g x) \<sqsubseteq> h"
  proof
    fix x
    show "f x \<squnion> g x \<sqsubseteq> h x"
    proof
      from fh show "f x \<sqsubseteq> h x" ..
      from gh show "g x \<sqsubseteq> h x" ..
    qed
  qed
qed

instance "fun" :: (type, lattice) lattice
proof
  fix f g :: "'a \<Rightarrow> 'b::lattice"
  show "\<exists>inf. is_inf f g inf" by rule (rule is_inf_fun) (* FIXME @{text "from \<dots> show \<dots> .."} does not work!? unification incompleteness!? *)
  show "\<exists>sup. is_sup f g sup" by rule (rule is_sup_fun)
qed

text \<open>
  The lattice operations on a general product structure (function
  space) indeed emerge by point-wise lifting of the original ones.
\<close>

theorem meet_fun: "f \<sqinter> g = (\<lambda>x. f x \<sqinter> g x)"
  by (rule meet_equality) (rule is_inf_fun)

theorem join_fun: "f \<squnion> g = (\<lambda>x. f x \<squnion> g x)"
  by (rule join_equality) (rule is_sup_fun)

subsection \<open>Monotonicity and semi-morphisms\<close>

text \<open>
  The lattice operations are monotone in both argument positions.  In
  fact, monotonicity of the second position is trivial due to
  commutativity.
\<close>

theorem meet_mono: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> w \<Longrightarrow> x \<sqinter> y \<sqsubseteq> z \<sqinter> w"
proof -
  {
    fix a b c :: "'a::lattice"
    assume "a \<sqsubseteq> c" have "a \<sqinter> b \<sqsubseteq> c \<sqinter> b"
    proof
      have "a \<sqinter> b \<sqsubseteq> a" ..
      also have "\<dots> \<sqsubseteq> c" by fact
      finally show "a \<sqinter> b \<sqsubseteq> c" .
      show "a \<sqinter> b \<sqsubseteq> b" ..
    qed
  } note this [elim?]
  assume "x \<sqsubseteq> z" then have "x \<sqinter> y \<sqsubseteq> z \<sqinter> y" ..
  also have "\<dots> = y \<sqinter> z" by (rule meet_commute)
  also assume "y \<sqsubseteq> w" then have "y \<sqinter> z \<sqsubseteq> w \<sqinter> z" ..
  also have "\<dots> = z \<sqinter> w" by (rule meet_commute)
  finally show ?thesis .
qed

theorem join_mono: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> w \<Longrightarrow> x \<squnion> y \<sqsubseteq> z \<squnion> w"
proof -
  assume "x \<sqsubseteq> z" then have "dual z \<sqsubseteq> dual x" ..
  moreover assume "y \<sqsubseteq> w" then have "dual w \<sqsubseteq> dual y" ..
  ultimately have "dual z \<sqinter> dual w \<sqsubseteq> dual x \<sqinter> dual y"
    by (rule meet_mono)
  then have "dual (z \<squnion> w) \<sqsubseteq> dual (x \<squnion> y)"
    by (simp only: dual_join)
  then show ?thesis ..
qed

text \<open>
  \medskip A semi-morphisms is a function \<open>f\<close> that preserves the
  lattice operations in the following manner: \<^term>\<open>f (x \<sqinter> y) \<sqsubseteq> f x
  \<sqinter> f y\<close> and \<^term>\<open>f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)\<close>, respectively.  Any of
  these properties is equivalent with monotonicity.
\<close>

theorem meet_semimorph:
  "(\<And>x y. f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y) \<equiv> (\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y)"
proof
  assume morph: "\<And>x y. f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y"
  fix x y :: "'a::lattice"
  assume "x \<sqsubseteq> y"
  then have "x \<sqinter> y = x" ..
  then have "x = x \<sqinter> y" ..
  also have "f \<dots> \<sqsubseteq> f x \<sqinter> f y" by (rule morph)
  also have "\<dots> \<sqsubseteq> f y" ..
  finally show "f x \<sqsubseteq> f y" .
next
  assume mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  show "\<And>x y. f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y"
  proof -
    fix x y
    show "f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y"
    proof
      have "x \<sqinter> y \<sqsubseteq> x" .. then show "f (x \<sqinter> y) \<sqsubseteq> f x" by (rule mono)
      have "x \<sqinter> y \<sqsubseteq> y" .. then show "f (x \<sqinter> y) \<sqsubseteq> f y" by (rule mono)
    qed
  qed
qed

lemma join_semimorph:
  "(\<And>x y. f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)) \<equiv> (\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y)"
proof
  assume morph: "\<And>x y. f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"
  fix x y :: "'a::lattice"
  assume "x \<sqsubseteq> y" then have "x \<squnion> y = y" ..
  have "f x \<sqsubseteq> f x \<squnion> f y" ..
  also have "\<dots> \<sqsubseteq> f (x \<squnion> y)" by (rule morph)
  also from \<open>x \<sqsubseteq> y\<close> have "x \<squnion> y = y" ..
  finally show "f x \<sqsubseteq> f y" .
next
  assume mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  show "\<And>x y. f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"
  proof -
    fix x y
    show "f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"
    proof
      have "x \<sqsubseteq> x \<squnion> y" .. then show "f x \<sqsubseteq> f (x \<squnion> y)" by (rule mono)
      have "y \<sqsubseteq> x \<squnion> y" .. then show "f y \<sqsubseteq> f (x \<squnion> y)" by (rule mono)
    qed
  qed
qed

end


theory PnP_Exercises imports Main
begin
(* 2.1 *)
value "1+(2::nat)"
value "1+(2::int)"
value "1-(2::nat)"
value "1-(2::int)"

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

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

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

lemma add_03: "m = add m 0"
  apply simp
  done

lemma add_05[simp]: "add 0 m = add m 0"
  apply (simp)
  done

lemma add_06[simp]: "Suc(add x y) = add x (Suc y)"
  apply (induction x)
  apply (auto)
  done
lemma add_07[simp]: "add x (Suc y) = Suc (add x y)"
  apply (simp)
  done

theorem add_comm: "add x y = add y x"
  apply (induct x)
  apply (simp)
  using add.simps(2) add_07 by presburger

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

lemma double_2: "double 0 = add 0 0"
  apply (simp)
  done

theorem double_add: "double n = add n n"
  apply (induction n)
  apply (simp)
  using add.simps(2) add_06 double.simps(2) by presburger

(* 2.3 *)
fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x [] = 0" |
"count x (Cons y xs) = (count x xs) + (if x = y then 1 else 0)"

theorem count_lt_len: "count x y \<le> length y"
  apply (induction y)
  apply (simp)
  apply (auto)
  done
end


theory Chapter4
imports "~~/src/HOL/IMP/ASM"
begin

text{*
\section*{Chapter 4}

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

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

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

fun set :: "'a tree \<Rightarrow> 'a set"  where
"set Tip = {}" |
"set (Node t1 a t2) = (set t1) Un {a} Un (set t2)"

fun ord :: "int tree \<Rightarrow> bool"  where
"ord Tip = True" |
"ord (Node t1 n t2) = ((ALL i : set t1. i \<le> n) & (ALL i : set t2. n \<le> i))"

text{* Hint: use quantifiers.

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

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
"ins n Tip = (Node Tip n Tip)" |
"ins n (Node t1 m t2) =
    (if n = m then Node t1 m t2
     else if n < m then Node (ins n t1) m t2
     else Node t1 m (ins n t2))"

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

lemma set_ins: "set(ins x t) = {x} \<union> set t"
apply(induction t)
apply(auto)
done

lemma ins_le:"(ALL n: set t. n \<le> m) & i < m \<Longrightarrow> ALL n: set (ins i t). n \<le> m"
apply(induction t)
apply(auto)
done

lemma ins_ge:"(ALL n: set t. m \<le> n) & ~(i < m) & i \<noteq> m \<Longrightarrow> ALL n: set (ins i t). m \<le> n"
apply(induction t)
apply(auto)
done

theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
apply(induction t)
apply(auto simp add:ins_le)
apply(auto simp add:ins_ge)
done

text{*
\endexercise

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

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

thm conjI
thm refl
thm refl[of "a"]
thm conjI [OF refl[of "a"] refl[of "b"]]

inductive palindrome :: "'a list \<Rightarrow> bool" where
base0: "palindrome []" |
base1: "palindrome [x]" |
cons_append: "palindrome x \<Longrightarrow> palindrome (a # x @ [a])"

text {* and prove *}

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
apply(induction xs rule: palindrome.induct)
apply(auto)
done

text{*
\endexercise

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

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

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

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

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

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

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

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

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

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

text{*
\endexercise

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

datatype alpha = a | b

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

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

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

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

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

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

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

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

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

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

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

text{*
\endexercise

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

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

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

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

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

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

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

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

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

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

end


(*
Exercise 2.2. Start from the definition of add given above. Prove that add
is associative and commutative. Define a recursive function double :: nat \<Rightarrow>
nat and prove double m = add m m.
*)

theory Answer
imports Main
begin

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

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

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

lemma add_comm: "add m n = add n m"
apply(induction m)
apply(auto)
done

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

lemma double_add: "double m = add m m"
apply(induction m)
apply(auto)
done

end


theory "Exercise-2"
  imports Main
begin
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

primrec mirror::"'a tree \<Rightarrow> 'a tree"where
"mirror Tip = Tip"|
"mirror (Node l a r) = Node (mirror l) a (mirror r)"

lemma "mirror(mirror r) = r"
  apply (induction r)
   apply auto
  done

datatype 'a option = None | Some 'a

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

definition sq::"nat\<Rightarrow>nat" where
"sq n = n*n"

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

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 n = n div 2"
  apply(induction n rule:div2.induct)
   apply auto
  done

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

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

theorem "treesum t = sum_list (contents t)"
  apply(induct t )
  apply auto
  done

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

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

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

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

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

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

value "intersperse a [b,c,d,e]"
thm intersperse.induct
thm intersperse.cases
theorem map_intersperse:"map f(intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
  apply auto
  done

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

lemma itrev_rule[simp]: "itrev xs ys = rev xs @ ys"
proof(induction xs arbitrary:ys)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case by auto
qed

theorem "itrev xs [] = rev xs"
  apply(induction xs)
   apply(auto)
  done

primrec itadd::"nat\<Rightarrow>nat\<Rightarrow>nat"where
"itadd 0 m = m"|
"itadd (Suc m ) n = itadd m (Suc n)"
value "itadd 3 4"

text "Tail-recursive: f ...  = f ... "
primrec add::"nat\<Rightarrow>nat\<Rightarrow>nat"where
"add 0 n = n"|
"add (Suc m) n = Suc (add m n)"

lemma add_itadd[simp]:"add m (Suc n) = Suc (add m n)"
  apply (induction m)
   apply auto
  done
theorem "itadd m n = add m n"
  apply(induction m arbitrary:n)
   apply auto
  done

datatype tree0 = Leaf|Node "tree0" "tree0"

fun nodes::"tree0 \<Rightarrow>nat"where
"nodes Leaf =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 explode_count:"nodes(explode n t) = 2^n * (nodes t +1)-1 "
  apply(induction n arbitrary: t)
   apply (auto simp add:algebra_simps)
  done

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

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

fun evalp::"int list \<Rightarrow> int \<Rightarrow> int"where
"evalp [] v = 0"|
"evalp (x # xs) v = x + v*evalp xs v"

value "evalp [1,2,3] x"

fun add_coeffs::"int list \<Rightarrow> int list \<Rightarrow>int list"where
"add_coeffs [] ys = ys"|
"add_coeffs xs [] = xs"|
"add_coeffs (x#xs) (y#ys) = [x+y] @ (add_coeffs xs ys)"
value "add_coeffs [1,2,3] [4,5]"
fun mult::"int list \<Rightarrow> int \<Rightarrow>int list"where
"mult [] _ = []"|
"mult (x#xs) y = (x*y) # mult xs y"
fun mult_coeffs::"int list \<Rightarrow> int list \<Rightarrow> int list"where
"mult_coeffs _ [] = []"|
"mult_coeffs xs (y # ys) = add_coeffs (mult xs y) (mult_coeffs (0#xs) ys)"
value "mult_coeffs [1,2,3] [4,5]"
fun coeffs :: "exp \<Rightarrow> int list"where
"coeffs Var = [0,1]"|
"coeffs (Const e) = [e]"|
"coeffs (Add e f) = add_coeffs (coeffs e) (coeffs f)"|
"coeffs (Mult e f) = mult_coeffs (coeffs e) (coeffs f)"
thm algebra_simps

lemma [simp]:"evalp (mult xs y) a = y * evalp xs a"
  apply(induction xs arbitrary:y)
   apply (auto simp add:algebra_simps)
  done

lemma [simp]:"evalp (mult_coeffs xs ys) a = (evalp xs a )*(evalp ys a)"
  apply (induction rule:mult_coeffs.induct)
   apply (auto simp add:algebra_simps)
  done

theorem "evalp (coeffs e) x = eval e x"
  apply (induction e)
  apply auto
  done


(*
    $Id: ex.thy,v 1.3 2005/06/29 07:38:01 kleing Exp $
    Author: Tobias Nipkow
*)

(*<*) theory ex3_1 imports Main begin (*>*)

subsubsection {* Power *}

text {* Define a primitive recursive function $pow~x~n$ that
computes $x^n$ on natural numbers. *}

fun  pow :: "nat => nat => nat" where
"pow x 0 = Suc 0"
|"pow x y = x * pow x (y-1)"

text {* Prove the well known equation $x^{m \cdot n} = (x^m)^n$: *}

lemma pow_1: " pow x (y+z) = pow x y * pow x z "
  apply( induct z)
   apply auto
  done

theorem pow_mult: "pow x (m * n) = pow (pow x m) n"
  apply (induct n)
   apply (auto simp add: pow_1)
  done

text {* Hint: prove a suitable lemma first.  If you need to appeal to
associativity and commutativity of multiplication: the corresponding
simplification rules are named @{text mult_ac}. *}

subsubsection {* Summation *}

text {* Define a (primitive recursive) function $sum~ns$ that sums a list
of natural numbers: $sum [n_1, \dots, n_k] = n_1 + \cdots + n_k$. *}

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

text {* Show that $sum$ is compatible with $rev$. You may need a lemma. *}

lemma sum_1:" sum (x@[y]) =sum x + y "
  apply (induct x)
   apply auto
  done

theorem sum_rev: "sum (rev ns) = sum ns"
  apply (induct ns)
   apply (auto simp add:sum_1)
  done

text {* Define a function $Sum~f~k$ that sums $f$ from $0$ up to $k-1$:
$Sum~f~k = f~0 + \cdots + f(k - 1)$. *}

fun  Sum :: "(nat => nat) => nat => nat" where
"Sum f 0 = 0"
| "Sum f (Suc(k)) = f k + Sum f k"

text {* Show the following equations for the pointwise summation of functions.
Determine first what the expression @{text whatever} should be. *}

theorem "Sum (%i. f i + g i) k = Sum f k + Sum g k"
  apply (induct k)
   apply auto
  done

theorem "Sum f (k + l) = Sum f k + Sum (%i. f(k+i)) l"
  apply (induct l)
   apply auto
  done

text {* What is the relationship between @{term sum} and @{text Sum}?
Prove the following equation, suitably instantiated. *}

theorem "Sum f k = sum (map f [0..<k])"
  apply (induct k)
   apply (auto simp add:sum_1)
  oops

text {* Hint: familiarize yourself with the predefined functions @{term map}
and @{text"[i..<j]"} on lists in theory List. *}

(*<*) end (*>*)


theory Chapter2
imports Main
begin

value  "1 + (2::nat)"

value "1 + (2::int)"

value "1 - (2::nat)"

value "1 - (2::int)"

value "[a,b] @ [c,d]"

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

lemma add_assoc : "add (add m n) p = add m (add n p)"
  apply (induction m)
  apply auto
  done

lemma add_aux1 [simp] : "n = add n 0"
  apply (induction n)
  apply auto
  done

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

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

lemma double_add: "double m = add m m"
  apply (induction m)
  apply auto
  done

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
"count [] x = 0" |
"count (x#xs) y = (if x = y then (1+ count xs y) else (count xs y))"

theorem "count xs x \<le> length xs"
  apply (induction xs)
  apply auto
  done

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

value "snoc [1,2,3] (4::int)"

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

value "reverse [1,2,3,(4::int)]"
value "reverse [(4::int)]"

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

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

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

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

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

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

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

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

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

value "rev (post_order (Node (Node (Tip 1) 4 (Tip 2)) 3 (Node (Tip 0) 7 (Tip (4::int)))))"
value "pre_order (mirror (Node (Node (Tip 1) 4 (Tip 2)) 3 (Node (Tip 0) 7 (Tip (4::int)))))"

lemma "pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
  apply auto
  done

end


(*<*) theory ex1_8 imports Main begin (*>*)

text {*
\begin{description}
\item[\bf (a)] Define a primitive recursive function @{term ListSum} that
computes the sum of all elements of a list of natural numbers.

Prove the following equations.  Note that @{term  "[0..n]"} und @{term
"replicate n a"} are already defined in a theory {\tt List.thy}.
\end{description}
*}

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

theorem "2 * ListSum [0..<n+1] = n * (n + 1)"
  apply (induct n)
   apply auto
  done

theorem "ListSum (replicate n a) = n * a"
  apply (induct n)
   apply auto
  done

text {*
\begin{description}
\item[\bf (b)] Define an equivalent function @{term ListSumT} using a
tail-recursive function @{term ListSumTAux}.  Prove that @{term ListSum}
and @{term ListSumT} are in fact equivalent.
\end{description}
*}

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

fun ListSumT :: "nat list \<Rightarrow> nat" where
"ListSumT x = ListSumTAux x 0"

lemma [simp]:" \<forall>a. ListSumTAux xs a = a+ListSum xs"
  apply (induct xs)
   apply auto
  done

theorem " ListSumT xs=ListSum xs "
  apply(induct xs)
   apply (auto )
  done

(*<*) end (*>*)


theory Chap2Exercises
  imports Main
begin

declare [[names_short]]

text "Exercise 2.1"

(* Following produces 3 *)
value "1 + (2::nat)"

(* Following produces 3 *)
value "1 + (2::int)"

(* Following produces 0 *)
value "1 - (2::nat)"

(* Following produces -1 *)
value "1 - (2::int)"

text "Exercise 2.2"

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

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

value "double 3"

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

lemma add_swap: "add x 0 = add 0 x"
  apply (induction x)
   apply (auto)
  done

lemma add_commutative: "add y x = add x y"
  apply (induction x)
   apply (auto)
  apply (simp add:add_swap)
  done

lemma double_is_addition: "add x x = double x"
  apply (induction x)
   apply (auto)
  done

text "Exercise 2.3"

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count a Nil = 0" |
  "count a (Cons x xs) = (if x = a then add 1 (count a xs) else add 0 (count a xs))"

value "count a [b, c, a]"

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

text "Exercise 2.4"

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

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

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

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

text "Exercise 2.5"

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

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

text "Exercise 2.6"

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

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

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

fun listsum :: "nat list \<Rightarrow> nat" where
  "listsum Nil = 0" |
  "listsum (Cons x xs) = x + listsum xs"

lemma sum_of_two_lists [simp]: "listsum x + listsum y = listsum (append x y)"
  apply (induction x)
   apply (auto)
  done

lemma sum_is_same: "treesum t = listsum (contents t)"
  apply (induction t)
  apply (auto)
  done

text "Exercise 2.7"

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

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

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Leaf a) = Cons a Nil" |
  "pre_order (Node l a r) = Cons a (append (pre_order l) (pre_order r))"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
  "post_order (Leaf a) = Cons a Nil" |
  "post_order (Node l a r) = append (append (post_order l) (post_order r)) (Cons a Nil)"

lemma pre_reverse_post: "pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
  apply (auto)
  done

text "Exercise 2.8"

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse a Nil = Nil" |
  "intersperse a (Cons b Nil) = Cons b Nil" |
  "intersperse a (Cons b xs) = Cons b (Cons a (intersperse a xs))"

value "intersperse a [b, c, d]"

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

text "Exercise 2.9"

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

lemma add_identity [simp]: "add n 0 = n"
  apply (induction n)
  apply (auto)
  done

lemma add_it_rec_equiv: "itadd n m = add n m"
  apply (induction m arbitrary: n)
   apply (auto)
  done

text "Exercise 2.10"

datatype tree0 = last | node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes last = 1" |
  "nodes (node n1 n2) = 1 + nodes n1 + nodes n2"

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

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

text "Exercise 2.11"

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

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval (Var) x = x" |
  "eval (Const c) x = c" |
  "eval (Add a b) x = (eval a) x + (eval b) x" |
  "eval (Mult a b) x = (eval a) x * (eval b) x"

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

end


theory Chapter2
  imports Main
begin

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

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

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

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

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

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

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

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

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

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

lemma add_suc0 [simp]: "Suc (add y 0) = add y (Suc 0)"
  apply (induction y)
   apply (auto)
  done

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

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

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

theorem double_add [simp]: "double n = (add n n)"
  apply (induction n)
   apply (auto)
  done

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

fun count::"'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x (Cons y xs) = (if (y = x) then 1 + (count x xs) else (count x xs))" |
"count x Nil = 0"

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

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

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

lemma app_snoc [simp]: "app xs (Cons x Nil) = snoc xs x"
  apply (induction xs)
  apply (auto)
  done

lemma rev_snoc [simp]: "rev (Cons x xs) = snoc (rev xs) x"
  apply (induction xs)
   apply (auto)
  done

lemma rev_reverse [simp]: "reverse xs = rev xs"
  apply (induction xs)
  apply (auto)
  done

theorem reverse_reverse [simp]: "reverse (reverse xs) = xs"
  apply (auto) (*not every proof needs induction, fool*)
  done

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

theorem arith_ser [simp]: "sum_upto n = n * (n + 1) div 2"
  apply (induction n)
   apply (auto)
  done

type_synonym string = "char list"

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

datatype 'a option = None | Some 'a

abbreviation sq'::"nat \<Rightarrow> nat" where
"sq' n \<equiv> n * n" (*abbreviations are directly inserted; \equiv is the same as ==*)

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

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

(*lemma "div2 n = n div 2"
  apply (induction n)
  apply (auto)
  done*) (*case analysis required -- see later section*)

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

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

fun sum_list::"nat list \<Rightarrow> nat" where
"sum_list Nil = 0" |
"sum_list (Cons x xs) = x + sum_list xs"

lemma add_list_sum [simp]: "sum_list (app xs ys) = (sum_list xs) + (sum_list ys)"
  apply (induction xs)
  apply (auto)
  done

theorem sum_tree_eq_sum_list [simp]: "sum_tree t = sum_list (contents t)"
  apply (induction t rule:sum_tree.induct)
  apply (auto)
  done

fun pre_order::"'a tree \<Rightarrow> 'a list" where
"pre_order Tip = Nil" |
"pre_order (Node l e r) = Cons e (app (pre_order l) (pre_order r))"

fun post_order::"'a tree \<Rightarrow> 'a list" where
"post_order Tip = Nil" |
"post_order (Node l e r) = snoc (app (post_order l) (post_order r)) e"

fun mirror::"'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l e r) = Node (mirror r) e (mirror l)"

lemma post_order_alt [simp]: "post_order (Node l e r) = app (app (post_order l) (post_order r)) (Cons e Nil)"
  apply (auto)
  done

lemma rev_mono_list [simp]: "rev (app xs (Cons x Nil)) = Cons x (rev xs)"
  apply (induction xs)
  apply (auto)
  done

lemma rev_snoc1 [simp]: "rev (snoc xs x) = Cons x (rev xs)"
  apply (induction xs)
  apply (auto)
  done

theorem mirror_order [simp]: "pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
  apply (auto)
  done

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

theorem map_intersperse [simp]: "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs)
  apply (auto)
  done

fun itrev::"'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev Nil ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

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

lemma "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
  apply (auto)
  done

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

lemma itadd_suc [simp]: "itadd n (Suc m) = Suc (itadd n m)"
  apply (induction n arbitrary: m)
  apply (auto)
  done

lemma "add n (Suc m) = itadd n (Suc m)"
  apply (induction n)
   apply (auto)
  done

lemma itadd0 [simp]: "itadd n 0 = n"
  apply (induction n)
  apply (auto)
  done

lemma add01 [simp]: "add (Suc n) 0 = Suc n"
  apply (induction n)
  apply (auto)
  done

lemma add1 [simp]: "add n (Suc 0) = Suc n"
  apply (induction n)
  apply (auto)
  done

lemma itadd_comm [simp]: "itadd n m = itadd m n"
  apply (induction n)
  apply (auto)
  done

lemma itadd_assoc [simp]: "itadd (itadd n m) x = itadd n (itadd m x)"
  apply (induction n)
  apply (auto)
  done

lemma itadd_add1 [simp]: "itadd n m = add (add n 0) m"
  apply (induction m arbitrary: n)
  apply (auto)
  done

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

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

lemma itadd_add [simp]: "itadd n m = add n m"
  apply (induction m arbitrary: n)
  apply (auto)
  done

datatype tree0 = Leaf | Node "tree0" "tree0"

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

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

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

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

fun eval::"exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var i = i" |
"eval (Const x) i = x" |
"eval (Add l r) i = (eval l i) + (eval r i)" |
"eval (Mult l r) i = (eval l i) * (eval r i)"

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

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

fun multp::"int list \<Rightarrow> int list \<Rightarrow> int list" where
"multp Nil ys = Nil" |
"multp (x#xs) ys = addp (map (\<lambda> y. x * y) ys) (0#(multp xs ys))"

fun coeffs::"exp \<Rightarrow> int list" where
"coeffs Var = [0, 1]" |
"coeffs (Const x) = [x, 0]" |
"coeffs (Add l r) = addp (coeffs l) (coeffs r)" |
"coeffs (Mult l r) = multp (coeffs l) (coeffs r)"

lemma evalp_addition [simp]: "evalp (addp e1 e2) x = evalp e1 x + evalp e2 x"
  apply (induction rule: addp.induct)
  apply (auto simp add: algebra_simps)
  done

lemma mult_map [simp]: "evalp (map ((*) xa) ys) x = xa * evalp ys x"
  apply (induction ys)
   apply (auto simp add: algebra_simps)
  done

lemma evalp_multiplication [simp]: "evalp (multp e1 e2) x = evalp e1 x * evalp e2 x"
  apply (induction rule: multp.induct)
  apply (auto simp add: algebra_simps)
  done

theorem coeffs_preserves_values [simp]: "evalp (coeffs e) x = eval e x"
  apply (induction e)
  apply (simp_all add: algebra_simps)
  done

end


section "Integer Compositions"

theory Integer_Compositions
  imports
    Common_Lemmas
begin

subsection"Definition"

definition integer_compositions :: "nat \<Rightarrow> nat list set" where
  "integer_compositions i = {xs. sum_list xs = i \<and> 0 \<notin> set xs}"
text "Integer compositions are \<open>integer_partitions\<close> where the order matters."
text "Cardinality: \<open>sum from n = 1 to i (binomial (i-1) (n-1)) = 2^(i-1)\<close>"
text "Example: \<open>integer_compositions 3 = {[3], [2,1], [1,2], [1,1,1]}\<close>"

subsection"Algorithm"

fun integer_composition_enum :: "nat \<Rightarrow> nat list list" where
  "integer_composition_enum 0 = [[]]"
| "integer_composition_enum (Suc n) =
    [Suc m #xs. m \<leftarrow> [0..< Suc n], xs \<leftarrow> integer_composition_enum (n-m)]"

subsection"Verification"

subsubsection"Correctness"

lemma integer_composition_enum_tail_elem:
  "x#xs \<in> set (integer_composition_enum n) \<Longrightarrow> xs \<in> set (integer_composition_enum (n - x))"
  by(induct n) auto

lemma integer_composition_enum_not_null_aux:
  "x#xs \<in> set (integer_composition_enum n) \<Longrightarrow> x \<noteq> 0"
  by(induct n) auto

lemma integer_composition_enum_not_null: "xs \<in> set (integer_composition_enum n) \<Longrightarrow> 0 \<notin> set xs"
proof(induct xs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons a xs)
  then show ?case
    using integer_composition_enum_not_null_aux integer_composition_enum_tail_elem
    by fastforce
qed

lemma integer_composition_enum_empty: "[] \<in> set (integer_composition_enum n) \<Longrightarrow> n = 0"
  by(induct n) auto

lemma integer_composition_enum_sum: "xs \<in> set (integer_composition_enum n) \<Longrightarrow> sum_list xs = n"
proof(induct n arbitrary: xs rule: integer_composition_enum.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  show ?case proof(cases xs)
    case Nil
    then show ?thesis using 2 by auto
  next
    case (Cons y ys)
    have p1: "sum_list ys = Suc x - y" using 2 Cons
      by auto

    have "Suc x \<ge> y"
      using 2 Cons by auto
    then have p2: "sum_list ys = Suc x - y \<Longrightarrow> y + sum_list ys = Suc x"
      by simp

    show ?thesis
      using p1 p2 Cons by simp
  qed
qed

lemma integer_composition_enum_head_set:
  assumes"x \<noteq> 0" and "x \<le> n"
  shows" xs \<in> set (integer_composition_enum (n-x)) \<Longrightarrow> x#xs \<in> set (integer_composition_enum n)"
using assms proof(induct n arbitrary: x xs)
  case 0
  then show ?case
    by simp
next
  case c1: (Suc n)
  from c1.prems have 1:
    "\<forall>y\<in>{0..<n}. x = Suc y \<longrightarrow> xs \<notin> set (integer_composition_enum (n - y)) \<Longrightarrow> x = Suc n"
    by(induct x) simp_all

  then have 2: "\<forall>y\<in>{0..<n}. x = Suc y \<longrightarrow> xs \<notin> set (integer_composition_enum (n - y)) \<Longrightarrow> xs = []"
    using c1.prems(1) by simp
  show ?case using 1 2 by auto
qed

lemma integer_composition_enum_correct_aux:
  "0 \<notin> set xs \<Longrightarrow> xs \<in> set (integer_composition_enum (sum_list xs))"
  by(induct xs) (auto simp: integer_composition_enum_head_set)

theorem integer_composition_enum_correct:
  "set (integer_composition_enum n) = integer_compositions n"
proof standard
  show "set (integer_composition_enum n) \<subseteq> integer_compositions n"
    unfolding integer_compositions_def
    using integer_composition_enum_not_null integer_composition_enum_sum by auto
next
  show "integer_compositions n \<subseteq> set (integer_composition_enum n)"
    unfolding integer_compositions_def
    using integer_composition_enum_correct_aux by auto
qed

subsubsection"Distinctness"

theorem integer_composition_enum_distinct:
  "distinct (integer_composition_enum n)"
proof(induct n rule: integer_composition_enum.induct)
  case 1
  then show ?case by auto
next
  case (2 n)

  have h1: "x \<in> set [0..<Suc n] \<Longrightarrow> distinct (integer_composition_enum (n - x))" for x
    using "2" by simp

  have h2: "distinct [0..<n]"
    by simp

  have "distinct [Suc m #xs. m \<leftarrow> [0..< n], xs \<leftarrow> integer_composition_enum (n-m)]"
    using h1 h2 Cons_Suc_distinct_concat_map_function by simp
  then show ?case by auto
qed

subsubsection"Cardinality"

lemma sum_list_two_pow_aux:
  "(\<Sum>x\<leftarrow>[0..< n]. (2::nat) ^ (n - x)) + 2 ^ (0 - 1) + 2 ^ 0 = 2 ^ (Suc n)"
proof(induct n)
  case 0
  then show ?case by simp
next
  case c1: (Suc n)

  have "x \<le> n \<Longrightarrow> 2 ^ (Suc n - x) = 2 * 2^ (n - x)" for x
    by (simp add: Suc_diff_le)
  also have "x \<in> set [0..<Suc n] \<Longrightarrow> x \<le> n" for x
    by auto
  ultimately have "(\<Sum>x\<leftarrow>[0..<Suc n]. 2 ^ (Suc n - x)) = (\<Sum>x\<leftarrow>[0..<Suc n]. 2* 2 ^ (n - x))"
     by (metis (mono_tags, lifting) map_eq_conv)

  also have "... = (\<Sum>x\<leftarrow>[0..< n]. 2* 2 ^ (n - x)) + 2* 2 ^ (0)"
    using sum_list_extract_last by simp

  also have "(\<Sum>x\<leftarrow>[0..< n]. (2::nat)* (2::nat) ^ (n - x)) = 2*(\<Sum>x\<leftarrow>[0..< n]. 2 ^ (n - x))"
    using sum_list_const_mult by fast

  ultimately have "(\<Sum>x\<leftarrow>[0..<Suc n]. (2::nat) ^ (Suc n - x))
      = 2*(\<Sum>x\<leftarrow>[0..< n]. 2 ^ (n - x)) + 2* 2 ^ (0)"
    by metis

  then show ?case using c1
    by simp
qed

lemma sum_list_two_pow:
  "Suc (\<Sum>x\<leftarrow>[0..<n]. 2 ^ (n - Suc x)) = 2 ^ n"
  using sum_list_two_pow_aux sum_list_extract_last by(cases n) auto

lemma integer_composition_enum_length:
  "length (integer_composition_enum n) = 2^(n-1)"
proof(induct n rule: integer_composition_enum.induct)
  case 1
  then show ?case by simp
next
  case (2 n)
  then have "length [Suc m #xs. m \<leftarrow> [0..< n], xs \<leftarrow> integer_composition_enum (n-m)]
        = (\<Sum>x\<leftarrow>[0..<n]. 2 ^ (n - x - 1))"
    using length_concat_map_function_sum_list [of
        "[0..< n]"
        "\<lambda> x. integer_composition_enum (n - x)"
        "\<lambda> x. 2 ^ (n - x - 1)"
        "\<lambda> m xs. Suc m #xs"]
    by auto

  then show ?case
    using sum_list_two_pow
    by simp
qed

theorem integer_compositions_card:
  "card (integer_compositions n) = 2^(n-1)"
  using integer_composition_enum_correct integer_composition_enum_length
    integer_composition_enum_distinct distinct_card by metis

end