(*  Title:      HOL/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports Main
begin

text \<open>
  Combinator terms do not have free variables.
  Example taken from \<^cite>\<open>camilleri92\<close>.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

datatype comb = K
              | S
              | Ap comb comb (infixl "\<bullet>" 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

inductive contract1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sup>1" 50)
  where
    K:     "K\<bullet>x\<bullet>y \<rightarrow>\<^sup>1 x"
  | S:     "S\<bullet>x\<bullet>y\<bullet>z \<rightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
  | Ap1:   "x \<rightarrow>\<^sup>1 y \<Longrightarrow> x\<bullet>z \<rightarrow>\<^sup>1 y\<bullet>z"
  | Ap2:   "x \<rightarrow>\<^sup>1 y \<Longrightarrow> z\<bullet>x \<rightarrow>\<^sup>1 z\<bullet>y"

abbreviation
  contract :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<rightarrow>" 50) where
  "contract \<equiv> contract1\<^sup>*\<^sup>*"

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

inductive parcontract1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<Rrightarrow>\<^sup>1" 50)
  where
    refl:  "x \<Rrightarrow>\<^sup>1 x"
  | K:     "K\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 x"
  | S:     "S\<bullet>x\<bullet>y\<bullet>z \<Rrightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
  | Ap:    "\<lbrakk>x \<Rrightarrow>\<^sup>1 y; z \<Rrightarrow>\<^sup>1 w\<rbrakk> \<Longrightarrow> x\<bullet>z \<Rrightarrow>\<^sup>1 y\<bullet>w"

abbreviation
  parcontract :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<Rrightarrow>" 50) where
  "parcontract \<equiv> parcontract1\<^sup>*\<^sup>*"

text \<open>
  Misc definitions.
\<close>

definition
  I :: comb where
  "I \<equiv> S\<bullet>K\<bullet>K"

definition
  diamond   :: "([comb,comb] \<Rightarrow> bool) \<Rightarrow> bool" where
    \<comment> \<open>confluence; Lambda/Commutation treats this more abstractly\<close>
  "diamond r \<equiv> \<forall>x y. r x y \<longrightarrow>
                  (\<forall>y'. r x y' \<longrightarrow>
                    (\<exists>z. r y z \<and> r y' z))"

subsection \<open>Reflexive/Transitive closure preserves Church-Rosser property\<close>

text\<open>Remark: So does the Transitive closure, with a similar proof\<close>

text\<open>Strip lemma.
   The induction hypothesis covers all but the last diamond of the strip.\<close>
lemma strip_lemma [rule_format]:
  assumes "diamond r" and r: "r\<^sup>*\<^sup>* x y" "r x y'"
  shows "\<exists>z. r\<^sup>*\<^sup>* y' z \<and> r y z"
  using r
proof (induction rule: rtranclp_induct)
  case base
  then show ?case
    by blast
next
  case (step y z)
  then show ?case
    using \<open>diamond r\<close> unfolding diamond_def
    by (metis rtranclp.rtrancl_into_rtrancl)
qed

proposition diamond_rtrancl:
  assumes "diamond r"
  shows "diamond(r\<^sup>*\<^sup>*)"
  unfolding diamond_def
proof (intro strip)
  fix x y y'
  assume "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x y'"
  then show "\<exists>z. r\<^sup>*\<^sup>* y z \<and> r\<^sup>*\<^sup>* y' z"
  proof (induction rule: rtranclp_induct)
    case base
    then show ?case
      by blast
  next
    case (step y z)
    then show ?case
      by (meson assms strip_lemma rtranclp.rtrancl_into_rtrancl)
  qed
qed

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
  K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

declare contract1.K [intro!] contract1.S [intro!]
declare contract1.Ap1 [intro] contract1.Ap2 [intro]

lemma I_contract_E [iff]: "\<not> I \<rightarrow>\<^sup>1 z"
  unfolding I_def by blast

lemma K1_contractD [elim!]: "K\<bullet>x \<rightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' \<and> x \<rightarrow>\<^sup>1 x')"
  by blast

lemma Ap_reduce1 [intro]: "x \<rightarrow> y \<Longrightarrow> x\<bullet>z \<rightarrow> y\<bullet>z"
  by (induction rule: rtranclp_induct; blast intro: rtranclp_trans)

lemma Ap_reduce2 [intro]: "x \<rightarrow> y \<Longrightarrow> z\<bullet>x \<rightarrow> z\<bullet>y"
  by (induction rule: rtranclp_induct; blast intro: rtranclp_trans)

text \<open>Counterexample to the diamond property for \<^term>\<open>x \<rightarrow>\<^sup>1 y\<close>\<close>

lemma not_diamond_contract: "\<not> diamond(contract1)"
  unfolding diamond_def by (metis S_contractE contract1.K)

subsection \<open>Results about Parallel Contraction\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract1.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>
text\<open>The rules below are not essential but make proofs much faster\<close>

lemma K1_parcontractD [dest!]: "K\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' \<and> x \<Rrightarrow>\<^sup>1 x')"
  by blast

lemma S1_parcontractD [dest!]: "S\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = S\<bullet>x' \<and> x \<Rrightarrow>\<^sup>1 x')"
  by blast

lemma S2_parcontractD [dest!]: "S\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x' y'. z = S\<bullet>x'\<bullet>y' \<and> x \<Rrightarrow>\<^sup>1 x' \<and> y \<Rrightarrow>\<^sup>1 y')"
  by blast

text\<open>Church-Rosser property for parallel contraction\<close>
proposition diamond_parcontract: "diamond parcontract1"
proof -
  have "(\<exists>z. w \<Rrightarrow>\<^sup>1 z \<and> y' \<Rrightarrow>\<^sup>1 z)" if "y \<Rrightarrow>\<^sup>1 w" "y \<Rrightarrow>\<^sup>1 y'" for w y y'
    using that by (induction arbitrary: y' rule: parcontract1.induct) fast+
  then show ?thesis
    by (auto simp: diamond_def)
qed

subsection \<open>Equivalence of \<^prop>\<open>p \<rightarrow> q\<close> and \<^prop>\<open>p \<Rrightarrow> q\<close>.\<close>

lemma contract_imp_parcontract: "x \<rightarrow>\<^sup>1 y \<Longrightarrow> x \<Rrightarrow>\<^sup>1 y"
  by (induction rule: contract1.induct; blast)

text\<open>Reductions: simply throw together reflexivity, transitivity and
  the one-step reductions\<close>

proposition reduce_I: "I\<bullet>x \<rightarrow> x"
  unfolding I_def
  by (meson contract1.K contract1.S r_into_rtranclp rtranclp.rtrancl_into_rtrancl)

lemma parcontract_imp_reduce: "x \<Rrightarrow>\<^sup>1 y \<Longrightarrow> x \<rightarrow> y"
proof (induction rule: parcontract1.induct)
  case (Ap x y z w)
  then show ?case
    by (meson Ap_reduce1 Ap_reduce2 rtranclp_trans)
qed auto

lemma reduce_eq_parreduce: "x \<rightarrow> y  \<longleftrightarrow>  x \<Rrightarrow> y"
  by (metis contract_imp_parcontract parcontract_imp_reduce predicate2I rtranclp_subset)

theorem diamond_reduce: "diamond(contract)"
  using diamond_parcontract diamond_rtrancl reduce_eq_parreduce by presburger

end


(*
  File:    Triangle.thy
  Author:  Manuel Eberl <manuel@pruvisto.org>

  Sine and cosine laws, angle sum in a triangle, congruence theorems,
  Isosceles Triangle Theorem
*)

section \<open>Basic Properties of Triangles\<close>
theory Triangle
imports
  Angles
begin

text \<open>
  We prove a number of basic geometric properties of triangles. All theorems hold
  in any real inner product space.
\<close>
subsection \<open>Thales' theorem\<close>

theorem thales:
  fixes A B C :: "'a :: real_inner"
  assumes "dist B (midpoint A C) = dist A C / 2"
  shows   "orthogonal (A - B) (C - B)"
proof -
  have "dist A C ^ 2 = dist B (midpoint A C) ^ 2 * 4"
    by (subst assms) (simp add: field_simps power2_eq_square)
  thus ?thesis
    by (auto simp: orthogonal_def dist_norm power2_norm_eq_inner midpoint_def
                   algebra_simps inner_commute)
qed

subsection \<open>Sine and cosine laws\<close>

text \<open>
  The proof of the Law of Cosines follows trivially from the definition of the angle,
  the definition of the norm in vector spaces with an inner product and the bilinearity
  of the inner product.
\<close>

lemma cosine_law_vector:
  "norm (u - v) ^ 2 = norm u ^ 2 + norm v ^ 2 - 2 * norm u * norm v * cos (vangle u v)"
  by (simp add: power2_norm_eq_inner cos_vangle algebra_simps inner_commute)

lemma cosine_law_triangle:
  "dist b c ^ 2 = dist a b ^ 2 + dist a c ^ 2 - 2 * dist a b * dist a c * cos (angle b a c)"
  using cosine_law_vector[of "b - a" "c - a"]
  by (simp add: dist_norm angle_def vangle_commute norm_minus_commute)

text \<open>
  According to our definition, angles are always between $0$ and $\pi$ and therefore,
  the sign of an angle is always non-negative. We can therefore look at
  $\sin(\alpha)^2$, which we can express in terms of $\cos(\alpha)$ using the
  identity $\sin(\alpha)^2 + \cos(\alpha)^2 = 1$. The remaining proof is then a
  trivial consequence of the definitions.
\<close>
lemma sine_law_triangle:
  "sin (angle a b c) * dist b c = sin (angle b a c) * dist a c" (is "?A = ?B")
proof (cases "a = b")
  assume neq: "a \<noteq> b"
  show ?thesis
  proof (rule power2_eq_imp_eq)
    from neq have "(sin (angle a b c) * dist b c) ^ 2 * dist a b ^ 2 =
                     dist a b ^ 2 * dist b c ^ 2 - ((a - b) \<bullet> (c - b)) ^ 2"
      by (simp add: sin_squared_eq cos_angle dist_commute field_simps)
    also have "\<dots> = dist a b ^ 2 * dist a c ^ 2 - ((b - a) \<bullet> (c - a)) ^ 2"
      by (simp only: dist_norm power2_norm_eq_inner)
         (simp add: power2_eq_square algebra_simps inner_commute)
    also from neq have "\<dots> = (sin (angle b a c) * dist a c) ^ 2 * dist a b ^ 2"
      by (simp add: sin_squared_eq cos_angle dist_commute field_simps)
    finally show "?A^2 = ?B^2" using neq by (subst (asm) mult_cancel_right) simp_all
  qed (auto intro!: mult_nonneg_nonneg sin_angle_nonneg)
qed simp_all

text \<open>
  The following forms of the Law of Sines/Cosines are more convenient for eliminating
  sines/cosines from a goal completely.
\<close>

lemma cosine_law_triangle':
  "2 * dist a b * dist a c * cos (angle b a c) = (dist a b ^ 2 + dist a c ^ 2 - dist b c ^ 2)"
  using cosine_law_triangle[of b c a] by simp

lemma cosine_law_triangle'':
  "cos (angle b a c) = (dist a b ^ 2 + dist a c ^ 2 - dist b c ^ 2) / (2 * dist a b * dist a c)"
  using cosine_law_triangle[of b c a] by simp

lemma sine_law_triangle':
  "b \<noteq> c \<Longrightarrow> sin (angle a b c) = sin (angle b a c) * dist a c / dist b c"
  using sine_law_triangle[of a b c] by (simp add: divide_simps)

lemma sine_law_triangle'':
  "b \<noteq> c \<Longrightarrow> sin (angle c b a) = sin (angle b a c) * dist a c / dist b c"
  using sine_law_triangle[of a b c] by (simp add: divide_simps angle_commute)

subsection \<open>Sum of angles\<close>

context
begin

private lemma gather_squares: "a * (a * b) = a^2 * (b :: real)"
  by (simp_all add: power2_eq_square)

private lemma eval_power: "x ^ numeral n = x * x ^ pred_numeral n"
  by (subst numeral_eq_Suc, subst power_Suc) simp

text \<open>
  The proof that the sum of the angles in a triangle is $\pi$ is somewhat more
  involved. Following the HOL Light proof by John Harrison, we first prove
  that $\cos(\alpha + \beta + \gamma) = -1$ and $\alpha + \beta + \gamma \in [0;3\pi)$,
  which then implies the theorem.

  The main work is proving $\cos(\alpha + \beta + \gamma)$. This is done using the
  addition theorems for the sine and cosine, then using the Laws of Sines to eliminate
  all $\sin$ terms save $\sin(\gamma)^2$, which only appears squared in the remaining goal.
  We then use $\sin(\gamma)^2 = 1 - \cos(\gamma)^2$ to eliminate this term and apply
  the law of cosines to eliminate this term as well.

  The remaining goal is a non-linear equation containing only the length of the sides
  of the triangle. It can be shown by simple algebraic rewriting.
\<close>
lemma angle_sum_triangle:
  assumes "a \<noteq> b \<or> b \<noteq> c \<or> a \<noteq> c"
  shows   "angle c a b + angle a b c + angle b c a = pi"
proof (rule cos_minus1_imp_pi)
  show "cos (angle c a b + angle a b c + angle b c a) = - 1"
  proof (cases "a \<noteq> b")
    case True
    thus "cos (angle c a b + angle a b c + angle b c a) = -1"
      apply (simp add: cos_add sin_add cosine_law_triangle'' field_simps
                       sine_law_triangle''[of a b c] sine_law_triangle''[of b a c]
                       angle_commute dist_commute gather_squares sin_squared_eq)
      apply (simp add: eval_power algebra_simps dist_commute)
      done
  qed (insert assms, auto)

  show "angle c a b + angle a b c + angle b c a < 3 * pi"
  proof (rule ccontr)
    assume "\<not>(angle c a b + angle a b c + angle b c a < 3 * pi)"
    with angle_le_pi[of c a b] angle_le_pi[of a b c] angle_le_pi[of b c a]
      have A: "angle c a b = pi" "angle a b c = pi" by simp_all
    thus False using angle_eq_pi_imp_dist_additive[of c a b]
                     angle_eq_pi_imp_dist_additive[of a b c] by (simp add: dist_commute)
  qed
qed (auto intro!: add_nonneg_nonneg angle_nonneg)

end

subsection \<open>Congruence Theorems\<close>

text \<open>
  If two triangles agree on two angles at a non-degenerate side, the third angle
  must also be equal.
\<close>
lemma similar_triangle_aa:
  assumes "b1 \<noteq> c1" "b2 \<noteq> c2"
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  assumes "angle b1 c1 a1 = angle b2 c2 a2"
  shows   "angle b1 a1 c1 = angle b2 a2 c2"
proof -
  from assms angle_sum_triangle[of a1 b1 c1] angle_sum_triangle[of a2 b2 c2, symmetric]
    show ?thesis by (auto simp: algebra_simps angle_commute)
qed

text \<open>
  A triangle is defined by its three angles and the lengths of three sides up to congruence.
  Two triangles are congruent if they have their angles are the same and their sides have
  the same length.
\<close>

locale congruent_triangle =
  fixes a1 b1 c1 :: "'a :: real_inner" and a2 b2 c2 :: "'b :: real_inner"
  assumes sides':  "dist a1 b1 = dist a2 b2" "dist a1 c1 = dist a2 c2" "dist b1 c1 = dist b2 c2"
      and angles': "angle b1 a1 c1 = angle b2 a2 c2" "angle a1 b1 c1 = angle a2 b2 c2"
                   "angle a1 c1 b1 = angle a2 c2 b2"
begin

lemma angles:
  "angle b1 a1 c1 = angle b2 a2 c2" "angle a1 b1 c1 = angle a2 b2 c2" "angle a1 c1 b1 = angle a2 c2 b2"
  "angle c1 a1 b1 = angle b2 a2 c2" "angle c1 b1 a1 = angle a2 b2 c2" "angle b1 c1 a1 = angle a2 c2 b2"
  "angle b1 a1 c1 = angle c2 a2 b2" "angle a1 b1 c1 = angle c2 b2 a2" "angle a1 c1 b1 = angle b2 c2 a2"
  "angle c1 a1 b1 = angle c2 a2 b2" "angle c1 b1 a1 = angle c2 b2 a2" "angle b1 c1 a1 = angle b2 c2 a2"
  using angles' by (simp_all add: angle_commute)

end

lemmas congruent_triangleD = congruent_triangle.sides congruent_triangle.angles

text \<open>
  Given two triangles that agree on a subset of its side lengths and angles that are
  sufficient to define a triangle uniquely up to congruence, one can conclude that they
  must also agree on all remaining quantities, i.e. that they are congruent.

  The following four congruence theorems state what constitutes such a uniquely-defining
  subset of quantities. Each theorem states in its name which quantities are required and
  in which order (clockwise or counter-clockwise): an ``s'' stands for a side,
  an ``a'' stands for an angle.

  The lemma ``congruent-triangleI-sas, for example, requires that two adjacent sides and the
  angle inbetween are the same in both triangles.
\<close>

lemma congruent_triangleI_sss:
  fixes a1 b1 c1 :: "'a :: real_inner" and a2 b2 c2 :: "'b :: real_inner"
  assumes "dist a1 b1 = dist a2 b2"
  assumes "dist b1 c1 = dist b2 c2"
  assumes "dist a1 c1 = dist a2 c2"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof -
  have A: "angle a1 b1 c1 = angle a2 b2 c2"
    if "dist a1 b1 = dist a2 b2" "dist b1 c1 = dist b2 c2" "dist a1 c1 = dist a2 c2"
    for a1 b1 c1 :: 'a and a2 b2 c2 :: 'b
  proof -
    from that cosine_law_triangle''[of a1 b1 c1] cosine_law_triangle''[of a2 b2 c2]
      show ?thesis by (intro cos_angle_eqD) (simp add: dist_commute)
  qed
  from assms show ?thesis by unfold_locales (auto intro!: A simp: dist_commute)
qed

lemmas congruent_triangle_sss = congruent_triangleD[OF congruent_triangleI_sss]

lemma congruent_triangleI_sas:
  assumes "dist a1 b1 = dist a2 b2"
  assumes "dist b1 c1 = dist b2 c2"
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof (rule congruent_triangleI_sss)
  show "dist a1 c1 = dist a2 c2"
  proof (rule power2_eq_imp_eq)
    from cosine_law_triangle[of a1 c1 b1] cosine_law_triangle[of a2 c2 b2] assms
      show "(dist a1 c1)\<^sup>2 = (dist a2 c2)\<^sup>2" by (simp add: dist_commute)
  qed simp_all
qed fact+

lemmas congruent_triangle_sas = congruent_triangleD[OF congruent_triangleI_sas]

lemma congruent_triangleI_aas:
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  assumes "angle b1 c1 a1 = angle b2 c2 a2"
  assumes "dist a1 b1 = dist a2 b2"
  assumes "\<not>collinear {a1,b1,c1}"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof (rule congruent_triangleI_sas)
  from \<open>\<not>collinear {a1,b1,c1}\<close> have neq: "a1 \<noteq> b1" by auto
  with assms(3) have neq': "a2 \<noteq> b2" by auto
  have A: "angle c1 a1 b1 = angle c2 a2 b2" using neq neq' assms
    using angle_sum_triangle[of a1 b1 c1] angle_sum_triangle[of a2 b2 c2]
    by simp
  from assms have B: "angle b1 a1 c1 \<in> {0<..<pi}"
    by (intro not_collinear_angle) (simp_all add: insert_commute)
  from sine_law_triangle[of c1 a1 b1] sine_law_triangle[of c2 a2 b2] assms A B
    show "dist b1 c1 = dist b2 c2"
    by (auto simp: angle_commute dist_commute sin_angle_zero_iff)
qed fact+

lemmas congruent_triangle_aas = congruent_triangleD[OF congruent_triangleI_aas]

lemma congruent_triangleI_asa:
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  assumes "dist a1 b1 = dist a2 b2"
  assumes "angle b1 a1 c1 = angle b2 a2 c2"
  assumes "\<not>collinear {a1, b1, c1}"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof (rule congruent_triangleI_aas)
  from assms have neq: "a1 \<noteq> b1" "a2 \<noteq> b2" by auto
  show "angle b1 c1 a1 = angle b2 c2 a2"
    by (rule similar_triangle_aa) (insert assms neq, simp_all add: angle_commute)
qed fact+

lemmas congruent_triangle_asa = congruent_triangleD[OF congruent_triangleI_asa]

subsection \<open>Isosceles Triangle Theorem\<close>

text \<open>
  We now prove the Isosceles Triangle Theorem: in a triangle where two sides have
  the same length, the two angles that are adjacent to only one of the two sides
  must be equal.
\<close>
lemma isosceles_triangle:
  assumes "dist a c = dist b c"
  shows   "angle b a c = angle a b c"
  by (rule congruent_triangle_sss) (insert assms, simp_all add: dist_commute)

text \<open>
  For the non-degenerate case (i.e. the three points are not collinear), We also
  prove the converse.
\<close>
lemma isosceles_triangle_converse:
  assumes "angle a b c = angle b a c" "\<not>collinear {a,b,c}"
  shows   "dist a c = dist b c"
  by (rule congruent_triangle_asa[OF assms(1) _ _ assms(2)])
     (simp_all add: dist_commute angle_commute assms)

subsection\<open>Contributions by Lukas Bulwahn\<close>

lemma Pythagoras:
  fixes A B C :: "'a :: real_inner"
  assumes "orthogonal (A - C) (B - C)"
  shows "(dist B C) ^ 2 + (dist C A) ^ 2 = (dist A B) ^ 2"
proof -
  from assms have "cos (angle A C B) = 0"
    by (metis orthogonal_iff_angle cos_pi_half)
  from this show ?thesis
    by (simp add: cosine_law_triangle[of A B C] dist_commute)
qed

lemma isosceles_triangle_orthogonal_on_midpoint:
  fixes A B C :: "'a :: euclidean_space"
  assumes "dist C A = dist C B"
  shows "orthogonal (C - midpoint A B) (A - midpoint A B)"
proof (cases "A = B")
  assume "A \<noteq> B"
  let ?M = "midpoint A B"
  from \<open>A \<noteq> B\<close> have "angle A ?M C = pi - angle B ?M C"
    by (intro angle_inverse between_midpoint)
       (auto simp: between_midpoint eq_commute[of _ "midpoint A B" for A B])
  moreover have "angle A ?M C = angle C ?M B"
  proof -
    have congruence: "congruent_triangle C A ?M C B ?M"
    proof (rule congruent_triangleI_sss)
      show "dist C A = dist C B" using assms .
      show "dist A ?M = dist B ?M" by (simp add: dist_midpoint)
      show "dist C (midpoint A B) = dist C (midpoint A B)" ..
    qed
    from this show ?thesis by (simp add: congruent_triangle.angles(6))
  qed
  ultimately have "angle A ?M C = pi / 2" by (simp add: angle_commute)
  from this show ?thesis
    by (simp add: orthogonal_iff_angle orthogonal_commute)
next
  assume "A = B"
  from this show ?thesis
    by (simp add: orthogonal_clauses(1))
qed

end


theory Exercises2
  imports Main
begin

(* Exercise 2.1 *)
value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

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

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

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

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

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

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

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

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

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

theorem rev_snoc[simp]: "reverse (snoc xs x) = (x#(reverse xs))"
  apply (induction xs)
   apply (auto)
  done

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

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

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

(* Exercise 2.6 *)
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

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

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

theorem sum_tree_thm[simp]: "sum_tree t = sum_list (contents t)"
  apply (induction t)
   apply (auto)
  done

(* Exercise 2.7 *)

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

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

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

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

theorem rev_pre_is_pos[simp]: "pre_order (mirror2 t) = rev (post_order t)"
  apply (induction t rule: post_order.induct)
   apply (auto)
  done

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

theorem intersperse_map[simp]:
  "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
    apply (auto)
  done

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

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

(* exercise 2.10 *)
datatype tree0 = Nil0 | Node0 tree0 tree0

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

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

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

lemma [simp] : "nodes (explode n (Node0 t t)) = 1 + 2 * nodes (explode n t)"
  apply (induction n arbitrary : t)ifexp=Bc2bool|If ifexp ifexp ifexp|Less2aexp aexp
  apply (auto)
  done

lemma [simp] : "Suc (2 * 2 ^ n + nodes t * (2 * 2 ^ n) - Suc (Suc 0)) = 2 * 2 ^ n + nodes t * (2 * 2 ^ n) - Suc 0"
  apply (induction n)
   apply (auto)
  done

lemma "(nodes (explode n t)) = explode_size n t"
  apply (induction n)
   apply (simp_all add : explode_size_def)
  apply (simp add : algebra_simps)
  done

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

value "(1 * (2::int))"

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

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp [] _ = 0"|
"evalp (c#cs) x = c * (x^(length (c#cs))) + (evalp cs x)"

fun degree :: "exp \<Rightarrow> int" where
"degree (Mult Var Var) = 2"|
"degree (Mult Var x) = 1 + (degree x)"|
"degree (Mult x Var) = 1 + (degree x)"|
"degree x = 0"

fun factor :: "exp \<Rightarrow> int" where
"factor (Mult x y) = (factor x) * (factor y)"|
"factor (Const x) = x"

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs (Const x) = [x]"|
"coeffs (Add a b) = (factor a) # (coeffs b)"

theorem "evalp (coeffs e) x = eval e x"
  apply (induction e arbitrary : x rule : coeffs.induct)
  apply (simp_all)

end


theory Assertion imports
"State"

begin

no_notation FForm ("F _")
no_notation EExp ("E _")

(*evalF defines the semantics of assertions written in first-order logic*)
primrec evalF :: "state => fform => bool" where
"evalF (f,WTrue) = (True)" |
"evalF (f,WFalse) = (False)" |
"evalF (f,e1 [=] e2) = (case (evalE (f,e1), evalE (f,e2)) of
                            (RR (r1),RR (r2)) => ((r1::real) = r2) |
                            (SS (r1),SS (r2)) => ((r1::string) = r2) |
                            (BB (r1),BB (r2)) => ((r1::bool) = r2) |
                            (_,_) => False)" |
"evalF (f,e1 [<] e2) = (case (evalE (f,e1), evalE (f,e2)) of
                            (RR (r1),RR (r2)) => ((r1::real) < r2) |
                            (_,_) => False)" |
"evalF (f,e1 [>] e2) = (case (evalE (f,e1), evalE (f,e2)) of
                            (RR (r1),RR (r2)) => (r1::real) > r2 |
                            (_,_) => False)" |
"evalF (f,[~] form1) = (~ (evalF (f,form1)))" |
"evalF (f,form1 [&] form2) = ((evalF (f,form1)) & (evalF (f,form2)))" |
"evalF (f,form1 [|] form2) = ((evalF (f,form1)) | (evalF (f,form2)))" |
"evalF (f,form1 [-->] form2) = ((evalF (f,form1)) --> (evalF (f,form2)))" |
"evalF (f,form1 [<->] form2) = ((evalF (f,form1)) \<longleftrightarrow> (evalF (f,form2)))" |
"evalF (f,WALL x form1)= (ALL (v::real). (evalF((%a. %i. (if (a=x) then (RR (v)) else (f(a, i)))), form1)))" |
"evalF (f,WEX x form1)= (EX (v::real). evalF((%a. %i. (if (a=x) then (RR (v)) else f(a, i))), form1))"

definition evalFP :: "cstate => fform => now => bool" where
"evalFP(f,P,c) == ALL s. inList(s,f(c)) --> evalF(s,P)"

(*ievalF defines the semantics of assertions written in interval logic and duration calculus*)
consts ievalF :: "cstate => fform => now => now => bool"
axiomatization where
chop_eval: "ievalF (f, P[^]Q, c, d) =  (EX k s1 s2. s1@s2=f(k) & ievalF (%t. if t=k then s1 else f(t), P, c, k)
                                                  & ievalF (%t. if t=k then s2 else f(t), Q, k, d))" and
chop_sep: "ievalF (f, P, c, d) = (ALL k s1 s2. s1@s2=f(k) --> ievalF (%t. if t=k then s1 else f(t), P, c, k)
                                                  & ievalF (%t. if t=k then s2 else f(t), P, k, d))" and
