theory HSV_tasks_2021_solutions imports Complex_Main begin

section \<open>Task 1: Factorising circuits.\<close>

(* Datatype for representing simple circuits. *)
datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

(* Simulates a circuit given a valuation for each input wire. *)
fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

(* Equivalence between circuits. *)
fun circuits_equiv (infix "\<sim>" 50) (* the "50" indicates the operator precedence *) where
  "c1 \<sim> c2 = (\<forall>\<rho>. simulate c1 \<rho> = simulate c2 \<rho>)"

(* An optimisation that exploits the following Boolean identities:
  `(a | b) & (a | c) = a | (b & c)`
  `(a | b) & (c | a) = a | (b & c)`
  `(a | b) & (b | c) = b | (a & c)`
  `(a | b) & (c | b) = b | (a & c)`
 *)
fun factorise where
  "factorise (NOT c) = NOT (factorise c)"
| "factorise (AND (OR c1 c2) (OR c3 c4)) = (
    let c1' = factorise c1; c2' = factorise c2; c3' = factorise c3; c4' = factorise c4 in
    if c1' = c3' then OR c1' (AND c2' c4')
    else if c1' = c4' then OR c1' (AND c2' c3')
    else if c2' = c3' then OR c2' (AND c1' c4')
    else if c2' = c4' then OR c2' (AND c1' c3')
    else AND (OR c1' c2') (OR c3' c4'))"
| "factorise (AND c1 c2) = AND (factorise c1) (factorise c2)"
| "factorise (OR c1 c2) = OR (factorise c1) (factorise c2)"
| "factorise TRUE = TRUE"
| "factorise FALSE = FALSE"
| "factorise (INPUT i) = INPUT i"

lemma (* test case *)
 "factorise (AND TRUE TRUE) = AND TRUE TRUE"
  by eval
lemma (* test case *)
  "factorise (AND (OR (INPUT 1) FALSE) (OR TRUE (INPUT 1))) =
  OR (INPUT 1) (AND FALSE TRUE)"
  by eval
lemma (* test case *)
  "factorise (NOT (AND (OR FALSE (INPUT 2)) (OR TRUE (INPUT 2)))) =
  NOT (OR (INPUT 2) (AND FALSE TRUE))"
  by eval

theorem factorise_is_sound: "factorise c \<sim> c"
proof (induct rule: factorise.induct)
  case (2 c1 c2 c3 c4)
  let ?c1' = "factorise c1"
  let ?c2' = "factorise c2"
  let ?c3' = "factorise c3"
  let ?c4' = "factorise c4"
  from 2 have IH: "?c1' \<sim> c1" "?c2' \<sim> c2" "?c3' \<sim> c3" "?c4' \<sim> c4" by auto
  have "factorise (AND (OR c1 c2) (OR c3 c4)) = (
        if ?c1' = ?c3' then OR ?c1' (AND ?c2' ?c4')
        else if ?c1' = ?c4' then OR ?c1' (AND ?c2' ?c3')
        else if ?c2' = ?c3' then OR ?c2' (AND ?c1' ?c4')
        else if ?c2' = ?c4' then OR ?c2' (AND ?c1' ?c3')
        else AND (OR ?c1' ?c2') (OR ?c3' ?c4'))"
    by auto
  also have "... \<sim> AND (OR c1 c2) (OR c3 c4)" using IH by auto
  finally show ?case by auto
qed(simp_all)

fun factorise2 where
  "factorise2 (NOT c) = NOT (factorise2 c)"
| "factorise2 (AND (OR c1 c2) (OR c3 c4)) = (
    let c1' = factorise2 c1; c2' = factorise2 c2; c3' = factorise2 c3; c4' = factorise2 c4 in
    if c1' = c3' then OR c1' (AND c2' c4')
    else if c1' = c4' then OR c1' (AND c2' c3')
    else if c2' = c3' then OR c2' (AND c1' c4')
    else if c2' = c4' then OR c2' (AND c1' c3')
    else AND (OR c1' c2') (OR c3' c4'))"
| "factorise2 (OR (AND c1 c2) (AND c3 c4)) = (
    let c1' = factorise2 c1; c2' = factorise2 c2; c3' = factorise2 c3; c4' = factorise2 c4 in
    if c1' = c3' then AND c1' (OR c2' c4')
    else if c1' = c4' then AND c1' (OR c2' c3')
    else if c2' = c3' then AND c2' (OR c1' c4')
    else if c2' = c4' then AND c2' (OR c1' c3')
    else OR (AND c1' c2') (AND c3' c4'))"
| "factorise2 (AND c1 c2) = AND (factorise2 c1) (factorise2 c2)"
| "factorise2 (OR c1 c2) = OR (factorise2 c1) (factorise2 c2)"
| "factorise2 TRUE = TRUE"
| "factorise2 FALSE = FALSE"
| "factorise2 (INPUT i) = INPUT i"

lemma (* test case *)
  "factorise2 (OR (AND (INPUT 1) (INPUT 2)) (AND TRUE (INPUT 1))) =
  AND (INPUT 1) (OR (INPUT 2) TRUE)"
  by eval

theorem factorise2_is_sound: "factorise2 c \<sim> c"
proof (induct rule: factorise2.induct)
  case (2 c1 c2 c3 c4)
  let ?c1' = "factorise2 c1"
  let ?c2' = "factorise2 c2"
  let ?c3' = "factorise2 c3"
  let ?c4' = "factorise2 c4"
  from 2 have IH: "?c1' \<sim> c1" "?c2' \<sim> c2" "?c3' \<sim> c3" "?c4' \<sim> c4" by auto
  have "factorise2 (AND (OR c1 c2) (OR c3 c4)) = (
        if ?c1' = ?c3' then OR ?c1' (AND ?c2' ?c4')
        else if ?c1' = ?c4' then OR ?c1' (AND ?c2' ?c3')
        else if ?c2' = ?c3' then OR ?c2' (AND ?c1' ?c4')
        else if ?c2' = ?c4' then OR ?c2' (AND ?c1' ?c3')
        else AND (OR ?c1' ?c2') (OR ?c3' ?c4'))"
    by auto
  also have "... \<sim> AND (OR c1 c2) (OR c3 c4)" using IH by auto
  finally show ?case by auto
next
  case (3 c1 c2 c3 c4)
  let ?c1' = "factorise2 c1"
  let ?c2' = "factorise2 c2"
  let ?c3' = "factorise2 c3"
  let ?c4' = "factorise2 c4"
  from 3 have IH: "?c1' \<sim> c1" "?c2' \<sim> c2" "?c3' \<sim> c3" "?c4' \<sim> c4" by auto
  have "factorise2 (OR (AND c1 c2) (AND c3 c4)) = (
        if ?c1' = ?c3' then AND ?c1' (OR ?c2' ?c4')
        else if ?c1' = ?c4' then AND ?c1' (OR ?c2' ?c3')
        else if ?c2' = ?c3' then AND ?c2' (OR ?c1' ?c4')
        else if ?c2' = ?c4' then AND ?c2' (OR ?c1' ?c3')
        else OR (AND ?c1' ?c2') (AND ?c3' ?c4'))"
    by auto
  also have "... \<sim> OR (AND c1 c2) (AND c3 c4)" using IH by auto
  finally show ?case by auto
qed(simp_all)

section \<open>Task 2: A theorem about divisibility.\<close>

theorem plus_dvd_odd_power:
  "(a::int) + b dvd a ^ (2 * n + 1) + b ^ (2 * n + 1)"
proof (induct n)
  case 0
  thus ?case by auto
next
  case (Suc n)
  then obtain k::int where "a ^ (2 * n + 1) + b ^ (2 * n + 1) = (a + b) * k"
    unfolding dvd_class.dvd_def by auto
  hence IH: "a ^ (2 * n + 1) = (a + b) * k - b ^ (2 * n + 1)" by auto

  have "a ^ (2 * Suc n + 1) + b ^ (2 * Suc n + 1) = a ^ (2 * n + 2 + 1) + b ^ (2 * n + 2 + 1)"
    by simp
  also have "... = a\<^sup>2 * a ^ (2 * n + 1) + b\<^sup>2 * b ^ (2 * n + 1)"
    by (metis (no_types, lifting) add.commute add_Suc_right plus_1_eq_Suc power_add)
  also have "... = a\<^sup>2 * ((a + b) * k - b ^ (2 * n + 1)) + b\<^sup>2 * b ^ (2 * n + 1)"
    unfolding IH by auto
  also have "... = a\<^sup>2 * (a + b) * k - a\<^sup>2 * b ^ (2 * n + 1) + b\<^sup>2 * b ^ (2 * n + 1)"
    by algebra
  also have "... = a\<^sup>2 * (a + b) * k - ((a\<^sup>2 - b\<^sup>2) * b ^ (2 * n + 1))"
    by algebra
  also have "... = a\<^sup>2 * (a + b) * k - ((a + b) * (a - b) * b ^ (2 * n + 1))"
    by algebra
  also have "... = (a + b) * (a\<^sup>2 * k - ((a - b) * b ^ (2 * n + 1)))"
    by algebra
  finally have "a ^ (2 * Suc n + 1) + b ^ (2 * Suc n + 1) =
    (a + b) * (a ^ 2 * k - ((a - b) * b ^ (2 * n + 1)))" .
  thus ?case by simp
qed

theorem plus_dvd_power:
  "(a::int) + b dvd a ^ (2 * n + 2) + b ^ (2 * n + 2)"
  oops

section \<open>Task 3: Proving that the shift-and-add-3 algorithm is correct.\<close>

subsection \<open>Binary and its conversion to nat\<close>

type_synonym bit = "bool"

abbreviation B0 where "B0 == False"
abbreviation B1 where "B1 == True"

(* The following lemma says that if I want to prove a property of
all 5-bit binary numbers, it suffices to just consider all 32 bit patterns. *)
lemma cases_b5:
  fixes v w x y z :: "bit"
  assumes "(v, w, x, y, z) = (B0, B0, B0, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B0, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B0, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B0, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B1, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B1, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B1, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B0, B1, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B0, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B0, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B0, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B0, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B1, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B1, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B1, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B0, B1, B1, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B0, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B0, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B0, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B0, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B1, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B1, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B1, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B0, B1, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B0, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B0, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B0, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B0, B1, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B1, B0, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B1, B0, B1) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B1, B1, B0) \<Longrightarrow> P v w x y z"
  assumes "(v, w, x, y, z) = (B1, B1, B1, B1, B1) \<Longrightarrow> P v w x y z"
  shows "P v w x y z"
  using assms
  apply (cases v)
   apply (cases w)
    apply (cases x)
     apply (cases y)
      apply (cases z)
       apply auto[2]
     apply (cases z)
      apply auto[2]
    apply (cases y)
     apply (cases z)
      apply auto[2]
    apply (cases z)
     apply auto[2]
   apply (cases x)
    apply (cases y)
     apply (cases z)
      apply auto[2]
    apply (cases z)
     apply auto[2]
   apply (cases y)
    apply (cases z)
     apply auto[2]
   apply (cases z)
    apply auto[2]
  apply (cases w)
   apply (cases x)
    apply (cases y)
     apply (cases z)
      apply auto[2]
    apply (cases z)
     apply auto[2]
   apply (cases y)
    apply (cases z)
     apply auto[2]
   apply (cases z)
    apply auto[2]
  apply (cases x)
   apply (cases y)
    apply (cases z)
     apply auto[2]
   apply (cases z)
    apply auto[2]
  apply (cases y)
   apply (cases z)
    apply auto[2]
  apply (cases z)
  apply auto[2]
  done

fun binary_to_nat :: "bit list \<Rightarrow> nat"
where
  "binary_to_nat [] = 0"
| "binary_to_nat (b # bs) = (if b then 2 ^ length bs else 0) + binary_to_nat bs"

lemma (* test case *) "binary_to_nat [B0, B1, B0, B1] = 5" by eval
lemma (* test case *) "binary_to_nat [B0, B0, B1, B0, B1] = 5" by eval
lemma (* test case *) "binary_to_nat [B1] = 1" by eval
lemma (* test case *) "binary_to_nat [B0] = 0" by eval

subsection \<open>BCD and its conversion to nat\<close>

type_synonym nibble = "bit * bit * bit * bit"

fun nibble_to_nat :: "nibble \<Rightarrow> nat"
where
  "nibble_to_nat (B0,B0,B0,B0) = 0"
| "nibble_to_nat (B0,B0,B0,B1) = 1"
| "nibble_to_nat (B0,B0,B1,B0) = 2"
| "nibble_to_nat (B0,B0,B1,B1) = 3"
| "nibble_to_nat (B0,B1,B0,B0) = 4"
| "nibble_to_nat (B0,B1,B0,B1) = 5"
| "nibble_to_nat (B0,B1,B1,B0) = 6"
| "nibble_to_nat (B0,B1,B1,B1) = 7"
| "nibble_to_nat (B1,B0,B0,B0) = 8"
| "nibble_to_nat (B1,B0,B0,B1) = 9"
| "nibble_to_nat (B1,B0,B1,B0) = 10"
| "nibble_to_nat (B1,B0,B1,B1) = 11"
| "nibble_to_nat (B1,B1,B0,B0) = 12"
| "nibble_to_nat (B1,B1,B0,B1) = 13"
| "nibble_to_nat (B1,B1,B1,B0) = 14"
| "nibble_to_nat (B1,B1,B1,B1) = 15"

fun bcd_to_nat :: "nibble list \<Rightarrow> nat"
where
  "bcd_to_nat [] = 0"
