theory Exercise3p11
imports AExp
begin

(*
This exercise is about a register machine and compiler for aexp. The machine instructions are

datatype instr = LDI int reg | LD vname reg | ADD reg reg

where type reg is a synonym for nat. Instruction LDI i r loads i into register r,
LD x r loads the value of x into register r, and ADD r1 r2 adds register r2 to register r1.

Define the execution of an instruction given a state and a register state (= function from registers to integers); the result is the new register state:

fun exec1 :: instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int

Define the execution exec of a list of instructions as for the stack machine. The compiler
takes an arithmetic expression a and a register r and produces a list of instructions whose
execution places the value of a into r. The registers > r should be used in a stack-like
fashion for intermediate results, the ones < r should be left alone. Define the compiler
and prove it correct:

exec (comp a r) s rs r = aval a s.

*)

type_synonym reg = nat

datatype instr = LDI int reg | LD vname reg | ADD reg reg

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
  "exec1 (LDI i r) s rs = rs (r := i)"  |
  "exec1 (LD x r) s  rs = rs (r := s x)" |
  "exec1 (ADD r1 r2) s rs = rs (r1 := rs r1 + rs r2)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
  "exec [] s rs = rs" |
  "exec (i#is) s rs = exec is s (exec1 i s rs)"

lemma exec_append[simp]: "exec (is1 @ is2) s rs = exec is2 s (exec is1 s rs)"
  apply (induction is1 arbitrary: rs)
   apply auto
  done

value "exec1 (ADD 0 1) <> <0 := 1, 1 := 3> 0"

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "comp (N n) r = [LDI n r]" |
  "comp (V x) r = [LD  x r]" |
  "comp (Plus a1 a2) r = comp a1 r @ comp a2 (r+1) @ [ ADD r (r+1) ]"

value "comp (Plus (N 1) (V ''x'')) 0"
value "exec (comp (Plus (N 1) (V ''x'')) 0) <''x'' := 10> <> 0"

lemma "exec (comp a r) s rs r = aval a s"
  apply (induction a arbitrary: r rs)
    apply (auto)
    done

end


(* Author: Tobias Nipkow, Daniel Stüwe *)

section \<open>Three-Way Comparison\<close>

theory Cmp
imports Main
begin

datatype cmp_val = LT | EQ | GT

definition cmp :: "'a:: linorder \<Rightarrow> 'a \<Rightarrow> cmp_val" where
"cmp x y = (if x < y then LT else if x=y then EQ else GT)"

lemma
    LT[simp]: "cmp x y = LT \<longleftrightarrow> x < y"
and EQ[simp]: "cmp x y = EQ \<longleftrightarrow> x = y"
and GT[simp]: "cmp x y = GT \<longleftrightarrow> x > y"
by (auto simp: cmp_def)

lemma case_cmp_if[simp]: "(case c of EQ \<Rightarrow> e | LT \<Rightarrow> l | GT \<Rightarrow> g) =
  (if c = LT then l else if c = GT then g else e)"
by(simp split: cmp_val.split)

end


section \<open> Space.thy \<close>

theory Space
imports Main
begin

(* Space type *)

type_synonym 'A Open = "'A set"

record 'A Space =
  opens :: "'A Open set"
  universe :: "'A set"

definition valid :: "'A Space \<Rightarrow> bool" where
  "valid T \<equiv>
    (\<forall>A. A \<in> opens T \<longrightarrow> A \<subseteq> universe T) \<and>
    ({} \<in> opens T \<and> universe T \<in> opens T \<and>
    (\<forall>A B. A \<in> opens T \<longrightarrow> B \<in> opens T \<longrightarrow> A \<inter> B \<in> opens T) \<and>
    (\<forall>U. U \<subseteq> opens T  \<longrightarrow> \<Union>U \<in> opens T))"

(* Inclusion type *)

record 'A Inclusion =
  dom :: "'A Open"
  cod :: "'A Open"

abbreviation (input) valid_inc :: "'A Inclusion \<Rightarrow> bool" where
  "valid_inc i \<equiv> dom i \<subseteq> cod i"

abbreviation inclusions :: "'A Space \<Rightarrow> 'A Inclusion set" where
  "inclusions T \<equiv> {i. valid_inc i \<and> dom i \<in> opens T \<and> cod i \<in> opens T}"