pf_eval: "ievalF (f, pf (P), c, d) = (c=d & (EX s. inList(s, f(c))) & evalF (s, P))" and
high_eval: "ievalF (f, high P, c, d) = ((ALL (k::real). (c<k & k<d) --> evalFP (f, P, k)))" and
chop_interval: "(ALL t. (c=d --> f(c)=g(c)) & (c<=t & t<=d --> f(t)=g(t))) ==> ievalF(f,P,c,d)=ievalF(g,P,c,d)"

lemma chop_eval1: "(EX k. ievalF (f, P, c, k) & ievalF (f, Q, k, d)) ==> ievalF (f, P[^]Q, c, d)"
apply (simp add: chop_eval,auto)
apply (cut_tac x=k in exI,auto)
apply (cut_tac x="f(k)" in exI,auto)
apply (subgoal_tac "f = (%t. if t = k then f(k) else f(t))",auto)
apply (subgoal_tac "(ALL ka s1 s2. s1@s2=f(ka) --> ievalF (%t. if t=ka then s1 else f(t), Q, k, ka)
                                                  & ievalF (%t. if t=ka then s2 else f(t), Q, ka, d))")
apply (subgoal_tac "ievalF(%t. if t = k then f(k) else f(t), Q, k, k) &
               ievalF(%t. if t = k then [] else f(t), Q, k, d)")
apply blast
apply (erule allE)+
apply blast
apply (cut_tac f=f and P=Q and c=k and d=d in chop_sep,auto)
done

(*The following axioms define the evaluation of formulas of part of first-order interval logic.*)
axiomatization where
True_eval : "ievalF (f,WTrue, c, d) = (True)"  and
False_eval : "ievalF (f,WFalse,c,d) = (False)" and
L_eval : "ievalF (f, (l [=] Real L), c, d) = (d-c = L)" and
(*Equal_eval : "ievalF (f,e1 [=] e2,c,d) = evalFP(f,e1 [=] e2,c)" and
Less_eval : "ievalF (f,e1 [<] e2,c,d) = evalFP(f,e1 [<] e2,c)" and
Great_eval: "ievalF (f,e1 [>] e2,c,d) = evalFP(f,e1 [>] e2,c)" and*)
Not_eval: "ievalF (f,[~] form1,c,d) = (~ (ievalF (f,form1,c,d)))" and
And_eval: "ievalF (f,form1 [&] form2,c,d) = ((ievalF (f,form1,c,d)) & (ievalF (f,form2,c,d)))" and
Or_eval: "ievalF (f,F' [|] G,c,d) = ((ievalF (f,F',c,d)) | (ievalF (f,G,c,d)))" and
Imply_eval: "ievalF (f,form1 [-->] form2,c,d) = ((ievalF (f,form1,c,d)) --> (ievalF (f,form2,c,d)))" and
Equiv_eval: "ievalF (f,form1 [<->] form2,c,d) = ((ievalF (f,form1,c,d)) \<longleftrightarrow> (ievalF (f,form2,c,d)))" and
ALL_eval: "ievalF (f,WALL x form1,c,d)= (ALL (v::real). ievalF((%t. List.map(%s. %y i. if y=x & i=R then RR(v) else s(y,i),f(t))), form1, c, d))" and
EX_eval: "ievalF (f,WEX x form1,c,d)= (EX (v::real). ievalF((%t. List.map(%s. %y i. if y=x & i=R then RR(v) else s(y,i),f(t))), form1, c, d))"

(*The following axioms define the semantic meanings of closure of formulas.*)
axiomatization where
close_fact1: "ALL t. (t>=b & t<c --> evalF (f, p)) --> (evalF (f, close(p)))" and
close_fact2: "ALL t. (t>=b & t<c --> evalF (f, p)) --> (evalF (f, close([~]p)))" and
close_fact3: "evalF (s,p) ==> evalF (s,close(p))"

end


theory Concrete_Semantics_5_1
  imports Main
begin

lemma "\<not> surj (f::'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
(*
from 0 have 1: "8A: 9 a: A = f a" by(simp add: surj_def )
from 1 have 2: "9 a: fx : x =2 f x g = f a" by blast
from 2 show "False" by blast
*)
  hence 1: "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp add: surj_def)
  thus "False" by blast
qed

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -
  have "\<exists>a. {x. x \<notin> f x} = f a" using s by (auto simp: surj_def)
  thus "False" by blast
qed

lemma "\<not> surj (f::'a \<Rightarrow> 'a set)"
proof
  assume"surj f"
  hence "\<exists> a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

lemma
  fixes a b :: int
  assumes "b dvd (a + b)"
  shows "b dvd a"
proof-
  have "\<exists>k'. a = b * k'" if asm: "a + b = b*k" for k
  proof
    show "a = b *(k - 1)" using asm by (simp add: algebra_simps)
  qed
  thus ?thesis using assms by(auto simp add: dvd_def)
qed

(* Exercise 5.1. *)
lemma assumes T: "\<forall> x y. T x y \<or> T y x"
  and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall> x y. T x y \<longrightarrow> A x y"
  and "A x y"
  shows "T x y"
proof(rule ccontr)
  assume "\<not> T x y"
  hence "T y x" using T by blast
  hence "A y x" using TA by blast
  hence "x = y" using assms by auto
  hence "T x x" using T by auto
  hence "T x y" using `x = y` by auto
  thus "False" using `\<not> T x y` by auto
qed

(* Exercise 5.2. *)
lemma "\<exists> ys zs. xs = ys @ zs \<and>
        (length ys = length zs \<or> length ys = length zs + 1)"
proof cases
  assume "even (length xs)"
  then obtain a where "length xs = 2 * a" by auto
    let ?ys = "take a xs"
    let ?zs = "drop a xs"
    have "xs = ?ys @ ?zs \<and>length ?ys = length ?zs" by(simp add: `length xs = 2 * a`)
    hence "xs = ?ys @ ?zs \<and>
        (length ?ys = length ?zs \<or> length ?ys = length ?zs + 1)" by (auto)
    thus ?thesis by blast
next
  assume "odd (length xs)"
  then obtain a where "length xs = (2 * a) + 1"
    using oddE by blast
    let ?ys = "take (a + 1) xs"
    let ?zs = "drop (a + 1) xs"
    have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" by (simp add: \<open>length xs = 2 * a + 1\<close>)
    hence "xs = ?ys @ ?zs \<and>
        (length ?ys = length ?zs \<or> length ?ys = length ?zs + 1)" by (auto)
    thus ?thesis  by blast
qed

(* Chap 5.4 *)

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
(*
  assume "xs = []"
*)
  case Nil
  then show ?thesis by simp
next
(*
  fix y ys assume "xs = y#ys"
*)
  case (Cons y ys)
  then show ?thesis
    by simp
qed

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

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc(Suc n)) = evn n"

