chapter \<open>Homework 1\<close>
theory Homework1sol
imports Main
begin

  (*
    This file is intended to be viewed within the Isabelle/jEdit IDE.
    In a standard text-editor, it is pretty unreadable!
  *)

  (*
    HOMEWORK #1

    Sample solutions and comments

  *)

section \<open>General Hints\<close>
(*
  The best way to work on this homework is to fill in the missing gaps in this file.

  All solutions are a few lines only, and do, unless indicated, not require
  to define any auxiliary functions. So if you end up with
  lengthy and complicated function definitions, you are probably just
  missing an easier solution.

  Do not hesitate to show me your problems with your solutions,
  eg, if Isabelle throws some cryptic error messages at you
    that you cannot decipher ...

*)

section \<open>Odd Natural Numbers\<close>
  (*
    Write a function to return whether a given natural number is odd:
  *)

  fun odd :: "nat \<Rightarrow> bool" where
    "odd 0 \<longleftrightarrow> False"
  | "odd (Suc n) \<longleftrightarrow> \<not>odd n"

  (*

    I accepted every solution here that produced the right result,
    a common one was
      "odd (Suc n) \<longleftrightarrow> n mod 2 = 0"

    however, note, that you don't need pattern matching at all in this case,
    and could, much simpler, write:
  *)

  fun odd' :: "nat \<Rightarrow> bool" where "odd' n \<longleftrightarrow> n mod 2 = 1"

  (* Test cases: *)
  value "odd 45"
  value "\<not>odd 42"

section \<open>Flattening of Nested Lists\<close>
  (*
    Write a function to flatten a list of lists, i.e.,
    concatenate all lists in the given list:
  *)

  fun flatten :: "'a list list \<Rightarrow> 'a list" where
    "flatten [] = []"
  | "flatten (l#ls) = l @ flatten ls"

  (*
    I ignored additions of superfluous stuff like "[]@l@flatten ls"
  *)

  (* Test cases *)
  value "flatten [[1::int,2],[],[3,4],[],[5]] = [1,2,3,4,5]"
  value "flatten [[],[],[],[1],[5]] = [1,5]"

section \<open>Full Adder\<close>
  (*
    Recall that a full adder (Wikipedia has a nice entry on that) is a circuit that
    takes three bits (two operands and a carry), and returns the
    sum and the new carry.

    We model this as two functions, one for the sum and one for the new carry.
    Complete the function definitions!
  *)

  (* Returns the sum *)
  fun full_adder_s :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool" where
    "full_adder_s False False False = False"
  | "full_adder_s False False True  = True"
  | "full_adder_s False True  False = True"
  | "full_adder_s False True  True  = False"
  | "full_adder_s True  False False = True"
  | "full_adder_s True  False True  = False"
  | "full_adder_s True  True  False = False"
  | "full_adder_s True  True  True  = True"

  (* Returns the new carry *)
  fun full_adder_c :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool" where
    "full_adder_c False False False = False"
  | "full_adder_c False False True  = False"
  | "full_adder_c False True  False = False"
  | "full_adder_c False True  True  = True"
  | "full_adder_c True  False False = False"
  | "full_adder_c True  False True  = True"
  | "full_adder_c True  True  False = True"
  | "full_adder_c True  True  True  = True"

  (*
    Good demo that you can use pattern matching for encoding
    truth-tables in a very readable way.
  *)

section \<open>Binary Numbers as Lists of Booleans\<close>
  (*
    We represent unsigned binary numbers as lists of Booleans.
    As addition goes from least to most significant bit, and
    lists are best processed from head to tail, the first element
    of the list is the least significant bit.

    For example:
      [True,False,True,True] represents the number 0b1101 = 13
      [False,False,True] represents 0b100 = 4

  *)

  (*
    Implement a function
      to_nat :: bool list \<Rightarrow> nat
    that returns the value of an unsigned binary number!
  *)
  fun to_nat :: "bool list \<Rightarrow> nat" where
    "to_nat [] = 0"
  | "to_nat (True#bs) = 1 + 2*to_nat bs"
  | "to_nat (False#bs) = 2*to_nat bs"

  (*
    The trick was to see how one can use the recursive function call.
    This turned out to be a bit more difficult.
  *)

  (* Test cases *)
  value "to_nat [True,False,True,True] = 13"
  value "to_nat [False,False,True] = 4"

section \<open>Adding Binary Numbers\<close>
  (*
    Implement a function add that adds two binary numbers.
    Hint: Start with a function addc that adds to binary numbers
        and takes an additional carry flag.

  *)

  fun addc :: "bool list \<Rightarrow> bool list \<Rightarrow> bool \<Rightarrow> bool list" where
    (* Addition completed. In case of overflow, we just add another bit to our result *)
    "addc [] [] c = (if c then [True] else [])"
    (* Special cases if the numbers have different length *)
  | "addc (a#as) [] c = full_adder_s a False c # addc as [] (full_adder_c a False c)"
  | "addc [] (b#bs) c = full_adder_s False b c # addc [] bs (full_adder_c False b c)"
    (* Standard case *)
  | "addc (a#as) (b#bs) c = full_adder_s a b c # addc as bs (full_adder_c a b c)"

  definition "add as bs = addc as bs False"

  (*
    It was not too difficult to derive the last equation.
  *)

  (* Test Cases *)
  value "add [True,True,False] [True,True,False] = [False,True,True]"
  value "add [True,False,True,False] [True,True,False,False] = [False, False, False, True]"
  value "add [True,False,True,True] [True,True,False,False] = [False, False, False, False, True]"
  value "addc [True,True,True] [True,False,True] True = [True, False, True, True]"

  (*
    By the way, if you wonder whether there is something meaningful to prove:
      You can show that your adder actually adds, wrt. your to_nat
      interpretation. Unfortunately, the proof is a bit technical,
      doing tons of case distinctions manually.
  *)

  lemma addc_correct:
    "to_nat (addc as bs c) = (to_nat as + to_nat bs + (if c then 1 else 0))"
    apply (induction as bs c rule: addc.induct)
    apply (auto split: if_splits)
    apply (case_tac a; simp)
    apply (case_tac a; simp)
    apply (case_tac a; simp)
    apply (case_tac a; simp)
    apply (case_tac b; simp)
    apply (case_tac b; simp)
    apply (case_tac b; simp)
    apply (case_tac b; simp)
    apply (case_tac a; case_tac b; simp)
    apply (case_tac a; case_tac b; simp)
    apply (case_tac a; case_tac b; simp)
    apply (case_tac a; case_tac b; simp)
    done

  lemma add_correct: "to_nat (add as bs) = to_nat as + to_nat bs"
    using addc_correct[where c=False] unfolding add_def by auto

section \<open>Bonus: Convert natural numbers to binary numbers\<close>

  fun to_bin :: "nat \<Rightarrow> bool list" where
    "to_bin 0 = []"
  | "to_bin n = (Parity.odd n # to_bin (n div 2))"

  (*
    Unfortunately, I saw only few correct solutions to this one ...
    all these did it like in the above, using either the odd function
    from the homework, or, as I did, the one from the HOL library.
    I had to refer to it by its long name "Parity.odd" as the short name "odd"
    is hidden by the definition of "odd" in this theory file.
  *)

  (**
    Again, you can prove something: converting to bin, and then to
      nat again should be identity. Note: The other way only holds if
      the binary number is normalized, i.e. has no zero at most significant
      position.
  *)
  lemma "to_nat (to_bin n) = n"
    apply (induction n rule: to_bin.induct)
    apply auto
    by (metis (full_types) Suc_eq_plus1_left even_Suc even_Suc_div_two
        even_two_times_div_two to_nat.simps(2) to_nat.simps(3))

  (* The last line of the proof was actually automatically found by some advanced
    proof search tool of Isabelle, which I will introduce later in the lecture, after
    the basics.
  *)

end


theory C2
imports "HOL-Algebra.Group"
begin

section \<open>The group C2\<close>

text \<open>
The two-element group is defined over the set of boolean values. This allows to
use the equality of boolean values as the group operation.
\<close>

definition "C2"
  where "C2 = \<lparr> carrier = UNIV, mult = (=), one = True \<rparr>"

lemma [simp]: "\<one>\<^bsub>C2\<^esub> = True"
  unfolding C2_def by simp

lemma [simp]: "carrier C2 = UNIV"
  unfolding C2_def by simp

lemma C2_is_group: "group C2"
  unfolding C2_def
  by (rule groupI, auto simp add:Units_def)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_HSortSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun toHeap :: "Nat list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 q (nil2)) = cons2 q (nil2)"
| "hpairwise (cons2 q (cons2 r qs)) =
     cons2 (hmerge q r) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 q (nil2)) = q"