(* There are built-in constructors (Inclusion.make), but the simplifier/SH doesn't seem to like them? *)
abbreviation (input) make_inc :: "'A Open \<Rightarrow> 'A Open \<Rightarrow> 'A Inclusion" where
"make_inc B A \<equiv> \<lparr> dom = B, cod = A \<rparr>"

(* Validity *)

lemma valid_welldefined : "valid T \<Longrightarrow> (A \<in> opens T \<Longrightarrow> A \<subseteq> universe T)"
  using valid_def by blast

lemma valid_empty : "valid T \<Longrightarrow> {} \<in> opens T"
  using valid_def by blast

lemma valid_universe : "valid T \<Longrightarrow> universe T \<in> opens T"
  using valid_def by blast

lemma valid_union : "valid T \<Longrightarrow> U \<subseteq> opens T \<Longrightarrow> \<Union>U \<in> opens T"
  using valid_def by blast

lemma valid_union2 : "valid T \<Longrightarrow> A \<in> opens T \<Longrightarrow> B \<in> opens T \<Longrightarrow> A \<union> B \<in> opens T"
  using valid_union [where ?T=T and ?U="{A,B}"]
  by force

lemma valid_inter : "valid T \<Longrightarrow> A \<in> opens T \<Longrightarrow> B \<in> opens T \<Longrightarrow> A \<inter> B \<in> opens T"
  using valid_def by blast

lemma valid_inc_dom : "i \<in> inclusions T \<Longrightarrow> dom i \<in> opens T"
  by simp

lemma valid_inc_cod: "i \<in> inclusions T \<Longrightarrow> cod i \<in> opens T"
  by simp

lemma validI [intro]: "(\<And>A. A \<in> opens T \<Longrightarrow> A \<subseteq> universe T) \<Longrightarrow> {} \<in> opens T \<Longrightarrow> universe T \<in> opens T
\<Longrightarrow> (\<And>U. U \<subseteq> opens T \<Longrightarrow> \<Union>U \<in> opens T) \<Longrightarrow> (\<And>A B. A \<in> opens T \<Longrightarrow> B \<in> opens T \<Longrightarrow> A \<inter> B \<in> opens T) \<Longrightarrow> valid T"
  by (simp add: valid_def)

(* Inclusion composition *)

definition "Space_compose_inclusion_endpoint_mistmatch _ _ \<equiv> undefined"

definition compose_inc :: "'A Inclusion \<Rightarrow> 'A Inclusion \<Rightarrow> 'A Inclusion" (infixl "\<propto>" 55) where
  "compose_inc j i \<equiv>
    if dom j = cod i
    then \<lparr> dom = dom i, cod = cod j \<rparr>
    else Space_compose_inclusion_endpoint_mistmatch j i"

lemma compose_inc_valid : "valid_inc j \<Longrightarrow> valid_inc i \<Longrightarrow> dom j = cod i \<Longrightarrow> valid_inc (j \<propto> i)"
  by (metis Inclusion.select_convs(1) Inclusion.select_convs(2) compose_inc_def dual_order.trans)

lemma dom_compose_inc [simp] : "dom j = cod i \<Longrightarrow> dom (j \<propto> i) = dom i"
  by (simp add: compose_inc_def)

lemma cod_compose_inc [simp] : "dom j = cod i \<Longrightarrow> cod (j \<propto> i) = cod j"
  by (simp add: compose_inc_def)

(* Identity inclusion *)

definition ident :: "'A Open \<Rightarrow> 'A Inclusion" where
  "ident A \<equiv> make_inc A A"

lemma ident_valid : "A \<in> opens T \<Longrightarrow> valid_inc (ident A)"
  by (simp add: ident_def)

lemma valid_ident_inc : "A \<in> opens T \<Longrightarrow> ident A \<in> inclusions T"
  by (simp add: ident_def)

lemma compose_inc_ident_left [simp] : "ident (cod i) \<propto> i = i"
  by (simp add: compose_inc_def ident_def)

lemma compose_inc_ident_right [simp] : "i \<propto> ident (dom i) = i"
  by (simp add: compose_inc_def ident_def)

(* Properties *)

lemma inc_cod_sup [simp] : "i \<in> inclusions T \<Longrightarrow> dom i \<union> cod i = cod i"
  by blast

lemma inc_dom_inf [simp] : "i \<in> inclusions T \<Longrightarrow> dom i \<inter> cod i = dom i"
  by blast

(* Examples *)

definition discrete :: "'a Space" where
  "discrete = \<lparr> opens = Pow UNIV, universe = UNIV \<rparr>"

lemma valid_discrete : "valid discrete"
  by (simp add: discrete_def valid_def)

definition codiscrete :: "'a Space" where
  "codiscrete = \<lparr> opens = {{}, UNIV}, universe = UNIV \<rparr>"

lemma valid_codiscrete : "valid codiscrete"
  unfolding codiscrete_def valid_def
  apply clarsimp
  by blast

definition sierpinski :: "bool Space" where
  "sierpinski =
    \<lparr> opens = {{}, {False}, UNIV },
      universe = UNIV \<rparr>"

lemma valid_sierpinski : "valid sierpinski"
  unfolding sierpinski_def valid_def
  apply clarsimp
  by blast

end


section \<open>Standard gates\<close>

theory Gates
  imports Complex_Matrix
begin

text \<open>Pauli matrices\<close>
definition sigma_x :: "complex mat" where
  "sigma_x = mat_of_rows_list 2 [[0, 1], [1, 0]]"

definition sigma_y :: "complex mat" where
  "sigma_y = mat_of_rows_list 2 [[0, -\<i>], [\<i>, 0]]"

definition sigma_z :: "complex mat" where
  "sigma_z = mat_of_rows_list 2 [[1, 0], [0, -1]]"

text \<open>Hadamard matrices\<close>
definition hadamard :: "complex mat" where
  "hadamard = mat 2 2 (\<lambda>(i, j). if (i = 0 \<or> j = 0) then 1 / csqrt 2 else - 1 / sqrt 2)"

lemma hadamard_dim:
  "hadamard \<in> carrier_mat 2 2"
  unfolding hadamard_def mat_of_rows_list_def by auto

lemma hermitian_hadamard:
  "hermitian hadamard"
  unfolding hermitian_def hadamard_def
  apply (rule eq_matI) by (auto simp add: adjoint_eval adjoint_dim)

lemma csqrt_2_sq:
  "complex_of_real (sqrt 2) * complex_of_real (sqrt 2) = 2"
  by (smt of_real_add of_real_hom.hom_one of_real_power one_add_one power2_eq_square real_sqrt_pow2)

lemma sum_le_2:
  "\<And>(f::nat\<Rightarrow>complex). sum f {0..<2} = f 0 + f 1"
  by (simp add: numeral_2_eq_2)

lemma unitary_hadamard:
  "unitary hadamard"
  unfolding unitary_def apply (rule)
  subgoal using carrier_matD[OF hadamard_dim] hadamard_def by auto
  apply (subst hermitian_hadamard[unfolded hermitian_def])
  unfolding inverts_mat_def
  apply (rule eq_matI) unfolding hadamard_def
    apply (auto simp add: carrier_matD[OF hadamard_dim] scalar_prod_def)
  by (auto simp add: sum_le_2 csqrt_2_sq)

text \<open>The matrix
  [0 0 .. 0 1
   1 0 .. 0 0
   0 1 .. 0 0
   . . .. . .
   0 0 .. 1 0]
  implements i := i + 1 in the last variable.
\<close>
definition mat_incr :: "nat \<Rightarrow> complex mat" where
  "mat_incr n = mat n n (\<lambda>(i,j). if i = 0 then (if j = n - 1 then 1 else 0) else (if i = j + 1 then 1 else 0))"

lemma adjoint_mat_incr:
  "adjoint (mat_incr n) = mat n n (\<lambda>(i,j). if j = 0 then (if i = n - 1 then 1 else 0) else (if j = i + 1 then 1 else 0))"
  apply (rule eq_matI) unfolding mat_incr_def
  by (auto simp add: adjoint_eval)

lemma unitary_mat_incr:
  "unitary (mat_incr n)"
  unfolding unitary_def inverts_mat_def
  using carrier_matD[OF mat_incr_dim] mat_incr_mult_adjoint_mat_incr by auto

end


(* Author: Peter Gammie
   Author: Andreas Lochbihler, ETH Zurich *)

section \<open>The Stern-Brocot Tree\<close>

theory Stern_Brocot_Tree
imports
  HOL.Rat
  "HOL-Library.Sublist"
  Cotree_Algebra
  Applicative_Lifting.Stream_Algebra
begin

text\<open>
  The Stern-Brocot tree is discussed at length by \<^citet>\<open>\<open>\S4.5\<close> in "GrahamKnuthPatashnik1994CM"\<close>.
  In essence the tree enumerates the rational numbers in their lowest terms by constructing the
  \<open>mediant\<close> of two bounding fractions.
\<close>

type_synonym fraction = "nat \<times> nat"

definition mediant :: "fraction \<times> fraction \<Rightarrow> fraction"
where "mediant \<equiv> \<lambda>((a, c), (b, d)). (a + b, c + d)"

definition stern_brocot :: "fraction tree"
where
  "stern_brocot = unfold_tree
    (\<lambda>(lb, ub). mediant (lb, ub))
    (\<lambda>(lb, ub). (lb, mediant (lb, ub)))
    (\<lambda>(lb, ub). (mediant (lb, ub), ub))
    ((0, 1), (1, 0))"

text\<open>
  This process is visualised in Figure~\ref{fig:stern-brocot-iterate}.
  Intuitively each node is labelled with the mediant of it's rightmost and leftmost ancestors.

  \begin{figure}
    \centering
    \begin{tikzpicture}[auto,thick,node distance=3cm,main node/.style={circle,draw,font=\sffamily\Large\bfseries}]
      \node[main node] (0) at (0, 0) {$\frac{1}{1}$};
      \node[main node] (1) at (-4, 1) {$\frac{0}{1}$};
      \node[main node] (2) at (4, 1) {$\frac{1}{0}$};
      \node[main node] (3) at (-2, -1) {$\frac{1}{2}$};
      \node[main node] (4) at (2, -1) {$\frac{2}{1}$};
      \node[main node] (5) at (-3, -2) {$\frac{1}{3}$};
      \node[main node] (6) at (3, -2) {$\frac{3}{1}$};
      \node[main node] (7) at (-1, -2) {$\frac{2}{3}$};
      \node[main node] (8) at (1, -2) {$\frac{3}{2}$};
      \node (9) at (-3.5, -3) {};
      \node (10) at (-2.5, -3) {};
      \node (11) at (-1.5, -3) {};
      \node (12) at (-0.5, -3) {};
      \node (13) at (0.5, -3) {};
      \node (14) at (1.5, -3) {};
      \node (15) at (2.5, -3) {};
      \node (16) at (3.5, -3) {};
      \path
        (1) edge[dashed] (0)
        (2) edge[dashed] (0)
        (0) edge (3)
        (0) edge (4)
        (3) edge (5)
        (3) edge (7)
        (4) edge (6)
        (4) edge (8)
        (5) edge[dotted] (9)
        (5) edge[dotted] (10)
        (6) edge[dotted] (15)
        (6) edge[dotted] (16)
        (7) edge[dotted] (11)
        (7) edge[dotted] (12)
        (8) edge[dotted] (13)
        (8) edge[dotted] (14);
    \end{tikzpicture}
    \label{fig:stern-brocot-iterate}
    \caption{Constructing the Stern-Brocot tree iteratively.}
  \end{figure}

  Our ultimate goal is to show that the Stern-Brocot tree contains all rationals (in lowest terms),
  and that each occurs exactly once in the tree. A proof is sketched in \<^citet>\<open>\<open>\S4.5\<close> in "GrahamKnuthPatashnik1994CM"\<close>.
\<close>

subsection \<open>Specification via a recursion equation\<close>

text \<open>
  \<^cite>\<open>"Hinze2009JFP"\<close> derives the following recurrence relation for the Stern-Brocot tree.
  We will show in \S\ref{section:eq:rec:iterative} that his derivation is sound with respect to the
  standard iterative definition of the tree shown above.
\<close>

abbreviation succ :: "fraction \<Rightarrow> fraction"
where "succ \<equiv> \<lambda>(m, n). (m + n, n)"

abbreviation recip :: "fraction \<Rightarrow> fraction"
where "recip \<equiv> \<lambda>(m, n). (n, m)"

corec stern_brocot_recurse :: "fraction tree"
where
  "stern_brocot_recurse =
   Node (1, 1)
     (map_tree recip (map_tree succ (map_tree recip stern_brocot_recurse)))
     (map_tree succ stern_brocot_recurse)"

text \<open>Actually, we would like to write the specification below, but \<open>(\<diamondop>)\<close> cannot be registered as friendly due to varying type parameters\<close>
lemma stern_brocot_unfold:
  "stern_brocot_recurse =
   Node (1, 1)
        (pure recip \<diamondop> (pure succ \<diamondop> (pure recip \<diamondop> stern_brocot_recurse)))
        (pure succ \<diamondop> stern_brocot_recurse)"
by(fact stern_brocot_recurse.code[unfolded map_tree_ap_tree_pure_tree[symmetric]])

lemma stern_brocot_simps [simp]:
  "root stern_brocot_recurse = (1, 1)"
  "left stern_brocot_recurse = pure recip \<diamondop> (pure succ \<diamondop> (pure recip \<diamondop> stern_brocot_recurse))"
  "right stern_brocot_recurse = pure succ \<diamondop> stern_brocot_recurse"
by (subst stern_brocot_unfold, simp)+

lemma stern_brocot_conv:
  "stern_brocot_recurse = tree_recurse (recip \<circ> succ \<circ> recip) succ (1, 1)"
apply(rule tree_recurse.unique)
apply(subst stern_brocot_unfold)
apply(simp add: o_assoc)
apply(rule conjI; applicative_nf; simp)
done

subsection \<open>Basic properties\<close>

text \<open>
  The recursive definition is useful for showing some basic properties of the tree,
  such as that the pairs of numbers at each node are coprime, and have non-zero denominators.
  Both are simple inductions on the path.
\<close>

lemma stern_brocot_denominator_non_zero:
  "case root (traverse_tree path stern_brocot_recurse) of (m, n) \<Rightarrow> m > 0 \<and> n > 0"
by(induct path)(auto split: dir.splits)

lemma stern_brocot_coprime:
  "case root (traverse_tree path stern_brocot_recurse) of (m, n) \<Rightarrow> coprime m n"
  by (induct path) (auto split: dir.splits simp add: coprime_iff_gcd_eq_1, metis gcd.commute gcd_add1)

subsection \<open>All the rationals\<close>

text\<open>
  For every pair of positive naturals, we can construct a path into the Stern-Brocot tree such that the naturals at the end of the path define the same rational as the pair we started with.
  Intuitively, the choices made by Euclid's algorithm define this path.
\<close>

function mk_path :: "nat \<Rightarrow> nat \<Rightarrow> path" where
  "m = n \<Longrightarrow> mk_path (Suc m) (Suc n) = []"
| "m < n \<Longrightarrow> mk_path (Suc m) (Suc n) = L # mk_path (Suc m) (n - m)"
| "m > n \<Longrightarrow> mk_path (Suc m) (Suc n) = R # mk_path (m - n) (Suc n)"
| "mk_path 0 _ = undefined"
| "mk_path _ 0 = undefined"
by atomize_elim(auto, arith)
termination mk_path by lexicographic_order

lemmas mk_path_induct[case_names equal less greater] = mk_path.induct

abbreviation rat_of :: "fraction \<Rightarrow> rat"
where "rat_of \<equiv> \<lambda>(x, y). Fract (int x) (int y)"

theorem stern_brocot_rationals:
  "\<lbrakk> m > 0; n > 0 \<rbrakk> \<Longrightarrow>
  root (traverse_tree (mk_path m n) (pure rat_of \<diamondop> stern_brocot_recurse)) = Fract (int m) (int n)"
proof(induction m n rule: mk_path_induct)
  case (less m n)
  with stern_brocot_denominator_non_zero[where path="mk_path (Suc m) (n - m)"]
  show ?case
    by (simp add: eq_rat field_simps of_nat_diff split: prod.split_asm)
next
  case (greater m n)
  with stern_brocot_denominator_non_zero[where path="mk_path (m - n) (Suc n)"]
  show ?case
    by (simp add: eq_rat field_simps of_nat_diff split: prod.split_asm)
qed (simp_all add: eq_rat)

subsection \<open>No repetitions\<close>

text \<open>
  We establish that the Stern-Brocot tree does not contain repetitions, i.e.,
  that each rational number appears at most once in it.
  Note that this property is stronger than merely requiring that pairs of naturals not be repeated,
  though it is implied by that property and @{thm [source] "stern_brocot_coprime"}.

  Intuitively, the tree enjoys the \emph{binary search tree} ordering property when we map our
  pairs of naturals into rationals. This suffices to show that each rational appears at most once
  in the tree. To establish this seems to require more structure than is present in the recursion
  equations, and so we follow \<^citet>\<open>"BackhouseFerreira2008MPC"\<close> and \<^citet>\<open>"Hinze2009JFP"\<close> by
  introducing another definition of the tree, which summarises the path to each node using a matrix.

  We then derive an iterative version and use invariant reasoning on that.
  We begin by defining some matrix machinery.
  This is all elementary and primitive (we do not need much algebra).
\<close>

type_synonym matrix = "fraction \<times> fraction"
type_synonym vector = fraction

definition times_matrix :: "matrix \<Rightarrow> matrix \<Rightarrow> matrix" (infixl "\<otimes>" 70)
where "times_matrix = (\<lambda>((a, c), (b, d)) ((a', c'), (b', d')).
       ((a * a' + b * c', c * a' + d * c'),
        (a * b' + b * d', c * b' + d * d')))"