lemma "ev n \<Longrightarrow> evn n"
proof(induction rule: ev.induct)
  case ev0
  show ?case by simp
(*case ev0 show ?case by simp*)
next
  case evSS
  thus ?case by simp
(* case (evSS m)
have "evn(Suc(Suc m)) = evn m" by simp
thus ?case using hevn mi by blast *)
qed

lemma not_even_1:"\<not> ev(Suc 0)"
proof
  assume "ev(Suc 0)" then show False by cases
qed

(* Exercise 5.4. *)

lemma "\<not> ev(Suc(Suc(Suc 0)))"
proof
  assume "ev(Suc(Suc(Suc 0)))" thus False
  proof cases
    assume "ev(Suc 0)" thus False by cases
  qed
(*  assume "ev(Suc(Suc(Suc 0)))"
  hence "ev(Suc 0)"
    using ev.cases by auto
  then show False by (auto simp add: not_even_1)*)
qed

lemma "ev(Suc m) \<Longrightarrow> \<not> ev m"
proof(induction "Suc m" arbitrary: m rule: ev.induct)
  fix n assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not> ev m"
  show "\<not> ev (Suc n)"
  proof
    assume "ev (Suc n)"
    thus False
    proof cases
      fix k assume "n = Suc k" "ev k"
      thus False using IH by auto
    qed
  qed