| "bcd_to_nat (n # ns) = bcd_to_nat ns + nibble_to_nat n * 10 ^ length ns"

lemma (* test case *) "bcd_to_nat [(B0,B1,B1,B0)] = 6" by eval
lemma (* test case *) "bcd_to_nat [(B0,B1,B1,B0),(B1,B0,B0,B1)] = 69" by eval
lemma (* test case *) "bcd_to_nat [(B0,B0,B0,B0),(B1,B0,B0,B1)] = 9" by eval
lemma (* test case *) "bcd_to_nat [(B0,B0,B1,B1),(B0,B0,B0,B0)] = 30" by eval

subsection \<open>Left-shifting BCD numbers\<close>

(*
"Add-three-and-shift"
                                                   bcd_part  bin_part         combined
    ([                   ], [1,0,1,0,1,0,1])              0        85      0 + 85 = 85
\<longrightarrow> ([          (0,0,0,1)], [0,1,0,1,0,1])                1        21   1*64 + 21 = 85
\<longrightarrow> ([          (0,0,1,0)], [1,0,1,0,1])                  2        21   2*32 + 21 = 85
\<longrightarrow> ([          (0,1,0,1)], [0,1,0,1])                    5         5    5*16 + 5 = 85
\<longrightarrow> ([(0,0,0,1),(0,0,0,0)], [1,0,1])                     10         5    10*8 + 5 = 85
\<longrightarrow> ([(0,0,1,0),(0,0,0,1)], [0,1])                       21         1    21*4 + 1 = 85
\<longrightarrow> ([(0,1,0,0),(0,0,1,0)], [1])                         42         1    42*2 + 1 = 85
\<longrightarrow> ([(1,0,0,0),(0,1,0,1)], [])                          85         0      85 + 0 = 85
\<longrightarrow> done
*)

fun shift_helper :: "nibble list \<Rightarrow> bit \<Rightarrow> (bit * nibble list)"
  where
  "shift_helper [] b = (b, [])"