definition times_vector :: "matrix \<Rightarrow> vector \<Rightarrow> vector" (infixr "\<odot>" 70)
where "times_vector = (\<lambda>((a, c), (b, d)) (a', c'). (a * a' + b * c', c * a' + d * c'))"

context begin

private definition F :: matrix where "F = ((0, 1), (1, 0))"
private definition I :: matrix where "I = ((1, 0), (0, 1))"
private definition LL :: matrix where "LL = ((1, 1), (0, 1))"
private definition UR :: matrix where "UR = ((1, 0), (1, 1))"

definition Det :: "matrix \<Rightarrow> nat" where "Det \<equiv> \<lambda>((a, c), (b, d)). a * d - b * c"

lemma Dets [iff]:
  "Det I = 1"
  "Det LL = 1"
  "Det UR = 1"
unfolding Det_def I_def LL_def UR_def by simp_all

lemma LL_UR_Det:
  "Det m = 1 \<Longrightarrow> Det (m \<otimes> LL) = 1"
  "Det m = 1 \<Longrightarrow> Det (LL \<otimes> m) = 1"
  "Det m = 1 \<Longrightarrow> Det (m \<otimes> UR) = 1"
  "Det m = 1 \<Longrightarrow> Det (UR \<otimes> m) = 1"
by (cases m, simp add: Det_def LL_def UR_def times_matrix_def split_def field_simps)+

lemma times_matrix_I [simp]:
  "I \<otimes> x = x"
  "x \<otimes> I = x"
by (simp_all add: times_matrix_def I_def split_def)

lemma times_matrix_assoc [simp]:
  "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
by (simp add: times_matrix_def field_simps split_def)

lemma LL_UR_pos:
  "0 < snd (mediant m) \<Longrightarrow> 0 < snd (mediant (m \<otimes> LL))"
  "0 < snd (mediant m) \<Longrightarrow> 0 < snd (mediant (m \<otimes> UR))"
by (cases m) (simp_all add: LL_def UR_def times_matrix_def split_def field_simps mediant_def)

lemma recip_succ_recip: "recip \<circ> succ \<circ> recip = (\<lambda>(x, y). (x, x + y))"
by (clarsimp simp: fun_eq_iff)

text \<open>
  \citeauthor{BackhouseFerreira2008MPC} work with the identity matrix @{const "I"} at the root.
  This has the advantage that all relevant matrices have determinants of @{term "1 :: nat"}.
\<close>

definition stern_brocot_iterate_aux :: "matrix \<Rightarrow> matrix tree"
where "stern_brocot_iterate_aux \<equiv> tree_iterate (\<lambda>s. s \<otimes> LL) (\<lambda>s. s \<otimes> UR)"

definition stern_brocot_iterate :: "fraction tree"
where "stern_brocot_iterate \<equiv> map_tree mediant (stern_brocot_iterate_aux I)"

lemma stern_brocot_recurse_iterate: "stern_brocot_recurse = stern_brocot_iterate" (is "?lhs = ?rhs")
proof -
  have "?rhs = map_tree mediant (tree_recurse ((\<otimes>) LL) ((\<otimes>) UR) I)"
    using tree_recurse_iterate[where f="(\<otimes>)" and l="LL" and r="UR" and \<epsilon>="I"]
    by (simp add: stern_brocot_iterate_def stern_brocot_iterate_aux_def)
 also have "\<dots> = tree_recurse ((\<odot>) LL) ((\<odot>) UR) (1, 1)"
   unfolding mediant_I_F(2)[symmetric]
   by (rule tree_recurse_fusion)(simp_all add: fun_eq_iff mediant_def times_matrix_def times_vector_def LL_def UR_def)[2]
 also have "\<dots> = ?lhs"
   by (simp add: stern_brocot_conv recip_succ_recip times_vector_def LL_def UR_def)
 finally show ?thesis by simp
qed

text\<open>
  The following are the key ordering properties derived by \<^citet>\<open>"BackhouseFerreira2008MPC"\<close>.
  They hinge on the matrices containing only natural numbers.
\<close>

lemma tree_ordering_left:
  assumes DX: "Det X = 1"
  assumes DY: "Det Y = 1"
  assumes MX: "0 < snd (mediant X)"
  shows "rat_of (mediant (X \<otimes> LL \<otimes> Y)) < rat_of (mediant X)"
proof -
  from DX DY have F: "0 < snd (mediant (X \<otimes> LL \<otimes> Y))"
    by (auto simp: Det_def times_matrix_def LL_def split_def mediant_def)
  obtain x11 x12 x21 x22 where X: "X = ((x11, x12), (x21, x22))" by(cases X) auto
  obtain y11 y12 y21 y22 where Y: "Y = ((y11, y12), (y21, y22))" by(cases Y) auto
  from DX DY have *: "(x12 * x21) * (y12 + y22) < (x11 * x22) * (y12 + y22)"
    by(simp add: X Y Det_def)(cases y12, simp_all add: field_simps)
  from DX DY MX F show ?thesis
    apply (simp add: split_def X Y of_nat_mult [symmetric] del: of_nat_mult)
    apply (clarsimp simp: Det_def times_matrix_def LL_def UR_def mediant_def split_def)
    using * by (simp add: field_simps)
qed

lemma tree_ordering_right:
  assumes DX: "Det X = 1"
  assumes DY: "Det Y = 1"
  assumes MX: "0 < snd (mediant X)"
  shows "rat_of (mediant X) < rat_of (mediant (X \<otimes> UR \<otimes> Y))"
proof -
  from DX DY have F: "0 < snd (mediant (X \<otimes> UR \<otimes> Y))"
    by (auto simp: Det_def times_matrix_def UR_def split_def mediant_def)
  obtain x11 x12 x21 x22 where X: "X = ((x11, x12), (x21, x22))" by(cases X) auto
  obtain y11 y12 y21 y22 where Y: "Y = ((y11, y12), (y21, y22))" by(cases Y) auto
  show ?thesis using DX DY MX F
    apply (simp add: X Y split_def of_nat_mult [symmetric] del: of_nat_mult)
    apply (simp add: Det_def times_matrix_def LL_def UR_def mediant_def split_def algebra_simps)
    apply (simp add: add_mult_distrib2[symmetric] mult.assoc[symmetric])
    apply (cases y21; simp)
    done