qed

(* Exercise 5.3. *)

(*it is not able to use rule: ev.induct, because if n = 0 then it were failed.*)
lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
proof -
  show "ev n"
    using assms ev.cases by blast
qed

(* Exercise 5.5. *)

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

inductive iter:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_refl: "iter r n x x" |
iter_step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r n x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof(induction rule:iter.induct)
case (iter_refl n x)
  then show ?case
    by (simp add: star.refl)
next
  case (iter_step x y n z)
then show ?case
  by (meson star.step)
qed

(*Exercise 5.6.*)

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems [] = {}" |
"elems (x#xs) = {x} \<union> elems xs"

lemma "x \<in> elems xs \<Longrightarrow> \<exists> ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
case Nil
  then show ?case by simp
next
  case (Cons a xs)
  show ?case
  proof cases
    assume "x = a"
    then obtain zs where "x#zs = a#xs" by blast
    let ?ys = "[]"
    have "x \<notin> elems ?ys"
      by simp
    show ?case
      using \<open>x = a\<close> \<open>x \<notin> elems []\<close> by blast
  next
    assume "x \<noteq> a"
(* get lists `ys` and `zs`, which were introduced from IH *)
(* it is not possible to use the following:
"by (auto simp add:`x \<in> elems(Cons a xs)`)"
. So I use "from A B have ...".
*)
    from this `x \<in> elems(Cons a xs)` have "x \<in> elems xs" by auto
    then obtain ys zs where "xs = ys @ x # zs \<and> x \<notin> elems ys"
      using Cons.IH by auto
(*It is not possible to derive ?case from this result.
Because we need the case of "a # xs =..."
*)
    from this `x \<noteq> a` obtain ys' where "a # xs = ys' @ x # zs \<and> x \<notin> elems ys'" by force
    show ?case
      using \<open>a # xs = ys' @ x # zs \<and> x \<notin> elems ys'\<close> by auto
  qed
qed

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
s_emp: "S[]" |
s_list: "S xs \<Longrightarrow> S (a # xs @ [b])" |
s_const: "S xs \<Longrightarrow> S ys \<Longrightarrow> S(xs@ys)"

(* Should not use S in def of balanced.
0 abab \<Rightarrow> 1 bab \<Rightarrow> 0 ab \<Rightarrow> 1 b \<Rightarrow> 0 []: True

0 abb \<Rightarrow> 1 bb \<Rightarrow> 0 b \<Rightarrow> -1 b \<Rightarrow> -2 []: False

0 aab \<Rightarrow> 1 ab \<Rightarrow> 2 b \<Rightarrow> 1 [] : False
*)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
"balanced 0 [] = True" |
"balanced n (a#xs) = balanced (Suc n) xs" |
"balanced (Suc n) (b#xs) = balanced n xs" |
"balanced _ _ = False"

lemma
  fixes n w
  assumes b: "balanced n w"
  shows "S (replicate n a @ w)"
proof -
  from b show ?thesis
  proof(induction w)
    case Nil
    then show ?case
    proof (induction n)
      case 0
      then show ?case
        by (simp add: s_emp)
    next
      case (Suc n)
      then show ?case
        by simp
    qed
  next
    case (Cons a w)
    then show ?case
    proof (induction n)
      case 0
      then show ?case sorry
    next
      case (Suc n)
      then show ?case sorry

    qed
  qed
qed

lemma
  fixes n w
  assumes s: "S (replicate n a @ w)"
  shows "balanced n w"
proof (induction w)
  case Nil
  then show ?case sorry
next
  case (Cons a w)
  then show ?case sorry
qed

corollary "balanced n w \<longleftrightarrow> S (replicate n a @ w)"
proof (induction w)
  case Nil
  then have "balanced n [] \<Longrightarrow> S(replicate n a @ [])"
  proof (induction n)
    case 0
    then show ?case
      by (simp add: s_emp)
  next
    case (Suc n)
    then show ?case sorry
  qed
  then have "S(replicate n a @ []) \<Longrightarrow> balanced n w"
  proof (induction n)
    case 0
    then show ?case sorry
  next
    case (Suc n)
    then show ?case sorry
  qed
  then show ?case sorry
next
  case (Cons a w)
  then have "balanced n w \<Longrightarrow> S(replicate n a @ w)"
  proof(induction n)
    case 0
    then show ?case sorry
  next
    case (Suc n)
    then show ?case sorry
  qed

  then have "S(replicate n a @ w) \<Longrightarrow> balanced n w"
  proof(induction n)
    case 0
    then show ?case sorry
  next
    case (Suc n)
    then show ?case sorry
  qed
  then show ?case sorry
qed

end