| "shift_helper ((b1, b2, b3, b4) # ns) b = (
    let (c, ns') = shift_helper ns b in
    (b1, (b2,b3,b4,c) # ns'))"

fun shift :: "nibble list \<Rightarrow> bit \<Rightarrow> nibble list"
where
  "shift ns b = (let (c,ns') = shift_helper ns b in
                 if c = B1 then (B0,B0,B0,c) # ns' else ns')"

lemma (* test case *)
  "shift [(B0, B1, B0, B1), (B1, B0, B1, B0)] B0
       = [(B1, B0, B1, B1), (B0, B1, B0, B0)]"
by eval

lemma (* test case *)
  "shift [(B1, B1, B0, B1), (B1, B0, B1, B0)] B0
       = [(B0, B0, B0, B1), (B1, B0, B1, B1), (B0, B1, B0, B0)]"
by eval

lemma (* test case *)
  "shift [] B1
       = [(B0, B0, B0, B1)]"
by eval

subsection \<open>Functions for adding 3 to BCD digits\<close>

(* Even though this function is only used on nibbles 0 to 9, I've
   defined it as a total, bijective function so that it is invertible;
   this seems to make the proof easier later on. *)
fun maybe_add3 :: "nibble \<Rightarrow> nibble"
where
  "maybe_add3 (B0,B0,B0,B0) = (B0,B0,B0,B0)" (* 0 \<rightarrow> 0 *)
| "maybe_add3 (B0,B0,B0,B1) = (B0,B0,B0,B1)" (* 1 \<rightarrow> 1 *)
| "maybe_add3 (B0,B0,B1,B0) = (B0,B0,B1,B0)" (* 2 \<rightarrow> 2 *)
| "maybe_add3 (B0,B0,B1,B1) = (B0,B0,B1,B1)" (* 3 \<rightarrow> 3 *)
| "maybe_add3 (B0,B1,B0,B0) = (B0,B1,B0,B0)" (* 4 \<rightarrow> 4 *)
| "maybe_add3 (B0,B1,B0,B1) = (B1,B0,B0,B0)" (* 5 \<rightarrow> 8 *)
| "maybe_add3 (B0,B1,B1,B0) = (B1,B0,B0,B1)" (* 6 \<rightarrow> 9 *)
| "maybe_add3 (B0,B1,B1,B1) = (B1,B0,B1,B0)" (* 7 \<rightarrow> 10 *)
| "maybe_add3 (B1,B0,B0,B0) = (B1,B0,B1,B1)" (* 8 \<rightarrow> 11 *)
| "maybe_add3 (B1,B0,B0,B1) = (B1,B1,B0,B0)" (* 9 \<rightarrow> 12 *)
| "maybe_add3 (B1,B0,B1,B0) = (B1,B1,B0,B1)" (* 10 \<rightarrow> 13 *)
| "maybe_add3 (B1,B0,B1,B1) = (B1,B1,B1,B0)" (* 11 \<rightarrow> 14 *)
| "maybe_add3 (B1,B1,B0,B0) = (B1,B1,B1,B1)" (* 12 \<rightarrow> 15 *)
| "maybe_add3 (B1,B1,B0,B1) = (B0,B1,B0,B1)" (* 13 \<rightarrow> 5 *)
| "maybe_add3 (B1,B1,B1,B0) = (B0,B1,B1,B0)" (* 14 \<rightarrow> 6 *)
| "maybe_add3 (B1,B1,B1,B1) = (B0,B1,B1,B1)" (* 15 \<rightarrow> 7 *)

fun maybe_add3_inv :: "nibble \<Rightarrow> nibble"
(* It's sometimes handy to be able to run the `maybe_add3` function backwards *)
where
  "maybe_add3_inv (B0,B0,B0,B0) = (B0,B0,B0,B0)"
| "maybe_add3_inv (B0,B0,B0,B1) = (B0,B0,B0,B1)"
| "maybe_add3_inv (B0,B0,B1,B0) = (B0,B0,B1,B0)"
| "maybe_add3_inv (B0,B0,B1,B1) = (B0,B0,B1,B1)"
| "maybe_add3_inv (B0,B1,B0,B0) = (B0,B1,B0,B0)"
| "maybe_add3_inv (B1,B0,B0,B0) = (B0,B1,B0,B1)"
| "maybe_add3_inv (B1,B0,B0,B1) = (B0,B1,B1,B0)"
| "maybe_add3_inv (B1,B0,B1,B0) = (B0,B1,B1,B1)"
| "maybe_add3_inv (B1,B0,B1,B1) = (B1,B0,B0,B0)"
| "maybe_add3_inv (B1,B1,B0,B0) = (B1,B0,B0,B1)"
| "maybe_add3_inv (B1,B1,B0,B1) = (B1,B0,B1,B0)"
| "maybe_add3_inv (B1,B1,B1,B0) = (B1,B0,B1,B1)"
| "maybe_add3_inv (B1,B1,B1,B1) = (B1,B1,B0,B0)"
| "maybe_add3_inv (B0,B1,B0,B1) = (B1,B1,B0,B1)"
| "maybe_add3_inv (B0,B1,B1,B0) = (B1,B1,B1,B0)"
| "maybe_add3_inv (B0,B1,B1,B1) = (B1,B1,B1,B1)"

lemma maybe_add3_inv1:
  "maybe_add3_inv (maybe_add3 n) = n"
by (cases n, metis (full_types) maybe_add3.simps maybe_add3_inv.simps)

lemma maybe_add3_inv2:
  "maybe_add3 (maybe_add3_inv n) = n"
by (cases n, metis (full_types) maybe_add3.simps maybe_add3_inv.simps)

subsection \<open>Converting binary to BCD\<close>

fun binary_to_bcd_helper :: "nibble list \<Rightarrow> bit list \<Rightarrow> nibble list"
where
  "binary_to_bcd_helper ns [] = ns"
| "binary_to_bcd_helper ns (b # bs) = binary_to_bcd_helper (shift (map maybe_add3 ns) b) bs"

fun binary_to_bcd :: "bit list \<Rightarrow> nibble list"
where
  "binary_to_bcd bs = binary_to_bcd_helper [] bs"

lemma (* test case *)
  "binary_to_bcd [B1,B0,B1,B0,B1,B0,B1] = [(B1,B0,B0,B0), (B0,B1,B0,B1)]"
  by eval

(* more test cases *)
lemma "binary_to_bcd [B1,B1,B1] = [(B0,B1,B1,B1)]" by eval
lemma "binary_to_bcd [B1,B0,B0,B0,B0,B0,B0,B0] = [(B0,B0,B0,B1),(B0,B0,B1,B0),(B1,B0,B0,B0)]" by eval
lemma "binary_to_bcd [B0,B0,B0,B0,B0,B1] = [(B0,B0,B0,B1)]" by eval
lemma "binary_to_bcd [B1,B1,B0,B0,B0,B0,B0] = [(B1,B0,B0,B1),(B0,B1,B1,B0)]" by eval

subsection \<open>Checking that nibbles correspond to valid BCD digits\<close>

fun valid_nibble :: "nibble \<Rightarrow> bool"
where
  "valid_nibble (B0,B0,B0,B0) = True"
| "valid_nibble (B0,B0,B0,B1) = True"
| "valid_nibble (B0,B0,B1,B0) = True"
| "valid_nibble (B0,B0,B1,B1) = True"
| "valid_nibble (B0,B1,B0,B0) = True"
| "valid_nibble (B0,B1,B0,B1) = True"
| "valid_nibble (B0,B1,B1,B0) = True"
| "valid_nibble (B0,B1,B1,B1) = True"
| "valid_nibble (B1,B0,B0,B0) = True"
| "valid_nibble (B1,B0,B0,B1) = True"
| "valid_nibble (B1,B0,B1,B0) = False"
| "valid_nibble (B1,B0,B1,B1) = False"
| "valid_nibble (B1,B1,B0,B0) = False"
| "valid_nibble (B1,B1,B0,B1) = False"
| "valid_nibble (B1,B1,B1,B0) = False"
| "valid_nibble (B1,B1,B1,B1) = False"

lemma shift_helper_valid:
  "list_all valid_nibble ns \<Longrightarrow>
  list_all valid_nibble (snd (shift_helper (map maybe_add3 ns) b))"
proof (induct ns)
  case Nil
  thus ?case by simp
next
  case (Cons n ns)
  thus ?case
    apply auto
    apply (cases "maybe_add3 n")
    apply auto
    apply (split prod.split)
    apply auto
    apply (cases n)
    apply (smt (z3) maybe_add3.simps valid_nibble.simps prod.inject)
    done
qed

lemma binary_to_bcd_helper_step_valid:
  assumes "list_all valid_nibble ns"
  shows "list_all valid_nibble (shift (map maybe_add3 ns) b)"
using assms
apply auto
apply (split prod.split)
apply (smt (z3) list_all_simps(1) shift_helper_valid snd_conv valid_nibble.simps(2))
done

lemma binary_to_bcd_helper_valid:
  "list_all valid_nibble ns \<Longrightarrow>
  list_all valid_nibble (binary_to_bcd_helper ns bs)"
proof (induct bs arbitrary: ns)
  case Nil
  thus ?case by auto
next
  case (Cons b bs)
  thus ?case using binary_to_bcd_helper_step_valid by auto
qed

theorem binary_to_bcd_valid:
  "list_all valid_nibble (binary_to_bcd bs)"
using binary_to_bcd_helper_valid by auto

subsection \<open>Proof that the binary_to_bcd translation is correct.\<close>

(* `shift_helper` doesn't change the length of its list *)
lemma length_shift_helper:
  "length ns = length (snd (shift_helper ns b))"
proof (induct ns)
  case Nil
  thus ?case by auto
next
  case (Cons a ns)
  show ?case
    apply auto
    apply (cases a)
    apply auto
    apply (cases "shift_helper ns b")
    apply (auto simp add: Cons)
    done
qed

lemma shift_helper:
  "list_all valid_nibble ns \<Longrightarrow>
  shift_helper (map maybe_add3 ns) b = (c, ns') \<Longrightarrow>
  bcd_to_nat ((B0,B0,B0,c) # ns') = bcd_to_nat ns * 2 + (if b then 1 else 0)"
proof (induct ns arbitrary: c ns')
  case Nil
  thus ?case by simp
next
  case (Cons n ns)

  obtain c' ns'' where *: "shift_helper (map maybe_add3 ns) b = (c', ns'')" by fastforce
  with Cons have IH:
    "bcd_to_nat ((B0, B0, B0, c') # ns'') = bcd_to_nat ns * 2 + (if b then 1 else 0)" by simp

  obtain b1 b2 b3 b4 where maybe_add3_n: "maybe_add3 n = (b1, b2, b3, b4)"
    by (cases rule: prod_cases4)
  hence "maybe_add3_inv (maybe_add3 n) = maybe_add3_inv (b1, b2, b3, b4)" by auto
  with maybe_add3_inv1 have n_def: "n = maybe_add3_inv (b1, b2, b3, b4)" by auto

  have "c = b1" and ns'_def: "ns' = (b2, b3, b4, c') # ns''" using maybe_add3_n * Cons by auto

  have "length ns'' = length ns"
    by (metis * length_map length_shift_helper snd_conv)

  have "nibble_to_nat (b2, b3, b4, c') * 10 ^ length ns +
    nibble_to_nat (B0, B0, B0, b1) * 10 * 10 ^ length ns =
    nibble_to_nat (B0, B0, B0, c') * 10 ^ length ns +
    nibble_to_nat n * 10 ^ length ns * 2"
    apply (rule cases_b5[of b1 b2 b3 b4 c'])
    using Cons apply (auto simp add: n_def)
    done
  thus ?case using ns'_def IH `length ns'' = length ns` `c = b1` by auto
qed

(* Determines the "current state" of a translation-in-progress. See examples below. *)
fun bcd_binary_to_nat :: "nibble list \<Rightarrow> bit list \<Rightarrow> nat"
where
  "bcd_binary_to_nat ns bs = bcd_to_nat ns * 2 ^ length bs + binary_to_nat bs"

lemma "bcd_binary_to_nat                             [] [B1,B0,B1,B0,B1,B0,B1] = 85" by eval
lemma "bcd_binary_to_nat                [(B0,B0,B0,B1)] [B0,B1,B0,B1,B0,B1]    = 85" by eval
lemma "bcd_binary_to_nat                [(B0,B0,B1,B0)] [B1,B0,B1,B0,B1]       = 85" by eval
lemma "bcd_binary_to_nat                [(B0,B1,B0,B1)] [B0,B1,B0,B1]          = 85" by eval
lemma "bcd_binary_to_nat [(B0,B0,B0,B1), (B0,B0,B0,B0)] [B1,B0,B1]             = 85" by eval
lemma "bcd_binary_to_nat [(B0,B0,B1,B0), (B0,B0,B0,B1)] [B0,B1]                = 85" by eval
lemma "bcd_binary_to_nat [(B0,B1,B0,B0), (B0,B0,B1,B0)] [B1]                   = 85" by eval
lemma "bcd_binary_to_nat [(B1,B0,B0,B0), (B0,B1,B0,B1)] []                     = 85" by eval

lemma binary_to_bcd_helper_step_correct:
  assumes "list_all valid_nibble ns"
  shows "bcd_binary_to_nat ns (b # bs) =
         bcd_binary_to_nat (shift (map maybe_add3 ns) b) bs"
proof -
  have "bcd_to_nat (shift (map maybe_add3 ns) B0) = bcd_to_nat ns * 2"
    apply (auto simp del: bcd_to_nat.simps)
    apply (split prod.split)
    apply (auto simp del: bcd_to_nat.simps)
    using assms shift_helper apply presburger
    apply (smt (z3) assms shift_helper add.right_neutral bcd_to_nat.simps(2)
     mult_zero_left nibble_to_nat.simps(1))
    done
  moreover
  have "bcd_to_nat (shift (map maybe_add3 ns) B1) = bcd_to_nat ns * 2 + 1"
    apply (auto simp del: bcd_to_nat.simps)
    apply (split prod.split)
    apply (auto simp del: bcd_to_nat.simps)
     using assms shift_helper apply presburger
    apply (smt (z3) One_nat_def add_Suc_shift add_right_imp_eq assms bcd_to_nat.simps(2)
       mult_zero_left nibble_to_nat.simps(1) shift_helper)
    done
  ultimately show ?thesis using assms by auto
qed

lemma binary_to_bcd_helper_correct:
  "list_all valid_nibble ns \<Longrightarrow>
  bcd_to_nat (binary_to_bcd_helper ns bs) = bcd_binary_to_nat ns bs"
proof (induct bs arbitrary: ns)
  case Nil
  thus ?case by simp
next
  case Cons
  thus ?case
    using binary_to_bcd_helper_step_correct and binary_to_bcd_helper_step_valid
    by auto
qed

theorem binary_to_bcd_correct:
  "bcd_to_nat (binary_to_bcd bs) = binary_to_nat bs"
using binary_to_bcd_helper_correct by auto

section \<open> Alternative implementation of binary_to_bcd that converts to nat and then to bcd \<close>

lemma mod10_induct [case_names 0 1 2 3 4 5 6 7 8 9]:
  fixes n :: nat
  assumes "P 0" "P 1" "P 2" "P 3" "P 4" "P 5" "P 6" "P 7" "P 8" "P 9"
  shows "P (n mod 10)"
proof -
  have "n mod 10 \<in> {..<10}"
    by simp
  also have "{..<10} = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9 :: nat}"
    by (simp add: lessThan_nat_numeral lessThan_Suc insert_commute)
  finally show ?thesis using assms
    by fastforce
qed

fun nat_to_nibble :: "nat \<Rightarrow> nibble"
where
  "nat_to_nibble n = (
     if n = 0 then (B0,B0,B0,B0) else
     if n = 1 then (B0,B0,B0,B1) else
     if n = 2 then (B0,B0,B1,B0) else
     if n = 3 then (B0,B0,B1,B1) else
     if n = 4 then (B0,B1,B0,B0) else
     if n = 5 then (B0,B1,B0,B1) else
     if n = 6 then (B0,B1,B1,B0) else
     if n = 7 then (B0,B1,B1,B1) else
     if n = 8 then (B1,B0,B0,B0) else
     if n = 9 then (B1,B0,B0,B1) else
                   (B1,B1,B1,B1))" (* unreachable *)

fun nat_to_bcd :: "nat \<Rightarrow> nibble list"
where
  "nat_to_bcd n = (if n = 0 then [] else
     nat_to_bcd (n div 10) @ [nat_to_nibble (n mod 10)])"

value "nat_to_bcd 420"
value "nat_to_bcd 42"
value "nat_to_bcd 4"
value "nat_to_bcd 0"

fun binary_to_bcd2 :: "bit list \<Rightarrow> nibble list"
where
  "binary_to_bcd2 bs = nat_to_bcd (binary_to_nat bs)"

lemma nat_to_nibble_valid:
  "valid_nibble (nat_to_nibble (n mod 10))"
by (induct rule: mod10_induct, auto)

lemma nat_to_bcd_valid:
  "list_all valid_nibble (nat_to_bcd n)"
  using nat_to_nibble_valid
  by (induct rule: nat_to_bcd.induct, simp)

theorem binary_to_bcd2_valid:
 "list_all valid_nibble (binary_to_bcd2 bs)"
using nat_to_bcd_valid by auto

lemma bcd_to_nat_snoc:
  "bcd_to_nat (ns @ [n]) = bcd_to_nat ns * 10 + bcd_to_nat [n]"
  by (induct ns, auto)

lemma bcd_to_nat_nibble:
  "bcd_to_nat [nat_to_nibble (n mod 10)] = n mod 10"
  by (induct rule: mod10_induct, auto)

lemma bcd_to_nat_inv:
  "bcd_to_nat (nat_to_bcd n) = n"
  apply (induct rule: nat_to_bcd.induct)
  apply (subst nat_to_bcd.simps)
  apply (case_tac "n=0")
   apply simp
  apply (simp del: nat_to_bcd.simps nat_to_nibble.simps)
  apply (subst bcd_to_nat_snoc)
  apply (subst bcd_to_nat_nibble)
  apply simp
  done

theorem binary_to_bcd2_correct:
  "bcd_to_nat (binary_to_bcd2 bs) = binary_to_nat bs"
  using bcd_to_nat_inv by auto

end


(* Author: Tobias Nipkow *)

section \<open>List Insertion and Deletion\<close>

theory List_Ins_Del
imports Sorted_Less
begin

subsection \<open>Elements in a list\<close>

lemma sorted_Cons_iff:
  "sorted(x # xs) = ((\<forall>y \<in> set xs. x < y) \<and> sorted xs)"
by(simp add: sorted_wrt_Cons)

lemma sorted_snoc_iff:
  "sorted(xs @ [x]) = (sorted xs \<and> (\<forall>y \<in> set xs. y < x))"
by(simp add: sorted_wrt_append)
(*
text\<open>The above two rules introduce quantifiers. It turns out
that in practice this is not a problem because of the simplicity of
the "isin" functions that implement @{const set}. Nevertheless
it is possible to avoid the quantifiers with the help of some rewrite rules:\<close>

lemma sorted_ConsD: "sorted (y # xs) \<Longrightarrow> x \<le> y \<Longrightarrow> x \<notin> set xs"
by (auto simp: sorted_Cons_iff)

lemma sorted_snocD: "sorted (xs @ [y]) \<Longrightarrow> y \<le> x \<Longrightarrow> x \<notin> set xs"
by (auto simp: sorted_snoc_iff)

lemmas isin_simps2 = sorted_lems sorted_ConsD sorted_snocD
*)

lemmas isin_simps = sorted_mid_iff' sorted_Cons_iff sorted_snoc_iff

subsection \<open>Inserting into an ordered list without duplicates:\<close>

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

lemma set_ins_list: "set (ins_list x xs) = set xs \<union> {x}"
by(induction xs) auto

lemma sorted_ins_list: "sorted xs \<Longrightarrow> sorted(ins_list x xs)"
by(induction xs rule: induct_list012) auto

lemma ins_list_sorted: "sorted (xs @ [a]) \<Longrightarrow>
  ins_list x (xs @ a # ys) =
  (if x < a then ins_list x xs @ (a#ys) else xs @ ins_list x (a#ys))"
by(induction xs) (auto simp: sorted_lems)

text\<open>In principle, @{thm ins_list_sorted} suffices, but the following two
corollaries speed up proofs.\<close>

corollary ins_list_sorted1: "sorted (xs @ [a]) \<Longrightarrow> a \<le> x \<Longrightarrow>
  ins_list x (xs @ a # ys) = xs @ ins_list x (a#ys)"
by(auto simp add: ins_list_sorted)

corollary ins_list_sorted2: "sorted (xs @ [a]) \<Longrightarrow> x < a \<Longrightarrow>
  ins_list x (xs @ a # ys) = ins_list x xs @ (a#ys)"
by(auto simp: ins_list_sorted)

lemmas ins_list_simps = sorted_lems ins_list_sorted1 ins_list_sorted2

text\<open>Splay trees need two additional \<^const>\<open>ins_list\<close> lemmas:\<close>

lemma ins_list_Cons: "sorted (x # xs) \<Longrightarrow> ins_list x xs = x # xs"
by (induction xs) auto

lemma ins_list_snoc: "sorted (xs @ [x]) \<Longrightarrow> ins_list x xs = xs @ [x]"
by(induction xs) (auto simp add: sorted_mid_iff2)

subsection \<open>Delete one occurrence of an element from a list:\<close>

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

lemma del_list_idem: "x \<notin> set xs \<Longrightarrow> del_list x xs = xs"
by (induct xs) simp_all

lemma set_del_list:
  "sorted xs \<Longrightarrow> set (del_list x xs) = set xs - {x}"
by(induct xs) (auto simp: sorted_Cons_iff)

lemma sorted_del_list: "sorted xs \<Longrightarrow> sorted(del_list x xs)"
apply(induction xs rule: induct_list012)
apply auto
by (meson order.strict_trans sorted_Cons_iff)

lemma del_list_sorted: "sorted (xs @ a # ys) \<Longrightarrow>
  del_list x (xs @ a # ys) = (if x < a then del_list x xs @ a # ys else xs @ del_list x (a # ys))"
by(induction xs)
  (fastforce simp: sorted_lems sorted_Cons_iff intro!: del_list_idem)+

text\<open>In principle, @{thm del_list_sorted} suffices, but the following
corollaries speed up proofs.\<close>

corollary del_list_sorted1: "sorted (xs @ a # ys) \<Longrightarrow> a \<le> x \<Longrightarrow>
  del_list x (xs @ a # ys) = xs @ del_list x (a # ys)"
by (auto simp: del_list_sorted)

corollary del_list_sorted2: "sorted (xs @ a # ys) \<Longrightarrow> x < a \<Longrightarrow>
  del_list x (xs @ a # ys) = del_list x xs @ a # ys"
by (auto simp: del_list_sorted)

corollary del_list_sorted3:
  "sorted (xs @ a # ys @ b # zs) \<Longrightarrow> x < b \<Longrightarrow>
  del_list x (xs @ a # ys @ b # zs) = del_list x (xs @ a # ys) @ b # zs"
by (auto simp: del_list_sorted sorted_lems)

corollary del_list_sorted4:
  "sorted (xs @ a # ys @ b # zs @ c # us) \<Longrightarrow> x < c \<Longrightarrow>
  del_list x (xs @ a # ys @ b # zs @ c # us) = del_list x (xs @ a # ys @ b # zs) @ c # us"
by (auto simp: del_list_sorted sorted_lems)

corollary del_list_sorted5:
  "sorted (xs @ a # ys @ b # zs @ c # us @ d # vs) \<Longrightarrow> x < d \<Longrightarrow>
   del_list x (xs @ a # ys @ b # zs @ c # us @ d # vs) =
   del_list x (xs @ a # ys @ b # zs @ c # us) @ d # vs"
by (auto simp: del_list_sorted sorted_lems)

lemmas del_list_simps = sorted_lems
  del_list_sorted1
  del_list_sorted2
  del_list_sorted3
  del_list_sorted4
  del_list_sorted5

text\<open>Splay trees need two additional \<^const>\<open>del_list\<close> lemmas:\<close>

lemma del_list_notin_Cons: "sorted (x # xs) \<Longrightarrow> del_list x xs = xs"
by(induction xs)(fastforce simp: sorted_Cons_iff)+

lemma del_list_sorted_app:
  "sorted(xs @ [x]) \<Longrightarrow> del_list x (xs @ ys) = xs @ del_list x ys"
by (induction xs) (auto simp: sorted_mid_iff2)

end


theory Majorities
imports Main
begin

section \<open>Utility Lemmas About Majorities\<close>

text \<open>
  Consensus algorithms usually ensure that a majority of processes
  proposes the same value before taking a decision,
  and we provide a few utility lemmas for reasoning about majorities.
\<close>

text \<open>
  Any two subsets \<open>S\<close> and \<open>T\<close> of a finite  set \<open>E\<close> such that
  the sum of their cardinalities is larger than the size of \<open>E\<close> have a
  non-empty intersection.
\<close>
lemma abs_majorities_intersect:
    assumes crd: "card E < card S + card T"
        and s: "S \<subseteq> E" and t: "T \<subseteq> E" and e: "finite E"
    shows "S \<inter> T \<noteq> {}"
proof (clarify)
  assume contra: "S \<inter> T = {}"
  from s t e have "finite S" and "finite T" by (auto simp: finite_subset)
  with crd contra have "card E < card (S \<union> T)" by (auto simp add: card_Un_Int)
  moreover
  from s t e have "card (S \<union> T) \<le> card E" by (simp add: card_mono)
  ultimately
  show "False" by simp
qed

lemma abs_majoritiesE:
  assumes crd: "card E < card S + card T"
      and s: "S \<subseteq> E" and t: "T \<subseteq> E" and e: "finite E"
  obtains p where "p \<in> S" and "p \<in> T"
proof -
  from assms have "S \<inter> T \<noteq> {}" by (rule abs_majorities_intersect)
  then obtain p where "p \<in> S \<inter> T" by blast
  with that show ?thesis by auto
qed

text \<open>Special case: both sets \<open>S\<close> and \<open>T\<close> are majorities.\<close>

lemma abs_majoritiesE':
  assumes Smaj: "card S > (card E) div 2" and Tmaj: "card T > (card E) div 2"
      and s: "S \<subseteq> E" and t: "T \<subseteq> E" and e: "finite E"
  obtains p where "p \<in> S" and "p \<in> T"
proof (rule abs_majoritiesE[OF _ s t e])
  from Smaj Tmaj show "card E < card S + card T" by auto
qed

text \<open>
  We restate the above theorems for the case where the base type
  is finite (taking \<open>E\<close> as the universal set).
\<close>

lemma majorities_intersect:
  assumes crd: "card (UNIV::('a::finite) set) < card (S::'a set) + card T"
  shows "S \<inter> T \<noteq> {}"
  by (rule abs_majorities_intersect[OF crd]) auto

lemma majoritiesE:
  assumes crd: "card (UNIV::('a::finite) set) < card (S::'a set) + card (T::'a set)"
  obtains p where "p \<in> S" and "p \<in> T"
using crd majorities_intersect by blast

lemma majoritiesE':
  assumes S: "card (S::('a::finite) set) > (card (UNIV::'a set)) div 2"
  and T: "card (T::'a set) > (card (UNIV::'a set)) div 2"
  obtains p where "p \<in> S" and "p \<in> T"
by (rule abs_majoritiesE'[OF S T]) auto

end (* theory Majorities *)


(*  Author:     Tobias Nipkow, TU München

A theory of types extended with a greatest and a least element.
Oriented towards numeric types, hence "\<infinity>" and "-\<infinity>".
*)

theory Extended
imports
  Main
  "~~/src/HOL/Library/Simps_Case_Conv"
begin

datatype 'a extended = Fin 'a | Pinf ("\<infinity>") | Minf ("-\<infinity>")

instantiation extended :: (order)order
begin

fun less_eq_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> bool" where
"Fin x \<le> Fin y = (x \<le> y)" |
"_     \<le> Pinf  = True" |
"Minf  \<le> _     = True" |
"(_::'a extended) \<le> _     = False"

case_of_simps less_eq_extended_case: less_eq_extended.simps

definition less_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> bool" where
"((x::'a extended) < y) = (x \<le> y & \<not> y \<le> x)"

instance
  by intro_classes (auto simp: less_extended_def less_eq_extended_case split: extended.splits)

end

instance extended :: (linorder)linorder
  by intro_classes (auto simp: less_eq_extended_case split:extended.splits)

lemma Minf_le[simp]: "Minf \<le> y"
by(cases y) auto
lemma le_Pinf[simp]: "x \<le> Pinf"
by(cases x) auto
lemma le_Minf[simp]: "x \<le> Minf \<longleftrightarrow> x = Minf"
by(cases x) auto
lemma Pinf_le[simp]: "Pinf \<le> x \<longleftrightarrow> x = Pinf"
by(cases x) auto

lemma less_extended_simps[simp]:
  "Fin x < Fin y = (x < y)"
  "Fin x < Pinf  = True"
  "Fin x < Minf  = False"
  "Pinf < h      = False"
  "Minf < Fin x  = True"
  "Minf < Pinf   = True"
  "l    < Minf   = False"
by (auto simp add: less_extended_def)

lemma min_extended_simps[simp]:
  "min (Fin x) (Fin y) = Fin(min x y)"
  "min xx      Pinf    = xx"
  "min xx      Minf    = Minf"
  "min Pinf    yy      = yy"
  "min Minf    yy      = Minf"
by (auto simp add: min_def)

lemma max_extended_simps[simp]:
  "max (Fin x) (Fin y) = Fin(max x y)"
  "max xx      Pinf    = Pinf"
  "max xx      Minf    = xx"
  "max Pinf    yy      = Pinf"
  "max Minf    yy      = yy"
by (auto simp add: max_def)

instantiation extended :: (zero)zero
begin
definition "0 = Fin(0::'a)"
instance ..
end

declare zero_extended_def[symmetric, code_post]

instantiation extended :: (one)one
begin
definition "1 = Fin(1::'a)"
instance ..
end

declare one_extended_def[symmetric, code_post]

instantiation extended :: (plus)plus
begin

text \<open>The following definition of of addition is totalized
to make it asociative and commutative. Normally the sum of plus and minus infinity is undefined.\<close>

fun plus_extended where
"Fin x + Fin y = Fin(x+y)" |
"Fin x + Pinf  = Pinf" |
"Pinf  + Fin x = Pinf" |
"Pinf  + Pinf  = Pinf" |
"Minf  + Fin y = Minf" |
"Fin x + Minf  = Minf" |
"Minf  + Minf  = Minf" |
"Minf  + Pinf  = Pinf" |
"Pinf  + Minf  = Pinf"

case_of_simps plus_case: plus_extended.simps

instance ..

end

instance extended :: (ab_semigroup_add)ab_semigroup_add
  by intro_classes (simp_all add: ac_simps plus_case split: extended.splits)

instance extended :: (ordered_ab_semigroup_add)ordered_ab_semigroup_add
  by intro_classes (auto simp: add_left_mono plus_case split: extended.splits)

instance extended :: (comm_monoid_add)comm_monoid_add
proof
  fix x :: "'a extended" show "0 + x = x" unfolding zero_extended_def by(cases x)auto
qed

instantiation extended :: (uminus)uminus
begin

fun uminus_extended where
"- (Fin x) = Fin (- x)" |
"- Pinf    = Minf" |
"- Minf    = Pinf"

instance ..

end

instantiation extended :: (ab_group_add)minus
begin
definition "x - y = x + -(y::'a extended)"
instance ..
end

lemma minus_extended_simps[simp]:
  "Fin x - Fin y = Fin(x - y)"
  "Fin x - Pinf  = Minf"
  "Fin x - Minf  = Pinf"
  "Pinf  - Fin y = Pinf"
  "Pinf  - Minf  = Pinf"
  "Minf  - Fin y = Minf"
  "Minf  - Pinf  = Minf"
  "Minf  - Minf  = Pinf"
  "Pinf  - Pinf  = Pinf"
by (simp_all add: minus_extended_def)

text\<open>Numerals:\<close>

instance extended :: ("{ab_semigroup_add,one}")numeral ..

lemma Fin_numeral[code_post]: "Fin(numeral w) = numeral w"
  apply (induct w rule: num_induct)
  apply (simp only: numeral_One one_extended_def)
  apply (simp only: numeral_inc one_extended_def plus_extended.simps(1)[symmetric])
  done

lemma Fin_neg_numeral[code_post]: "Fin (- numeral w) = - numeral w"
by (simp only: Fin_numeral uminus_extended.simps[symmetric])

instantiation extended :: (lattice)bounded_lattice
begin

definition "bot = Minf"
definition "top = Pinf"

fun inf_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> 'a extended" where
"inf_extended (Fin i) (Fin j) = Fin (inf i j)" |
"inf_extended a Minf = Minf" |
"inf_extended Minf a = Minf" |
"inf_extended Pinf a = a" |
"inf_extended a Pinf = a"

fun sup_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> 'a extended" where
"sup_extended (Fin i) (Fin j) = Fin (sup i j)" |
"sup_extended a Pinf = Pinf" |
"sup_extended Pinf a = Pinf" |
"sup_extended Minf a = a" |
"sup_extended a Minf = a"

case_of_simps inf_extended_case: inf_extended.simps
case_of_simps sup_extended_case: sup_extended.simps

instance
  by (intro_classes) (auto simp: inf_extended_case sup_extended_case less_eq_extended_case
    bot_extended_def top_extended_def split: extended.splits)
end

end


theory example
  imports Main

begin

declare [[names_short]]
datatype 'a list = Empty | Cons 'a "'a list"

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

(* Found termination order: "size <*mlex*> {}" *)

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

(* Found termination order: "(\<lambda>p. size (fst p)) <*mlex*> {}" *)

fun add_tl :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
  "add_tl x Empty = Cons x Empty"
| "add_tl x (Cons y ys) = Cons y (add_tl x ys)"

(* Found termination order: "(\<lambda>p. size (snd p)) <*mlex*> {}" *)

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

(* Found termination order: "size <*mlex*> {}" *)

lemma concat_empty [simp]: "concat xs Empty = xs"
  apply(induction xs)
  apply(auto)
  done

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

lemma reverse_concat [simp]: "reverse (concat xs ys) = concat (reverse ys) (reverse xs)"
  apply(induction xs)
(*  1. reverse (concat Empty ys) = concat (reverse ys) (reverse Empty)
    2. \<And>x1 xs.
          reverse (concat xs ys) = concat (reverse ys) (reverse xs) \<Longrightarrow>
          reverse (concat (Cons x1 xs) ys) = concat (reverse ys) (reverse (Cons x1 xs)) *)
(* after reverse_empty :
 1. \<And>x1 xs.
       reverse (concat xs ys) = concat (reverse ys) (reverse xs) \<Longrightarrow>
       concat (concat (reverse ys) (reverse xs)) (Cons x1 Empty) =
       concat (reverse ys) (concat (reverse xs) (Cons x1 Empty))
*)
  apply(auto)
  done
(*
 1. reverse ys = concat (reverse ys) Empty
 2. \<And>x1 xs.
       reverse (concat xs ys) = concat (reverse ys) (reverse xs) \<Longrightarrow>
       concat (concat (reverse ys) (reverse xs)) (Cons x1 Empty) =
       concat (reverse ys) (concat (reverse xs) (Cons x1 Empty))
*)

theorem reverse_reverse [simp]: "reverse(reverse(x)) = x"
  apply(induction x)
  apply(auto)
  done

 (* 1. \<And>x1 x. reverse (reverse x) = x \<Longrightarrow> reverse (concat (reverse x) (Cons x1 Empty)) = Cons x1 x *)
 (* assoc *)
end


(* < *)
theory mp2_sol
  imports Main
begin
(* > *)
section{*Boolean Expressions, Evaluation and Substitution*}

text{*
The following is a slightly revised version of the type of boolean
expressions presented in class.
*}
datatype 'a boolexp =
   TRUE | FALSE |Atom 'a | Not "'a boolexp"
  | And "'a boolexp" "'a boolexp"
  | Or "'a boolexp" "'a boolexp"
  | Implies "'a boolexp" "'a boolexp"

text{* And the following is an implementation of the Standard
Interpretation function defined on page 4 0f
\texttt{02\_prop\_log\_model.pdf}. *}

fun boolexp_eval
where
   "boolexp_eval v TRUE = True"
 | "boolexp_eval v FALSE = False"
 | "boolexp_eval v (Atom x) = v x"
 | "boolexp_eval v (Not b) = (\<not> (boolexp_eval v b))"
 | "boolexp_eval v (And a b) =
    ((boolexp_eval v a) \<and> (boolexp_eval v b))"
 | "boolexp_eval v (Or a b) =
    ((boolexp_eval v a) \<or> (boolexp_eval v b))"
 | "boolexp_eval v (Implies a b) =
    ((\<not> (boolexp_eval v a))\<or> (boolexp_eval v b))"

section{* Problems *}

text{*
Below you are asked to define substitution and the set of variables
occurring in a proposition.  You are additionally asked to prove a few
simple properties about these two functions.

\begin{problem} (7 pts)
Define @{term "boolexp_subst"} that, given a propositional atom (@{term "x :: 'a"}), and two
boolexps, creates a third boolexp that is the result of replacing all
occurrences of the propositional atom in the second boolexp with the first
boolexp.

You will likely find it helpful to use something like
@{term "(if x = y then result1 else result2)"}
\end{problem}
*}
fun boolexp_subst :: "'a \<Rightarrow> 'a boolexp \<Rightarrow> 'a boolexp \<Rightarrow> 'a boolexp" where
  "boolexp_subst x b TRUE = TRUE"
| "boolexp_subst x b FALSE = FALSE"
| "boolexp_subst x b (Atom y) = (if x = y then b else (Atom y))"
| "boolexp_subst x b (Not b1) = Not (boolexp_subst x b b1)"
| "boolexp_subst x b (And b1 b2) = And (boolexp_subst x b b1) (boolexp_subst x b b2)"
| "boolexp_subst x b (Or b1 b2) = Or (boolexp_subst x b b1) (boolexp_subst x b b2)"
| "boolexp_subst x b (Implies b1 b2) = Implies (boolexp_subst x b b1) (boolexp_subst x b b2)"

text{* If you have done your work right, the following should give a result of
@{term "And (Atom ''b'') (Implies (Atom ''b'') TRUE) :: char list boolexp"}
*}

value "boolexp_subst ''a'' (Implies (Atom ''b'') TRUE) (And (Atom ''b'') (Atom ''a''))"

text{*
\begin{problem} (3 pts)
Prove that if you evaluate with a valuation @{term "v"} a boolexp that is the
result of substituting all occurences of a propositional atom @{term "x"} by
the proposition @{const "TRUE"}, the result is the same as if you had evaluated the
original boolexp using the valuation @{term "(\<lambda> y. if y = x then TRUE else v y)"}
\end{problem}
*}

lemma subst_to_eval:
"boolexp_eval v (boolexp_subst x TRUE b) =
 boolexp_eval (\<lambda> y. if y = x then True else v y) b"
  by (induct "b", simp_all)

text{*
\begin{problem} (6 pts)
Define a function @{term "atoms_of_boolexp :: 'a boolexp \<Rightarrow>
'a list"} that returns a list containing exactly the propositional
atoms that occur in the input boolexp.  Duplicates are allowed in the
list.  There is no required order.  The empty list is represented by
@{term "[]"}.  To insert an element @{term "x"} at the front of a list
@{term "lst"} use @{term "(x # lst)"}.  To append list @{term "l2"}
onto list @{term "l1"} use @{term "(l1 @ l2)"}.
\end{problem}
*}

fun  atoms_of_boolexp :: "'a boolexp \<Rightarrow> 'a list" where
  "atoms_of_boolexp TRUE = []"
| "atoms_of_boolexp FALSE = []"
| "atoms_of_boolexp (Atom x) = [x]"
| "atoms_of_boolexp (Not b) = atoms_of_boolexp b"
| "atoms_of_boolexp (And b1 b2) = (atoms_of_boolexp b1) @ (atoms_of_boolexp b2)"
| "atoms_of_boolexp (Or b1 b2) = (atoms_of_boolexp b1) @ (atoms_of_boolexp b2)"
| "atoms_of_boolexp (Implies b1 b2) = (atoms_of_boolexp b1) @ (atoms_of_boolexp b2)"

text{*
If your definition in Problem 3 is correct, the following lemma should
complete, producing a theorem
*}

lemma test_problem3:
"set (atoms_of_boolexp (Or (Implies (Atom ''b'') TRUE) (And (Atom ''b'') (Atom ''a'')))) =
 {''a'', ''b''}"
by (simp, blast)

text{*
\begin{problem} (3 pts)
Prove that if two valuations are the same on the propositional atoms in a
boolexp, then they will give the same result when used to evaluate the boolexp.
*}

lemma same_on_atoms_same_value:
"(\<forall> x. x : set (atoms_of_boolexp b) \<longrightarrow> v1 x = v2 x) \<longrightarrow>
  (boolexp_eval v1 b = boolexp_eval v2 b)"
by (induct b, simp_all)

text{*
\begin{problem} (3 pts)
Prove that substituting for an atom that is not in a boolexp yields
the same boolexp.
*}

lemma subst_nonexistant_atom:
"x \<notin> set(atoms_of_boolexp b) \<longrightarrow> (boolexp_subst x b' b = b)"
by (induct "b", simp_all)

end


(*  Title:      FOL/ex/Quantifiers_Cla.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>First-Order Logic: quantifier examples (classical version)\<close>

theory Quantifiers_Cla
imports FOL
begin

lemma "(\<forall>x y. P(x,y)) \<longrightarrow> (\<forall>y x. P(x,y))"
  by fast

lemma "(\<exists>x y. P(x,y)) \<longrightarrow> (\<exists>y x. P(x,y))"
  by fast

text \<open>Converse is false.\<close>
lemma "(\<forall>x. P(x)) \<or> (\<forall>x. Q(x)) \<longrightarrow> (\<forall>x. P(x) \<or> Q(x))"
  by fast

lemma "(\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x. Q(x)))"
  by fast

lemma "(\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> Q)"
  by fast

text \<open>Some harder ones.\<close>

lemma "(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> (\<exists>x. P(x)) \<or> (\<exists>x. Q(x))"
  by fast

\<comment> \<open>Converse is false.\<close>
lemma "(\<exists>x. P(x) \<and> Q(x)) \<longrightarrow> (\<exists>x. P(x)) \<and> (\<exists>x. Q(x))"
  by fast

text \<open>Basic test of quantifier reasoning.\<close>

\<comment> \<open>TRUE\<close>
lemma "(\<exists>y. \<forall>x. Q(x,y)) \<longrightarrow> (\<forall>x. \<exists>y. Q(x,y))"
  by fast

lemma "(\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))"
  by fast

text \<open>The following should fail, as they are false!\<close>

lemma "(\<forall>x. \<exists>y. Q(x,y)) \<longrightarrow> (\<exists>y. \<forall>x. Q(x,y))"
  apply fast?
  oops

lemma "(\<exists>x. Q(x)) \<longrightarrow> (\<forall>x. Q(x))"
  apply fast?
  oops

schematic_goal "P(?a) \<longrightarrow> (\<forall>x. P(x))"
  apply fast?
  oops

schematic_goal "(P(?a) \<longrightarrow> (\<forall>x. Q(x))) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> Q(x))"
  apply fast?
  oops

text \<open>Back to things that are provable \dots\<close>

lemma "(\<forall>x. P(x) \<longrightarrow> Q(x)) \<and> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))"
  by fast

text \<open>An example of why \<open>exI\<close> should be delayed as long as possible.\<close>
lemma "(P \<longrightarrow> (\<exists>x. Q(x))) \<and> P \<longrightarrow> (\<exists>x. Q(x))"
  by fast

schematic_goal "(\<forall>x. P(x) \<longrightarrow> Q(f(x))) \<and> (\<forall>x. Q(x) \<longrightarrow> R(g(x))) \<and> P(d) \<longrightarrow> R(?a)"
  by fast

lemma "(\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))"
  by fast

text \<open>Some slow ones\<close>

text \<open>Principia Mathematica *11.53\<close>
lemma "(\<forall>x y. P(x) \<longrightarrow> Q(y)) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> (\<forall>y. Q(y)))"
  by fast

(*Principia Mathematica *11.55  *)
lemma "(\<exists>x y. P(x) \<and> Q(x,y)) \<longleftrightarrow> (\<exists>x. P(x) \<and> (\<exists>y. Q(x,y)))"
  by fast

(*Principia Mathematica *11.61  *)
lemma "(\<exists>y. \<forall>x. P(x) \<longrightarrow> Q(x,y)) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> (\<exists>y. Q(x,y)))"
  by fast

end


theory prog_01
  imports Main
begin

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

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

value "fib(8)"
fun gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"gcd m n = (if n=0 then m then gcd n (m mod n))"

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

lemma Lemma0[simp]: "add m 0 = m"
  by (induct m) simp_all
lemma Lemma2 [simp]: "add m (Suc n) = Suc (add m n)"
  by (induct m) simp_all

theorem Commu: "add m k = add k m"
  apply (induction k)
  apply (auto)
  done

theorem add_community: "add k m = add m k"
  apply(induction k)
   apply(subst Lemma0)
   apply (subst add.simps(1))
   apply(rule refl)
  apply (subst add.simps(2))
  apply(erule ssubst)
apply (subst Lemma2)
apply (rule refl)
  done
end


theory Coin imports "~~/src/HOL/Library/Multiset" begin

section "Fundamental Lemmas"
subsection "nat"

theorem "\<lbrakk> v1 dvd v2; v = v1 * c1 + v2 * c2; c2 \<ge> c2' \<rbrakk> \<Longrightarrow> \<exists>c1'. v = v1 * (c1 + c1') + v2 * (c2 - c2')" for v :: nat
  apply(rule_tac x="(v2 div v1) * c2'" in exI)
  apply(auto simp add: add_mult_distrib2 diff_mult_distrib2)
  done

lemma le_div_plus_mod[rule_format]: "\<forall>x. x \<ge> y \<longrightarrow> y > 1 \<longrightarrow> x > x div y + x mod y" for x :: nat and y :: nat
  apply(induct y)
  apply(force)
  apply(auto)
  by (metis Suc_mono div_greater_zero_iff less_diff_conv minus_mod_eq_div_mult n_less_n_mult_m zero_less_Suc)

lemma plus_minus_assoc: "b \<ge> c \<Longrightarrow> a + b - c = a + (b - c)" for a :: nat
  by auto

lemma a_minus_b_plus_c_plus_d_le_a: "a \<ge> b \<Longrightarrow> a - b + c + d < a \<longleftrightarrow> b > c + d" for a :: nat
  by auto

lemma a_eq_a_minus_b_plus_c_plus_d_is_b_eq_c_plus_d: "a \<ge> b \<Longrightarrow> a = a - b + c + d \<longleftrightarrow> b = c + d"  for a :: nat
  by auto

lemma a_eq_b_plus_a_minus_b: "a \<ge> b \<Longrightarrow> a = b + (a - b)" for a :: nat
  by auto

lemma a_plus_b_eq_b_plus_c_minus_d: "c \<ge> d \<Longrightarrow> a + b = b + c - d \<longleftrightarrow> a = c - d" for a :: nat
  by auto

lemma a_plus_b_minus_c_le_a: "c \<ge> b \<Longrightarrow> a + b - c \<le> a" for a :: nat
  apply(simp)
  done

lemma le_1_is_lt_2: "x \<le> Suc 0 \<Longrightarrow> x < 2" for x :: nat
  by auto

lemma le_4_is_lt_5: "x \<le> 4 \<Longrightarrow> x < 5" for x :: nat
  by auto

lemma le_Suc_flip_le: "\<lbrakk> x \<le> Suc y; y < x \<rbrakk> \<Longrightarrow> Suc y = x"
  apply(simp)
  done

lemma neq_le_SucD: "\<lbrakk> x \<noteq> z; x < y; y = z + 1 \<rbrakk> \<Longrightarrow> x < z" for x :: nat
  apply(auto)
  done

lemma n_eq_div_plus_mod: "v2 = m * v1 \<Longrightarrow> n * v1 = n div m * v2 + n mod m * v1" for n :: nat
  by (metis distrib_right div_mult_mod_eq mult.assoc)

lemma le_minus[rule_format]: "x \<le> x - y \<longrightarrow> x \<le> y \<or> y = 0"  for x :: nat
  apply(induct x arbitrary: y)
  apply(auto)
  done

subsection "multiset"
lemma (in comm_monoid_diff) fold_mset_empty: "fold_mset (+) x {#} = x"
  by auto

lemma (in comm_monoid_diff) abc_bac: "a + (b + c) = b + (a + c)"
  by (rule local.add.left_commute)

lemma (in comm_monoid_diff) comm_monoid_add_comp_fun_commute: "comp_fun_commute (+)"
  by (auto simp add: comp_fun_commute_def abc_bac intro: local.add.left_commute)

lemma (in comm_monoid_diff) fold_mset_add: "fold_mset (+) y (add_mset x M) = x + (fold_mset (+) y M)"
  by (auto simp add: comp_fun_commute.fold_mset_add_mset comm_monoid_add_comp_fun_commute)

lemma (in comm_monoid_diff) fold_mset_plus: "fold_mset (+) (x + y) M = y + fold_mset (+) x M"
  apply(induct M)
  apply(subst (1 2) fold_mset_empty)
  apply(rule add_commute)
  apply(subst (1 2) fold_mset_add)
  apply(erule ssubst)
  apply(subst (1 2) add_assoc[symmetric])
  apply(subst add_commute)
  apply(rule refl)
  done

lemma replicate_mset_subseteq: "replicate_mset (count C c) c \<subseteq># C"
  using count_le_replicate_mset_subset_eq by fastforce

lemma count_le_size: "count C x \<le> size C"
  using replicate_mset_subseteq size_mset_mono by fastforce

lemma count_add_mset_eq_count: "\<lbrakk> xa \<noteq> x \<rbrakk> \<Longrightarrow> count (add_mset xa M) x = count M x"
  by auto

lemma count_eq_replicate_mset_subset_eq: "count M x = n \<Longrightarrow> replicate_mset n x \<subseteq># M"
  using count_le_replicate_mset_subset_eq by fastforce

lemma subset_add_weak: "A \<subseteq># B \<Longrightarrow> A \<subseteq># add_mset x B"
  using subset_mset.order.trans by fastforce

lemma subset_plus_weak: "A \<subseteq># B \<Longrightarrow> A \<subseteq># B + C"
  by (simp add: subset_mset.add_increasing2)

lemma count_size_FalseE: "\<lbrakk>count M x = n; size M < n\<rbrakk> \<Longrightarrow> False"
  by (meson count_le_size not_le)

lemma image_mset_diff_nat: "B \<subseteq># A \<Longrightarrow> image_mset f (A - B) = image_mset f A - image_mset f B"  for f :: "'a \<Rightarrow> nat"
  apply(unfold image_mset_def)
  by (metis image_mset_Diff image_mset_def)

section "Coins"
subsection "Coin Definitions"
datatype Coin = One | Five | Ten | Fifty | Hundred | FiveHundred

subsection "Value of Coins"
type_alias val_unit = nat

fun val_yen_unit :: "Coin \<Rightarrow> val_unit" where
  "val_yen_unit One = 1" |
  "val_yen_unit Five = 5" |
  "val_yen_unit Ten = 10" |
  "val_yen_unit Fifty = 50" |
  "val_yen_unit Hundred = 100" |
  "val_yen_unit FiveHundred = 500"

theorem inj_val_yen_unit: "inj val_yen_unit"
  apply(unfold inj_def)
  apply(intro allI)
  apply(case_tac x)
  apply(case_tac y)
  apply(auto)
  apply(case_tac y)
  apply(auto)
  apply(case_tac y)
  apply(auto)
  apply(case_tac y)
  apply(auto)
  apply(case_tac y)
  apply(auto)
  apply(case_tac y)
  apply(auto)
  done

theorem range_val_yen_unit: "range val_yen_unit = {1, 5, 10, 50, 100, 500}"
  apply(subst full_SetCompr_eq[symmetric])
  apply(auto)
  apply(case_tac xa)
  apply(auto)
  apply(rule_tac x=One in exI)
  apply(force)
  apply(rule_tac x=Five in exI)
  apply(force)
  apply(rule_tac x=Ten in exI)
  apply(force)
  apply(rule_tac x=Fifty in exI)
  apply(force)
  apply(rule_tac x=Hundred in exI)
  apply(force)
  apply(rule_tac x=FiveHundred in exI)
  apply(force)
  done

lemma val_yen_unit_gt_0: "val_yen_unit x > 0"
  apply(case_tac x)
  apply(auto)
  done

lemma val_yen_unit_eq_0E: "val_yen_unit x = 0 \<Longrightarrow> P"
  apply(insert val_yen_unit_gt_0)
  apply(subst (asm) zero_less_iff_neq_zero)
  apply(drule_tac x=x in meta_spec)
  apply(erule notE)
  apply(assumption)
  done

definition val :: "Coin multiset \<Rightarrow> nat" where
  "val M = sum_mset (image_mset val_yen_unit M)"

lemma val_empty: "val {#} = 0"
  apply(auto simp add: val_def)
  done

lemma val_singleton: "val {#c#} = val_yen_unit c"
  apply(unfold val_def)
  apply(auto)
  done

lemma val_add: "val (add_mset x M) = val_yen_unit x + val M"
  apply(induct M)
  apply(auto simp add: val_def)
  done

lemma val_plus: "val (A + B) = val A + val B"
  apply(auto simp add: val_def)
  done

lemma val_diff: "B \<subseteq># A \<Longrightarrow> val (A - B) = val A - val B"
  apply(auto simp add: val_def)
  apply(subst image_mset_diff_nat)
  apply(assumption)
  apply(rule ordered_cancel_comm_monoid_diff_class.sum_mset_diff)
  apply(erule image_mset_subseteq_mono)
  done

theorem val_aribitrary: "\<exists>C1 C2. C1 \<noteq> C2 \<and> val C1 = val C2"
  apply(rule_tac x="{# Five #}" in exI)
  apply(rule_tac x="{# One, One, One, One, One #}" in exI)
  apply(auto simp add: val_add)
  done

lemma val_0: "val C = 0 \<longleftrightarrow> C = {#}"
  apply(case_tac C)
  apply(auto simp add: val_empty val_add val_yen_unit_gt_0)
  done

lemma val_add_gt_0: "val (add_mset c C) > 0"
  apply(subst val_add)
  apply(rule trans_less_add1)
  apply(rule val_yen_unit_gt_0)
  done

lemma val_gt_0_eq_not_empty: "val C > 0 \<longleftrightarrow> C \<noteq> {#}"
  apply(rule iffI)
  apply(case_tac C)
  apply(clarify)
  apply(subst (asm) val_empty)
  apply(subst (asm) less_nat_zero_code)
  apply(erule FalseE)
  apply(erule ssubst)
  apply(subst neq_commute)
  apply(rule empty_not_add_mset)
  apply(drule multi_nonempty_split)
  apply(elim exE)
  apply(erule ssubst)
  apply(rule val_add_gt_0)
  done

lemma val_replicate_mset_count: "val (replicate_mset n x) = n * val_yen_unit x"
  apply(induct n)
  apply(auto simp add: val_empty val_add)
  done

lemma count_le_val: "count C x * val_yen_unit x \<le> val C"
  apply(induct C)
  apply(auto simp add: val_add)
  done

lemma same_val_singleton_size_le[rule_format]: "val {#c#} = val C \<longrightarrow> size {#c#} \<le> size C"
  apply(case_tac C)
  apply(erule ssubst)
  apply(rule impI)
  apply(subst (asm) val_add)
  apply(subst (asm) (1 2) val_empty)
  apply(subst (asm) add_0_right)
  apply(erule val_yen_unit_eq_0E)
  apply(case_tac x)
  apply(auto)
  done

definition dvd_coins :: "val_unit set \<Rightarrow> bool" where
  "dvd_coins V \<equiv> \<forall>v1 \<in> V. \<forall>v2 \<in> V. v1 < v2 \<longrightarrow> v1 dvd v2"

theorem dvd_coins_yen: "dvd_coins (range val_yen_unit)"
  apply(unfold dvd_coins_def range_val_yen_unit)
  apply(auto)
  done

definition next_Coin :: "Coin \<Rightarrow> Coin \<Rightarrow> bool" where
  "next_Coin c1 c3 \<equiv> \<nexists>c2. val_unit c1 < val_unit c2 \<and> val_unit c2 < val_unit c3"

fun next_Coin :: "Coin \<Rightarrow> Coin option"where
  "next_Coin One = Some Five" |
  "next_Coin Five = Some Ten" |
  "next_Coin Ten = Some Fifty" |
  "next_Coin Fifty = Some Hundred" |
  "next_Coin Hundred = Some FiveHundred" |
  "next_Coin FiveHundred = None"

fun redundant_since :: "Coin \<Rightarrow> nat option"where
  "redundant_since One = Some 5" |
  "redundant_since Five = Some 2" |
  "redundant_since Ten = Some 5" |
  "redundant_since Fifty = Some 2" |
  "redundant_since Hundred = Some 5" |
  "redundant_since FiveHundred = None"

lemma redundant_sinceD: "redundant_since c = Some m \<Longrightarrow> \<exists>c'. next_Coin c = Some c'"
  apply(case_tac c)
  apply(auto)
  done

lemma redundant_since_gtD: "redundant_since x = Some m \<Longrightarrow> m > 1"
  apply(case_tac x)
  apply(auto)
  done

lemma all_redundant_since_imp: "(\<forall>c m. redundant_since c = Some m \<longrightarrow> P c m) \<longleftrightarrow>
    (P One 5 \<and> P Five 2 \<and> P Ten 5 \<and> P Fifty 2 \<and> P Hundred 5)"
  apply(auto)
  apply(case_tac c)
  apply(auto)
  done

lemma val_yen_unit_next_Coin: "\<lbrakk> redundant_since c = Some m; next_Coin c = Some c'\<rbrakk> \<Longrightarrow> val_yen_unit c' = m * val_yen_unit c"
  apply(case_tac c)
  apply(auto)
  done

subsection "Normal form"
definition normal :: "Coin multiset \<Rightarrow> bool" where
  "normal C \<equiv> \<forall>C'. val C = val C' \<longrightarrow> size C \<le> size C'"

lemma normal_empty: "normal {#}"
  apply(unfold normal_def)
  apply(auto)
  done

lemma normal_singleton: "normal {# c #}"
  apply(unfold normal_def)
  apply(clarify)
  apply(erule same_val_singleton_size_le)
  done

lemma not_normal_singletonE: "\<not>normal {# c #} \<Longrightarrow> P"
  apply(erule notE)
  apply(rule normal_singleton)
  done

lemma normal_add_imp_normal: "normal (add_mset c C) \<Longrightarrow> normal C"
  apply(unfold normal_def)
  apply(auto)
  apply(drule_tac x="add_mset c C'" in spec)
  apply(drule mp)
  apply(subst (1 2) val_add)
  apply(auto)
  done

lemma normal_add_add_imp_normal: "normal (add_mset c1 (add_mset c2 C)) \<Longrightarrow> normal C \<and> normal (add_mset c1 C) \<and> normal (add_mset c2 C)"
  apply(intro conjI)
  apply(drule normal_add_imp_normal)
  apply(erule normal_add_imp_normal)
  apply(subst (asm) add_mset_commute)
  apply(erule normal_add_imp_normal)
  apply(erule normal_add_imp_normal)
  done

theorem not_normal_if_redundant: "\<lbrakk> redundant_since c = Some m; count C c = m \<rbrakk> \<Longrightarrow> \<not> normal C"
  apply(unfold normal_def)
  apply(subst not_all)
  apply(frule redundant_sinceD)
  apply(clarify)
  apply(rule_tac x="C + {# c' #} - replicate_mset m c" in exI)
  apply(clarify)
  apply(subst (asm) size_Diff_submset)
  apply(rule subset_plus_weak)
  apply(force intro: count_eq_replicate_mset_subset_eq)
  apply(clarsimp)
  apply(drule mp)
  apply(subst val_diff)
  apply(rule subset_add_weak)
  apply(force intro: count_eq_replicate_mset_subset_eq)
  apply(subst val_replicate_mset_count)
  apply(subst val_add)
  apply(case_tac c)
  apply(auto)
  apply(case_tac c)
  apply(auto dest!: le_minus le_1_is_lt_2 le_4_is_lt_5 elim: count_size_FalseE)
  done

definition no_redundant :: "Coin multiset \<Rightarrow> bool" where
  "no_redundant C \<equiv> \<forall>c n. redundant_since c = Some n \<longrightarrow> count C c < n"

lemma no_redundant_empty: "no_redundant {#}"
  apply(unfold no_redundant_def)
  apply(auto)
  apply(case_tac c)
  apply(auto)
  done

lemma no_redundant_singleton: "no_redundant {#c#}"
  apply(unfold no_redundant_def)
  apply(rule allI)
  apply(case_tac ca)
  apply(auto)
  done

lemma no_redundant_add_imp_no_redundant[rule_format]: "no_redundant (add_mset c C) \<longrightarrow> no_redundant C"
  apply(auto simp add: no_redundant_def)
  done

lemma no_redundant_not_no_redundant_addD: "\<lbrakk> no_redundant C; \<not> no_redundant (add_mset c C) \<rbrakk> \<Longrightarrow> redundant_since c = Some (Suc (count C c))"
  apply(unfold no_redundant_def not_all not_imp not_less)
  apply(elim exE conjE)
  apply(drule_tac x=x in spec)
  apply(drule_tac x=xa in spec)
  apply(drule mp)
  apply(assumption)
  apply(subst (asm) count_add_mset)
  apply(case_tac "c=x")
  apply(subst (asm) if_P)
  apply(assumption)
  apply(drule le_Suc_flip_le)
  apply(assumption)
  apply(clarify)
  apply(subst (asm) if_not_P)
  apply(assumption)
  apply(subst (asm) not_less[symmetric])
  apply(erule notE)
  apply(assumption)
  done

lemma redundant_since_eq_Some_SucD: "\<lbrakk> redundant_since c = Some (Suc (count C c)); next_Coin c = Some c' \<rbrakk> \<Longrightarrow> val (replicate_mset (count C c) c) \<le> val {#c'#}"
  apply(subst val_replicate_mset_count)
  apply(subst val_singleton)
  apply(case_tac c)
  apply(auto)
  done

lemma not_no_redundant_imp_not_normal[rule_format]: "\<not>no_redundant C \<longrightarrow> \<not>normal C"
  apply(induct C)
  apply(rule impI)
  apply(erule notE)
  apply(rule no_redundant_empty)

  apply(rule impI)
  apply(case_tac "\<not>no_redundant C")
  apply(drule mp)
  apply(assumption)
  apply(erule_tac Q="normal C" in contrapos_nn)
  apply(erule normal_add_imp_normal)

  apply(subst (asm) not_not)
  apply(drule no_redundant_not_no_redundant_addD)
  apply(assumption)
  apply(subst normal_def)
  apply(unfold not_all not_imp size_add_mset not_le less_Suc_eq_le)
  apply(frule redundant_sinceD)
  apply(elim exE)
  apply(rule_tac x="C + {#c'#} - replicate_mset (count C x) x" in exI)
  apply(rule conjI)
  apply(subst val_add)
  apply(subst val_diff)
  apply(rule subset_plus_weak)
  apply(rule replicate_mset_subseteq)
  apply(subst val_plus)
  apply(subst a_plus_b_eq_b_plus_c_minus_d)
  apply(erule redundant_since_eq_Some_SucD)
  apply(assumption)
  apply(subst val_replicate_mset_count)
  apply(drule_tac val_yen_unit_next_Coin)
  apply(assumption)
  apply(subst val_singleton)
  apply(erule_tac t="val_yen_unit c'" in ssubst)
  apply(subst mult_Suc)
  apply(subst diff_add_inverse2)
  apply(rule refl)

  apply(subst size_Diff_submset)
  apply(rule subset_plus_weak)
  apply(rule replicate_mset_subseteq)
  apply(subst size_union)
  apply(subst size_single)
  apply(subst size_replicate_mset)
  apply(drule redundant_since_gtD)
  apply(subst (asm) less_Suc_eq_le)
  apply(rule a_plus_b_minus_c_le_a)
  apply(assumption)
  done

theorem normal_imp_no_redundant: "normal C \<Longrightarrow> no_redundant C"
  apply(erule contrapos_pp)
  apply(erule not_no_redundant_imp_not_normal)
  done

lemma x[rule_format]: "no_redundant C \<longrightarrow> val C = val C' \<longrightarrow> size C \<le> size C' \<longrightarrow>
       no_redundant (add_mset x C) \<longrightarrow> val (add_mset x C) = val C' \<longrightarrow> size (add_mset x C) \<le> size C'"
  apply(induct C')
  apply(force simp add: val_empty val_0)

  apply(clarsimp simp add: val_add)
  apply(case_tac x)
  apply(auto)
  done

lemma "no_redundant C \<longrightarrow> val C = val C' \<longrightarrow> size C \<le> size C'"
  apply(induct C)
  apply(intro impI)
  apply(subst size_empty)
  apply(rule le0)
  apply(clarify)
  oops

theorem no_redundant_imp_normal[rule_format]: "no_redundant C \<longrightarrow> normal C"
  apply(unfold no_redundant_def normal_def)
  oops

theorem normal_uniq: "\<lbrakk> normal C1; normal C2; val C1 = val C2 \<rbrakk> \<Longrightarrow> C1 = C2"
  apply(auto simp add: normal_def)
  oops

theorem normal_total: "\<forall>v. \<exists>C. v = val C \<and> normal C"
  apply(unfold normal_def)
  oops

theorem "\<lbrakk> normal C0; normal C2 \<rbrakk> \<Longrightarrow> \<exists>C1. C1 \<subseteq># C0 \<and> normal (C0 - C1 + C2)"
  oops

subsection "Normalize"
definition normalize1 :: "Coin \<Rightarrow> Coin multiset \<Rightarrow> Coin multiset" where
  "normalize1 c C \<equiv> case (next_Coin c, redundant_since c) of
    (Some c', Some n) \<Rightarrow>
      C - (replicate_mset (count C c) c)
      + (replicate_mset ((count C c) div n) c')
      + (replicate_mset ((count C c) mod n) c) |
    _ \<Rightarrow> C"

lemma redundant_since_normnalize1_D: "\<lbrakk> redundant_since c = Some n; C' = normalize1 c C; next_Coin c = Some c' \<rbrakk> \<Longrightarrow>
    C' = C - (replicate_mset (count C c) c)
       + (replicate_mset ((count C c) div n) c')
       + (replicate_mset ((count C c) mod n) c)"
  apply(unfold normalize1_def)
  apply(auto)
  done

theorem same_val_size_leI: "\<lbrakk> redundant_since c = Some m; count C c \<ge> m; C' = normalize1 c C \<rbrakk> \<Longrightarrow> val C = val C' \<and> size C' < size C"
  apply(frule redundant_sinceD)
  apply(elim exE)
  apply(frule redundant_since_normnalize1_D)
  apply(assumption)
  apply(assumption)
  apply(erule_tac s=" C - replicate_mset (count C c) c + replicate_mset (count C c div m) c' + replicate_mset (count C c mod m) c" in ssubst)
  apply(auto simp add: val_plus val_replicate_mset_count)
  apply(subst val_diff)
  apply(rule replicate_mset_subseteq)
  apply(subst val_replicate_mset_count)
  apply(subst a_eq_a_minus_b_plus_c_plus_d_is_b_eq_c_plus_d)
  apply(rule count_le_val)
  apply(rule n_eq_div_plus_mod)
  apply(force intro: val_yen_unit_next_Coin)
  apply(subst size_Diff_submset)
  apply(rule replicate_mset_subseteq)
  apply(subst size_replicate_mset)
  apply(subst a_minus_b_plus_c_plus_d_le_a)
  apply(rule count_le_size)
  apply(rule le_div_plus_mod)
  apply(assumption)
  apply(case_tac c)
  apply(auto)
  done

end


section \<open>Helpers\<close>

theory Helpers imports Main begin

text \<open>
  First, we will prove a few lemmas unrelated to graphs or Menger's Theorem.  These lemmas
  will simplify some of the other proof steps.
\<close>

text \<open>
  If two finite sets have different cardinality, then there exists an element in the larger set
  that is not in the smaller set.
\<close>
lemma card_finite_less_ex:
  assumes finite_A: "finite A"
      and finite_B: "finite B"
      and card_AB: "card A < card B"
  shows "\<exists>b \<in> B. b \<notin> A"
proof-
  have "card (B - A) > 0" using finite_A finite_B card_AB
    by (meson Diff_eq_empty_iff card_eq_0_iff card_mono finite_Diff gr0I leD)
  then show ?thesis using finite_B
    by (metis Diff_eq_empty_iff card_0_eq finite_Diff neq_iff subsetI)
qed

text \<open>
  The cardinality of the union of two disjoint finite sets is the sum of their cardinalities
  even if we intersect everything with a fixed set @{term X}.
\<close>
lemma card_intersect_sum_disjoint:
  assumes "finite B" "finite C" "A = B \<union> C" "B \<inter> C = {}"
    shows "card (A \<inter> X) = card (B \<inter> X) + card (C \<inter> X)"
  by (metis (no_types, lifting) Un_Diff_Int assms card_Un_disjoint finite_Int inf.commute
      inf_sup_distrib2 sup_eq_bot_iff)

text \<open>
  If @{term x} is in a list @{term xs} but is not its last element, then it is also in
  @{term "butlast xs"}.
\<close>
lemma set_butlast: "\<lbrakk> x \<in> set xs; x \<noteq> last xs \<rbrakk> \<Longrightarrow> x \<in> set (butlast xs)"
  by (metis butlast.simps(2) in_set_butlast_appendI last.simps last_appendR
      list.set_intros(1) split_list_first)

text \<open>
  If a property @{term P} is satisfiable and if we have a weight measure mapping into the natural
  numbers, then there exists an element of minimum weight satisfying @{term P} because the
  natural numbers are well-ordered.
\<close>
lemma arg_min_ex:
  fixes P :: "'a \<Rightarrow> bool" and weight :: "'a \<Rightarrow> nat"
  assumes "\<exists>x. P x"
  obtains x where "P x" "\<And>y. P y \<Longrightarrow> weight x \<le> weight y"
proof (cases "\<exists>x. P x \<and> weight x = 0")
  case True then show ?thesis using that by auto
next
  case False then show ?thesis
    using that ex_least_nat_le[of "\<lambda>n. \<exists>x. P x \<and> weight x = n"] assms by (metis not_le_imp_less)
qed

end


theory List_util
  imports Main
begin

inductive same_length :: "'a list \<Rightarrow> 'b list \<Rightarrow> bool" where
  same_length_Nil: "same_length [] []" |
  same_length_Cons: "same_length xs ys \<Longrightarrow> same_length (x # xs) (y # ys)"

code_pred same_length .

lemma same_length_iff_eq_lengths: "same_length xs ys \<longleftrightarrow> length xs = length ys"
proof
  assume "same_length xs ys"
  then show "length xs = length ys"
    by (induction xs ys rule: same_length.induct) simp_all
next
  assume "length xs = length ys"
  then show "same_length xs ys"
  proof (induction xs arbitrary: ys)
    case Nil
    then show ?case
      by (simp add: same_length_Nil)
  next
    case (Cons x xs)
    then show ?case
      by (metis length_Suc_conv same_length_Cons)
  qed
qed

lemma same_length_Cons:
  "same_length (x # xs) ys \<Longrightarrow> \<exists>y ys'. ys = y # ys'"
  "same_length xs (y # ys) \<Longrightarrow> \<exists>x xs'. xs = x # xs'"
proof -
  assume "same_length (x # xs) ys"
  then show "\<exists>y ys'. ys = y # ys'"
    by (induction "x # xs" ys rule: same_length.induct) simp
next
  assume "same_length xs (y # ys)"
  then show "\<exists>x xs'. xs = x # xs'"
    by (induction xs "y # ys" rule: same_length.induct) simp
qed

section \<open>nth\_opt\<close>

fun nth_opt where
  "nth_opt (x # _) 0 = Some x" |
  "nth_opt (_ # xs) (Suc n) = nth_opt xs n" |
  "nth_opt _ _ = None"

lemma nth_opt_eq_Some_conv: "nth_opt xs n = Some x \<longleftrightarrow> n < length xs \<and> xs ! n = x"
  by (induction xs n rule: nth_opt.induct; simp)

lemmas nth_opt_eq_SomeD[dest] = nth_opt_eq_Some_conv[THEN iffD1]

section \<open>Generic lemmas\<close>

lemma list_rel_imp_pred1:
  assumes
    "list_all2 R xs ys" and
    "\<And>x y. (x, y) \<in> set (zip xs ys) \<Longrightarrow> R x y \<Longrightarrow> P x"
  shows "list_all P xs"
  using assms
  by (induction xs ys rule: list.rel_induct) auto

lemma list_rel_imp_pred2:
  assumes
    "list_all2 R xs ys" and
    "\<And>x y. (x, y) \<in> set (zip xs ys) \<Longrightarrow> R x y \<Longrightarrow> P y"
  shows "list_all P ys"
  using assms
  by (induction xs ys rule: list.rel_induct) auto

lemma eq_append_conv_conj: "(zs = xs @ ys) = (xs = take (length xs) zs \<and> ys = drop (length xs) zs)"
  by (metis append_eq_conv_conj)

lemma list_all_list_updateI: "list_all P xs \<Longrightarrow> P x \<Longrightarrow> list_all P (list_update xs n x)"
  by (induction xs arbitrary: n) (auto simp add: nat.split_sels(2))

lemmas list_all2_update1_cong = list_all2_update_cong[of _ _ ys _ "ys ! i" i for ys i, simplified]
lemmas list_all2_update2_cong = list_all2_update_cong[of _ xs _ "xs ! i" _ i for xs i, simplified]

lemma map_list_update_id:
  "f (xs ! pc) = f instr \<Longrightarrow> map f (xs[pc := instr]) = map f xs"
  using list_update_id map_update by metis

lemma list_all_eq_const_imp_replicate:
  assumes "list_all (\<lambda>x. x = y) xs"
  shows "xs = replicate (length xs) y"
  using assms
  by (induction xs; simp)

lemma list_all_eq_const_imp_replicate':
  assumes "list_all ((=) y) xs"
  shows "xs = replicate (length xs) y"
  using assms
  by (induction xs; simp)

lemma list_all_eq_const_replicate_lhs[intro]:
  "list_all (\<lambda>x. y = x) (replicate n y)"
  by (simp add: list_all_length)

lemma list_all_eq_const_replicate_rhs[intro]:
  "list_all (\<lambda>x. x = y) (replicate n y)"
  by (simp add: list_all_length)

lemma list_all_eq_const_replicate[simp]: "list_all ((=) c) (replicate n c)"
  by (simp add: list_all_length)

lemma replicate_eq_map:
  assumes "n = length xs" and "\<And>y. y \<in> set xs \<Longrightarrow> f y = x"
  shows "replicate n x = map f xs"
  using assms
proof (induction xs arbitrary: n)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  thus ?case by (cases n; auto)
qed

lemma replicate_eq_impl_Ball_eq:
  shows "replicate n c = xs \<Longrightarrow> (\<forall>x \<in> set xs. x = c)"
  by (meson in_set_replicate)

lemma rel_option_map_of:
  assumes "list_all2 (rel_prod (=) R) xs ys"
  shows "rel_option R (map_of xs l) (map_of ys l)"
  using assms
proof (induction xs ys rule: list.rel_induct)
  case Nil
  thus ?case by simp
next
  case (Cons x xs y ys)
  from Cons.hyps have "fst x = fst y" and "R (snd x) (snd y)"
    by (simp_all add: rel_prod_sel)
  show ?case
  proof (cases "l = fst y")
    case True
    then show ?thesis
      by (simp add: \<open>fst x = fst y\<close> \<open>R (snd x) (snd y)\<close>)
  next
    case False
    then show ?thesis
      using Cons.IH
      by (simp add: \<open>fst x = fst y\<close> )
  qed
qed

lemma list_all2_rel_prod_nth:
  assumes "list_all2 (rel_prod R1 R2) xs ys" and "n < length xs"
  shows "R1 (fst (xs ! n)) (fst (ys ! n)) \<and> R2 (snd (xs ! n)) (snd (ys ! n))"
  using assms
proof (induction n arbitrary: xs ys)
  case 0
  then show ?case
    using assms(1,2)
    by (auto elim: list.rel_cases)
next
  case (Suc n)
  then obtain x xs' y ys' where xs_def[simp]: "xs = x # xs'" and ys_def[simp]: "ys = y # ys'"
    by (auto elim: list.rel_cases)
  show ?case
    using Suc.prems Suc.IH[of xs' ys']
    by force
qed

lemma list_all2_rel_prod_fst_hd:
  assumes "list_all2 (rel_prod R1 R2) xs ys" and "xs \<noteq> [] \<or> ys \<noteq> []"
  shows "R1 (fst (hd xs)) (fst (hd ys)) \<and> R2 (snd (hd xs)) (snd (hd ys))"
  using assms
  by (auto simp: rel_prod_sel elim: list.rel_cases)

lemma list_all2_rel_prod_fst_last:
  assumes "list_all2 (rel_prod R1 R2) xs ys" and "xs \<noteq> [] \<or> ys \<noteq> []"
  shows "R1 (fst (last xs)) (fst (last ys)) \<and> R2 (snd (last xs)) (snd (last ys))"
proof -
  have "xs \<noteq> []" and "ys \<noteq> []"
    using assms by (auto elim: list.rel_cases)
  moreover have "length xs = length ys"
    by (rule assms(1)[THEN list_all2_lengthD])
  ultimately show ?thesis
    using list_all2_rel_prod_nth[OF assms(1)]
    by (simp add: last_conv_nth)
qed

lemma list_all_nthD[intro]: "list_all P xs \<Longrightarrow> n < length xs \<Longrightarrow> P (xs ! n)"
  by (simp add: list_all_length)

lemma "list_all P xs \<Longrightarrow> \<forall>x\<in> set xs. P x"
  using list_all_iff list.pred_set
  by (simp add: list_all_iff)

lemma list_all_map_of_SomeD:
  assumes "list_all P kvs" and "map_of kvs k = Some v"
  shows "P (k, v)"
  using assms
  unfolding list.pred_set
  by (auto dest: map_of_SomeD)

lemma list_all_not_nthD:"list_all P xs \<Longrightarrow> \<not> P (xs ! n) \<Longrightarrow> length xs \<le> n"
proof (induction xs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  then show ?case
    by (cases n) simp_all
qed

lemma list_all_butlast_not_nthD: "list_all P (butlast xs) \<Longrightarrow> \<not> P (xs ! n) \<Longrightarrow> length xs \<le> Suc n"
  using list_all_not_nthD[of _ "butlast xs" for xs, simplified]
  by (smt (z3) One_nat_def Suc_pred le_Suc_eq length_butlast length_greater_0_conv less_Suc_eq list.pred_inject(1) list_all_not_nthD not_le nth_butlast)

lemma list_all_replicateI[intro]: "P x \<Longrightarrow> list_all P (replicate n x)"
  unfolding list.pred_set
  by simp

lemma map_eq_append_replicate_conv:
  assumes "map f xs = replicate n x @ ys"
  shows "map f (take n xs) = replicate n x"
  using assms
  by (metis append_eq_conv_conj length_replicate take_map)

lemma map_eq_replicate_imp_list_all_const:
  "map f xs = replicate n x \<Longrightarrow> n = length xs \<Longrightarrow> list_all (\<lambda>y. f y = x) xs"
  by (induction xs arbitrary: n) simp_all

lemma map_eq_replicateI: "length xs = n \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = c) \<Longrightarrow> map f xs = replicate n c"
  by (induction xs arbitrary: n) auto

lemma list_all_dropI[intro]: "list_all P xs \<Longrightarrow> list_all P (drop n xs)"
  by (metis append_take_drop_id list_all_append)

section \<open>Non-empty list\<close>

type_synonym 'a nlist = "'a \<times> 'a list"

end


(*  Title:      Sigma_Algebra.thy

    Author:     Stefan Richter, Markus Wenzel, TU Muenchen
    License:    LGPL

Changes for Accordance to Joe Hurd's conventions
and additions by Stefan Richter 2002
*)

header {* Sigma algebras *}

theory Sigma_Algebra imports Main begin

text {* The $\isacommand {theory}$ command commences a formal document and enumerates the
  theories it depends on. With the @{text Main} theory, a standard
  selection of useful HOL theories excluding the real
  numbers is loaded. This theory includes and builds upon a tiny theory of the
  same name by Markus Wenzel. This theory as well as @{text Measure}
  in \ref{sec:measure-spaces} is heavily
  influenced by Joe Hurd's thesis \cite{hurd2002} and has been designed to keep the terminology as
  consistent as possible with that work.

  Sigma algebras are an elementary concept in measure
  theory. To measure --- that is to integrate --- functions, we first have
  to measure sets. Unfortunately, when dealing with a large universe,
  it is often not possible to consistently assign a measure to every
  subset. Therefore it is necessary to define the set of measurable
  subsets of the universe. A sigma algebra is such a set that has
  three very natural and desirable properties. *}

definition
  sigma_algebra:: "'a set set \<Rightarrow> bool" where
  "sigma_algebra A \<longleftrightarrow>
  {} \<in> A \<and> (\<forall>a. a \<in> A \<longrightarrow> -a \<in> A) \<and>
  (\<forall>a. (\<forall> i::nat. a i \<in> A) \<longrightarrow> (\<Union>i. a i) \<in> A)"

text {*
  The $\isacommand {definition}$ command defines new constants, which
  are just named functions in HOL. Mind that the third condition
  expresses the fact that the union of countably many sets in $A$ is
  again a set in $A$ without explicitly defining the notion of
  countability.

  Sigma algebras can naturally be created as the closure of any set of
  sets with regard to the properties just postulated. Markus Wenzel
  wrote the following
  inductive definition of the $\isa {sigma}$ operator.  *}

inductive_set
  sigma :: "'a set set \<Rightarrow> 'a set set"
  for A :: "'a set set"
  where
    basic: "a \<in> A \<Longrightarrow> a \<in> sigma A"
  | empty: "{} \<in> sigma A"
  | complement: "a \<in> sigma A \<Longrightarrow> -a \<in> sigma A"
  | Union: "(\<And>i::nat. a i \<in> sigma A) \<Longrightarrow> (\<Union>i. a i) \<in> sigma A"

text {* He also proved the following basic facts. The easy proofs are omitted.
*}

theorem sigma_UNIV: "UNIV \<in> sigma A"
(*<*)proof -
  have "{} \<in> sigma A" by (rule sigma.empty)
  hence "-{} \<in> sigma A" by (rule sigma.complement)
  also have "-{} = UNIV" by simp
  finally show ?thesis .
qed(*>*)

theorem sigma_Inter:
  "(\<And>i::nat. a i \<in> sigma A) \<Longrightarrow> (\<Inter>i. a i) \<in> sigma A"
(*<*) proof -
  assume "\<And>i::nat. a i \<in> sigma A"
  hence "\<And>i::nat. -(a i) \<in> sigma A" by (rule sigma.complement)
  hence "(\<Union>i. -(a i)) \<in> sigma A" by (rule sigma.Union)
  hence "-(\<Union>i. -(a i)) \<in> sigma A" by (rule sigma.complement)
  also have "-(\<Union>i. -(a i)) = (\<Inter>i. a i)" by simp
  finally show ?thesis .
qed(*>*)

text {*It is trivial to show the connection between our first
  definitions. We use the opportunity to introduce the proof syntax.*}

theorem assumes sa: "sigma_algebra A"
  -- "Named premises are introduced like this."

  shows sigma_sigma_algebra: "sigma A = A"
proof

  txt {*The $\isacommand {proof}$ command alone invokes a single standard rule to
    simplify the goal. Here the following two subgoals emerge.*}

  show "A \<subseteq> sigma A"
    -- {*The $\isacommand {show}$ command starts the proof of a subgoal.*}

    by (auto simp add: sigma.basic)

  txt {* This is easy enough to be solved by an automatic step,
    indicated by the keyword $\isacommand {by}$. The method $\isacommand {auto}$ is stated in parentheses, with attributes to it following.  In
    this case, the first introduction rule for the $\isacommand {sigma}$
    operator is given as an extra simplification rule. *}

  show "sigma A \<subseteq> A"
  proof

    txt {*Because this goal is not quite as trivial, another proof is
      invoked, delimiting a block as in a programming language.*}

    fix x
    -- "A new named variable is introduced."

    assume "x \<in> sigma A"

    txt {*An assumption is made that must be justified by the current proof
      context. In this case the corresponding fact had been generated
      by a rule automatically invoked by the inner $\isacommand {proof}$
      command.*}

    from this sa show "x \<in> A"

      txt {* Named facts can explicitly be given to the proof methods using
        $\isacommand {from}$. A special name is @{text this}, which denotes
        current facts generated by the last command. Usually $\isacommand
        {from}$ @{text "this sa"} --- remember that @{text sa} is an assumption from above
        --- is abbreviated to $\isacommand {with}$ @{text "sa"}, but in this case the order of
        facts is relevant for the following method and $\isacommand
        {with}$
        would have put the current facts last. *}

      by (induct rule: sigma.induct) (auto simp add: sigma_algebra_def)

    txt {*Two methods may be carried out at $\isacommand {by}$. The first
      one applies induction here via the canonical rule generated by the
      inductive definition above, while the latter solves the
      resulting subgoals by an automatic step involving
      simplification.*}

  qed
qed

text "These two steps finish their respective proofs, checking
  that all subgoals have been proven."

text {* To end this theory we prove a special case of the @{text
  sigma_Inter} theorem above. It seems trivial that
  the fact holds for two sets as well as for countably many.
  We get a first taste of the cost of formal reasoning here, however. The
  idea must be made precise by exhibiting a concrete sequence of
  sets. *}

primrec trivial_series:: "'a set \<Rightarrow> 'a set \<Rightarrow> (nat \<Rightarrow> 'a set)"
where
  "trivial_series a b 0 = a"
| "trivial_series a b (Suc n) = b"

text {*Using $\isacommand {primrec}$, primitive recursive functions over
  inductively defined data types --- the natural numbers in this case ---
  may be constructed.*}

theorem assumes s: "sigma_algebra A" and a: "a \<in> A" and b: "b \<in> A"
  shows sigma_algebra_inter: "a \<inter> b \<in> A"
proof -
    -- {*This form of $\isacommand {proof}$ foregoes the application of a rule.*}

  have "a \<inter> b = (\<Inter>i::nat. trivial_series a b i)"

    txt {*Intermediate facts that do not solve any subgoals yet are established this way.*}

  proof (rule set_eqI)

    txt {*The  $\isacommand {proof}$ command may also take one explicit method
      as an argument like the single rule application in this instance.*}

    fix x

    {
      fix i
      assume "x \<in> a \<inter> b"
      hence "x \<in> trivial_series a b i" by (cases i) auto
        -- {*This is just an abbreviation for $\isacommand {"from this have"}$.*}
    }

    txt {*Curly braces can be used to explicitly delimit
      blocks. In conjunction with $\isacommand {fix}$, universal
      quantification over the fixed variable $i$ is achieved
      for the last statement in the block, which is exported to the
      enclosing block.*}

    hence "x \<in> a \<inter> b \<Longrightarrow> \<forall>i. x \<in> trivial_series a b i"
      by fast
    also

    txt {*The statement $\isacommand {also}$ introduces calculational
      reasoning. This basically amounts to collecting facts. With
      $\isacommand {also}$, the current fact is added to a special list of
      theorems called the calculation and
      an automatically selected transitivity rule
      is additionally applied from the second collected fact on.*}

    { assume "\<And>i. x \<in> trivial_series a b i"
      hence "x \<in> trivial_series a b 0" and "x \<in> trivial_series a b 1"
        by this+
      hence "x \<in> a \<inter> b"
        by simp
    }
    hence "\<forall>i. x \<in> trivial_series a b i \<Longrightarrow> x \<in> a \<inter> b"
      by blast

    ultimately have "x \<in> a \<inter> b = (\<forall>i::nat. x \<in> trivial_series a b i)" ..

    txt {*The accumulated calculational facts including the current one
      are exposed to the next statement by  $\isacommand {ultimately}$ and
      the calculation list is then erased. The two dots after the
      statement here indicate proof by a single automatically
      selected rule.*}

    also have "\<dots> =  (x \<in> (\<Inter>i::nat. trivial_series a b i))"
      by simp
    finally show "x \<in> a \<inter> b = (x \<in> (\<Inter>i::nat. trivial_series a b i))" .

    txt {*The $\isacommand {finally}$ directive behaves like $\isacommand {ultimately}$
      with the addition of a further transitivity rule application. A
      single dot stands for proof by assumption.*}

  qed

  moreover have "(\<Inter>i::nat. trivial_series a b i) \<in> A"
  proof -
    { fix i
      from a b have "trivial_series a b i \<in> A"
        by (cases i) auto
    }
    hence "\<And>i. trivial_series a b i \<in> sigma A"
      by (simp only: sigma.basic)
    hence "(\<Inter>i::nat. trivial_series a b i) \<in> sigma A"
      by (simp only: sigma_Inter)
    with s show ?thesis
      by (simp only: sigma_sigma_algebra)
  qed

  ultimately show ?thesis by simp
qed

text {* Of course, a like theorem holds for union instead of
  intersection.  But as we will not need it in what follows, the
  theory is finished with the following easy properties instead.
  Note that the former is a kind of generalization of the last result and
  could be used to  shorten its proof. Unfortunately, this one was needed ---
  and therefore found --- only late in the development.
  *}

theorem sigma_INTER:
  assumes a:"(\<And>i::nat. i \<in> S \<Longrightarrow> a i \<in> sigma A)"
  shows "(\<Inter>i\<in>S. a i) \<in> sigma A"(*<*)
proof -
  from a have "\<And>i. (if i\<in>S then {} else UNIV) \<union> a i \<in> sigma A"
    by (simp add: sigma.intros sigma_UNIV)
  hence "(\<Inter>i. (if i\<in>S then {} else UNIV) \<union> a i) \<in> sigma A"
    by (rule sigma_Inter)
  also have "(\<Inter>i. (if i\<in>S then {} else UNIV) \<union> a i) = (\<Inter>i\<in>S. a i)"
    by force
  finally show ?thesis .
qed(*>*)

lemma assumes s: "sigma_algebra a" shows sigma_algebra_UNIV: "UNIV \<in> a"(*<*)
proof -
  from s have "{}\<in>a" by (unfold sigma_algebra_def) blast
  with s show ?thesis by (unfold sigma_algebra_def) auto
qed(*>*)

end