| "hmerging (cons2 q (cons2 z x2)) =
     hmerging (hpairwise (cons2 q (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "Nat list => Nat list" where
  "hsort x = toList (toHeap2 x)"

theorem property0 :
  "ordered (hsort xs)"
  oops

end


theory Lists1_6
imports Main
begin

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

value "sum [1::nat,2]"

primrec flatten :: "'a list list \<Rightarrow> 'a list"
where
  "flatten [] = []"
| "flatten (x#xs) = x @ (flatten xs)"

value "flatten []"
value "flatten [[]]"
value "flatten [[],[1,2],[1,3]]"

lemma "sum [2::nat, 4, 8] = 14"
  by auto

lemma "flatten [[2::nat, 3], [4, 5], [7, 9]] = [2::nat,3,4,5,7,9]"
  by auto

lemma "length (flatten xs) = sum (map length xs)"
  apply (induct xs)
  apply simp+
done

lemma sum_append: "sum (xs @ ys) = sum xs + sum ys"
  apply (induct xs)
    apply simp
  apply (induct ys)
  apply simp+
done

lemma flatten_append: "flatten (xs @ ys) = flatten xs @ flatten ys"
  apply (induct xs)
  apply (induct ys)
  apply simp+
done

lemma "flatten (map rev (rev xs)) = rev (flatten xs)"
  apply (induct xs)
  apply (simp add:flatten_append)+
done

lemma "flatten (rev (map rev xs)) = rev (flatten xs)"
  apply (induct xs)
  apply (simp add:flatten_append)+
done

lemma "list_all (list_all P) xs = list_all P (flatten xs)"
  apply (induct xs)
  apply simp+
done

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

lemma "sum (rev xs) = sum xs"
  apply (induct xs)
  apply (simp add:sum_append)+
done

lemma "list_all (\<lambda>x. x\<ge>1) xs \<longrightarrow> length xs \<le> sum xs"
  apply (induct xs)
  apply auto
done

primrec list_exists:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "list_exists P [] = False"
| "list_exists P (x#xs) = (P x \<or> list_exists P xs)"

value "list_exists (\<lambda>x. x=3) []"
value "list_exists (\<lambda>x. x=3) [3]"
value "list_exists (\<lambda>x. x=3) [1::int,3]"

lemma "list_exists (\<lambda>n. n < 3) [4::nat, 3, 7] = False"
  by auto

lemma "list_exists (\<lambda>n. n < 4) [4::nat, 3, 7] = True"
  by auto

lemma list_exists_append: "list_exists P (xs@ys) = (list_exists P xs \<or> list_exists P ys)"
  apply (induct ys)
    apply simp
  apply (induct xs)
  apply simp
  apply auto
done

lemma "list_exists (list_exists P) xs = list_exists P (flatten xs)"
  apply (induct xs)
  apply (simp add:list_exists_append)+
done

definition list_exists2 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "list_exists2 P xs == \<not> list_all (\<lambda>x. \<not> P x) xs"

lemma "list_exists P xs = list_exists2 P xs"
  apply (induct xs)
  apply (simp add:list_exists2_def)+
done

end


section "Weights for Dijkstra's Algorithm"
theory Weight
imports Complex_Main
begin

text \<open>
  In this theory, we set up a type class for weights, and
  a typeclass for weights with an infinity element. The latter
  one is used internally in Dijkstra's algorithm.

  Moreover, we provide a datatype that adds an infinity element to a given
  base type.
\<close>

subsection \<open>Type Classes Setup\<close>

class weight = ordered_ab_semigroup_add + comm_monoid_add + linorder
begin

lemma add_nonneg_nonneg [simp]:
  assumes "0 \<le> a" and "0 \<le> b" shows "0 \<le> a + b"
proof -
  have "0 + 0 \<le> a + b"
    using assms by (rule add_mono)
  then show ?thesis by simp
qed

lemma add_nonpos_nonpos[simp]:
  assumes "a \<le> 0" and "b \<le> 0" shows "a + b \<le> 0"
proof -
  have "a + b \<le> 0 + 0"
    using assms by (rule add_mono)
  then show ?thesis by simp
qed

lemma add_nonneg_eq_0_iff:
  assumes x: "0 \<le> x" and y: "0 \<le> y"
  shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (metis add.comm_neutral add.left_neutral add_left_mono antisym x y)

lemma add_incr: "0\<le>b \<Longrightarrow> a \<le> a+b"
  by (metis add.comm_neutral add_left_mono)

lemma add_incr_left[simp, intro!]: "0\<le>b \<Longrightarrow> a \<le> b + a"
  by (metis add_incr add.commute)

lemma sum_not_less[simp, intro!]:
  "0\<le>b \<Longrightarrow> \<not> (a+b < a)"
  "0\<le>a \<Longrightarrow> \<not> (a+b < b)"
  apply (metis add_incr less_le_not_le)
  apply (metis add_incr_left less_le_not_le)
  done

end

instance nat :: weight ..
instance int :: weight ..
instance rat :: weight ..
instance real :: weight ..

term top

class top_weight = order_top + weight +
  assumes inf_add_right[simp]: "a + top = top"
begin

lemma inf_add_left[simp]: "top + a = top"
  by (metis add.commute inf_add_right)

lemmas [simp] = top_unique less_top[symmetric]

lemma not_less_inf[simp]:
  "\<not> (a < top) \<longleftrightarrow> a=top"
  by simp

end

subsection \<open>Adding Infinity\<close>
text \<open>
  We provide a standard way to add an infinity element to any type.
\<close>

datatype 'a infty = Infty | Num 'a

primrec val where "val (Num d) = d"

lemma num_val_iff[simp]: "e\<noteq>Infty \<Longrightarrow> Num (val e) = e" by (cases e) auto

type_synonym NatB = "nat infty"

instantiation infty :: (weight) top_weight
begin
  definition "(0::'a infty) == Num 0"
  definition "top \<equiv> Infty"

  fun less_eq_infty where
    "less_eq Infty (Num _) \<longleftrightarrow> False" |
    "less_eq _ Infty \<longleftrightarrow> True" |
    "less_eq (Num a) (Num b) \<longleftrightarrow> a\<le>b"

  fun less_infty where
    "less Infty _ \<longleftrightarrow> False" |
    "less (Num _) Infty \<longleftrightarrow> True" |
    "less (Num a) (Num b) \<longleftrightarrow> a<b"

  lemma [simp]: "less a Infty \<longleftrightarrow> a \<noteq> Infty"
    by (cases a) auto

  fun plus_infty where
    "plus _ Infty = Infty" |
    "plus Infty _ = Infty" |
    "plus (Num a) (Num b) = Num (a+b)"

  lemma [simp]: "plus Infty a = Infty" by (cases a) simp_all

  instance
    apply (intro_classes)
    apply (case_tac [!] x) [4]
    apply simp_all
    apply (case_tac [!] y) [3]
    apply (simp_all add: less_le_not_le)
    apply (case_tac z)
    apply (simp_all add: top_infty_def zero_infty_def)
    apply (case_tac [!] a) [4]
    apply simp_all
    apply (case_tac [!] b) [3]
    apply (simp_all add: ac_simps)
    apply (case_tac [!] c) [2]
    apply (simp_all add: ac_simps add_right_mono)
    apply (case_tac "(x,y)" rule: less_eq_infty.cases)
    apply (simp_all add: linear)
    done
end

subsubsection \<open>Unboxing\<close>

text \<open>Conversion between the constants defined by the
  typeclass, and the concrete functions on the @{typ "'a infty"} type.
\<close>
lemma infty_inf_unbox:
  "Num a \<noteq> top"
  "top \<noteq> Num a"
  "Infty = top"
  by (auto simp add: top_infty_def)

lemma infty_ord_unbox:
  "Num a \<le> Num b \<longleftrightarrow> a \<le> b"
  "Num a < Num b \<longleftrightarrow> a < b"
  by auto

lemma infty_plus_unbox:
  "Num a + Num b = Num (a+b)"
  by (auto)

lemma infty_zero_unbox:
  "Num a = 0 \<longleftrightarrow> a = 0"
  "Num 0 = 0"
  by (auto simp: zero_infty_def)

lemmas infty_unbox =
  infty_inf_unbox infty_zero_unbox infty_ord_unbox infty_plus_unbox

lemma inf_not_zero[simp]:
  "top\<noteq>(0::_ infty)" "(0::_ infty)\<noteq>top"
  apply (unfold zero_infty_def top_infty_def)
  apply auto
  done

lemma num_val_iff'[simp]: "e\<noteq>top \<Longrightarrow> Num (val e) = e"
  by (cases e) (auto simp add: infty_unbox)

lemma infty_neE:
  "\<lbrakk>a\<noteq>Infty; \<And>d. a=Num d \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  "\<lbrakk>a\<noteq>top; \<And>d. a=Num d \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (case_tac [!] a) (auto simp add: infty_unbox)

end


(* author: wzh*)

theory Chapter2
  imports Main
begin

(* 'b option means None | Some 'b  *)
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))"

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

lemma "div2 n = n div 2"
  apply(induction n rule: div2.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 xs ys = (rev xs) @ ys"
  apply(induction xs arbitrary: ys)
   apply(auto)
  done

end


theory tape_nat_conversion
  imports Main "Turing" "../IMP-/Com" "../IMP-/Big_StepT" "../IMP-/Small_StepT" "../IMP-/Big_Step_Small_Step_Equivalence"  "../IMP-/Max_Constant"
begin

text "In this theory we prove the conversion between natural numbers and the tape as described in turing.thy .
Note that this closely mirrors the conversion between a binary (in string format or similar) and natural numbers"
type_synonym enc_tape = "nat \<times> nat \<times> nat"
abbreviation LeftShift_nat:: "nat \<Rightarrow> nat" where
" LeftShift_nat a \<equiv> a + a"

subsection "Conversion from tape to natural"
fun tape_to_nat :: "cell list \<Rightarrow> nat" where
"tape_to_nat [] = 0" |
"tape_to_nat (x#xs) = (if x = Bk then LeftShift_nat (tape_to_nat xs)
                                   else LeftShift_nat (tape_to_nat xs) + 1)"

fun encode_tape :: "config \<Rightarrow> enc_tape" where
"encode_tape (s,ls,rs) = (s, tape_to_nat ls, tape_to_nat rs)"

lemma t2n_0: "(\<forall>x\<in> set xs. x = Bk) \<longleftrightarrow>  tape_to_nat xs = 0 "
  apply(induct xs)
   apply(auto)
  done

lemma tape_to_nat_even: "even (tape_to_nat xs) \<longleftrightarrow> hd xs = Bk \<or> xs = []"
  apply (induct xs)
   apply(auto)
  done

lemma tape_to_nat_odd: " xs \<noteq> [] \<Longrightarrow> odd (tape_to_nat xs) \<longleftrightarrow> hd xs = Oc"
  apply (induct xs)
  using cell.exhaust by auto

subsection "Conversion from natural to tape"
fun nat_to_tape :: "nat \<Rightarrow> cell list" where
"nat_to_tape 0 = []" |
"nat_to_tape n = (if (n mod 2) = 1 then Oc else Bk) # nat_to_tape (n div 2)"

fun decode_tape :: "enc_tape \<Rightarrow> config" where
"decode_tape (z,n,m) = (z, nat_to_tape n, nat_to_tape m)"

lemma nat_to_tape_double[simp]: "n > 0 \<Longrightarrow> nat_to_tape (2 * n) = Bk # (nat_to_tape n)"
  apply(induct n)
   apply(auto)
  done

lemma nat_to_tape_nth_bit: "nat_to_tape (2^n) = replicate n Bk  @ [Oc]"
  apply(induct n)
   apply(auto)
  done

text "This function is used to compare tapes with each other. Two tapes are considered equal,
if they are the same ignoring any leading blank cells."
fun is_cell_list_eq :: "cell list \<Rightarrow> cell list \<Rightarrow> bool" where
"is_cell_list_eq xs ys = (dropWhile (\<lambda>x. x = Bk)(rev xs)  = dropWhile (\<lambda>y. y = Bk) (rev ys))"

lemma tape_to_nat_app_bk[simp]: "tape_to_nat (xs @ [Bk]) = tape_to_nat xs"
  apply(induct xs)
   apply(auto)
  done

lemma is_cell_list_eq_same[simp]: "is_cell_list_eq xs xs"
  apply(induct xs)
   apply(auto)
  done

lemma is_cell_list_eq_com: "is_cell_list_eq xs ys \<Longrightarrow> is_cell_list_eq ys xs"
  apply(induct xs)
   apply(auto)
  done

lemma is_cell_list_eq_cons:
  assumes "is_cell_list_eq xs ys"
  shows "is_cell_list_eq (x#xs) (x#ys)"
using assms proof -
  have "(dropWhile (\<lambda>x. x = Bk)(rev xs) = dropWhile (\<lambda>y. y = Bk) (rev ys))" using assms by auto
  then have "(if (\<forall>x\<in>set xs.  x = Bk) then dropWhile(\<lambda>x. x = Bk) [] else dropWhile (\<lambda>x. x = Bk) (rev xs) @ []) =
            (if (\<forall>x\<in>set ys.  x = Bk) then dropWhile(\<lambda>x. x = Bk) [] else dropWhile (\<lambda>x. x = Bk) (rev ys) @ [])"
    by (smt (verit, best) dropWhile_eq_Nil_conv set_rev)
  then have "(if (\<forall>x\<in>set xs.  x = Bk) then dropWhile(\<lambda>x. x = Bk) [x] else dropWhile (\<lambda>x. x = Bk) (rev xs) @ [x]) =
            (if (\<forall>x\<in>set ys.  x = Bk) then dropWhile(\<lambda>x. x = Bk) [x] else dropWhile (\<lambda>x. x = Bk) (rev ys) @ [x])"
    by (smt (verit, best) \<open>dropWhile (\<lambda>x. x = Bk) (rev xs) = dropWhile (\<lambda>y. y = Bk) (rev ys)\<close> dropWhile_eq_Nil_conv set_rev)
  then have "(dropWhile (\<lambda>x. x = Bk)((rev xs) @ [x]) = dropWhile (\<lambda>y. y = Bk) ((rev ys) @ [x]))" by (simp add: dropWhile_append)
  then show ?thesis by simp
qed

lemma tape_to_nat_inverse: "tape_to_nat(nat_to_tape n) = n"
proof(induct n rule: nat_to_tape.induct)
  case 1
  then show ?case by simp
next
  case (2 v)
  then show ?case
    proof (cases v rule: parity_cases)
    case even
    then have "tape_to_nat (nat_to_tape (Suc v)) = tape_to_nat (Oc # nat_to_tape (Suc v div 2))" by auto
    also have "... = 2 * tape_to_nat(nat_to_tape (Suc v div 2)) + 1" by simp
    also have "... = 2 * (Suc v div 2) + 1" using "2" by simp
    then show ?thesis by (metis calculation even(1) even_Suc odd_two_times_div_two_succ)
  next
    case odd
    then have "tape_to_nat (nat_to_tape (Suc v)) = tape_to_nat (Bk # nat_to_tape (Suc v div 2))" by simp
    also have "... = 2 * tape_to_nat (nat_to_tape (Suc v div 2))" by simp
    also have "... = 2 * Suc v div 2" by (metis "2" div_mult_swap even_Suc odd(1))
    finally show ?thesis by auto
        qed
qed

lemma nat_to_tape_inverse: "is_cell_list_eq (nat_to_tape(tape_to_nat xs)) xs"
proof (induction xs rule: tape_to_nat.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs)
  then show ?case proof (cases x)
    case Bk
    then have "is_cell_list_eq (nat_to_tape(tape_to_nat xs)) xs" using 2 by simp
    then have Bk_cons: "is_cell_list_eq (Bk # nat_to_tape(tape_to_nat xs)) (Bk#xs)" using is_cell_list_eq_cons by fast
    consider "(\<forall>x\<in>set xs. x = Bk)" | "Oc \<in> set xs" using cell.exhaust by auto
    then have "is_cell_list_eq (nat_to_tape(2 * tape_to_nat xs)) (Bk#xs)" proof (cases)
      case 1
       then show ?thesis using t2n_0 Bk_cons by simp
    next
      case 2
      then show ?thesis using Bk_cons using t2n_0 by fastforce
    qed (* case distinction on xs all blank vs some Oc *)
    then show ?thesis by (simp add: Bk mult_2)
  next
    case Oc
    then have "is_cell_list_eq (nat_to_tape(tape_to_nat xs)) xs" using 2 by simp
    then have "is_cell_list_eq (Oc # nat_to_tape(tape_to_nat xs)) (Oc#xs)" using is_cell_list_eq_cons by fast
    then have "is_cell_list_eq (nat_to_tape(2 * tape_to_nat xs + 1)) (Oc#xs)" by simp
    then show ?thesis by (simp add: Oc mult_2)
  qed
qed

lemma encode_decode_inverse: "(z,x,y) = encode_tape(decode_tape(z,x,y))"
  by (simp add: tape_to_nat_inverse)
lemma decode_encode_inverse:
  assumes encoded_decoded: "(z1,x1,y1) = decode_tape(encode_tape(z,x,y))"
  shows "z=z1 \<and> is_cell_list_eq x x1 \<and> is_cell_list_eq y y1"
  using encoded_decoded nat_to_tape_inverse by auto

end


theory Trees2_2
imports Main
begin

(* copied from question *)
primrec sum :: "nat list \<Rightarrow> nat"
where
  "sum [] = 0"
| "sum (x # xs) = x + sum xs"

theorem sum_foldr: "sum xs = foldr (op +) xs 0"
  apply (induct xs)
  apply simp
  apply simp
done

theorem length_foldr: "length xs = foldr (\<lambda> x res. 1 + res) xs 0"
  apply (induct xs)
  apply simp
  apply simp
done

theorem "sum (map (\<lambda> x. x + 3) xs) = foldr (\<lambda> x res. res + x + 3) xs 0"
  apply (induct xs)
  apply simp
  apply simp
done

theorem "foldr g (map f xs) a = foldr (\<lambda> x res. (g (f x) res)) xs a"
  apply (induct xs)
  apply simp
  apply simp
done

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

value "rev_acc [] []"
value "rev_acc [1,2] []"
value "rev_acc [] [1,2]"
value "rev_acc [1,2] [3,4]"

theorem rev_acc_foldl: "rev_acc xs a = foldl (\<lambda> ys x. x # ys) a xs"
  apply (induct xs arbitrary:a)
  apply simp
  apply simp
done

theorem sum_append[simp]: "sum (xs @ ys) = sum xs + sum ys"
  apply (induct xs)
  apply simp
  apply simp
done

(* Unclear how the problem was solved in text *)
theorem foldr_append: "foldr f (xs @ ys) a = f (foldr f xs a) (foldr f ys a)"
  quickcheck
oops

(*
primrec prod :: "nat list \<Rightarrow> nat"
where
  "prod [] = 1"
| "prod (x#xs) = x * prod xs"
*)

definition prod: "prod xs \<equiv> foldr (op *) xs (1::nat)"

value "prod []"
value "prod [2]"
value "prod [1,2,3]"

(* FIXME: unable to prove this lemma *)
theorem "prod (xs @ ys) = prod xs * prod ys"
oops

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

value "Tip"
value "Node Tip 2 Tip"

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

value "preorder Tip"
value "preorder (Node (Node Tip 3 Tip) 2 (Node Tip 4 Tip))"

primrec postorder :: "'a tree \<Rightarrow> 'a list"
where
  "postorder Tip = []"
| "postorder (Node l v r) = (postorder l) @ (postorder r) @ [v]"

value "postorder Tip"
value "postorder (Node (Node Tip 3 Tip) 2 (Node Tip 4 Tip))"

fun postorder_acc:: "['a tree, 'a list] \<Rightarrow> 'a list"
where
  "postorder_acc Tip acc = acc"
| "postorder_acc (Node l v r) acc = (postorder_acc l (postorder_acc r (v#acc)))"

value "postorder_acc Tip []"
value "postorder_acc (Node (Node Tip 3 Tip) 2 (Node Tip 4 Tip)) []"

theorem "postorder_acc t xs = (postorder t) @ xs"
  apply (induct t arbitrary:xs)
  apply simp+
done

fun foldl_tree :: "('b => 'a => 'b) \<Rightarrow> 'b \<Rightarrow> 'a tree \<Rightarrow> 'b"
where
  "foldl_tree f acc Tip = acc"
| "foldl_tree f acc (Node l v r) = foldl_tree f (foldl_tree f (f acc v) r) l"

theorem "\<forall> a. postorder_acc t a = foldl_tree (\<lambda> xs x. Cons x xs) a t"
  apply (induct t)
  apply simp
  apply simp
done

primrec tree_sum :: "nat tree \<Rightarrow> nat"
where
  "tree_sum Tip = 0"
| "tree_sum (Node l v r) = v + (tree_sum l) + (tree_sum r)"

theorem "tree_sum t = sum (preorder t)"
  apply (induct t)
  apply simp+
done

end


(*<*)
theory ex09_2
imports
  "~~/src/HOL/Data_Structures/Tree23_Set"
begin
(*>*)

text \<open>\Exercise{Joining 2-3-Trees}

  Write a join function for 2-3-trees: The function shall take two
  2-3-trees \<open>l\<close> and \<open>r\<close> and an element \<open>x\<close>, and return a new 2-3-tree with
  the inorder-traversal \<open>l x r\<close> .

  Write two functions, one for the height of \<open>l\<close> being greater, the
  other for the height of \<open>r\<close> being greater.
\<close>

text \<open>\<open>height r\<close> greater\<close>
fun joinL :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>i"
(*<*)
where
"joinL l x r =
  (if height l = height r then Up\<^sub>i l x r
   else case r of
     Node2 r1 a r2 \<Rightarrow>
       (case joinL l x r1 of
         T\<^sub>i t \<Rightarrow> T\<^sub>i (Node2 t a r2) |
         Up\<^sub>i t1 b t2 \<Rightarrow> T\<^sub>i (Node3 t1 b t2 a r2)) |
     Node3 r1 a r2 b r3 \<Rightarrow> (case joinL l x r1 of
         T\<^sub>i t \<Rightarrow> T\<^sub>i (Node3 t a r2 b r3) |
         Up\<^sub>i t1 y t2 \<Rightarrow> Up\<^sub>i (Node2 t1 y t2) a (Node2 r2 b r3)))"
(*>*)

lemma bal_joinL: "\<lbrakk> bal l; bal r; height l \<le> height r \<rbrakk> \<Longrightarrow>
  bal (tree\<^sub>i (joinL l x r)) \<and> height(joinL l x r) = height r"
(*<*)
apply(induction r)
  apply simp
 apply (fastforce simp: le_less split: up\<^sub>i.split)
apply (fastforce simp: le_less split: up\<^sub>i.split)
done
(*>*)

lemma inorder_joinL: "\<lbrakk> bal l; bal r; height l \<le> height r \<rbrakk> \<Longrightarrow> inorder (tree\<^sub>i (joinL l x r)) = inorder l @x # inorder r"
(*<*)
  apply(induction r)
  apply (auto split: up\<^sub>i.splits)
  done
(*>*)

text \<open>\<open>height l\<close> greater\<close>
fun joinR :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>i"
(*<*)
where
"joinR l x r =
  (if height l = height r then Up\<^sub>i l x r
   else case l of
     Node2 l1 a l2 \<Rightarrow>
       (case joinR l2 x r of
         T\<^sub>i t \<Rightarrow> T\<^sub>i (Node2 l1 a t) |
         Up\<^sub>i t1 b t2 \<Rightarrow> T\<^sub>i (Node3 l1 a t1 b t2)) |
     Node3 l1 a l2 b l3 \<Rightarrow> (case joinR l3 x r of
         T\<^sub>i t \<Rightarrow> T\<^sub>i (Node3 l1 a l2 b t) |
         Up\<^sub>i t1 y t2 \<Rightarrow> Up\<^sub>i (Node2 l1 a l2) b (Node2 t1 y t2)))"
(*>*)

lemma bal_joinR: "\<lbrakk> bal l; bal r; height l \<ge> height r \<rbrakk> \<Longrightarrow>
  bal (tree\<^sub>i (joinR l x r)) \<and> height(joinR l x r) = height l"
  text \<open>Note the generalization: We augmented the lemma with a statement about the height of the result.\<close>
(*<*)
apply(induction l)
  apply simp
 apply (auto simp: le_less split!: up\<^sub>i.splits tree23.split)[]
apply (fastforce simp: le_less split: up\<^sub>i.split)
done
(*>*)

lemma inorder_joinR: "\<lbrakk> bal l; bal r; height l \<ge> height r \<rbrakk> \<Longrightarrow> inorder (tree\<^sub>i (joinR l x r)) = inorder l @x # inorder r"
(*<*)
  apply(induction l)
  apply simp
  apply (auto split!: up\<^sub>i.splits tree23.split)
  done
(*>*)

text \<open>Combine both functions\<close>
fun join :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23"
(*<*)
where
"join l x r =
  (if height l > height r
   then tree\<^sub>i(joinR l x r)
   else if height l < height r
   then tree\<^sub>i(joinL l x r)
   else Node2 l x r)"
(*>*)

lemma "\<lbrakk> bal l; bal r \<rbrakk> \<Longrightarrow> bal (join l x r)"
(*<*)
  by(auto simp: bal_joinL bal_joinR simp del: joinL.simps joinR.simps)
(*>*)

lemma "\<lbrakk> bal l; bal r \<rbrakk> \<Longrightarrow> inorder (join l x r) = inorder l @x # inorder r"
(*<*)
  by(auto simp: inorder_joinL inorder_joinR simp del: joinL.simps joinR.simps)
(*>*)

(*<*)
end
(*>*)


chapter \<open>Colored Tiles\<close>
section \<open>Challenge\<close>
text_raw \<open>{\upshape
This problem is based on Project Euler problem \#114.

Alice and Bob are decorating their kitchen, and they want to add
a single row of fifty tiles on the edge of the kitchen counter.
Tiles can be either red or black, and for aesthetic reasons,
Alice and Bob insist that red tiles come by blocks of
at least three consecutive tiles.
Before starting, they wish to know how many ways
there are of doing this.
They come up with the following algorithm:
\begin{lstlisting}[language=C,morekeywords={procedure,function,end,to,in,var,then,not,mod}]
var count[51]   // count[i] is the number of valid rows of size i
count[0] := 1   // []
count[1] := 1   // [B] - cannot have a single red tile
count[2] := 1   // [BB] - cannot have one or two red tiles
count[3] := 2   // [BBB] or [RRR]
for n = 4 to 50 do
    count[n] := count[n-1]  // either the row starts with a black tile
    for k = 3 to n-1 do     // or it starts with a block of k red tiles
        count[n] := count[n] + count[n-k-1]  // followed by a black one
    end-for
    count[n] := count[n]+1  // or the entire row is red
end-for
\end{lstlisting}

\paragraph{Verification tasks.}
You should verify that at the end, \texttt{count[50]} will contain the right number.

\bigskip
\noindent\emph{Hint:}
Since the algorithm works by enumerating the valid colorings, we expect you to give
a nice specification of a valid coloring and to prove the following properties:
\begin{enumerate}
\item Each coloring counted by the algorithm is valid.
\item No coloring is counted twice.
\item No valid coloring is missed.
\end{enumerate}
}
\clearpage
\<close>
section \<open>Solution\<close>
theory Challenge2
imports "lib/VTcomp"
begin

  text \<open>
    The algorithm describes a dynamic programming scheme.

    Instead of proving the 3 properties stated in the challenge separately,
    we approach the problem by

    \<^enum> Giving a natural specification of a valid tiling as a grammar
    \<^enum> Deriving a recursion equation for the number of valid tilings
    \<^enum> Verifying that the program returns the correct number
      (which obviously implies all three properties stated in the challenge)
  \<close>

  subsection \<open>Problem Specification\<close>

  subsubsection \<open>Colors\<close>

  datatype color = R | B

  subsubsection \<open>Direct Natural Definition of a Valid Line\<close>

  inductive valid where
    "valid []" |
    "valid xs \<Longrightarrow> valid (B # xs)" |
    "valid xs \<Longrightarrow> n \<ge> 3 \<Longrightarrow> valid (replicate n R @ xs)"

  definition "lcount n = card {l. length l=n \<and> valid l}"

  subsection \<open>Derivation of Recursion Equations\<close>

  text \<open>This alternative variant helps us to prove the split lemma below.\<close>
  inductive valid' where
    "valid' []" |
    "n \<ge> 3 \<Longrightarrow> valid' (replicate n R)" |
    "valid' xs \<Longrightarrow> valid' (B # xs)" |
    "valid' xs \<Longrightarrow> n \<ge> 3 \<Longrightarrow> valid' (replicate n R @ B # xs)"

  lemma valid_valid':
    "valid l \<Longrightarrow> valid' l"
    by (induction rule: valid.induct)
       (auto 4 4 intro: valid'.intros elim: valid'.cases
          simp: replicate_add[symmetric] append_assoc[symmetric]
       )

  lemmas valid_red = valid.intros(3)[OF valid.intros(1), simplified]

  lemma valid'_valid:
    "valid' l \<Longrightarrow> valid l"
    by (induction rule: valid'.induct) (auto intro: valid.intros valid_red)

  lemma valid_eq_valid':
    "valid' l = valid l"
    using valid_valid' valid'_valid by metis

  subsubsection \<open>Additional Facts on Replicate\<close>

  lemma replicate_iff:
    "(\<forall>i<length l. l ! i = R) \<longleftrightarrow> (\<exists> n. l = replicate n R)"
    by auto (metis (full_types) in_set_conv_nth replicate_eqI)

  lemma replicate_iff2:
    "(\<forall>i<n. l ! i = R) \<longleftrightarrow> (\<exists> l'. l = replicate n R @ l')" if "n < length l"
    using that by (auto simp: list_eq_iff_nth_eq nth_append intro: exI[where x = "drop n l"])

  lemma replicate_Cons_eq:
    "replicate n x = y # ys \<longleftrightarrow> (\<exists> n'. n = Suc n' \<and> x = y \<and> replicate n' x = ys)"
    by (cases n) auto

  subsubsection \<open>Main Case Analysis on \<open>@term valid\<close>\<close>

  lemma valid_split:
    "valid l \<longleftrightarrow>
    l = [] \<or>
    (l!0 = B \<and> valid (tl l)) \<or>
    length l \<ge> 3 \<and> (\<forall> i < length l. l ! i = R) \<or>
    (\<exists> j < length l. j \<ge> 3 \<and> (\<forall> i < j. l ! i = R) \<and> l ! j = B \<and> valid (drop (j + 1) l))"
    unfolding valid_eq_valid'[symmetric]
    apply standard
    subgoal
      by (erule valid'.cases) (auto simp: nth_append nth_Cons split: nat.splits)
    subgoal
      by (auto intro: valid'.intros simp: replicate_iff elim!: disjE1)
         (fastforce intro: valid'.intros simp: neq_Nil_conv replicate_iff2 nth_append)+
    done

  subsubsection \<open>Base cases\<close>

  lemma lc0_aux:
    "{l. l = [] \<and> valid l} = {[]}"
    by (auto intro: valid.intros)

  lemma lc0: "lcount 0 = 1"
    by (auto simp: lc0_aux lcount_def)

  lemma lc1aux: "{l. length l=1 \<and> valid l} = {[B]}"
    by (auto intro: valid.intros elim: valid.cases simp: replicate_Cons_eq)

  lemma lc2aux: "{l. length l=2 \<and> valid l} = {[B,B]}"
    by (auto 4 3 intro: valid.intros elim: valid.cases simp: replicate_Cons_eq)

  lemma lc3_aux: "{l. length l=3 \<and> valid l} = {[B,B,B], [R,R,R]}"
    by (auto 4 4 intro: valid.intros valid_red[of 3, simplified] elim: valid.cases
        simp: replicate_Cons_eq)

  lemma lcounts_init: "lcount 0 = 1" "lcount 1 = 1" "lcount 2 = 1" "lcount 3 = 2"
    using lc0 lc1aux lc2aux lc3_aux unfolding lcount_def by simp_all

  subsubsection \<open>The Recursion Case\<close>

  lemma finite_valid_length:
    "finite {l. length l = n \<and> valid l}" (is "finite ?S")
  proof -
    have "?S \<subseteq> lists {R, B} \<inter> {l. length l = n}"
      by (auto intro: color.exhaust)
    moreover have "finite \<dots>"
      by (auto intro: lists_of_len_fin1)
    ultimately show ?thesis
      by (rule finite_subset)
  qed

  lemma valid_line_just_B:
    "valid (replicate n B)"
    by (induction n) (auto intro: valid.intros)

  lemma valid_line_aux:
    "{l. length l = n \<and> valid l} \<noteq> {}" (is "?S \<noteq> {}")
    using valid_line_just_B[of n] by force

  lemma replicate_unequal_aux:
    "replicate x R @ B # l \<noteq> replicate y R @ B # l'" (is "?l \<noteq> ?r") if \<open>x < y\<close> for l l'
  proof -
    have "?l ! x = B" "?r ! x = R"
      using that by (auto simp: nth_append)
    then show ?thesis
      by auto
  qed

  lemma valid_prepend_B_iff:
    "valid (B # xs) \<longleftrightarrow> valid xs"
    by (auto intro: valid.intros elim: valid.cases simp: Cons_replicate_eq Cons_eq_append_conv)

  lemma lcrec: "lcount n = lcount (n-1) + 1 + (\<Sum>i=3..<n. lcount (n-i-1))" if \<open>n>3\<close>
  proof -
    have "{l. length l = n \<and> valid l}
          = {l. length l = n \<and> valid (tl l) \<and> l!0=B}
          \<union> {l. length l = n \<and>
              (\<exists> i. i < n \<and> i \<ge> 3 \<and> (\<forall> k < i. l!k = R) \<and> l!i = B \<and> valid (drop (i + 1) l))}
          \<union> {l. length l = n \<and> (\<forall>i<n. l!i=R)}
          " (is "?A = ?B \<union> ?D \<union> ?C")
      using \<open>n > 3\<close> by (subst valid_split) auto

    let ?B1 = "((#) B) ` {l. length l = n - Suc 0 \<and> valid l}"
    from \<open>n > 3\<close> have "?B = ?B1"
      apply safe
      subgoal for l
        by (cases l) (auto simp: valid_prepend_B_iff)
      by auto
    have 1: "card ?B1 = lcount (n-1)"
      unfolding lcount_def by (auto intro: card_image)

    have "?C = {replicate n R}"
      by (auto simp: nth_equalityI)
    have 2: "card {replicate n R} = 1"
      by auto

    let ?D1="(\<Union> i \<in> {3..<n}. (\<lambda> l. replicate i R @ B # l)` {l. length l = n - i - 1 \<and> valid l})"
    have "?D =
        (\<Union>i \<in> {3..<n}. {l. length l = n \<and> (\<forall> k < i. l!k = R) \<and> l!i = B \<and> valid (drop (i + 1) l)})"
      by auto
    have "{l. length l = n \<and> (\<forall> k < i. l!k = R) \<and> l!i = B \<and> valid (drop (i + 1) l)}
              = (\<lambda> l. replicate i R @ B # l)` {l. length l = n - i - 1 \<and> valid l}"
      if "i < n" "2 < i" for i
      apply safe
      subgoal for l
        apply (rule image_eqI[where x = "drop (i + 1) l"])
         apply (rule nth_equalityI)
        using that
          apply (simp_all split: nat.split add: nth_Cons nth_append)
        using add_diff_inverse_nat apply fastforce
        done
      using that by (simp add: nth_append; fail)+

    then have D_eq: "?D = ?D1"
      unfolding \<open>?D = _\<close> by auto

    have inj: "inj_on (\<lambda>l. replicate x R @ B # l) {l. length l = n - Suc x \<and> valid l}" for x
      unfolding inj_on_def by auto

    have *:
      "(\<lambda>l. replicate x R @ B # l) ` {l. length l = n - Suc x \<and> valid l} \<inter>
         (\<lambda>l. replicate y R @ B # l) ` {l. length l = n - Suc y \<and> valid l} = {}"
      if "3 \<le> x" "x < y" "y < n" for x y
      using that replicate_unequal_aux[OF \<open>x < y\<close>] by auto

    have 3: "card ?D1 = (\<Sum>i=3..<n. lcount (n-i-1))"
    proof (subst card_Union_disjoint, goal_cases)
      case 1
      show ?case
        unfolding pairwise_def disjnt_def
      proof (clarsimp, goal_cases)
        case prems: (1 x y)
        from prems show ?case
          apply -
          apply (rule linorder_cases[of x y])
            apply (rule *; assumption)
           apply (simp; fail)
          apply (subst Int_commute; rule *; assumption)
          done
      qed
    next
      case 3
      show ?case
      proof (subst sum.reindex, unfold inj_on_def, clarsimp, goal_cases)
        case prems: (1 x y)
        with *[of y x] *[of x y] valid_line_aux[of "n - Suc x"] show ?case
          by - (rule linorder_cases[of x y], auto)
      next
        case 2
        then show ?case
          by (simp add: lcount_def card_image[OF inj])
      qed
    qed (auto intro: finite_subset[OF _ finite_valid_length])

    show ?thesis
      apply (subst lcount_def)
      unfolding \<open>?A = _\<close> \<open>?B = _\<close> \<open>?C = _\<close> D_eq
      apply (subst card_Un_disjoint)
        (* Finiteness *)
         apply (blast intro: finite_subset[OF _ finite_valid_length])+
        (* Disjointness *)
      subgoal
        using Cons_replicate_eq[of B _ n R] replicate_unequal_aux by fastforce
      apply (subst card_Un_disjoint)
        (* Finiteness *)
         apply (blast intro: finite_subset[OF _ finite_valid_length])+
        (* Disjointness & final rewriting *)
      unfolding 1 2 3
      by (auto simp: Cons_replicate_eq Cons_eq_append_conv)
  qed

subsection \<open>Verification of Program\<close>
  subsubsection \<open>Inner Loop: Summation\<close>
  definition "sum_prog \<Phi> l u f \<equiv>
    nfoldli [l..<u] (\<lambda>_. True) (\<lambda>i s. doN {
      ASSERT (\<Phi> i);
      RETURN (s+f i)
    }) 0"

  lemma sum_spec[THEN SPEC_trans, refine_vcg]:
    assumes "l\<le>u"
    assumes "\<And>i. l\<le>i \<Longrightarrow> i<u \<Longrightarrow> \<Phi> i"
    shows "sum_prog \<Phi> l u f \<le> SPEC (\<lambda>r. r=(\<Sum>i=l..<u. f i))"
    unfolding sum_prog_def
    supply nfoldli_upt_rule[where I="\<lambda>j s. s=(\<Sum>i=l..<j. f i)", refine_vcg]
    apply refine_vcg
    using assms
    apply auto
    done

  subsubsection \<open>Main Program\<close>
  definition "icount M \<equiv> doN {
    ASSERT (M>2);
    let c = op_array_replicate (M+1) 0;
    let c = c[0:=1, 1:=1, 2:=1, 3:=2];

    ASSERT (\<forall>i<4. c!i = lcount i);

    c\<leftarrow>nfoldli [4..<M+1] (\<lambda>_. True) (\<lambda>n c. doN {
      \<^cancel>\<open>\<open>let sum =    (\<Sum>i=3..<n. c!(n-i-1));\<close>\<close>
      sum \<leftarrow> sum_prog (\<lambda>i. n-i-1 < length c) 3 n (\<lambda>i. c!(n-i-1));
      ASSERT (n-1<length c \<and> n<length c);
      RETURN (c[n := c!(n-1) + 1 + sum])
    }) c;

    ASSERT (\<forall>i\<le>M. c!i = lcount i);

    ASSERT (M < length c);
    RETURN (c!M)
  }"

  subsubsection \<open>Abstract Correctness Statement\<close>
  theorem icount_correct: "M>2 \<Longrightarrow> icount M \<le> SPEC (\<lambda>r. r=lcount M)"
    unfolding icount_def
    thm nfoldli_upt_rule
    supply nfoldli_upt_rule[where
      I="\<lambda>n c. length c = M+1 \<and> ( \<forall>i<n. c!i = lcount i)", refine_vcg]
    apply refine_vcg
    apply (auto simp:)
    subgoal for i
      apply (subgoal_tac "i\<in>{0,1,2,3}") using lcounts_init
      by (auto)

    subgoal for i c j
      apply (cases "j<i")
      apply auto
      apply (subgoal_tac "i=j")
      apply auto
      apply (subst lcrec[where n=j])
      apply auto
      done
    done

  subsection \<open>Refinement to Imperative Code\<close>
  sepref_definition icount_impl is "icount" :: "nat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
    unfolding icount_def sum_prog_def
    by sepref

  subsubsection \<open>Main Correctness Statement\<close>
  text \<open>
  As the main theorem, we prove the following Hoare triple, stating:
  starting from the empty heap, our program will compute the correct result (@{term "lcount M"}).
  \<close>
  theorem icount_impl_correct:
    "M>2 \<Longrightarrow> <emp> icount_impl M <\<lambda>r. \<up>(r = lcount M)>\<^sub>t"
  proof -
    note A = icount_impl.refine[to_hnr, THEN hn_refineD]
    note A = A[unfolded autoref_tag_defs]
    note A = A[unfolded hn_ctxt_def pure_def, of M M, simplified]
    note [sep_heap_rules] = A

    assume "M>2"

    show ?thesis
      using icount_correct[OF \<open>M>2\<close>]
      by (sep_auto simp: refine_pw_simps pw_le_iff)
  qed

  subsubsection \<open>Code Export\<close>
  export_code icount_impl in SML_imp module_name Tiling
  export_code icount_impl in OCaml_imp module_name Tiling
  export_code icount_impl in Haskell module_name Tiling
  export_code icount_impl in Scala_imp module_name Tiling

subsection \<open>Alternative Problem Specification\<close>
  text \<open>Alternative definition of a valid line that we used in the competition\<close>

context fixes l :: "color list" begin

  inductive valid_point where
    "\<lbrakk>i+2<length l; l!i=R; l!(i+1) = R; l!(i+2) = R \<rbrakk> \<Longrightarrow> valid_point i"
  | "\<lbrakk>1\<le>i;i+1<length l; l!(i-1)=R; l!(i) = R; l!(i+1) = R \<rbrakk> \<Longrightarrow> valid_point i"
  | "\<lbrakk>2\<le>i; i<length l; l!(i-2)=R; l!(i-1) = R; l!(i) = R \<rbrakk> \<Longrightarrow> valid_point i"
  | "\<lbrakk> i<length l; l!i=B\<rbrakk> \<Longrightarrow> valid_point i"

  definition "valid_line = (\<forall>i<length l. valid_point i)"
end

lemma valid_lineI:
  assumes "\<And> i. i < length l \<Longrightarrow> valid_point l i"
  shows "valid_line l"
  using assms unfolding valid_line_def by auto

lemma valid_B_first:
  "valid_point xs i \<Longrightarrow> i < length xs \<Longrightarrow> valid_point (B # xs) (i + 1)"
  by (auto intro: valid_point.intros simp: numeral_2_eq_2 elim!: valid_point.cases)

lemma valid_line_prepend_B:
  "valid_line (B # xs)" if "valid_line xs"
  using that
  apply -
  apply (rule valid_lineI)
  subgoal for i
    by (cases i) (auto intro: valid_B_first[simplified] valid_point.intros simp: valid_line_def)
  done

lemma valid_drop_B:
  "valid_point xs (i - 1)" if "valid_point (B # xs) i" "i > 0"
  using that
  apply cases
     apply (fastforce intro: valid_point.intros)
  subgoal
    by (cases "i = 1") (auto intro: valid_point.intros(2))
  subgoal
    unfolding numeral_nat by (cases "i = 2") (auto intro: valid_point.intros(3))
  apply (fastforce intro: valid_point.intros)
  done

lemma valid_line_drop_B:
  "valid_line xs" if "valid_line (B # xs)"
  using that unfolding valid_line_def
proof (safe, goal_cases)
  case (1 i)
  with valid_drop_B[of xs "i + 1"] show ?case
    by auto
qed

lemma valid_line_prepend_B_iff:
  "valid_line (B # xs) \<longleftrightarrow> valid_line xs"
  using valid_line_prepend_B valid_line_drop_B by metis

lemma cases_valid_line:
  assumes
    "l = [] \<or>
    (l!0 = B \<and> valid_line (tl l)) \<or>
    length l \<ge> 3 \<and> (\<forall> i < length l. l ! i = R) \<or>
    (\<exists> j < length l. j \<ge> 3 \<and> (\<forall> i < j. l ! i = R) \<and> l ! j = B \<and> valid_line (drop (j + 1) l))"
    (is "?a \<or> ?b \<or> ?c \<or> ?d")
  shows "valid_line l"
proof -
  from assms consider (empty) ?a | (B) "\<not> ?a \<and> ?b" | (all_red) ?c | (R_B) ?d
    by blast
  then show ?thesis
  proof cases
    case empty
    then show ?thesis
      by (simp add: valid_line_def)
  next
    case B
    then show ?thesis
      by (cases l) (auto simp: valid_line_prepend_B_iff)
  next
    case prems: all_red
    show ?thesis
    proof (rule valid_lineI)
      fix i assume "i < length l"
      consider "i = 0" | "i = 1" | "i > 1"
        by atomize_elim auto
      then show "valid_point l i"
        using \<open>i < _\<close> prems by cases (auto 4 4 intro: valid_point.intros)
    qed
  next
    case R_B
    then obtain j where j:
      "j<length l" "3 \<le> j" "(\<forall>i<j. l ! i = R)" "l ! j = B" "valid_line (drop (j + 1) l)"
      by blast
    show ?thesis
    proof (rule valid_lineI)
      fix i assume "i < length l"
      with \<open>j \<ge> 3\<close> consider "i \<le> j - 3" | "i = j - 2" | "i = j - 1" | "i = j" | "i > j"
        by atomize_elim auto
      then show "valid_point l i"
      proof cases
        case 5
        with \<open>valid_line _\<close> \<open>i < length l\<close> have "valid_point (drop (j + 1) l) (i - j - 1)"
          unfolding valid_line_def by auto
        then show ?thesis
          using \<open>i > j\<close> by cases (auto intro: valid_point.intros)
      qed (use j in \<open>auto intro: valid_point.intros\<close>)
    qed
  qed
qed

lemma valid_line_cases:
  "l = [] \<or>
  (l!0 = B \<and> valid_line (tl l)) \<or>
  length l \<ge> 3 \<and> (\<forall> i < length l. l ! i = R) \<or>
  (\<exists> j < length l. j \<ge> 3 \<and> (\<forall> i < j. l ! i = R) \<and> l ! j = B \<and> valid_line (drop (j + 1) l))"
  if "valid_line l"
proof (cases "l = []")
  case True
  then show ?thesis
    by (simp add: valid_line_def)
next
  case False
  show ?thesis
  proof (cases "l!0 = B")
    case True
    with \<open>l \<noteq> []\<close> have "l = B # tl l"
      by (cases l) auto
    with \<open>valid_line l\<close> True show ?thesis
      by (metis valid_line_prepend_B_iff)
  next
    case False
    from \<open>valid_line l\<close> \<open>l \<noteq> []\<close> have "valid_point l 0"
      unfolding valid_line_def by auto
    with False have red_start: "length l \<ge> 3" "l!0 = R" "l!1 = R" "l!2 = R"
      by (auto elim!: valid_point.cases simp: numeral_2_eq_2)
    show ?thesis
    proof (cases "\<forall>i < length l. l ! i = R")
      case True
      with \<open>length l \<ge> 3\<close> show ?thesis
        by auto
    next
      case False
      let ?S = "{j. j < length l \<and> j \<ge> 3 \<and> l ! j = B}" let ?j = "Min ?S"
      have B_ge_3: "i \<ge> 3" if "l ! i = B" for i
      proof -
        consider "i = 0" | "i = 1" | "i = 2" | "i \<ge> 3"
          by atomize_elim auto
        then show "i \<ge> 3"
          using red_start \<open>l ! i = B\<close> by cases auto
      qed
      from False obtain i where "l ! i = B" "i < length l" "i \<ge> 3"
        by (auto intro: B_ge_3 color.exhaust)
      then have "?j \<in> ?S"
        by - (rule Min_in, auto)
      have "\<forall>i < ?j. l ! i = R"
      proof -
        {
          fix i assume "i < ?j" "l ! i = B"
          then have "i \<ge> 3"
            by (auto intro: B_ge_3)
          with \<open>i < ?j\<close> \<open>l ! i = B\<close> red_start \<open>?j \<in> ?S\<close> have "i \<in> ?S"
            by auto
          then have "?j \<le> i"
            by (auto intro: Min_le)
          with \<open>i < ?j\<close> have False
            by simp
        }
        then show ?thesis
          by (auto intro: color.exhaust)
      qed
      with \<open>?j \<in> ?S\<close> obtain j where j: "j < length l" "j \<ge> 3" "\<forall>i < j. l ! i = R" "l ! j = B"
        by blast
      moreover have "valid_line (drop (j + 1) l)"
      proof (rule valid_lineI)
        fix i assume "i < length (drop (j + 1) l)"
        with j \<open>valid_line l\<close> have "valid_point l (j + i + 1)"
          unfolding valid_line_def by auto
        then show "valid_point (drop (j + 1) l) i"
        proof cases
          case 2
          then show ?thesis
            using j by (cases i) (auto intro: valid_point.intros)
        next
          case prems: 3
          consider "i = 0" | "i = 1" | "i > 1"
            by atomize_elim auto
          then show ?thesis
            using j prems by cases (auto intro: valid_point.intros)
        qed (auto intro: valid_point.intros)
      qed
      ultimately show ?thesis
        by auto
    qed
  qed
qed

lemma valid_line_split:
  "valid_line l \<longleftrightarrow>
  l = [] \<or>
  (l!0 = B \<and> valid_line (tl l)) \<or>
  length l \<ge> 3 \<and> (\<forall> i < length l. l ! i = R) \<or>
  (\<exists> j < length l. j \<ge> 3 \<and> (\<forall> i < j. l ! i = R) \<and> l ! j = B \<and> valid_line (drop (j + 1) l))"
  using valid_line_cases cases_valid_line by blast

text \<open>Connection to the easier definition given above\<close>

end


(*  Title:      HOL/Library/Complemented_Lattices.thy
    Authors:    Jose Manuel Rodriguez Caballero, Dominique Unruh
*)

section \<open>Complemented Lattices\<close>

theory Complemented_Lattices
  imports Main
begin

text \<open>The following class \<open>complemented_lattice\<close> describes complemented lattices (with
  \<^const>\<open>uminus\<close> for the complement). The definition follows
  \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Definition_and_basic_properties\<close>.
  Additionally, it adopts the convention from \<^class>\<open>boolean_algebra\<close> of defining
  \<^const>\<open>minus\<close> in terms of the complement.\<close>

class complemented_lattice = bounded_lattice + uminus + minus
  opening lattice_syntax +
  assumes inf_compl_bot [simp]: \<open>x \<sqinter> - x = \<bottom>\<close>
    and sup_compl_top [simp]: \<open>x \<squnion> - x = \<top>\<close>
    and diff_eq: \<open>x - y = x \<sqinter> - y\<close>
begin

lemma dual_complemented_lattice:
  "class.complemented_lattice (\<lambda>x y. x \<squnion> (- y)) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
proof (rule class.complemented_lattice.intro)
  show "class.bounded_lattice (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
    by (rule dual_bounded_lattice)
  show "class.complemented_lattice_axioms (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<sqinter>) \<top> \<bottom>"
    by (unfold_locales, auto simp add: diff_eq)
qed

lemma compl_inf_bot [simp]: \<open>- x \<sqinter> x = \<bottom>\<close>
  by (simp add: inf_commute)

lemma compl_sup_top [simp]: \<open>- x \<squnion> x = \<top>\<close>
  by (simp add: sup_commute)

end

class complete_complemented_lattice = complemented_lattice + complete_lattice

text \<open>The following class \<open>complemented_lattice\<close> describes orthocomplemented lattices,
  following   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthocomplementation\<close>.\<close>
class orthocomplemented_lattice = complemented_lattice
  opening lattice_syntax +
  assumes ortho_involution [simp]: "- (- x) = x"
    and ortho_antimono: "x \<le> y \<Longrightarrow> - x \<ge> - y" begin

lemma dual_orthocomplemented_lattice:
  "class.orthocomplemented_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
proof (rule class.orthocomplemented_lattice.intro)
  show "class.complemented_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
    by (rule dual_complemented_lattice)
  show "class.orthocomplemented_lattice_axioms uminus (\<lambda>x y. y \<le> x)"
    by (unfold_locales, auto simp add: diff_eq intro: ortho_antimono)
qed

lemma compl_eq_compl_iff [simp]: \<open>- x = - y \<longleftrightarrow> x = y\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?P
  then have \<open>- (- x) = - (- y)\<close>
    by simp
  then show ?Q
    by simp
next
  assume ?Q
  then show ?P
    by simp
qed

lemma compl_bot_eq [simp]: \<open>- \<bottom> = \<top>\<close>
proof -
  have \<open>- \<bottom> = - (\<top> \<sqinter> - \<top>)\<close>
    by simp
  also have \<open>\<dots> = \<top>\<close>
    by (simp only: inf_top_left) simp
  finally show ?thesis .
qed

lemma compl_top_eq [simp]: "- \<top> = \<bottom>"
  using compl_bot_eq ortho_involution by blast

text \<open>De Morgan's law\<close> \<comment> \<open>Proof from \<^url>\<open>https://planetmath.org/orthocomplementedlattice\<close>\<close>
lemma compl_sup [simp]: "- (x \<squnion> y) = - x \<sqinter> - y"
proof -
  have "- (x \<squnion> y) \<le> - x"
    by (simp add: ortho_antimono)
  moreover have "- (x \<squnion> y) \<le> - y"
    by (simp add: ortho_antimono)
  ultimately have 1: "- (x \<squnion> y) \<le> - x \<sqinter> - y"
    by (simp add: sup.coboundedI1)
  have \<open>x \<le> - (-x \<sqinter> -y)\<close>
    by (metis inf.cobounded1 ortho_antimono ortho_involution)
  moreover have \<open>y \<le> - (-x \<sqinter> -y)\<close>
    by (metis inf.cobounded2 ortho_antimono ortho_involution)
  ultimately have \<open>x \<squnion> y \<le> - (-x \<sqinter> -y)\<close>
    by auto
  hence 2: \<open>-x \<sqinter> -y \<le> - (x \<squnion> y)\<close>
    using ortho_antimono by fastforce
  from 1 2 show ?thesis
    using dual_order.antisym by blast
qed

text \<open>De Morgan's law\<close>
lemma compl_inf [simp]: "- (x \<sqinter> y) = - x \<squnion> - y"
  using compl_sup
  by (metis ortho_involution)

lemma compl_mono:
  assumes "x \<le> y"
  shows "- y \<le> - x"
  by (simp add: assms local.ortho_antimono)

lemma compl_le_compl_iff [simp]: "- x \<le> - y \<longleftrightarrow> y \<le> x"
  by (auto dest: compl_mono)

lemma compl_le_swap2:
  assumes "- y \<le> x"
  shows "- x \<le> y"
  using assms local.ortho_antimono by fastforce

lemma compl_less_compl_iff[simp]: "- x < - y \<longleftrightarrow> y < x"
  by (auto simp add: less_le)

lemma compl_less_swap1:
  assumes "y < - x"
  shows "x < - y"
  using assms compl_less_compl_iff by fastforce

lemma compl_less_swap2:
  assumes "- y < x"
  shows "- x < y"
  using assms compl_le_swap1 compl_le_swap2 less_le_not_le by auto

lemma sup_cancel_left1: \<open>x \<squnion> a \<squnion> (- x \<squnion> b) = \<top>\<close>
  by (simp add: sup_commute sup_left_commute)

lemma sup_cancel_left2: \<open>- x \<squnion> a \<squnion> (x \<squnion> b) = \<top>\<close>
  by (simp add: sup.commute sup_left_commute)

lemma inf_cancel_left1: \<open>x \<sqinter> a \<sqinter> (- x \<sqinter> b) = \<bottom>\<close>
  by (simp add: inf.left_commute inf_commute)

lemma inf_cancel_left2: \<open>- x \<sqinter> a \<sqinter> (x \<sqinter> b) = \<bottom>\<close>
  using inf.left_commute inf_commute by auto

lemma sup_compl_top_left1 [simp]: \<open>- x \<squnion> (x \<squnion> y) = \<top>\<close>
  by (simp add: sup_assoc[symmetric])

lemma sup_compl_top_left2 [simp]: \<open>x \<squnion> (- x \<squnion> y) = \<top>\<close>
  using sup_compl_top_left1[of "- x" y] by simp

lemma inf_compl_bot_left1 [simp]: \<open>- x \<sqinter> (x \<sqinter> y) = \<bottom>\<close>
  by (simp add: inf_assoc[symmetric])

lemma inf_compl_bot_left2 [simp]: \<open>x \<sqinter> (- x \<sqinter> y) = \<bottom>\<close>
  using inf_compl_bot_left1[of "- x" y] by simp

lemma inf_compl_bot_right [simp]: \<open>x \<sqinter> (y \<sqinter> - x) = \<bottom>\<close>
  by (subst inf_left_commute) simp

end

class complete_orthocomplemented_lattice = orthocomplemented_lattice + complete_lattice
begin

subclass complete_complemented_lattice ..

end

text \<open>The following class \<open>orthomodular_lattice\<close> describes orthomodular lattices,
following   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthomodular_lattices\<close>.\<close>
class orthomodular_lattice = orthocomplemented_lattice
  opening lattice_syntax +
  assumes orthomodular: "x \<le> y \<Longrightarrow> x \<squnion> (- x) \<sqinter> y = y" begin

lemma dual_orthomodular_lattice:
  "class.orthomodular_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>)  \<top> \<bottom>"
proof (rule class.orthomodular_lattice.intro)
  show "class.orthocomplemented_lattice (\<lambda>x y. x \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
    by (rule dual_orthocomplemented_lattice)
  show "class.orthomodular_lattice_axioms uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<sqinter>)"
  proof (unfold_locales)
    show "(x::'a) \<sqinter> (- x \<squnion> y) = y"
      if "(y::'a) \<le> x"
      for x :: 'a
        and y :: 'a
      using that local.compl_eq_compl_iff local.ortho_antimono local.orthomodular by fastforce
  qed

qed

end

class complete_orthomodular_lattice = orthomodular_lattice + complete_lattice
begin

subclass complete_orthocomplemented_lattice ..

end

context boolean_algebra
  opening lattice_syntax
begin

subclass orthomodular_lattice
proof
  fix x y
  show \<open>x \<squnion> - x \<sqinter> y = y\<close>
    if \<open>x \<le> y\<close>
    using that
    by (simp add: sup.absorb_iff2 sup_inf_distrib1)
  show \<open>x - y = x \<sqinter> - y\<close>
    by (simp add: diff_eq)
qed auto

end

context complete_boolean_algebra
begin

subclass complete_orthomodular_lattice ..

end

lemma image_of_maximum:
  fixes f::"'a::order \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes "mono f"
    and "\<And>x. x:M \<Longrightarrow> x\<le>m"
    and "m:M"
  shows "(SUP x\<in>M. f x) = f m"
  by (smt (verit, ccfv_threshold) assms(1) assms(2) assms(3) cSup_eq_maximum imageE imageI monoD)

lemma cSup_eq_cSup:
  fixes A B :: \<open>'a::conditionally_complete_lattice set\<close>
  assumes bdd: \<open>bdd_above A\<close>
  assumes B: \<open>\<And>a. a\<in>A \<Longrightarrow> \<exists>b\<in>B. b \<ge> a\<close>
  assumes A: \<open>\<And>b. b\<in>B \<Longrightarrow> \<exists>a\<in>A. a \<ge> b\<close>
  shows \<open>Sup A = Sup B\<close>
proof (cases \<open>B = {}\<close>)
  case True
  with A B have \<open>A = {}\<close>
    by auto
  with True show ?thesis by simp
next
  case False
  have \<open>bdd_above B\<close>
    by (meson A bdd bdd_above_def order_trans)
  have \<open>A \<noteq> {}\<close>
    using A False by blast
  moreover have \<open>a \<le> Sup B\<close> if \<open>a \<in> A\<close> for a
  proof -
    obtain b where \<open>b \<in> B\<close> and \<open>b \<ge> a\<close>
      using B \<open>a \<in> A\<close> by auto
    then show ?thesis
      apply (rule cSup_upper2)
      using \<open>bdd_above B\<close> by simp
  qed
  moreover have \<open>Sup B \<le> c\<close> if \<open>\<And>a. a \<in> A \<Longrightarrow> a \<le> c\<close> for c
    using False apply (rule cSup_least)
    using A that by fastforce
  ultimately show ?thesis
    by (rule cSup_eq_non_empty)
qed

end


(*<*)
theory Brent
imports
  Basis
begin
(*>*)
section\<open> Brent's algorithm \label{sec:brent} \<close>

text\<open>

@{cite "Brent:1980"} improved on the Tortoise and Hare algorithm and
used it to factor large primes. In practice it makes significantly
fewer calls to the function \<open>f\<close> before detecting a loop.

We begin by defining the base-2 logarithm.

\<close>

fun lg :: "nat \<Rightarrow> nat" where
[simp del]: "lg x = (if x \<le> 1 then 0 else 1 + lg (x div 2))"

lemma lg_safe:
  "lg 0 = 0"
  "lg (Suc 0) = 0"
  "lg (Suc (Suc 0)) = 1"
  "0 < x \<Longrightarrow> lg (x + x) = 1 + lg x"
by (simp_all add: lg.simps)

lemma lg_inv:
  "0 < x \<Longrightarrow> lg (2 ^ x) = x"
proof(induct x)
  case (Suc x) then show ?case
    by (cases x, simp_all add: lg.simps Suc_lessI not_le)
qed simp

lemma lg_inv2:
  \<open>2 ^ lg x = x\<close> if \<open>2 ^ i = x\<close> for x
proof -
  have \<open>2 ^ lg (2 ^ i) = (2::nat) ^ i\<close>
    by (induction i) (simp_all add: lg_safe mult_2)
  with that show ?thesis
    by simp
qed

lemmas lg_simps = lg_safe lg_inv lg_inv2

subsection\<open> Finding \<open>lambda\<close> \<close>

text (in properties) \<open>

Imagine now that the Tortoise carries an unbounded number of carrots,
which he passes to the Hare when they meet, and the Hare has a
teleporter. The Hare eats a carrot each time she waits for the
function @{term "f"} to execute, and initially has just one. If she
runs out of carrots before meeting the Tortoise again, she teleports
him to her position, and he gives her twice as many carrots as the
last time they met (tracked by the variable \<open>carrots\<close>). By
counting how many carrots she has eaten from when she last teleported
the Tortoise (recorded in \<open>l\<close>) until she finally has surplus
carrots when she meets him again, the Hare directly discovers @{term
"lambda"}.

\<close>

record 'a state =
  m :: nat  \<comment> \<open>\<open>\<mu>\<close>\<close>
  l :: nat  \<comment> \<open>\<open>\<lambda>\<close>\<close>
  carrots :: nat
  hare :: "'a"
  tortoise :: "'a"

context properties
begin

definition (in fx0) find_lambda :: "'a state \<Rightarrow> 'a state" where
  "find_lambda \<equiv>
    (\<lambda>s. s\<lparr> carrots := 1, l := 1, tortoise := x0, hare := f x0 \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          ( ( \<^bold>if carrots \<^bold>= l \<^bold>then (\<lambda>s. s\<lparr> tortoise := hare s, carrots := 2 * carrots s, l := 0 \<rparr>)
                             \<^bold>else SKIP ) ;;
            (\<lambda>s. s\<lparr> hare := f (hare s), l := l s + 1 \<rparr>) )"

text\<open>

The termination argument goes intuitively as follows. The Hare eats as
many carrots as it takes to teleport the Tortoise into the
loop. Afterwards she continues the teleportation dance until the
Tortoise has given her enough carrots to make it all the way around
the loop and back to him.

We can calculate the Tortoise's position as a function of \<open>carrots\<close>.

\<close>

definition carrots_total :: "nat \<Rightarrow> nat" where
  "carrots_total c \<equiv> \<Sum>i<lg c. 2 ^ i"

lemma carrots_total_simps:
  "carrots_total (Suc 0) = 0"
  "carrots_total (Suc (Suc 0)) = 1"
  "2 ^ i = c \<Longrightarrow> carrots_total (c + c) = c + carrots_total c"
by (auto simp: carrots_total_def lg_simps)

definition find_lambda_measures :: "( (nat \<times> nat) \<times> (nat \<times> nat) ) set" where
  "find_lambda_measures \<equiv>
    measures [\<lambda>(l, c). mu - carrots_total c,
              \<lambda>(l, c). LEAST i. lambda \<le> c * 2^i,
              \<lambda>(l, c). c - l]"

lemma find_lambda_measures_wellfounded:
  "wf find_lambda_measures"
by (simp add: find_lambda_measures_def)

lemma find_lambda_measures_decreases1:
  assumes "c = 2 ^ i"
  assumes "mu \<le> carrots_total c \<longrightarrow> c \<le> lambda"
  assumes "seq (carrots_total c) \<noteq> seq (carrots_total c + c)"
  shows "( (c', 2 * c), (c, c) ) \<in> find_lambda_measures"
proof(cases "mu \<le> carrots_total c")
  case False with assms show ?thesis
    by (auto simp: find_lambda_measures_def carrots_total_simps mult_2 field_simps diff_less_mono2)
next
  case True
  { fix x assume x: "(0::nat) < x" have "\<exists>n. lambda \<le> x * 2 ^ n"
    proof(induct lambda)
      case (Suc i)
      then obtain n where "i \<le> x * 2 ^ n" by blast
      with x show ?case
        by (clarsimp intro!: exI[where x="Suc n"] simp: field_simps mult_2)
           (metis Nat.add_0_right Suc_leI linorder_neqE_nat mult_eq_0_iff add_left_cancel not_le numeral_2_eq_2 old.nat.distinct(2) power_not_zero trans_le_add2)
    qed simp } note ex = this
  have "(LEAST j. lambda \<le> 2 ^ (i + 1) * 2 ^ j) < (LEAST j. lambda \<le> 2 ^ i * 2 ^ j)"
  proof(rule LeastI2_wellorder_ex[OF ex, rotated], rule LeastI2_wellorder_ex[OF ex, rotated])
    fix x y
    assume "lambda \<le> 2 ^ i * 2 ^ y"
           "lambda \<le> 2 ^ (i + 1) * 2 ^ x"
           "\<forall>z. lambda \<le> 2 ^ (i + 1) * 2 ^ z \<longrightarrow> x \<le> z"
    with True assms properties_loop[where i="carrots_total c" and j=1]
    show "x < y" by (cases y, auto simp: less_Suc_eq_le)
  qed simp_all
  with True \<open>c = 2 ^ i\<close> show ?thesis
    by (clarsimp simp: find_lambda_measures_def mult_2 carrots_total_simps field_simps power_add)
qed

lemma find_lambda_measures_decreases2:
  assumes "ls < c"
  shows "( (Suc ls, c), (ls, c) ) \<in> find_lambda_measures"
using assms by (simp add: find_lambda_measures_def)

lemma find_lambda:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> find_lambda \<lbrace>l \<^bold>= \<langle>lambda\<rangle>\<rbrace>"
apply (simp add: find_lambda_def)
apply (rule hoare_pre)
apply (rule whileI[where I="\<langle>0\<rangle> \<^bold>< l \<^bold>\<and> l \<^bold>\<le> carrots \<^bold>\<and> (\<langle>mu\<rangle> \<^bold>\<le> carrots_total \<circ> carrots \<^bold>\<longrightarrow> l \<^bold>\<le> \<langle>lambda\<rangle>) \<^bold>\<and> (\<^bold>\<exists>i. carrots \<^bold>= \<langle>2^i\<rangle>)
                           \<^bold>\<and> tortoise \<^bold>= seq \<circ> carrots_total \<circ> carrots \<^bold>\<and> hare \<^bold>= seq \<circ> (l \<^bold>+ (carrots_total \<circ> carrots))"
                      and r="inv_image find_lambda_measures (l \<^bold>\<bowtie> carrots)"]
            wp_intro)+
   using properties_lambda_gt_0
   apply (clarsimp simp: field_simps mult_2_right carrots_total_simps)
   apply (intro conjI impI)
      apply (metis mult_2 power_Suc)
     apply (case_tac "mu \<le> carrots_total (l s)")
      apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1]
     apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1]
    apply (cut_tac i="carrots_total (2 ^ x)" and j=1 in properties_loop, simp)
    apply (fastforce simp: le_eq_less_or_eq field_simps)
   apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1]
   apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1]
  apply (simp add: find_lambda_measures_wellfounded)
 apply (clarsimp simp: add.commute find_lambda_measures_decreases1 find_lambda_measures_decreases2)
apply (rule wp_intro)
using properties_lambda_gt_0
apply (simp add: carrots_total_simps exI[where x=0])
done

subsection\<open> Finding \<open>mu\<close> \<close>

text\<open>

With @{term "lambda"} in hand, we can find \<open>mu\<close> using the same
approach as for the Tortoise and Hare (\S\ref{sec:th-finding-mu}),
after we first move the Hare to @{term "lambda"}.

\<close>

definition (in fx0) find_mu :: "'a state \<Rightarrow> 'a state" where
  "find_mu \<equiv>
    (\<lambda>s. s\<lparr> m := 0, tortoise := x0, hare := seq (l s) \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          (\<lambda>s. s\<lparr> tortoise := f (tortoise s), hare := f (hare s), m := m s + 1 \<rparr>)"

lemma find_mu:
  "\<lbrace>l \<^bold>= \<langle>lambda\<rangle>\<rbrace> find_mu \<lbrace>l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
apply (simp add: find_mu_def)
apply (rule hoare_pre)
apply (rule whileI[where I="l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>\<le> \<langle>mu\<rangle> \<^bold>\<and> tortoise \<^bold>= seq \<circ> m \<^bold>\<and> hare \<^bold>= seq \<circ> (m \<^bold>+ l)"
                      and r="measure (\<langle>mu\<rangle> \<^bold>- m)"]
            wp_intro)+
   using properties_lambda_gt_0 properties_loop[where i=mu and j=1]
   apply (fastforce simp: le_less dest: properties_loops_ge_mu)
  apply simp
 using properties_loop[where i=mu and j=1, simplified]
 apply (fastforce simp: le_eq_less_or_eq)
apply (rule wp_intro)
apply simp
done

subsection\<open> Top level \<close>

definition (in fx0) brent :: "'a state \<Rightarrow> 'a state" where
  "brent \<equiv> find_lambda ;; find_mu"

theorem brent:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> brent \<lbrace>l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
unfolding brent_def
by (rule find_lambda find_mu wp_intro)+

end

corollary brent_correct:
  assumes s': "s' = fx0.brent f x arbitrary"
  shows "fx0.properties f x (l s') (m s')"
using assms properties.brent[where f=f and ?x0.0=x]
by (fastforce intro: fx0.properties_existence[where f=f and ?x0.0=x]
               simp:  Basis.properties_def valid_def)

schematic_goal brent_code[code]:
  "fx0.brent f x = ?code"
unfolding fx0.brent_def fx0.find_lambda_def fx0.find_mu_def fcomp_assoc[symmetric] fcomp_comp
by (rule refl)

export_code fx0.brent in SML
(*<*)

end
(*>*)