(*
  File:                      Duplicate_Free_Multiset.thy
  Authors and contributors:  Mathias Fleury, Daniela Kaufmann, JKU;
                             Jose Divasón, Sebastiaan Joosten, René Thiemann, Akihisa Yamada
*)

theory Duplicate_Free_Multiset
imports Multiset_More
begin

section \<open>Duplicate Free Multisets\<close>

text \<open>Duplicate free multisets are isomorphic to finite sets, but it can be useful to reason about
  duplication to speak about intermediate execution steps in the refinements.
\<close>

definition distinct_mset :: "'a multiset \<Rightarrow> bool" where
  "distinct_mset S \<longleftrightarrow> (\<forall>a. a \<in># S \<longrightarrow> count S a = 1)"

lemma distinct_mset_count_less_1: "distinct_mset S \<longleftrightarrow> (\<forall>a. count S a \<le> 1)"
  using eq_iff nat_le_linear unfolding distinct_mset_def by fastforce

lemma distinct_mset_empty[simp]: "distinct_mset {#}"
  unfolding distinct_mset_def by auto

lemma distinct_mset_singleton: "distinct_mset {#a#}"
  unfolding distinct_mset_def by auto

lemma distinct_mset_union:
  assumes dist: "distinct_mset (A + B)"
  shows "distinct_mset A"
  unfolding distinct_mset_count_less_1
proof (rule allI)
  fix a
  have \<open>count A a \<le> count (A + B) a\<close> by auto
  moreover have \<open>count (A + B) a \<le> 1\<close>
    using dist unfolding distinct_mset_count_less_1 by auto
  ultimately show \<open>count A a \<le> 1\<close>
    by simp
qed

lemma distinct_mset_minus[simp]: "distinct_mset A \<Longrightarrow> distinct_mset (A - B)"
  by (metis diff_subset_eq_self mset_subset_eq_exists_conv distinct_mset_union)

lemma distinct_mset_rempdups_union_mset:
  assumes "distinct_mset A" and "distinct_mset B"
  shows "A \<union># B = remdups_mset (A + B)"
  using assms nat_le_linear unfolding remdups_mset_def
  by (force simp add: multiset_eq_iff max_def count_mset_set_if distinct_mset_def not_in_iff)

lemma distinct_mset_add_mset[simp]: "distinct_mset (add_mset a L) \<longleftrightarrow> a \<notin># L \<and> distinct_mset L"
  unfolding distinct_mset_def
  apply (rule iffI)
   apply (auto split: if_split_asm; fail)[]
  by (auto simp: not_in_iff; fail)

lemma distinct_mset_size_eq_card: "distinct_mset C \<Longrightarrow> size C = card (set_mset C)"
  by (induction C) auto