qed

lemma stern_brocot_iterate_aux_decompose:
  "\<exists>m''. m \<otimes> m'' = root (traverse_tree path (stern_brocot_iterate_aux m)) \<and> Det m'' = 1"
proof(induction path arbitrary: m)
  case Nil show ?case
    by (auto simp add: stern_brocot_iterate_aux_def intro: exI[where x=I] simp del: split_paired_Ex)
next
  case (Cons d ds m)
  from Cons.IH[where m="m \<otimes> UR"] Cons.IH[where m="m \<otimes> LL"] show ?case
    by(simp add: stern_brocot_iterate_aux_def split: dir.splits del: split_paired_Ex)(fastforce simp: LL_UR_Det)
qed

lemma stern_brocot_fractions_not_repeated_strict_prefix:
  assumes "root (traverse_tree path stern_brocot_iterate) = root (traverse_tree path' stern_brocot_iterate)"
  assumes pp': "strict_prefix path path'"
  shows False
proof -
  from pp' obtain d ds where pp': "path' = path @ [d] @ ds" by (auto elim!: strict_prefixE')
  define m where "m = root (traverse_tree path (stern_brocot_iterate_aux I))"
  then have Dm: "Det m = 1" and Pm: "0 < snd (mediant m)"
    using stern_brocot_iterate_aux_Det[where path="path" and m="I"] by simp_all
  define m' where "m' = root (traverse_tree path' (stern_brocot_iterate_aux I))"
  then have Dm': "Det m' = 1"
    using stern_brocot_iterate_aux_Det[where path=path' and m="I"] by simp
  let ?M = "case d of L \<Rightarrow> m \<otimes> LL | R \<Rightarrow> m \<otimes> UR"
  from pp' have "root (traverse_tree ds (stern_brocot_iterate_aux ?M)) = m'"
    by(simp add: m_def m'_def stern_brocot_iterate_aux_def traverse_tree_tree_iterate split: dir.splits)
  then obtain m'' where mm'm'': "?M \<otimes> m''= m'" and Dm'': "Det m'' = 1"
    using stern_brocot_iterate_aux_decompose[where path="ds" and m="?M"] by clarsimp
  hence "case d of L \<Rightarrow> rat_of (mediant m') < rat_of (mediant m) | R \<Rightarrow> rat_of (mediant m) < rat_of (mediant m')"
    using tree_ordering_left[OF Dm Dm'' Pm] tree_ordering_right[OF Dm Dm'' Pm]
    by (simp split: dir.splits)
  with assms show False
    by (simp add: stern_brocot_iterate_def m_def m'_def split: dir.splits)
qed

lemma stern_brocot_fractions_not_repeated_parallel:
  assumes "root (traverse_tree path stern_brocot_iterate) = root (traverse_tree path' stern_brocot_iterate)"
  assumes p: "path = pref @ d # ds"
  assumes p': "path' = pref @ d' # ds'"
  assumes dd': "d \<noteq> d'"
  shows False
proof -
  define m where "m = root (traverse_tree pref (stern_brocot_iterate_aux I))"
  then have Dm: "Det m = 1" and Pm: "0 < snd (mediant m)"
    using stern_brocot_iterate_aux_Det[where path="pref" and m="I"] by simp_all
  define pm where "pm = root (traverse_tree path (stern_brocot_iterate_aux I))"
  then have Dpm: "Det pm = 1"
    using stern_brocot_iterate_aux_Det[where path=path and m="I"] by simp
  let ?M = "case d of L \<Rightarrow> m \<otimes> LL | R \<Rightarrow> m \<otimes> UR"
  from p
  have "root (traverse_tree ds (stern_brocot_iterate_aux ?M)) = pm"
    by(simp add: stern_brocot_iterate_aux_def m_def pm_def traverse_tree_tree_iterate split: dir.splits)
  then obtain pm'
    where pm': "?M \<otimes> pm'= pm" and Dpm': "Det pm' = 1"
    using stern_brocot_iterate_aux_decompose[where path="ds" and m="?M"] by clarsimp
  hence "case d of L \<Rightarrow> rat_of (mediant pm) < rat_of (mediant m) | R \<Rightarrow> rat_of (mediant m) < rat_of (mediant pm)"
    using tree_ordering_left[OF Dm Dpm' Pm, unfolded pm']
          tree_ordering_right[OF Dm Dpm' Pm, unfolded pm']
    by (simp split: dir.splits)
  moreover
  define p'm where "p'm = root (traverse_tree path' (stern_brocot_iterate_aux I))"
  then have Dp'm: "Det p'm = 1"
    using stern_brocot_iterate_aux_Det[where path=path' and m="I"] by simp
  let ?M' = "case d' of L \<Rightarrow> m \<otimes> LL | R \<Rightarrow> m \<otimes> UR"
  from p'
  have "root (traverse_tree ds' (stern_brocot_iterate_aux ?M')) = p'm"
    by(simp add: stern_brocot_iterate_aux_def m_def p'm_def traverse_tree_tree_iterate split: dir.splits)
  then obtain p'm'
    where p'm': "?M' \<otimes> p'm' = p'm" and Dp'm': "Det p'm' = 1"
    using stern_brocot_iterate_aux_decompose[where path="ds'" and m="?M'"] by clarsimp
  hence "case d' of L \<Rightarrow> rat_of (mediant p'm) < rat_of (mediant m) | R \<Rightarrow> rat_of (mediant m) < rat_of (mediant p'm)"
    using tree_ordering_left[OF Dm Dp'm' Pm, unfolded pm']
          tree_ordering_right[OF Dm Dp'm' Pm, unfolded pm']
    by (simp split: dir.splits)
  ultimately show False using pm' p'm' assms
    by(simp add: m_def pm_def p'm_def stern_brocot_iterate_def split: dir.splits)
qed

lemma lists_not_eq:
  assumes "xs \<noteq> ys"
  obtains
    (c1) "strict_prefix xs ys"
  | (c2) "strict_prefix ys xs"
  | (c3) ps x y xs' ys'
          where "xs = ps @ x # xs'" and "ys = ps @ y # ys'" and "x \<noteq> y"
using assms
by (cases xs ys rule: prefix_cases)
   (blast dest: parallel_decomp prefix_order.neq_le_trans)+

text \<open> The function @{const Fract} is injective under certain conditions. \<close>

lemma rat_inv_eq:
  assumes "Fract a b = Fract c d"
  assumes "b > 0"
  assumes "d > 0"
  assumes "coprime a b"
  assumes "coprime c d"
  shows "a = c \<and> b = d"
proof -
  from \<open>b > 0\<close> \<open>d > 0\<close> \<open>Fract a b = Fract c d\<close>
  have *: "a * d = c * b" by (simp add: eq_rat)
  from arg_cong[where f=sgn, OF this] \<open>b > 0\<close> \<open>d > 0\<close>
  have "sgn a = sgn c" by (simp add: sgn_mult)
  with * show ?thesis
    using \<open>b > 0\<close> \<open>d > 0\<close> coprime_crossproduct_int[OF \<open>coprime a b\<close> \<open>coprime c d\<close>]
    by (simp add: abs_sgn)
qed

theorem stern_brocot_rationals_not_repeated:
  assumes "root (traverse_tree path (pure rat_of \<diamondop> stern_brocot_recurse))
         = root (traverse_tree path' (pure rat_of \<diamondop> stern_brocot_recurse))"
  shows "path = path'"
using assms
using stern_brocot_coprime[where path=path]
      stern_brocot_coprime[where path=path']
      stern_brocot_denominator_non_zero[where path=path]
      stern_brocot_denominator_non_zero[where path=path']
by(auto simp: gcd_int_def dest!: rat_inv_eq intro: stern_brocot_fractions_not_repeated simp add: stern_brocot_recurse_iterate[symmetric] split: prod.splits)

subsection \<open>Equivalence of recursive and iterative version \label{section:eq:rec:iterative}\<close>

text \<open>
  \citeauthor{Hinze2009JFP} shows that it does not matter whether we use @{const I} or
  @{const "F"} at the root provided we swap the left and right matrices too.
\<close>

definition stern_brocot_Hinze_iterate :: "fraction tree"
where "stern_brocot_Hinze_iterate = map_tree mediant (tree_iterate (\<lambda>s. s \<otimes> UR) (\<lambda>s. s \<otimes> LL) F)"

lemma mediant_times_F: "mediant \<circ> (\<lambda>s. s \<otimes> F) = mediant"
by(simp add: times_matrix_def F_def mediant_def split_def o_def add.commute)

lemma stern_brocot_iterate: "stern_brocot = stern_brocot_iterate"
proof -
  have "stern_brocot = stern_brocot_Hinze_iterate"
    unfolding stern_brocot_def stern_brocot_Hinze_iterate_def
    by(subst unfold_tree_tree_iterate)(simp add: F_def times_matrix_def mediant_def UR_def LL_def split_def)
  also have "\<dots> = map_tree mediant (map_tree (\<lambda>s. s \<otimes> F) (tree_iterate (\<lambda>s. s \<otimes> LL) (\<lambda>s. s \<otimes> UR) I))"
    unfolding stern_brocot_Hinze_iterate_def
    by(subst tree_iterate_fusion[where l'="\<lambda>s. s \<otimes> UR" and r'="\<lambda>s. s \<otimes> LL"])
      (simp_all add: fun_eq_iff times_matrix_def UR_def LL_def F_def I_def)
  also have "\<dots> = stern_brocot_iterate"
    by(simp only: tree.map_comp mediant_times_F stern_brocot_iterate_def stern_brocot_iterate_aux_def)
  finally show ?thesis .
qed

theorem stern_brocot_mediant_recurse: "stern_brocot = stern_brocot_recurse"
by(simp add: stern_brocot_recurse_iterate stern_brocot_iterate)

end

no_notation times_matrix (infixl "\<otimes>" 70)
  and times_vector (infixl "\<odot>" 70)

section \<open>Linearising the Stern-Brocot Tree\<close>

subsection \<open>Turning a tree into a stream\<close>

corec tree_chop :: "'a tree \<Rightarrow> 'a tree"
where "tree_chop t = Node (root (left t)) (right t) (tree_chop (left t))"

lemma tree_chop_sel [simp]:
  "root (tree_chop t) = root (left t)"
  "left (tree_chop t) = right t"
  "right (tree_chop t) = tree_chop (left t)"
by(subst tree_chop.code; simp; fail)+

text \<open>@{const tree_chop} is a idiom homomorphism\<close>

lemma tree_chop_pure_tree [simp]:
  "tree_chop (pure x) = pure x"
by(coinduction rule: tree.coinduct_strong) auto

lemma tree_chop_ap_tree [simp]:
  "tree_chop (f \<diamondop> x) = tree_chop f \<diamondop> tree_chop x"
by(coinduction arbitrary: f x rule: tree.coinduct_strong) auto

lemma tree_chop_plus: "tree_chop (t + t') = tree_chop t + tree_chop t'"
by(simp add: plus_tree_def)

corec stream :: "'a tree \<Rightarrow> 'a stream"
where "stream t = root t ## stream (tree_chop t)"

lemma stream_sel [simp]:
  "shd (stream t) = root t"
  "stl (stream t) = stream (tree_chop t)"
by(subst stream.code; simp; fail)+

text\<open>@{const "stream"} is an idiom homomorphism.\<close>

lemma stream_pure [simp]: "stream (pure x) = pure x"
by coinduction auto

lemma stream_ap [simp]: "stream (f \<diamondop> x) = stream f \<diamondop> stream x"
by(coinduction arbitrary: f x) auto

lemma stream_plus [simp]: "stream (t + t') = stream t + stream t'"
by(simp add: plus_stream_def plus_tree_def)

lemma stream_minus [simp]: "stream (t - t') = stream t - stream t'"
by(simp add: minus_stream_def minus_tree_def)

lemma stream_times [simp]: "stream (t * t') = stream t * stream t'"
by(simp add: times_stream_def times_tree_def)

lemma stream_mod [simp]: "stream (t mod t') = stream t mod stream t'"
by(simp add: modulo_stream_def modulo_tree_def)

lemma stream_1 [simp]: "stream 1 = 1"
by(simp add: one_tree_def one_stream_def)

lemma stream_numeral [simp]: "stream (numeral n) = numeral n"
by(induct n)(simp_all only: numeral.simps stream_plus stream_1)

subsection \<open>Split the Stern-Brocot tree into numerators and denumerators\<close>

corec num_den :: "bool \<Rightarrow> nat tree"
where
  "num_den x =
   Node 1
     (if x then num_den True else num_den True + num_den False)
     (if x then num_den True + num_den False else num_den False)"

abbreviation num where "num \<equiv> num_den True"
abbreviation den where "den \<equiv> num_den False"

lemma num_unfold: "num = Node 1 num (num + den)"
by(subst num_den.code; simp)

lemma den_unfold: "den = Node 1 (num + den) den"
by(subst num_den.code; simp)

lemma num_simps [simp]:
  "root num = 1"
  "left num = num"
  "right num = num + den"
by(subst num_unfold, simp)+

lemma den_simps [simp]:
  "root den = 1"
  "left den = num + den"
  "right den = den"
by (subst den_unfold, simp)+

lemma stern_brocot_num_den:
  "pure_tree Pair \<diamondop> num \<diamondop> den = stern_brocot_recurse"
apply(rule stern_brocot_recurse.unique)
apply(subst den_unfold)
apply(subst num_unfold)
apply(simp; intro conjI)
apply(applicative_lifting; simp)+
done

lemma den_eq_chop_num: "den = tree_chop num"
by(coinduction rule: tree.coinduct_strong) simp

lemma num_conv: "num = pure fst \<diamondop> stern_brocot_recurse"
unfolding stern_brocot_num_den[symmetric]
apply(simp add: map_tree_ap_tree_pure_tree stern_brocot_num_den[symmetric])
apply(applicative_lifting; simp)
done

lemma den_conv: "den = pure snd \<diamondop> stern_brocot_recurse"
unfolding stern_brocot_num_den[symmetric]
apply(simp add: map_tree_ap_tree_pure_tree stern_brocot_num_den[symmetric])
apply(applicative_lifting; simp)
done

corec num_mod_den :: "nat tree"
where "num_mod_den = Node 0 num num_mod_den"

lemma num_mod_den_simps [simp]:
  "root num_mod_den = 0"
  "left num_mod_den = num"
  "right num_mod_den = num_mod_den"
by(subst num_mod_den.code; simp; fail)+

text\<open>
  The arithmetic transformations need the precondition that @{const den} contains only
  positive numbers, no @{term "0 :: nat"}. \<^citet>\<open>\<open>p502\<close> in "Hinze2009JFP"\<close> gets a bit sloppy here; it is
  not straightforward to adapt his lifting framework \<^cite>\<open>"Hinze2010Lifting"\<close> to conditional equations.
\<close>

lemma mod_tree_lemma1:
  fixes x :: "nat tree"
  assumes "\<forall>i\<in>set_tree y. 0 < i"
  shows "x mod (x + y) = x"
proof -
  have "rel_tree (=) (x mod (x + y)) x" by applicative_lifting(simp add: assms)
  thus ?thesis by(unfold tree.rel_eq)
qed

lemma mod_tree_lemma2:
  fixes x y :: "'a :: unique_euclidean_semiring tree"
  shows "(x + y) mod y = x mod y"
by applicative_lifting simp

lemma set_tree_pathD: "x \<in> set_tree t \<Longrightarrow> \<exists>p. x = root (traverse_tree p t)"
by(induct rule: set_tree_induct)(auto intro: exI[where x="[]"] exI[where x="L # p" for p] exI[where x="R # p" for p])

lemma den_gt_0: "0 < x" if "x \<in> set_tree den"
proof -
  from that obtain p where "x = root (traverse_tree p den)" by(blast dest: set_tree_pathD)
  with stern_brocot_denominator_non_zero[of p] show "0 < x" by(simp add: den_conv split_beta)
qed

lemma num_mod_den: "num mod den = num_mod_den"
by(rule num_mod_den.unique)(rule tree.expand, simp add: mod_tree_lemma2 mod_tree_lemma1 den_gt_0)

lemma tree_chop_den: "tree_chop den = num + den - 2 * (num mod den)"
proof -
  have le: "0 < y \<Longrightarrow> 2 * (x mod y) \<le> x + y" for x y :: nat
    by (simp add: mult_2 add_mono)

  text \<open>We switch to @{typ int} such that all cancellation laws are available.\<close>
  define den' where "den' = pure int \<diamondop> den"
  define num' where "num' = pure int \<diamondop> num"
  define num_mod_den' where "num_mod_den' = pure int \<diamondop> num_mod_den"

  have [simp]: "root num' = 1" "left num' = num'" unfolding den'_def num'_def by simp_all
  have [simp]: "right num' = num' + den'" unfolding den'_def num'_def ap_tree.sel pure_tree_simps num_simps
    by applicative_lifting simp

  have num_mod_den'_simps [simp]: "root num_mod_den' = 0" "left num_mod_den' = num'" "right num_mod_den' = num_mod_den'"
    by(simp_all add: num_mod_den'_def num'_def)
  have den'_eq_chop_num': "den' = tree_chop num'" by(simp add: den'_def num'_def den_eq_chop_num)
  have num_mod_den'2_unique: "\<And>x. x = Node 0 (2 * num') x \<Longrightarrow> x = 2 * num_mod_den'"
    by(corec_unique)(rule tree.expand; simp)
  have num'_plus_den'_minus_chop_den': "num' + den' - tree_chop den' = 2 * num_mod_den'"
    by(rule num_mod_den'2_unique)(rule tree.expand, simp add: tree_chop_plus den'_eq_chop_num')

  have "tree_chop den = pure nat \<diamondop> (tree_chop den')"
    unfolding den_conv tree_chop_ap_tree tree_chop_pure_tree den'_def by applicative_nf simp
  also have "tree_chop den' = num' + den' - tree_chop den' + tree_chop den' - 2 * num_mod_den'"
    by(subst num'_plus_den'_minus_chop_den') simp
  also have "\<dots> = num' + den' - 2 * (num' mod den')"
    unfolding num_mod_den'_def num'_def den'_def num_mod_den[symmetric]
    by applicative_lifting(simp add: zmod_int)
  also have [unfolded tree.rel_eq]: "rel_tree (=) \<dots> (pure int \<diamondop> (num + den - 2 * (num mod den)))"
    unfolding num'_def den'_def by(applicative_lifting)(simp add: of_nat_diff zmod_int le den_gt_0)
  also have "pure nat \<diamondop> (pure int \<diamondop> (num + den - 2 * (num mod den))) = num + den - 2 * (num mod den)" by(applicative_nf) simp
  finally show ?thesis .
qed

subsection\<open>Loopless linearisation of the Stern-Brocot tree.\<close>

text \<open>
  This is a loopless linearisation of the Stern-Brocot tree that gives Stern's diatomic sequence,
  which is also known as Dijkstra's fusc function \<^cite>\<open>"Dijkstra1982EWD570" and "Dijkstra1982EWD578"\<close>.
  Loopless \`a la \<^cite>\<open>"Bird2006MPC"\<close> means that the first element of the stream can be computed in linear
  time and every further element in constant time.
\<close>

friend_of_corec smap :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
where "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"
subgoal by(rule stream.expand) simp
subgoal by(fold relator_eq)(transfer_prover)
done

definition step :: "nat \<times> nat \<Rightarrow> nat \<times> nat"
where "step = (\<lambda>(n, d). (d, n + d - 2 * (n mod d)))"

corec stern_brocot_loopless :: "fraction stream"
where "stern_brocot_loopless = (1, 1) ## smap step stern_brocot_loopless"

lemmas stern_brocot_loopless_rec = stern_brocot_loopless.code

friend_of_corec plus where "s + s' = (shd s + shd s') ## (stl s + stl s')"
subgoal by (rule stream.expand; simp add: plus_stream_shd plus_stream_stl)
subgoal by transfer_prover
done

friend_of_corec minus where "t - t' = (shd t - shd t') ## (stl t - stl t')"
subgoal by (rule stream.expand; simp add: minus_stream_def)
subgoal by transfer_prover
done

friend_of_corec times where "t * t' = (shd t * shd t') ## (stl t * stl t')"
subgoal by (rule stream.expand; simp add: times_stream_def)
subgoal by transfer_prover
done

friend_of_corec modulo where "t mod t' = (shd t mod shd t') ## (stl t mod stl t')"
subgoal by (rule stream.expand; simp add: modulo_stream_def)
subgoal by transfer_prover
done

corec fusc' :: "nat stream"
where "fusc' = 1 ## (((1 ## fusc') + fusc') - 2 * ((1 ## fusc') mod fusc'))"

definition fusc where "fusc = 1 ## fusc'"

lemma fusc_unfold: "fusc = 1 ## fusc'" by(fact fusc_def)

lemma fusc'_unfold: "fusc' = 1 ## (fusc + fusc' - 2 * (fusc mod fusc'))"
by(subst fusc'.code)(simp add: fusc_def)

lemma fusc_simps [simp]:
  "shd fusc = 1"
  "stl fusc = fusc'"
by(simp_all add: fusc_unfold)

lemma fusc'_simps [simp]:
  "shd fusc' = 1"
  "stl fusc' = fusc + fusc' - 2 * (fusc mod fusc')"
by(subst fusc'_unfold, simp)+

subsection \<open>Equivalence with Dijkstra's fusc function\<close>

lemma stern_brocot_loopless_siterate: "stern_brocot_loopless = siterate step (1, 1)"
by(rule stern_brocot_loopless.unique[symmetric])(rule stream.expand; simp add: smap_siterate[symmetric])

lemma fusc_fusc'_iterate: "pure Pair \<diamondop> fusc \<diamondop> fusc' = stern_brocot_loopless"
apply(rule stern_brocot_loopless.unique)
apply(rule stream.expand; simp add: step_def)
apply(applicative_lifting; simp)
done

theorem stern_brocot_loopless:
  "stream stern_brocot_recurse = stern_brocot_loopless" (is "?lhs = ?rhs")
proof(rule stern_brocot_loopless.unique)
  have eq: "?lhs = stream (pure_tree Pair \<diamondop> num \<diamondop> den)" by (simp only: stern_brocot_num_den)
  have num: "stream num = 1 ## stream den"
    by (rule stream.expand) (simp add: den_eq_chop_num)
  have den: "stream den = 1 ## (stream num + stream den - 2 * (stream num mod stream den))"
    by (rule stream.expand)(simp add: tree_chop_den)
  show "?lhs = (1, 1) ## smap step ?lhs" unfolding eq
    by(rule stream.expand)(simp add: den_eq_chop_num[symmetric] tree_chop_den; applicative_lifting; simp add: step_def)
qed

end


(*
    $Id: sol.thy,v 1.4 2011/06/28 18:11:38 webertj Exp $
*)

header {* Sum of List Elements, Tail-Recursively *}

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

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

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

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

  theorem ListSum_append[simp]: "ListSum (xs @ ys) = ListSum xs + ListSum ys"
    apply (induct xs)
    apply auto
  done

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

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

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

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

  definition ListSumT :: "nat list \<Rightarrow> nat" where
    "ListSumT xs == ListSumTAux xs 0"

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

  lemma [simp]: "ListSumT (x#xs) = x + ListSumT xs"
    by (auto simp add: ListSumT_def ListSumTAux_add[THEN sym])

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

(*<*) 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_HSortCount
  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 plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

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

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

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (hsort xs)) = (count x xs))"
  oops

end


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

section \<open>Quotient types\<close>

theory Quotient_Type
imports "MainRLT"
begin

text \<open>We introduce the notion of quotient types over equivalence relations
  via type classes.\<close>

subsection \<open>Equivalence relations and quotient types\<close>

text \<open>Type class \<open>equiv\<close> models equivalence relations
  \<open>\<sim> :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>.\<close>

class eqv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infixl "\<sim>" 50)

class equiv = eqv +
  assumes equiv_refl [intro]: "x \<sim> x"
    and equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
    and equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
begin

lemma equiv_not_sym [sym]: "\<not> x \<sim> y \<Longrightarrow> \<not> y \<sim> x"
proof -
  assume "\<not> x \<sim> y"
  then show "\<not> y \<sim> x" by (rule contrapos_nn) (rule equiv_sym)
qed

lemma not_equiv_trans1 [trans]: "\<not> x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> \<not> x \<sim> z"
proof -
  assume "\<not> x \<sim> y" and "y \<sim> z"
  show "\<not> x \<sim> z"
  proof
    assume "x \<sim> z"
    also from \<open>y \<sim> z\<close> have "z \<sim> y" ..
    finally have "x \<sim> y" .
    with \<open>\<not> x \<sim> y\<close> show False by contradiction
  qed
qed

lemma not_equiv_trans2 [trans]: "x \<sim> y \<Longrightarrow> \<not> y \<sim> z \<Longrightarrow> \<not> x \<sim> z"
proof -
  assume "\<not> y \<sim> z"
  then have "\<not> z \<sim> y" ..
  also
  assume "x \<sim> y"
  then have "y \<sim> x" ..
  finally have "\<not> z \<sim> x" .
  then show "\<not> x \<sim> z" ..
qed

end

text \<open>The quotient type \<open>'a quot\<close> consists of all \emph{equivalence
  classes} over elements of the base type \<^typ>\<open>'a\<close>.\<close>

definition (in eqv) "quot = {{x. a \<sim> x} | a. True}"

typedef (overloaded) 'a quot = "quot :: 'a::eqv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]:
  assumes "R \<in> quot"
  obtains a where "R = {x. a \<sim> x}"
  using assms unfolding quot_def by blast

text \<open>Abstracted equivalence classes are the canonical representation of
  elements of a quotient type.\<close>

definition "class" :: "'a::equiv \<Rightarrow> 'a quot"  ("\<lfloor>_\<rfloor>")
  where "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R
  assume R: "A = Abs_quot R"
  assume "R \<in> quot"
  then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis unfolding class_def .
qed

lemma quot_cases [cases type: quot]:
  obtains a where "A = \<lfloor>a\<rfloor>"
  using quot_exhaust by blast

subsection \<open>Equality on quotients\<close>

text \<open>Equality of canonical quotient elements coincides with the original
  relation.\<close>

theorem quot_equality [iff?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> b"
proof
  assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  show "a \<sim> b"
  proof -
    from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
      by (simp only: class_def Abs_quot_inject quotI)
    moreover have "a \<sim> a" ..
    ultimately have "a \<in> {x. b \<sim> x}" by blast
    then have "b \<sim> a" by blast
    then show ?thesis ..
  qed
next
  assume ab: "a \<sim> b"
  show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  proof -
    have "{x. a \<sim> x} = {x. b \<sim> x}"
    proof (rule Collect_cong)
      fix x show "(a \<sim> x) = (b \<sim> x)"
      proof
        from ab have "b \<sim> a" ..
        also assume "a \<sim> x"
        finally show "b \<sim> x" .
      next
        note ab
        also assume "b \<sim> x"
        finally show "a \<sim> x" .
      qed
    qed
    then show ?thesis by (simp only: class_def)
  qed
qed

subsection \<open>Picking representing elements\<close>

definition pick :: "'a::equiv quot \<Rightarrow> 'a"
  where "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    then have "a \<sim> x" ..
    then show "x \<sim> a" ..
  qed
qed

theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by (simp only: pick_equiv)
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
  with a show ?thesis by simp
qed

text \<open>The following rules support canonical function definitions on quotient
  types (with up to two arguments). Note that the stripped-down version
  without additional conditions is sufficient most of the time.\<close>

theorem quot_cond_function:
  assumes eq: "\<And>X Y. P X Y \<Longrightarrow> f X Y \<equiv> g (pick X) (pick Y)"
    and cong: "\<And>x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> \<Longrightarrow> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
      \<Longrightarrow> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> \<Longrightarrow> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> \<Longrightarrow> g x y = g x' y'"
    and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
proof -
  from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
  also have "... = g a b"
  proof (rule cong)
    show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
    moreover
    show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
    moreover
    show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
    ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
  qed
  finally show ?thesis .
qed

theorem quot_function:
  assumes "\<And>X Y. f X Y \<equiv> g (pick X) (pick Y)"
    and "\<And>x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> \<Longrightarrow> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> \<Longrightarrow> g x y = g x' y'"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  using assms and TrueI
  by (rule quot_cond_function)

theorem quot_function':
  "(\<And>X Y. f X Y \<equiv> g (pick X) (pick Y)) \<Longrightarrow>
    (\<And>x x' y y'. x \<sim> x' \<Longrightarrow> y \<sim> y' \<Longrightarrow> g x y = g x' y') \<Longrightarrow>
    f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  by (rule quot_function) (simp_all only: quot_equality)

end


subsection \<open>Local versions of relations\<close>

theory Relations
  imports
    "HOL-Library.Multiset"
    "Abstract-Rewriting.Abstract_Rewriting"
begin

text\<open>Common predicates on relations\<close>

definition compatible_l :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where
  "compatible_l R1 R2 \<equiv> R1 O R2 \<subseteq> R2"

definition compatible_r :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where
  "compatible_r R1 R2 \<equiv> R2 O R1 \<subseteq> R2"

text\<open>Local reflexivity\<close>

definition locally_refl :: "'a rel \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_refl R A \<equiv> (\<forall> a. a \<in># A \<longrightarrow> (a,a) \<in> R)"

definition locally_irrefl :: "'a rel \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_irrefl R A \<equiv> (\<forall>t. t \<in># A \<longrightarrow> (t,t) \<notin> R)"

text\<open>Local symmetry\<close>

definition locally_sym :: "'a rel \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_sym R A \<equiv> (\<forall>t u. t \<in># A \<longrightarrow> u \<in># A \<longrightarrow>
               (t,u) \<in> R \<longrightarrow> (u,t) \<in> R)"

definition locally_antisym :: "'a rel \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_antisym R A \<equiv> (\<forall>t u. t \<in># A \<longrightarrow> u \<in># A \<longrightarrow>
               (t,u) \<in> R \<longrightarrow> (u,t) \<in> R \<longrightarrow> t = u)"

text\<open>Local transitivity\<close>

definition locally_trans :: "'a rel \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_trans R A B C \<equiv> (\<forall>t u v.
               t \<in># A \<longrightarrow> u \<in># B \<longrightarrow> v \<in># C \<longrightarrow>
               (t,u) \<in> R \<longrightarrow> (u,v) \<in> R \<longrightarrow> (t,v) \<in> R)"

text\<open>Local inclusion\<close>

definition locally_included :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_included R1 R2 A B \<equiv> (\<forall>t u. t \<in># A \<longrightarrow> u \<in># B \<longrightarrow>
               (t,u) \<in> R1 \<longrightarrow>  (t,u) \<in> R2)"

text\<open>Local transitivity compatibility\<close>

definition locally_compatible_l :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_compatible_l R1 R2 A B C \<equiv> (\<forall>t u v. t \<in># A \<longrightarrow> u \<in># B \<longrightarrow> v \<in># C \<longrightarrow>
               (t,u) \<in> R1 \<longrightarrow> (u,v) \<in> R2 \<longrightarrow> (t,v) \<in> R2)"

definition locally_compatible_r :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
  "locally_compatible_r R1 R2 A B C \<equiv> (\<forall>t u v. t \<in># A \<longrightarrow> u \<in># B \<longrightarrow> v \<in># C \<longrightarrow>
               (t,u) \<in> R2 \<longrightarrow> (u,v) \<in> R1 \<longrightarrow> (t,v) \<in> R2)"

text\<open>included + compatible $\longrightarrow$  transitive\<close>

lemma in_cl_tr:
  assumes "R1 \<subseteq> R2"
    and "compatible_l R2 R1"
  shows "trans R1"
proof-
  {
    fix x y z
    assume s_x_y: "(x,y) \<in> R1" and s_y_z: "(y,z) \<in> R1"
    from assms s_x_y have "(x,y) \<in> R2" by auto
    with s_y_z assms(2)[unfolded compatible_l_def]  have "(x,z) \<in> R1" by blast
  }
  then show ?thesis unfolding trans_def by fast
qed

lemma in_cr_tr:
  assumes "R1 \<subseteq> R2"
    and "compatible_r R2 R1"
  shows "trans R1"
proof-
  {
    fix x y z
    assume s_x_y: "(x,y) \<in> R1" and s_y_z: "(y,z) \<in> R1"
    with assms have "(y,z) \<in> R2" by auto
    with s_x_y assms(2)[unfolded compatible_r_def] have "(x,z) \<in> R1" by blast
  }
  then show ?thesis unfolding trans_def by fast
qed

text\<open>If a property holds globally, it also holds locally. Obviously.\<close>

lemma r_lr:
  assumes "refl R"
  shows "locally_refl R A"
  using assms unfolding refl_on_def locally_refl_def by blast

lemma tr_ltr:
  assumes "trans R"
  shows "locally_trans R A B C"
  using assms unfolding trans_def and locally_trans_def by fast

lemma in_lin:
  assumes "R1 \<subseteq> R2"
  shows "locally_included R1 R2 A B"
  using assms unfolding locally_included_def by auto

lemma cl_lcl:
  assumes "compatible_l R1 R2"
  shows "locally_compatible_l R1 R2 A B C"
  using assms unfolding compatible_l_def and locally_compatible_l_def by auto

lemma cr_lcr:
  assumes "compatible_r R1 R2"
  shows "locally_compatible_r R1 R2 A B C"
  using assms unfolding compatible_r_def and locally_compatible_r_def by auto

text\<open>If a predicate holds on a set then it holds on
  all the subsets:\<close>

lemma lr_trans_l:
  assumes "locally_refl R (A + B)"
  shows "locally_refl R A"
  using assms unfolding locally_refl_def
  by auto

lemma li_trans_l:
  assumes "locally_irrefl R (A + B)"
  shows "locally_irrefl R A"
  using assms unfolding locally_irrefl_def
  by auto

lemma ls_trans_l:
  assumes "locally_sym R (A + B)"
  shows "locally_sym R A"
  using assms unfolding locally_sym_def
  by auto

lemma las_trans_l:
  assumes "locally_antisym R (A + B)"
  shows "locally_antisym R A"
  using assms unfolding locally_antisym_def
  by auto

lemma lt_trans_l:
  assumes "locally_trans R (A + B) (C + D) (E + F)"
  shows "locally_trans R A C E"
  using assms[unfolded locally_trans_def, rule_format]
  unfolding locally_trans_def by auto

lemma lin_trans_l:
  assumes "locally_included R1 R2 (A + B) (C + D)"
  shows "locally_included R1 R2 A C"
  using assms unfolding locally_included_def by auto

lemma lcl_trans_l:
  assumes "locally_compatible_l R1 R2 (A + B) (C + D) (E + F)"
  shows "locally_compatible_l R1 R2 A C E"
  using assms[unfolded locally_compatible_l_def, rule_format]
  unfolding locally_compatible_l_def by auto

lemma lcr_trans_l:
  assumes "locally_compatible_r R1 R2 (A + B) (C + D) (E + F)"
  shows "locally_compatible_r R1 R2 A C E"
  using assms[unfolded locally_compatible_r_def, rule_format]
  unfolding locally_compatible_r_def by auto

lemma lr_trans_r:
  assumes "locally_refl R (A + B)"
  shows "locally_refl R B"
  using assms unfolding locally_refl_def
  by auto

lemma li_trans_r:
  assumes "locally_irrefl R (A + B)"
  shows "locally_irrefl R B"
  using assms unfolding locally_irrefl_def
  by auto

lemma ls_trans_r:
  assumes "locally_sym R (A + B)"
  shows "locally_sym R B"
  using assms unfolding locally_sym_def
  by auto

lemma las_trans_r:
  assumes "locally_antisym R (A + B)"
  shows "locally_antisym R B"
  using assms unfolding locally_antisym_def
  by auto

lemma lt_trans_r:
  assumes "locally_trans R (A + B) (C + D) (E + F)"
  shows "locally_trans R B D F"
  using assms[unfolded locally_trans_def, rule_format]
  unfolding locally_trans_def
  by auto

lemma lin_trans_r:
  assumes "locally_included R1 R2 (A + B) (C + D)"
  shows "locally_included R1 R2 B D"
  using assms unfolding locally_included_def by auto

lemma lcl_trans_r:
  assumes "locally_compatible_l R1 R2 (A + B) (C + D) (E + F)"
  shows "locally_compatible_l R1 R2 B D F"
  using assms[unfolded locally_compatible_l_def, rule_format]
  unfolding locally_compatible_l_def by auto

lemma lcr_trans_r:
  assumes "locally_compatible_r R1 R2 (A + B) (C + D) (E + F)"
  shows "locally_compatible_r R1 R2 B D F"
  using assms[unfolded locally_compatible_r_def, rule_format]
  unfolding locally_compatible_r_def by auto

lemma lr_minus:
  assumes "locally_refl R A"
  shows "locally_refl R (A - B)"
  using assms unfolding locally_refl_def by (meson in_diffD)

lemma li_minus:
  assumes "locally_irrefl R A"
  shows "locally_irrefl R (A - B)"
  using assms unfolding locally_irrefl_def by (meson in_diffD)

lemma ls_minus:
  assumes "locally_sym R A"
  shows "locally_sym R (A - B)"
  using assms unfolding locally_sym_def by (meson in_diffD)

lemma las_minus:
  assumes "locally_antisym R A"
  shows "locally_antisym R (A - B)"
  using assms unfolding locally_antisym_def by (meson in_diffD)

lemma lt_minus:
  assumes "locally_trans R A C E"
  shows "locally_trans R (A - B) (C - D) (E - F)"
  using assms[unfolded locally_trans_def, rule_format]
  unfolding locally_trans_def by (meson in_diffD)

lemma lin_minus:
  assumes "locally_included R1 R2 A C"
  shows "locally_included R1 R2 (A - B) (C - D)"
  using assms unfolding locally_included_def by (meson in_diffD)

lemma lcl_minus:
  assumes "locally_compatible_l R1 R2 A C E"
  shows "locally_compatible_l R1 R2 (A - B) (C - D) (E - F)"
  using assms[unfolded locally_compatible_l_def, rule_format]
  unfolding locally_compatible_l_def by (meson in_diffD)

lemma lcr_minus:
  assumes "locally_compatible_r R1 R2 A C E"
  shows "locally_compatible_r R1 R2 (A - B) (C - D) (E - F)"
  using assms[unfolded locally_compatible_r_def, rule_format]
  unfolding locally_compatible_r_def by (meson in_diffD)

text \<open>Notations\<close>

notation restrict (infixl "\<restriction>" 80)

lemma mem_restrictI[intro!]: assumes "x \<in> X" "y \<in> X" "(x,y) \<in> R" shows "(x,y) \<in> R \<restriction> X"
  using assms unfolding restrict_def by auto

lemma mem_restrictD[dest]: assumes "(x,y) \<in> R \<restriction> X" shows "x \<in> X" "y \<in> X" "(x,y) \<in> R"
  using assms unfolding restrict_def by auto

end


(*  Title:      HOL/ex/MergeSort.thy
    Author:     Tobias Nipkow
    Copyright   2002 TU Muenchen
*)

section{*Merge Sort*}

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

context linorder
begin

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

lemma multiset_of_merge [simp]:
  "multiset_of (merge xs ys) = multiset_of xs + multiset_of ys"
  by (induct xs ys rule: merge.induct) (simp_all add: ac_simps)

lemma set_merge [simp]:
  "set (merge xs ys) = set xs \<union> set ys"
  by (induct xs ys rule: merge.induct) auto

lemma sorted_merge [simp]:
  "sorted (merge xs ys) \<longleftrightarrow> sorted xs \<and> sorted ys"
  by (induct xs ys rule: merge.induct) (auto simp add: ball_Un not_le less_le sorted_Cons)

fun msort :: "'a list \<Rightarrow> 'a list"
where
  "msort [] = []"
| "msort [x] = [x]"
| "msort xs = merge (msort (take (size xs div 2) xs))
                    (msort (drop (size xs div 2) xs))"

lemma sorted_msort:
  "sorted (msort xs)"
  by (induct xs rule: msort.induct) simp_all

lemma multiset_of_msort:
  "multiset_of (msort xs) = multiset_of xs"
  by (induct xs rule: msort.induct)
    (simp_all, metis append_take_drop_id drop_Suc_Cons multiset_of.simps(2) multiset_of_append take_Suc_Cons)

theorem msort_sort:
  "sort = msort"
  by (rule ext, rule properties_for_sort) (fact multiset_of_msort sorted_msort)+

end

end


theory Exercises
imports Main
begin

text \<open> Exercise 2.1 \<close>
value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"
text \<open> End of exercise 2.1 \<close>

text \<open> Exercise 2.2 \<close>
fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "add 0 n = n" | "add (Suc m) n = Suc (add m n)"

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

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

lemma add_assoc[simp]: "add (add a b) c = add a (add b c)"
  apply(induction a)
  apply(auto)
done

lemma add_comm[simp]: "add a b = add b a"
  apply(induction a)
  apply(auto)
done

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

lemma double_and_add : "double m = add m m"
  apply(induction m)
  apply(auto)
done
text \<open> Exercise 2.2 \<close>

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

theorem upperBound_of_count : "count n xs \<le> length xs"
  apply(induction xs)
  apply(auto)
  done
text \<open> End of exercise 2.3 \<close>

text \<open> Exercise 2.4 \<close>
fun snoc :: " 'a list \<Rightarrow> 'a \<Rightarrow> 'a list "
  where
    "snoc [] n =  [n]" |
    "snoc (x # xs) n = x # (snoc xs n) "

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

theorem rev_rev : "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto)
  done
text \<open> End of exercise 2.4 \<close>

text \<open> Exercise 2.5 \<close>
fun sum :: " nat \<Rightarrow> nat "
  where "sum 0 = 0" | "sum (Suc n) = (Suc n) + (sum n)"

theorem known_fact : "sum n = n * (n+1) div 2"
  apply(induction n)
  apply(auto)
done
text \<open> End of exercise 2.5 \<close>

text \<open> Exercise 2.6 \<close>
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

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

fun treesum :: " nat tree \<Rightarrow> nat  "
  where "treesum Tip = 0" |
        "treesum (Node t1 x t2) = sum_list (contents (Node t1 x t2))"

lemma treesum_equals_sum_list : "treesum myTree = sum_list (contents myTree)"
   apply(induction)
   apply(auto)
done
text \<open> End of exercise 2.6 \<close>

text \<open> Exercise 2.7 \<close>

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

fun mirror :: " 'a tree2 \<Rightarrow> 'a tree2"
  where "mirror (Tip x) = Tip x"|
        "mirror (Node t1 x t2) = Node (mirror t2) x (mirror t1)"

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

fun post_order :: " 'a tree2 \<Rightarrow> 'a list "
  where "post_order (Tip x) = x # []" |
        "post_order (Node t1 x t2) = ( (post_order t1) @ (post_order t2) ) @ (x # [])"

text \<open>
      1
     /\
    2  3
   /\  /\
  4 5  6 7
pre: 1-2-4-5-3-6-7
post: 4-5-2-6-7-3-1
\<close>

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

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

text \<open> End of exercise 2.7 \<close>

text \<open> End of exercise 2.8 \<close>

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

lemma map_interspere_propertie : "map f (interspere n l) = interspere (f n) (map f l)"
  apply(induction l rule: interspere.induct)
  apply(auto)
done

text \<open> End of exercise 2.8 \<close>

text \<open> Exercise 2.9 \<close>

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

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

text \<open> End of exercise 2.9 \<close>

text \<open> Exercise 2.10 \<close>

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

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

text \<open>
    N
   / \
  T   N
     / \
    T   T
\<close>
value "nodes (Node (Node Tip Tip) Tip)"

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

value "nodes (explode 0 (Node (Node Tip Tip) Tip))"
text \<open>
  So... My Tree0 has 5 elements.
  Explode 0 -> 5. Right
  Explode 1 -> 5 + 5 + 1, since it duplicates the previous and add a node.
  Explode 2 -> 11 + 11 + 1, same reasoning as before...
  Therefore let's define n := nodes myTree and f(x) = 2x + 1
    0 -> n              :5
    1 -> f(n)           :11 2*5 + 1
    2 -> f(f(n))        :23 2(2*5+1) + 1
    3 -> f(f(f(n)))     :47 2*(2*(2*5 + 1) + 1
\<close>

fun size_explode :: "nat \<Rightarrow> tree0 \<Rightarrow> nat" where
"size_explode n t = 2^n * (nodes t) + 2^n - 1"

value "nodes (explode 0 (Node (Node Tip Tip) Tip))"
value "nodes (explode 1 (Node (Node Tip Tip) Tip))"
value "nodes (explode 2 (Node (Node Tip Tip) Tip))"

value "size_explode 0 (Node (Node Tip Tip) Tip)"
value "size_explode 1 (Node (Node Tip Tip) Tip)"
value "size_explode 2 (Node (Node Tip Tip) Tip)"

lemma expression : "nodes (explode n t) = size_explode n t"
  apply(induction n arbitrary:t)
  apply(auto simp add: algebra_simps)
done

text \<open> End of exercise 2.10 \<close>

text \<open> Exercise 2.11 \<close>

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

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

value"Add (Var) (Add (Var) (Const 3))"
text \<open> This seems to be x + x + 3 \<close>
value"eval (Add (Var) (Add (Var) (Const 3))) 10"
text \<open> 10 + 10 + 3 = 23, which is exactly the output. Wow. think I got it. \<close>

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

value "evalp [4::int,2] 0"
value "evalp [4::int,2] 1"
value "evalp [4::int,2] 2"

text \<open>
The above definition is based on the fact that we can put the Var (namely x) in evidence.
\<close>

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs Var = [0,1]"|
"coeffs (Const n) = [n]"|
"coeffs (Add a b) = (coeffs a) @ (coeffs b)"|
"coeffs (Mult a b) = coeffs a"

value "evalp (coeffs (Add (Const (4)) (Mult (Const (2)) Var))) 0"
value "evalp (coeffs (Add (Const (4)) (Mult (Const (2)) Var))) 1"
value "evalp (coeffs (Add (Const (4)) (Mult (Const (2)) Var))) 2"

value "eval (Add (Const (4)) (Mult (Const (2)) Var)) 0"
value "eval (Add (Const (4)) (Mult (Const (2)) Var)) 1"
value "eval (Add (Const (4)) (Mult (Const (2)) Var)) 2"

text \<open>
It seems to work fine when the expression is indeed a linear polynomial in it's most compact form.
But it's not working when it's not... For example x + x is returning [1,1]
and the correct output is [2]
 \<close>

theorem voila : "evalp (coeffs e) x = eval e x"
  apply(induction e arbitrary:x)
  apply(auto)

text \<open> End of exercise 2.11 \<close>
end