lemma distinct_mset_add:
  "distinct_mset (L + L') \<longleftrightarrow> distinct_mset L \<and> distinct_mset L' \<and> L \<inter># L' = {#}"
  by (induction L arbitrary: L') auto

lemma distinct_mset_set_mset_ident[simp]: "distinct_mset M \<Longrightarrow> mset_set (set_mset M) = M"
  by (induction M) auto

lemma distinct_finite_set_mset_subseteq_iff[iff]:
  assumes "distinct_mset M" "finite N"
  shows "set_mset M \<subseteq> N \<longleftrightarrow> M \<subseteq># mset_set N"
  by (metis assms distinct_mset_set_mset_ident finite_set_mset msubset_mset_set_iff)

lemma distinct_mem_diff_mset:
  assumes dist: "distinct_mset M" and mem: "x \<in> set_mset (M - N)"
  shows "x \<notin> set_mset N"
proof -
  have "count M x = 1"
    using dist mem by (meson distinct_mset_def in_diffD)
  then show ?thesis
    using mem by (metis count_greater_eq_one_iff in_diff_count not_less)
qed

lemma distinct_set_mset_eq:
  assumes "distinct_mset M" "distinct_mset N" "set_mset M = set_mset N"
  shows "M = N"
  using assms distinct_mset_set_mset_ident by fastforce

lemma distinct_mset_union_mset[simp]:
  \<open>distinct_mset (D \<union># C) \<longleftrightarrow> distinct_mset D \<and> distinct_mset C\<close>
  unfolding distinct_mset_count_less_1 by force

lemma distinct_mset_inter_mset:
  "distinct_mset C \<Longrightarrow> distinct_mset (C \<inter># D)"
  "distinct_mset D \<Longrightarrow> distinct_mset (C \<inter># D)"
  by (auto simp add: distinct_mset_def min_def count_eq_zero_iff elim!: le_SucE)

lemma distinct_mset_remove1_All: "distinct_mset C \<Longrightarrow> remove1_mset L C = removeAll_mset L C"
  by (auto simp: multiset_eq_iff distinct_mset_count_less_1)

lemma distinct_mset_size_2: "distinct_mset {#a, b#} \<longleftrightarrow> a \<noteq> b"
  by auto

lemma distinct_mset_filter: "distinct_mset M \<Longrightarrow> distinct_mset {# L \<in># M. P L#}"
  by (simp add: distinct_mset_def)

lemma distinct_mset_mset_distinct[simp]: \<open>distinct_mset (mset xs) = distinct xs\<close>
  by (induction xs) auto

lemma distinct_image_mset_inj:
  \<open>inj_on f (set_mset M) \<Longrightarrow> distinct_mset (image_mset f M) \<longleftrightarrow> distinct_mset M\<close>
  by (induction M) (auto simp: inj_on_def)

lemma distinct_mset_remdups_mset_id: \<open>distinct_mset C \<Longrightarrow> remdups_mset C = C\<close>
  by (induction C)  auto

lemma distinct_mset_image_mset:
  \<open>distinct_mset (image_mset f (mset xs)) \<longleftrightarrow> distinct (map f xs)\<close>
  apply (subst mset_map[symmetric])
  apply (subst distinct_mset_mset_distinct)
  ..

lemma distinct_mset_mono: \<open>D' \<subseteq># D \<Longrightarrow> distinct_mset D \<Longrightarrow> distinct_mset D'\<close>
  by (metis distinct_mset_union subset_mset.le_iff_add)

lemma distinct_mset_mono_strict: \<open>D' \<subset># D \<Longrightarrow> distinct_mset D \<Longrightarrow> distinct_mset D'\<close>
  using distinct_mset_mono by auto

lemma distinct_set_mset_eq_iff:
  assumes \<open>distinct_mset M\<close> \<open>distinct_mset N\<close>
  shows \<open>set_mset M = set_mset N \<longleftrightarrow> M = N\<close>
  using assms distinct_mset_set_mset_ident by fastforce

lemma distinct_mset_union2:
  \<open>distinct_mset (A + B) \<Longrightarrow> distinct_mset B\<close>
  using distinct_mset_union[of B A]
  by (auto simp: ac_simps)

lemma distinct_mset_mset_set: \<open>distinct_mset (mset_set A)\<close>
  unfolding distinct_mset_def count_mset_set_if by (auto simp: not_in_iff)

lemma distinct_mset_inter_remdups_mset:
  assumes dist: \<open>distinct_mset A\<close>
  shows \<open>A \<inter># remdups_mset B = A \<inter># B\<close>
proof -
  have [simp]: \<open>A' \<inter># remove1_mset a (remdups_mset Aa) = A' \<inter># Aa\<close>
    if
      \<open>A' \<inter># remdups_mset Aa = A' \<inter># Aa\<close> and
      \<open>a \<notin># A'\<close> and
      \<open>a \<in># Aa\<close>
    for A' Aa :: \<open>'a multiset\<close> and a
  by (metis insert_DiffM inter_add_right1 set_mset_remdups_mset that)

  show ?thesis
    using dist
    apply (induction A)
    subgoal by auto
     subgoal for a A'
       by (cases \<open>a \<in># B\<close>)
         (use multi_member_split[of a \<open>B\<close>]  multi_member_split[of a \<open>A\<close>] in
           \<open>auto simp: mset_set.insert_remove\<close>)
    done
qed

abbreviation (input) is_mset_set :: \<open>'a multiset \<Rightarrow> bool\<close>
  where \<open>is_mset_set \<equiv> distinct_mset\<close>

lemma is_mset_set_def:
  \<open>is_mset_set X \<longleftrightarrow> (\<forall>x \<in># X. count X x = 1)\<close>
  by (auto simp add: distinct_mset_def)

lemma is_mset_setD[dest]: "is_mset_set X \<Longrightarrow> x \<in># X \<Longrightarrow> count X x = 1"
  unfolding is_mset_set_def by auto

lemma is_mset_setI[intro]:
  assumes "\<And>x. x \<in># X \<Longrightarrow> count X x = 1"
  shows "is_mset_set X"
  using assms unfolding is_mset_set_def by auto

lemma is_mset_set[simp]: "is_mset_set (mset_set X)"
  by (fact distinct_mset_mset_set)

lemma is_mset_set_add[simp]:
  "is_mset_set (X + {#x#}) \<longleftrightarrow> is_mset_set X \<and> x \<notin># X" (is "?L \<longleftrightarrow> ?R")
proof(intro iffI conjI)
  assume L: ?L
  with count_eq_zero_iff count_single show "is_mset_set X"
    unfolding is_mset_set_def
    by (metis (no_types, opaque_lifting) add_mset_add_single count_add_mset nat.inject set_mset_add_mset_insert union_single_eq_member)
  show "x \<notin># X"
  proof
    assume "x \<in># X"
    then have "count (X + {#x#}) x > 1" by auto
    with L show False by (auto simp: is_mset_set_def)
  qed
next
  assume R: ?R show ?L
  proof
    fix x' assume x': "x' \<in># X + {#x#}"
    show "count (X + {#x#}) x' = 1"
    proof(cases "x' \<in># X")
      case True with R have "count X x' = 1" by auto
        moreover from True R have "count {#x#} x' = 0" by auto
        ultimately show ?thesis by auto
    next
      case False then have "count X x' = 0" by (simp add: not_in_iff)
        with R x' show ?thesis by auto
    qed
  qed
qed

lemma mset_set_id:
  assumes "is_mset_set X"
  shows "mset_set (set_mset X) = X"
  using assms by (fact distinct_mset_set_mset_ident)

lemma is_mset_set_image:
  assumes "inj_on f (set_mset X)" and "is_mset_set X"
  shows "is_mset_set (image_mset f X)"
proof (cases X)
  case empty then show ?thesis by auto
next
  case (add x X)
    define X' where "X' \<equiv> add_mset x X"
    with assms add have inj:"inj_on f (set_mset X')"
          and X': "is_mset_set X'" by auto
  show ?thesis
  proof(unfold add, intro is_mset_setI, fold X'_def)
    fix y assume "y \<in># image_mset f X'"
    then have "y \<in> f ` set_mset X'" by auto
    with inj have "\<exists>!x'. x' \<in># X' \<and> y = f x'" by (meson imageE inj_onD)
    then obtain x' where x': "{x'. x' \<in># X' \<and> y = f x'} = {x'}" by auto
    then have "count (image_mset f X') y = count X' x'"
      by (simp add: count_image_mset')
    also from X' x' have "... = 1" by auto
    finally show "count (image_mset f X') y = 1".
  qed
qed

end


(*
    $Id: sol.thy,v 1.5 2012/08/13 15:59:05 webertj Exp $
    Author: Gerwin Klein
*)

header {* The Towers of Hanoi *}

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

text {*
We are given 3 pegs $A$, $B$ and $C$, and $n$ disks with a hole, such that no
two disks have the same diameter.  Initially all $n$ disks rest on peg $A$,
ordered according to their size, with the largest one at the bottom.  The aim
is to transfer all $n$ disks from $A$ to $C$ by a sequence of single-disk moves
such that we never place a larger disk on top of a smaller one.  Peg $B$ may be
used for intermediate storage.

\begin{center}
\includegraphics[width=0.8\textwidth]{Hanoi}
\end{center}

\medskip The pegs and moves can be modelled as follows:
*}

datatype peg = A | B | C

type_synonym move = "peg * peg"

text {*
Define a primitive recursive function

  @{text "move :: nat => peg => peg => move list"}

such that @{term move}$~n~a~b$ returns a list of (legal) moves that transfer
$n$ disks from peg $a$ to peg $c$.
*}

primrec other :: "peg \<Rightarrow> peg \<Rightarrow> peg" where
  "other A x = (if x = B then C else B)"
| "other B x = (if x = A then C else A)"
| "other C x = (if x = A then B else A)"

primrec move :: "nat \<Rightarrow> peg \<Rightarrow> peg \<Rightarrow> move list" where
  "move 0       src dst = []"
| "move (Suc n) src dst = (move n src (other src dst)) @ [(src,dst)] @ (move n (other src dst) dst)"

text {*
Show that this requires $2^n - 1$ moves:
*}

theorem "length (move n a b) = 2^n - 1"
(*<*) oops (*>*)

text {*
Hint: You need to strengthen the theorem for the induction to go through.
Beware: subtraction on natural numbers behaves oddly: $n - m = 0$ if $n \le m$.
*}

lemma "\<forall>x y. length (move n x y) = 2^n - 1"
  apply (induct n)
    apply simp
  apply auto
done

subsection {* Correctness *}

text {*
In the last section we introduced the towers of Hanoi and defined a function
@{term move} to generate the moves to solve the puzzle.  Now it is time to show
that @{term move} is correct.  This means that
\begin{itemize}
\item when executing the list of moves, the result is indeed the intended one,
      i.e.\ all disks are moved from one peg to another, and
\item all of the moves are legal, i.e.\ never is a larger disk placed on top of
      a smaller one.
\end{itemize}

Hint: This is a non-trivial undertaking.  The complexity of your proofs will
depend crucially on your choice of model, and you may have to revise your model
as you proceed with the proof.
*}

type_synonym
  config = "peg \<Rightarrow> nat list"

primrec lt :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "lt n [] = True"
| "lt n (x#xs) = (n < x \<and> lt n xs)"

primrec ordered :: "nat list \<Rightarrow> bool" where
  "ordered [] = True"
 | "ordered (x#xs) = (lt x xs \<and> ordered xs)"

definition hanoi :: "config \<Rightarrow> bool" where
  "hanoi cfg \<equiv> \<forall>s. ordered (cfg s)"

definition step :: "config \<Rightarrow> move \<Rightarrow> config option" where
  "step c x \<equiv> let (src,dst) = x in
    if c src = [] then None
    else let src' = tl (c src);
             m = hd (c src);
             dst' = m # (c dst);
             c' = (c (src:= src')) (dst:= dst')
         in if hanoi c' then Some c' else None"

primrec exec :: "config \<Rightarrow> move list \<Rightarrow> config option" where
  "exec c [] = Some c"
| "exec c (x#xs) = (let cfg' = step c x in if cfg' = None then None else exec (the cfg') xs)"

primrec tower :: "nat \<Rightarrow> nat list" where
  "tower 0 = []"
| "tower (Suc n) = tower n @ [Suc n]"

lemma "move 1 A C = [(A,C)]"
  by simp

lemma "move 2 A C = [(A, B), (A, C), (B, C)]"
  by (simp add: numeral_2_eq_2)

lemma "move 3 A C = [(A, C), (A, B), (C, B), (A, C), (B, A), (B, C), (A, C)]"
  by (simp add: numeral_3_eq_3)

lemma [simp]:
  "\<forall>cfg. exec cfg (a@b) = (let cfg' = exec cfg a in if cfg' = None then None else exec (the cfg') b)"
  by (induct a, auto simp add: Let_def)

lemma neq_Nil_snoC:
  "\<forall>n. length xs = Suc n \<longrightarrow> (\<exists>x' xs'. xs = xs' @ [x'])"
  apply (induct xs)
  apply simp
  apply clarsimp
  apply (case_tac xs)
   apply simp
  apply clarsimp
  done

lemma otherF [simp]: "x = other x y \<Longrightarrow> False"
  apply (cases x, auto split: split_if_asm)
  done

lemma [simp]: "x\<noteq>y \<Longrightarrow> other x (other x y) = y"
  apply (cases x)
  apply (cases y, auto)+
  done

lemma [simp]: "x\<noteq>y \<Longrightarrow> other (other x y) y = x"
  apply (cases x)
  apply (cases y, auto)+
  done

primrec gt :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "gt n [] = True"
| "gt n (x#xs) = (x < n \<and>  gt n xs)"

lemma [simp]:
  "lt n (a@b) = (lt n a \<and> lt n b)"
  apply (induct a)
  apply auto
  done

lemma [simp]:
  "gt n (a@b) = (gt n a \<and> gt n b)"
  apply (induct a)
  apply auto
done

lemma lt_mono [rule_format, simp]:
  "a < b \<longrightarrow> lt b xs \<longrightarrow> lt a xs"
  apply (induct xs)
  apply auto
done

lemma [simp]:
  "ordered (a@n#b) = (ordered a \<and> lt n b \<and> gt n a \<and> ordered b)"
  apply (induct a)
   apply simp
  apply auto
done

lemma gt_iff:
  "gt n xs = (\<forall>x \<in> set xs. x < n)"
  by (induct xs, auto)

lemma [simp]:
  "xs \<noteq> [] \<longrightarrow> last xs \<in> set xs"
  by (induct xs, auto)

lemma [simp]:
  "\<lbrakk>cfg src = ts' @ t' # xs; hanoi cfg; ts' \<noteq> []\<rbrakk> \<Longrightarrow> last ts' < t'"
  apply (unfold hanoi_def)
  apply (erule_tac x = src in allE)
  apply (clarsimp simp add: gt_iff)
done

lemma neq_other:
  "\<lbrakk> s \<noteq> src; s \<noteq> dst; src\<noteq>dst \<rbrakk> \<Longrightarrow> s = other src dst"
  apply (cases src, auto)
  apply (cases s, auto)
  apply (cases s, auto)
  apply (cases dst, auto)
  apply (cases s, auto)
  apply (cases s, auto)
  apply (cases dst, auto)
  apply (cases s, auto)
  apply (cases s, auto)
  apply (cases dst, auto)
  done

lemma ordered_appendI [rule_format]:
  "ordered a \<longrightarrow> lt t b \<longrightarrow> gt t a \<longrightarrow> ordered b \<longrightarrow> ordered (a@b)"
  by (induct a, auto)

lemma [simp]:
  "\<forall>cfg. exec cfg xs = Some cfg' \<longrightarrow> hanoi cfg \<longrightarrow> hanoi cfg'"
  apply (induct xs)
   apply simp
  apply (auto simp add: step_def Let_def split: split_if_asm)
done

lemma hanoi_lemma:
  "\<forall>cfg src dst t xs ys zs.
       cfg src = t @ xs \<longrightarrow> cfg dst = ys \<longrightarrow> cfg (other src dst) = zs \<longrightarrow>
       length t = n \<longrightarrow>
       hanoi cfg \<longrightarrow>
       lt (last t) ys \<longrightarrow> lt (last t) zs \<longrightarrow>
       src \<noteq> dst \<longrightarrow>
  (\<exists>cfg'. exec cfg (move n src dst) = Some cfg' \<and> cfg' src = xs \<and> cfg' dst = t @ ys \<and> cfg' (other src dst) = zs)"
apply (induct n)
 apply simp
apply clarsimp
apply (case_tac "n=0")
 apply (simp add: Let_def)
 apply (case_tac t)
  apply simp
 apply simp
 apply (rule conjI)
  apply (clarsimp simp add: step_def Let_def hanoi_def)
  apply (erule_tac x = src in allE)
  apply simp
 apply (clarsimp simp add: step_def Let_def)
apply clarsimp
apply (subgoal_tac "\<exists>t' ts'. t = ts' @ [t']")
 prefer 2
 apply (simp add: neq_Nil_snoC)
apply clarsimp
apply (frule spec, erule allE, erule_tac x = "other src dst" in allE, erule allE, erule allE, erule impE, assumption)
apply (erule impE, rule refl)
apply (erule impE, assumption)
apply simp
apply (subgoal_tac "last ts' < t'")
 apply (erule impE)
  apply (erule lt_mono, assumption)
 apply (erule impE)
  apply (erule lt_mono, assumption)
 apply (erule impE)
  apply rule
  apply (erule otherF)
 prefer 2
 apply simp
apply clarsimp
apply (clarsimp simp add: Let_def)
apply (rule conjI)
 apply (clarsimp simp add: step_def Let_def hanoi_def)
 apply (rule conjI)
  apply (erule_tac x=src in allE)
  apply clarsimp
 apply clarsimp
 apply (drule neq_other, assumption, assumption)
 apply simp
 apply (frule_tac x="other src dst" in spec)
 apply (drule_tac x="src" in spec)
 apply clarsimp
 apply (rule ordered_appendI, assumption+)
apply (clarsimp simp add: step_def Let_def)
apply (erule_tac x="cfg'(src := xs, dst := t' # cfg dst)" in allE)
apply (erule_tac x="other src dst" in allE)
apply (erule_tac x="dst" in allE)
apply (erule allE)+
apply (erule impE)
 apply simp
apply (erule impE, rule refl)
apply (erule impE)
 apply simp
apply (erule impE)
 apply simp
 apply (rule lt_mono)
 apply (subgoal_tac "last ts' < t'")
  prefer 2
  apply simp
 apply assumption+
apply (erule impE)
 apply (subgoal_tac "last ts' < t'")
  prefer 2
  apply simp
 apply (unfold hanoi_def)
 apply (erule_tac x = src in allE)
 apply (erule lt_mono)
 apply simp
apply clarsimp
done

lemma [simp]: "length (tower n) = n"
  by (induct n, auto)

lemma "lt 0 (tower n)"
  by (induct n, auto)

lemma gt_mono [rule_format, simp]: "x < y \<longrightarrow> gt x xs \<longrightarrow> gt y xs"
  apply (induct xs)
  apply auto
done

lemma [simp]: "gt (Suc n) (tower n)"
  apply (induct n)
  apply auto
  apply (rule gt_mono)
  defer
  apply assumption
  apply simp
done

lemma [simp]: "ordered (tower n)"
  apply (induct n)
  apply auto
done

lemma hanoi_start:
  "\<lbrakk> cfg A = tower n; cfg B = []; cfg C = [] \<rbrakk> \<Longrightarrow>
  hanoi cfg"
  apply (unfold hanoi_def)
  apply (rule allI)
  apply (case_tac s)
  apply auto
done

theorem hanoi:
  "\<lbrakk>cfg A = tower n;
    cfg B = [];
    cfg C = []\<rbrakk> \<Longrightarrow>
  \<exists>cfg'. exec cfg (move n A C) = Some cfg' \<and>
    cfg' A = [] \<and>
    cfg' B = [] \<and>
    cfg' C = tower n"
  apply (frule hanoi_start, assumption+)
  apply (insert hanoi_lemma [of n])
  apply (erule_tac x=cfg in allE)
  apply (erule_tac x=A in allE)
  apply (erule_tac x=C in allE)
  apply (erule_tac x="tower n" in allE)
  apply (erule allE)+
  apply (erule impE)
   apply simp
  apply (erule impE, assumption)+
  apply (erule impE, simp)
  apply clarsimp
done

(*<*) end (*>*)


theory Lists1_4
imports Main
begin

primrec first_pos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"
where
  "first_pos P [] = 0"
| "first_pos P (x#xs) = (if (P x) then 0 else (Suc (first_pos P xs)))"

lemma "first_pos (\<lambda>x. x=3) [1::nat,3,5,3,1] = 1"
  by auto

lemma "first_pos (\<lambda>x. x > 4) [1::nat, 3, 5, 7] = 2"
  by auto

lemma "first_pos (\<lambda>x. (length x) > 1) [[], [1, 2], [3]] = 1"
  by auto

(* different from text *)
lemma "list_all (\<lambda>x. \<not>P x) xs \<longrightarrow> first_pos P xs = length xs"
  apply (induct xs)
  apply simp+
done

value "take 3 [1::int,1,2,3]"

lemma "list_all (\<lambda>x. \<not>P x) (take (first_pos P xs) xs)"
  apply (induct xs)
  apply simp+
done

lemma "first_pos (\<lambda>x. P x \<or> Q x) xs = (min (first_pos P xs) (first_pos Q xs))"
  apply (induct xs)
  apply simp+
done

lemma "first_pos (\<lambda>x. P x \<and> Q x) xs \<ge> (max (first_pos P xs) (first_pos Q xs))"
  apply (induct xs)
  apply simp+
done

(* different from text *)
lemma "(list_all P xs) \<longrightarrow> (list_all Q xs) \<longrightarrow> (first_pos P xs \<ge> first_pos Q xs)"
  apply (induct xs)
  apply simp+
done

primrec count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"
where
  "count P [] = 0"
| "count P (x#xs) = (if (P x) then Suc (count P xs) else count P xs)"

value "count (\<lambda>x. x>2) [3::nat]"
value "count (\<lambda>x. x>2) [1::nat,2,3,4,5]"

lemma count_append: "count P (xs@ys) = count P xs + count P ys"
  apply (induct xs)
  apply simp+
done

lemma "count P xs = count P (rev xs)"
  apply (induct xs)
  apply (simp add:count_append)+
done

value "filter (\<lambda>x. x>2) [1,2,3,4,5::int]"

lemma "length (filter P xs) = count P xs"
  apply (induct xs)
  apply simp+
done

end


(* Author: Tobias Nipkow *)

header "Extended Regular Expressions"

theory Regular_Exp2
imports Regular_Set
begin

datatype (atoms: 'a) rexp =
  is_Zero: Zero |
  is_One: One |
  Atom 'a |
  Plus "('a rexp)" "('a rexp)" |
  Times "('a rexp)" "('a rexp)" |
  Star "('a rexp)" |
  Not "('a rexp)" |
  Inter "('a rexp)" "('a rexp)"

context
fixes S :: "'a set"
begin

primrec lang :: "'a rexp => 'a lang" where
"lang Zero = {}" |
"lang One = {[]}" |
"lang (Atom a) = {[a]}" |
"lang (Plus r s) = (lang r) Un (lang s)" |
"lang (Times r s) = conc (lang r) (lang s)" |
"lang (Star r) = star(lang r)" |
"lang (Not r) = lists S - lang r" |
"lang (Inter r s) = (lang r Int lang s)"

end

lemma lang_subset_lists: "atoms r \<subseteq> S \<Longrightarrow> lang S r \<subseteq> lists S"
by(induction r)(auto simp: conc_subset_lists star_subset_lists)

primrec nullable :: "'a rexp \<Rightarrow> bool" where
"nullable Zero = False" |
"nullable One = True" |
"nullable (Atom c) = False" |
"nullable (Plus r1 r2) = (nullable r1 \<or> nullable r2)" |
"nullable (Times r1 r2) = (nullable r1 \<and> nullable r2)" |
"nullable (Star r) = True" |
"nullable (Not r) = (\<not> (nullable r))" |
"nullable (Inter r s) = (nullable r \<and> nullable s)"

lemma nullable_iff: "nullable r \<longleftrightarrow> [] \<in> lang S r"
by (induct r) (auto simp add: conc_def split: if_splits)

end


section \<open>Algorithms to compute all complex and real roots of a cubic polynomial\<close>

theory Cubic_Polynomials
  imports
    Cardanos_Formula
    Complex_Roots
begin

text \<open>The real case where a result is only delivered if the discriminant is negative\<close>

definition solve_depressed_cubic_Cardano_real :: "real \<Rightarrow> real \<Rightarrow> real option" where
  "solve_depressed_cubic_Cardano_real e f = (
    if e = 0 then Some (root 3 (-f)) else
     let v = - (e ^ 3 / 27) in
     case rroots2 [:v,f,1:] of
       [u,_] \<Rightarrow> let rt = root 3 u in Some (rt - e / (3 * rt))
     | _ \<Rightarrow> None)"

lemma solve_depressed_cubic_Cardano_real:
  assumes "solve_depressed_cubic_Cardano_real e f = Some y"
  shows "{y. y^3 + e * y + f = 0} = {y}"
proof (cases "e = 0")
  case True
  have "{y. y^3 + e * y + f = 0} = {y. y^3 = -f}" unfolding True
    by (auto simp add: field_simps)
  also have "\<dots> = {root 3 (-f)}"
    using odd_real_root_unique[of 3 _ "-f"] odd_real_root_pow[of 3] by auto
  also have "root 3 (-f) = y" using assms unfolding True solve_depressed_cubic_Cardano_real_def
    by auto
  finally show ?thesis .
next
  case False
  define v where "v = - (e ^ 3 / 27)"
  note * = assms[unfolded solve_depressed_cubic_Cardano_real_def Let_def, folded v_def]
  let ?rr = "rroots2 [:v,f,1:]"
  from * False obtain u u' where rr: "?rr = [u,u']"
    by (cases ?rr; cases "tl ?rr"; cases "tl (tl ?rr)"; auto split: if_splits)
  from *[unfolded rr list.simps] False
  have y: "y = root 3 u - e / (3 * root 3 u)" by auto
  have "u \<in> set (rroots2 [:v,f,1:])" unfolding rr by auto
  also have "set (rroots2 [:v,f,1:]) = {u. poly [:v,f,1:] u = 0}"
    by (subst rroots2, auto)
  finally have u: "u^2 + f * u + v = 0" by (simp add: field_simps power2_eq_square)
  note Cardano = solve_cubic_depressed_Cardano_real[OF False v_def u]
  have 2: "2 = Suc (Suc 0)" by simp
  from rr have 0: "f\<^sup>2 - 4 * v \<noteq> 0" unfolding rroots2_def Let_def
    by (auto split: if_splits simp: 2)
  hence 0: "discriminant_cubic_depressed e f \<noteq> 0"
    unfolding discriminant_cubic_depressed_def v_def by auto
  show ?thesis using Cardano(1) Cardano(2)[OF 0] unfolding y[symmetric] by blast
qed

text \<open>The complex case\<close>

definition solve_depressed_cubic_complex :: "complex \<Rightarrow> complex \<Rightarrow> complex list" where
  "solve_depressed_cubic_complex e f = (let
          ys = (if e = 0 then all_croots 3 (- f) else (let
       u = hd (croots2 [: - (e ^ 3 / 27) ,f,1:]);
       zs = all_croots 3 u
       in map (\<lambda> z. z - e / (3 * z)) zs))
      in remdups ys)"

lemma solve_depressed_cubic_complex_code[code]:
  "solve_depressed_cubic_complex e f = (let
          ys = (if e = 0 then all_croots 3 (- f) else (let
            f2 = f / 2;
            u = - f2 + csqrt (f2^2 + e ^ 3 / 27);
            zs = all_croots 3 u
            in map (\<lambda> z. z - e / (3 * z)) zs))
      in remdups ys)"
  unfolding solve_depressed_cubic_complex_def Let_def croots2_def
  by (simp add: numeral_2_eq_2)

lemma solve_depressed_cubic_complex: "y \<in> set (solve_depressed_cubic_complex e f)
  \<longleftrightarrow> (y^3 + e * y + f = 0)"
proof (cases "e = 0")
  case True
  thus ?thesis by (simp add: solve_depressed_cubic_complex_def Let_def all_croots eq_neg_iff_add_eq_0)
next
  case e0: False
  hence id: "(if e = 0 then x else y) = y" for x y :: "complex list" by simp
  define v where "v = - (e ^ 3 / 27)"
  define p where "p = [:v, f, 1:]"
  have p2: "degree p = 2" unfolding p_def by auto
  let ?u = "hd (croots2 p)"
  define u where "u = ?u"
  have "u \<in> set (croots2 p)" unfolding croots2_def Let_def u_def by auto
  with croots2[OF p2] have "poly p u = 0" by auto
  hence u: "u^2 + f * u + v = 0" unfolding p_def
    by (simp add: field_simps power2_eq_square)
  note cube_roots = all_croots[of 3, simplified]
  show ?thesis unfolding solve_depressed_cubic_complex_def Let_def set_remdups set_map id cube_roots
    unfolding v_def[symmetric] p_def[symmetric] set_concat set_map
      u_def[symmetric]
  proof -
    have p: "{x. poly p x = 0} = {u. u^2 + f * u + v = 0}" unfolding p_def by (auto simp: field_simps power2_eq_square)
    have cube: "\<Union> (set ` all_croots 3 ` {x. poly p x = 0}) = {z. \<exists> u. u\<^sup>2 + f * u + v = 0 \<and> z ^ 3 = u}"
      unfolding p by (auto simp: cube_roots)
    show "(y \<in> (\<lambda>z. z - e / (3 * z)) ` {y. y ^ 3 = u}) = (y ^ 3 + e * y + f = 0)"
      using solve_cubic_depressed_Cardano_complex[OF e0 v_def u] cube by blast
  qed
qed

text \<open>For the general real case, we first try Cardano with negative discrimiant and only if it is not applicable,
   then we go for the calculation using complex numbers. Note that for for non-negative delta
   no filter is required to identify the real roots from the list of complex roots, since in that case we
   already know that all roots are real.\<close>
definition solve_depressed_cubic_real :: "real \<Rightarrow> real \<Rightarrow> real list" where
  "solve_depressed_cubic_real e f = (case solve_depressed_cubic_Cardano_real e f
      of Some y \<Rightarrow> [y]
       | None \<Rightarrow> map Re (solve_depressed_cubic_complex (of_real e) (of_real f)))"

lemma solve_depressed_cubic_real_code[code]: "solve_depressed_cubic_real e f =
  (if e = 0 then [root 3 (-f)] else
   let v = e ^ 3 / 27;
       f2 = f / 2;
       f2v = f2^2 + v in
   if f2v > 0 then
     let u = -f2 + sqrt f2v;
         rt = root 3 u
      in [rt - e / (3 * rt)]
  else
  let ce3 = of_real e / 3;
      u = - of_real f2 + csqrt (of_real f2v) in
   map Re (remdups (map (\<lambda>rt. rt - ce3 / rt) (all_croots 3 u))))"
proof -
  have id: "rroots2 [:v, f, 1:] = (let
     f2 = f / 2;
     bac = f2\<^sup>2 - v in
     if bac = 0 then [- f2] else
     if bac < 0 then [] else let e = sqrt bac in [- f2 + e, - f2 - e])" for v
    unfolding rroots2_def Let_def numeral_2_eq_2 by auto
  define foo :: "real \<Rightarrow> real \<Rightarrow> real option" where
    "foo f2v f2 = (case (if f2v = 0 then [- f2] else []) of [] \<Rightarrow> None | _ \<Rightarrow> None)"
    for f2v f2
  have "solve_depressed_cubic_real e f = (if e = 0 then [root 3 (-f)] else
   let v = e ^ 3 / 27;
       f2 = f / 2;
       f2v = f2\<^sup>2 + v in
   if f2v > 0 then
     let u = -f2 + sqrt f2v;
         rt = root 3 u
      in [rt - e / (3 * rt)]
  else
  (case foo f2v f2 of
     None \<Rightarrow> let u = - cor f2 + csqrt (cor f2v) in
   map Re
    (remdups (map (\<lambda>z. z - cor e / (3 * z)) (all_croots 3 u)))
   | Some y \<Rightarrow> []))"
    unfolding solve_depressed_cubic_real_def solve_depressed_cubic_Cardano_real_def
      solve_depressed_cubic_complex_code
      Let_def id foo_def
    by (auto split: if_splits)
  also have id: "foo f2v f2 = None"
    for f2v f2 unfolding foo_def by auto
  ultimately show ?thesis by (auto simp: Let_def)
qed

lemma solve_depressed_cubic_real: "y \<in> set (solve_depressed_cubic_real e f)
  \<longleftrightarrow> (y^3 + e * y + f = 0)"
proof (cases "solve_depressed_cubic_Cardano_real e f")
  case (Some x)
  show ?thesis unfolding solve_depressed_cubic_real_def Some option.simps
    using solve_depressed_cubic_Cardano_real[OF Some] by auto
next
  case None
  from this[unfolded solve_depressed_cubic_Cardano_real_def Let_def rroots2_def]
  have disc: "0 \<le> discriminant_cubic_depressed e f" unfolding discriminant_cubic_depressed_def
    by (auto split: if_splits simp: numeral_2_eq_2)
  let ?c = "complex_of_real"
  let ?y = "?c y"
  let ?e = "?c e"
  let ?f = "?c f"
  have sub: "set (solve_depressed_cubic_complex ?e ?f) \<subseteq> \<real>"
  proof
    fix y
    assume y: "y \<in> set (solve_depressed_cubic_complex ?e ?f)"
    show "y \<in> \<real>"
      by (rule solve_cubic_depressed_Cardano_all_real_roots[OF disc y[unfolded solve_depressed_cubic_complex]])
  qed
  have "y^3 + e * y + f = 0 \<longleftrightarrow> (?c (y^3 + e * y + f) = ?c 0)" unfolding of_real_eq_iff by simp
  also have "\<dots> \<longleftrightarrow> ?y^3 + ?e * ?y + ?f = 0" by simp
  also have "\<dots> \<longleftrightarrow> ?y \<in> set (solve_depressed_cubic_complex ?e ?f)"
    unfolding solve_depressed_cubic_complex ..
  also have "\<dots> \<longleftrightarrow> y \<in> Re ` set (solve_depressed_cubic_complex ?e ?f)" using sub by force
  finally show ?thesis unfolding solve_depressed_cubic_real_def None by auto
qed

text \<open>Combining the various algorithms\<close>

lemma degree3_coeffs: "degree p = 3 \<Longrightarrow>
  \<exists> a b c d. p = [: d, c, b, a :] \<and> a \<noteq> 0"
  by (metis One_nat_def Suc_1 degree2_coeffs degree_pCons_eq_if nat.inject numeral_3_eq_3 pCons_cases zero_neq_numeral)

definition roots3_generic :: "('a :: field_char_0 \<Rightarrow> 'a \<Rightarrow> 'a list) \<Rightarrow> 'a poly \<Rightarrow> 'a list" where
  "roots3_generic depressed_solver p = (let
     cs = coeffs p;
     a = cs ! 3; b = cs ! 2; c = cs ! 1; d = cs ! 0;
     a3 = 3 * a;
     ba3 = b / a3;
     b2 = b * b;
     b3 = b2 * b;
     e = (c - b2 / a3) / a;
     f = (d + 2 * b3 / (27 * a^2) - b * c / a3) / a;
     roots = depressed_solver e f
     in map (\<lambda> y. y - ba3) roots)"

lemma roots3_generic: assumes deg: "degree p = 3"
  and solver: "\<And> e f y. y \<in> set (depressed_solver e f) \<longleftrightarrow> y^3 + e * y + f = 0"
  shows "set (roots3_generic depressed_solver p) = {x. poly p x = 0}"
proof -
  note powers = field_simps power3_eq_cube power2_eq_square
  from degree3_coeffs[OF deg] obtain a b c d where
    p: "p = [:d,c,b,a:]" and a: "a \<noteq> 0" by auto
  have coeffs: "coeffs p ! 3 = a" "coeffs p ! 2 = b" "coeffs p ! 1 = c" "coeffs p ! 0 = d"
    unfolding p using a by auto
  define e where "e = (c - b^2 / (3 * a)) / a"
  define f where "f = (d + 2 * b^3 / (27 * a^2) - b * c / (3 * a)) / a"
  note def = roots3_generic_def[of depressed_solver p, unfolded Let_def coeffs,
      folded power3_eq_cube, folded power2_eq_square,  folded e_def f_def]
  {
    fix x :: 'a
    define y where "y = x + b / (3 * a)"
    have xy: "x = y - b / (3 * a)" unfolding y_def by auto
    have "poly p x = 0 \<longleftrightarrow> a * x^3 + b * x^2 + c * x + d = 0" unfolding p
      by (simp add: powers)
    also have "\<dots> \<longleftrightarrow> (y ^ 3 + e * y + f = 0)"
      unfolding to_depressed_cubic[OF a xy e_def f_def] ..
    also have "\<dots> \<longleftrightarrow> y \<in> set (depressed_solver e f)"
      unfolding solver ..
    also have "\<dots> \<longleftrightarrow> x \<in> set (roots3_generic depressed_solver p)" unfolding xy def by auto
    finally have "poly p x = 0 \<longleftrightarrow> x \<in> set (roots3_generic depressed_solver p)" by auto
  }
  thus ?thesis by auto
qed

definition croots3 :: "complex poly \<Rightarrow> complex list" where
  "croots3 = roots3_generic solve_depressed_cubic_complex"

lemma croots3: assumes deg: "degree p = 3"
  shows "set (croots3 p) = { x. poly p x = 0}"
  unfolding croots3_def by (rule roots3_generic[OF deg solve_depressed_cubic_complex])

definition rroots3 :: "real poly \<Rightarrow> real list" where
  "rroots3 = roots3_generic solve_depressed_cubic_real"

lemma rroots3: assumes deg: "degree p = 3"
  shows "set (rroots3 p) = { x. poly p x = 0}"
  unfolding rroots3_def by (rule roots3_generic[OF deg solve_depressed_cubic_real])

end