(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Omega\<close>

theory OrdinalOmega
imports OrdinalFix
begin

subsection \<open>Embedding naturals in the ordinals\<close>

primrec ordinal_of_nat :: "nat \<Rightarrow> ordinal"
where
  "ordinal_of_nat 0 = 0"
| "ordinal_of_nat (Suc n) = oSuc (ordinal_of_nat n)"

lemma strict_mono_ordinal_of_nat: "strict_mono ordinal_of_nat"
by (rule strict_mono_natI, simp)

lemma not_limit_ordinal_nat: "\<not> limit_ordinal (ordinal_of_nat n)"
by (induct n) simp_all

lemma ordinal_of_nat_eq [simp]:
"(ordinal_of_nat x = ordinal_of_nat y) = (x = y)"
by (rule strict_mono_cancel_eq[OF strict_mono_ordinal_of_nat])

lemma ordinal_of_nat_less [simp]:
"(ordinal_of_nat x < ordinal_of_nat y) = (x < y)"
by (rule strict_mono_cancel_less[OF strict_mono_ordinal_of_nat])

lemma ordinal_of_nat_le [simp]:
"(ordinal_of_nat x \<le> ordinal_of_nat y) = (x \<le> y)"
by (rule strict_mono_cancel_le[OF strict_mono_ordinal_of_nat])

lemma ordinal_of_nat_plus [simp]:
"ordinal_of_nat x + ordinal_of_nat y = ordinal_of_nat (x + y)"
by (induct y) simp_all

lemma ordinal_of_nat_times [simp]:
"ordinal_of_nat x * ordinal_of_nat y = ordinal_of_nat (x * y)"
by (induct y) (simp_all add: add.commute)

lemma ordinal_of_nat_exp [simp]:
"ordinal_of_nat x ** ordinal_of_nat y = ordinal_of_nat (x ^ y)"
by (induct y, cases x) (simp_all add: mult.commute)

lemma oSuc_plus_ordinal_of_nat:
"oSuc x + ordinal_of_nat n = oSuc (x + ordinal_of_nat n)"
by (induct n) simp_all

lemma less_ordinal_of_nat:
"(x < ordinal_of_nat n) = (\<exists>m. x = ordinal_of_nat m \<and> m < n)"
 apply (induct n)
  apply simp
 apply (safe, simp_all del: ordinal_of_nat.simps)
 apply (auto elim: less_oSucE)
done

lemma le_ordinal_of_nat:
"(x \<le> ordinal_of_nat n) = (\<exists>m. x = ordinal_of_nat m \<and> m \<le> n)"
by (auto simp add: order_le_less less_ordinal_of_nat)

subsection \<open>Omega, the least limit ordinal\<close>

definition
  omega :: "ordinal"  ("\<omega>") where
  "omega = oLimit ordinal_of_nat"

lemma less_omegaD: "x < \<omega> \<Longrightarrow> \<exists>n. x = ordinal_of_nat n"
 apply (unfold omega_def)
 apply (drule less_oLimitD)
 apply (clarsimp simp add: less_ordinal_of_nat)
done

lemma omega_leI: "\<forall>n. ordinal_of_nat n \<le> x \<Longrightarrow> \<omega> \<le> x"
by (unfold omega_def, erule oLimit_leI)

lemma nat_le_omega [simp]: "ordinal_of_nat n \<le> \<omega>"
by (unfold omega_def, rule le_oLimit)

lemma nat_less_omega [simp]: "ordinal_of_nat n < \<omega>"
 apply (rule_tac y="ordinal_of_nat (Suc n)" in order_less_le_trans, simp)
 apply (rule nat_le_omega)
done

lemma zero_less_omega [simp]: "0 < \<omega>"
by (cut_tac n=0 in nat_less_omega, simp)

lemma limit_ordinal_omega: "limit_ordinal \<omega>"
 apply (rule limit_ordinalI[rule_format], simp)
 apply (drule less_omegaD, clarify)
 apply (subgoal_tac "ordinal_of_nat (Suc n) < \<omega>", simp)
 apply (simp only: nat_less_omega)
done

lemma Least_limit_ordinal: "(LEAST x. limit_ordinal x) = \<omega>"
 apply (rule Least_equality)
  apply (rule limit_ordinal_omega)
 apply (erule contrapos_pp)
 apply (simp add: linorder_not_le)
 apply (drule less_omegaD, erule exE)
 apply (simp add: not_limit_ordinal_nat)
done

lemma "range f = range ordinal_of_nat \<Longrightarrow> oLimit f = \<omega>"
 apply (rule order_antisym)
  apply (rule oLimit_leI, clarify)
  apply (drule equalityD1)
  apply (drule_tac c="f n" in subsetD, simp)
  apply clarsimp
 apply (rule omega_leI, clarify)
 apply (drule equalityD2)
 apply (drule_tac c="ordinal_of_nat n" in subsetD, simp)
 apply clarsimp
done

subsection \<open>Arithmetic properties of @{term \<omega>}\<close>

lemma oSuc_less_omega [simp]: "(oSuc x < \<omega>) = (x < \<omega>)"
by (rule oSuc_less_limit_ordinal[OF limit_ordinal_omega])

lemma oSuc_plus_omega [simp]: "oSuc x + \<omega> = x + \<omega>"
 apply (simp add: omega_def)
 apply (rule oLimit_eqI)
  apply (rule_tac x="Suc n" in exI)
  apply (simp add: oSuc_plus_ordinal_of_nat)
 apply (rule_tac x=n in exI)
 apply (simp add: oSuc_plus_ordinal_of_nat order_less_imp_le)
done

lemma ordinal_of_nat_plus_omega [simp]:
"ordinal_of_nat n + \<omega> = \<omega>"
by (induct n) simp_all

lemma ordinal_of_nat_times_omega [simp]:
"0 < k \<Longrightarrow> ordinal_of_nat k * \<omega> = \<omega>"
 apply (simp add: omega_def)
 apply (rule oLimit_eqI)
  apply (rule_tac exI, rule order_refl)
 apply (rule_tac x=n in exI, simp)
done

lemma ordinal_plus_times_omega: "x + x * \<omega> = x * \<omega>"
 apply (subgoal_tac "x + x * \<omega> = x * (1 + \<omega>)", simp)
 apply (simp del: oSuc_plus_omega add: ordinal_times_distrib)
done

lemma ordinal_plus_absorb: "x * \<omega> \<le> y \<Longrightarrow> x + y = y"
 apply (drule ordinal_plus_minus2)
 apply (erule subst)
 apply (simp only: ordinal_plus_assoc[symmetric] ordinal_plus_times_omega)
done

lemma ordinal_less_plusL: "y < x * \<omega> \<Longrightarrow> y < x + y"
 apply (case_tac "x = 0", simp_all)
 apply (drule ordinal_div_less)
 apply (drule less_omegaD, clarify)
 apply (rule_tac y="x * (1 + ordinal_of_nat n)" in order_less_le_trans)
  apply (simp add: oSuc_plus_ordinal_of_nat)
  apply (erule subst)
  apply (erule ordinal_less_times_div_plus)
 apply (simp add: ordinal_times_distrib)
 apply (erule subst)
 apply (rule ordinal_times_div_le)
done

lemma ordinal_plus_absorb_iff: "(x + y = y) = (x * \<omega> \<le> y)"
 apply safe
  apply (rule ccontr, simp add: linorder_not_le)
  apply (drule ordinal_less_plusL, simp)
 apply (erule ordinal_plus_absorb)
done

lemma ordinal_less_plusL_iff: "(y < x + y) = (y < x * \<omega>)"
 apply safe
  apply (rule ccontr, simp add: linorder_not_less)
  apply (drule ordinal_plus_absorb, simp)
 apply (erule ordinal_less_plusL)
done

subsection \<open>Additive principal ordinals\<close>

locale additive_principal =
  fixes a :: ordinal
  assumes not_0:  "0 < a"
  assumes sum_eq: "\<And>b. b < a \<Longrightarrow> b + a = a"

lemma (in additive_principal) sum_less:
"\<lbrakk>x < a; y < a\<rbrakk> \<Longrightarrow> x + y < a"
by (drule sum_eq, erule subst, simp)

lemma (in additive_principal) times_nat_less:
"x < a \<Longrightarrow> x * ordinal_of_nat n < a"
 apply (induct_tac n)
  apply (simp add: not_0)
 apply (simp add: sum_less)
done

lemma not_additive_principal_0: "\<not> additive_principal 0"
by (clarify, drule additive_principal.not_0, simp)

lemma additive_principal_oSuc:
"additive_principal (oSuc a) = (a = 0)"
 apply safe
  apply (rule ccontr, simp)
  apply (subgoal_tac "a + oSuc 0 < oSuc a", simp)
  apply (erule additive_principal.sum_less, simp_all)
 apply (simp add: additive_principal_def)
done

lemma additive_principal_intro2 [rule_format]:
assumes not_0: "0 < a"
shows "(\<forall>x<a. \<forall>y<a. x + y < a) \<longrightarrow> additive_principal a"
 apply (simp add: additive_principal_def not_0)
 apply (rule_tac a=a in oLimit_induct)
   apply simp
  apply clarsimp
  apply (drule_tac x=x in spec, simp)
  apply (drule_tac x=1 in spec, simp)
  apply (simp add: linorder_not_less)
 apply clarsimp
 apply (rule order_antisym)
  apply (rule oLimit_leI, clarify)
  apply (rule order_less_imp_le)
  apply (simp add: strict_mono_less_oLimit)
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply (rule ordinal_le_plusL)
done

lemma additive_principal_1: "additive_principal (oSuc 0)"
by (simp add: additive_principal_def)

lemma additive_principal_omega: "additive_principal \<omega>"
 apply (rule additive_principal.intro)
  apply (rule zero_less_omega)
 apply (drule less_omegaD, clarify)
 apply (rule ordinal_of_nat_plus_omega)
done

lemma additive_principal_times_omega:
"0 < x \<Longrightarrow> additive_principal (x * \<omega>)"
 apply (rule additive_principal.intro)
  apply simp
 apply (simp add: omega_def)
 apply (drule less_oLimitD, clarify, rename_tac k)
 apply (drule_tac x=b in order_less_imp_le)
 apply (rule oLimit_eqI)
  apply (rule_tac x="k + n" in exI)
  apply (erule order_trans[OF ordinal_plus_monoL])
  apply (simp add: ordinal_times_distrib[symmetric])
 apply (rule_tac x=n in exI, simp)
done

lemma additive_principal_oLimit:
"\<forall>n. additive_principal (f n) \<Longrightarrow> additive_principal (oLimit f)"
 apply (rule additive_principal.intro)
  apply (rule_tac n=0 in less_oLimitI)
  apply (simp add: additive_principal.not_0)
 apply simp
 apply (drule less_oLimitD, clarify, rename_tac k)
 apply (rule oLimit_eqI)
  apply (rule_tac x="f n" and y = "f k" in linorder_le_cases)
   apply (rule_tac x=k in exI)
   apply (rule_tac y="b + f k" in order_trans, simp)
   apply (simp add: additive_principal.sum_eq)
  apply (rule_tac x=n in exI)
  apply (drule order_less_le_trans, assumption)
  apply (simp add: additive_principal.sum_eq)
 apply (rule_tac x=n in exI, simp)
done

lemma additive_principal_omega_exp: "additive_principal (\<omega> ** x)"
 apply (rule_tac a=x in oLimit_induct)
   apply (simp add: additive_principal_1)
  apply (simp add: additive_principal_times_omega)
 apply (simp add: additive_principal_oLimit)
done

lemma (in additive_principal) omega_exp: "\<exists>x. a = \<omega> ** x"
 apply (subgoal_tac "\<exists>x. \<omega> ** x \<le> a \<and> a < \<omega> ** (oSuc x)")
  prefer 2
  apply (rule normal.oInv_ex)
   apply (rule normal_exp, simp)
  apply (simp add: oSuc_le_eq_less not_0)
 apply (auto simp add: order_le_less)
 apply (subgoal_tac "a < a", simp)
 apply (rule order_less_trans)
  apply (rule_tac y="\<omega> ** x" in ordinal_less_times_div_plus)
  apply simp
 apply (drule ordinal_div_less)
 apply (drule less_omegaD, clarify)
 apply (drule_tac n="Suc n" in times_nat_less)
 apply simp
done

lemma additive_principal_iff:
"additive_principal a = (\<exists>x. a = \<omega> ** x)"
by (auto intro: additive_principal_omega_exp
                additive_principal.omega_exp)

lemma absorb_omega_exp:
"x < \<omega> ** a \<Longrightarrow> x + \<omega> ** a = \<omega> ** a"
by (rule additive_principal.sum_eq[OF additive_principal_omega_exp])

lemma absorb_omega_exp2: "a < b \<Longrightarrow> \<omega> ** a + \<omega> ** b = \<omega> ** b"
by (rule absorb_omega_exp, simp add: ordinal_exp_strict_monoR)

subsection \<open>Cantor normal form\<close>

lemma cnf_lemma: "x > 0 \<Longrightarrow> x - \<omega> ** oLog \<omega> x < x"
  apply (subst ordinal_minus_less_eq)
   apply (erule ordinal_exp_oLog_le, simp)
  apply (rule ordinal_less_plusL)
  apply (rule ordinal_less_exp_oLog, simp)
  done

primrec from_cnf where
  "from_cnf []       = 0"
  | "from_cnf (x # xs) = \<omega> ** x + from_cnf xs"

function to_cnf where
 [simp del]: "to_cnf x = (if x = 0 then [] else
    oLog \<omega> x # to_cnf (x - \<omega> ** oLog \<omega> x))"
by pat_completeness auto

termination by (relation "{(x, y). x < y}")
  (simp_all add: wf cnf_lemma)

lemma to_cnf_0 [simp]: "to_cnf 0 = []"
by (simp add: to_cnf.simps)

lemma to_cnf_not_0:
"0 < x \<Longrightarrow> to_cnf x = oLog \<omega> x # to_cnf (x - \<omega> ** oLog \<omega> x)"
by (simp add: to_cnf.simps[of x])

lemma to_cnf_eq_Cons: "to_cnf x = a # list \<Longrightarrow> a = oLog \<omega> x"
by (case_tac "x = 0", simp, simp add: to_cnf_not_0)

lemma to_cnf_inverse: "from_cnf (to_cnf x) = x"
 apply (rule wf_induct[OF wf], simp)
 apply (case_tac "x = 0", simp_all)
 apply (simp add: to_cnf_not_0)
 apply (simp add: cnf_lemma)
 apply (rule ordinal_plus_minus2)
 apply (erule ordinal_exp_oLog_le, simp)
done

primrec normalize_cnf where
  normalize_cnf_Nil: "normalize_cnf [] = []"
  | normalize_cnf_Cons: "normalize_cnf (x # xs) =
      (case xs of [] \<Rightarrow> [x] | y # ys \<Rightarrow>
        (if x < y then [] else [x]) @ normalize_cnf xs)"

lemma from_cnf_normalize_cnf: "from_cnf (normalize_cnf xs) = from_cnf xs"
 apply (induct_tac xs, simp_all)
 apply (case_tac list, simp, clarsimp simp del: normalize_cnf_Cons)
 apply (simp add: ordinal_plus_assoc[symmetric] absorb_omega_exp2)
done

lemma normalize_cnf_to_cnf: "normalize_cnf (to_cnf x) = to_cnf x"
 apply (rule_tac a=x in wf_induct[OF wf], simp)
 apply (case_tac "x = 0", simp_all)
 apply (drule spec, drule mp, erule cnf_lemma)
 apply (simp add: to_cnf_not_0)
 apply (case_tac "to_cnf (x - \<omega> ** oLog \<omega> x)", simp_all)
 apply (drule to_cnf_eq_Cons, simp add: linorder_not_less)
 apply (rule ordinal_oLog_monoR)
 apply (rule order_less_imp_le)
 apply (erule cnf_lemma)
done

text "alternate form of CNF"

lemma cnf2_lemma:
"0 < x \<Longrightarrow> x mod \<omega> ** oLog \<omega> x < x"
 apply (rule order_less_le_trans)
  apply (rule ordinal_mod_less, simp)
 apply (erule ordinal_exp_oLog_le, simp)
done

primrec from_cnf2 where
  "from_cnf2 []       = 0"
  | "from_cnf2 (x # xs) = \<omega> ** fst x * ordinal_of_nat (snd x) + from_cnf2 xs"

function to_cnf2 where
  [simp del]: "to_cnf2 x = (if x = 0 then [] else
    (oLog \<omega> x, inv ordinal_of_nat (x div (\<omega> ** oLog \<omega> x)))
      # to_cnf2 (x mod (\<omega> ** oLog \<omega> x)))"
by pat_completeness auto

termination by (relation "{(x,y). x < y}")
  (simp_all add: wf cnf2_lemma)

lemma to_cnf2_0 [simp]: "to_cnf2 0 = []"
by (simp add: to_cnf2.simps)

lemma to_cnf2_not_0:
"0 < x \<Longrightarrow> to_cnf2 x =
  (oLog \<omega> x, inv ordinal_of_nat (x div (\<omega> ** oLog \<omega> x)))
     # to_cnf2 (x mod (\<omega> ** oLog \<omega> x))"
by (simp add: to_cnf2.simps[of x])

lemma to_cnf2_eq_Cons: "to_cnf2 x = (a,b) # list \<Longrightarrow> a = oLog \<omega> x"
by (case_tac "x = 0", simp, simp add: to_cnf2_not_0)

lemma ordinal_of_nat_of_ordinal:
"x < \<omega> \<Longrightarrow> ordinal_of_nat (inv ordinal_of_nat x) = x"
 apply (rule f_inv_into_f)
 apply (simp add: image_def)
 apply (erule less_omegaD)
done

lemma to_cnf2_inverse: "from_cnf2 (to_cnf2 x) = x"
 apply (rule wf_induct[OF wf], simp)
 apply (case_tac "x = 0", simp_all)
 apply (simp add: to_cnf2_not_0)
 apply (simp add: cnf2_lemma)
 apply (drule_tac x="x mod \<omega> ** oLog \<omega> x" in spec)
 apply (simp add: cnf2_lemma)
 apply (subst ordinal_of_nat_of_ordinal)
  apply (rule ordinal_div_less)
  apply (rule ordinal_less_exp_oLog, simp)
 apply (rule ordinal_div_plus_mod)
done

primrec is_normalized2 where
  is_normalized2_Nil: "is_normalized2 [] = True"
  | is_normalized2_Cons: "is_normalized2 (x # xs) =
      (case xs of [] \<Rightarrow> True | y # ys \<Rightarrow> fst y < fst x \<and> is_normalized2 xs)"

lemma is_normalized2_to_cnf2: "is_normalized2 (to_cnf2 x)"
 apply (rule_tac a=x in wf_induct[OF wf], simp)
 apply (case_tac "x = 0", simp_all)
 apply (drule spec, drule mp, erule cnf2_lemma)
 apply (simp add: to_cnf2_not_0)
 apply (case_tac "x mod \<omega> ** oLog \<omega> x = 0", simp_all)
 apply (case_tac "to_cnf2 (x mod \<omega> ** oLog \<omega> x)", simp_all)
 apply (case_tac a, simp)
 apply (drule to_cnf2_eq_Cons, simp)
 apply (erule ordinal_oLog_less, simp)
 apply (rule ordinal_mod_less, simp)
done

subsection \<open>Epsilon 0\<close>

definition epsilon0 :: ordinal  ("\<epsilon>\<^sub>0") where
  "epsilon0 = oFix ((**) \<omega>) 0"

lemma less_omega_exp: "x < \<epsilon>\<^sub>0 \<Longrightarrow> x < \<omega> ** x"
 apply (unfold epsilon0_def)
 apply (erule less_oFix_0D)
 apply (rule continuous.mono)
 apply (rule continuous_exp)
 apply (rule zero_less_omega)
done

lemma omega_exp_epsilon0: "\<omega> ** \<epsilon>\<^sub>0 = \<epsilon>\<^sub>0"
 apply (unfold epsilon0_def)
 apply (rule oFix_fixed)
  apply (rule continuous_exp)
  apply (rule zero_less_omega)
 apply simp
done

lemma oLog_omega_less: "\<lbrakk>0 < x; x < \<epsilon>\<^sub>0\<rbrakk> \<Longrightarrow> oLog \<omega> x < x"
 apply (erule ordinal_oLog_less)
  apply simp
 apply (erule less_omega_exp)
done

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Metric_Class

imports
  Metric_Locale

begin

text {*
This theory introduces the metric space class.
%We include instance results here -- largely because it is a small theory but also because the fact that the reals is a metri%c space is a natural result to show continuity of the distance function.
%It might be that later this should be rationalised into the Metric_Topology theory, but it might also be nice to keep some clean results separately.

A metric space has a distance function between its elements.

*}

class dist =
  fixes
    distance :: "['a, 'a] \<rightarrow> \<real>"

notation (xsymbols output)
  distance ("\<rho>'(_, _')")

notation (zed)
  distance ("\<^mcdist>{:_:}{:_:}")

class metric = dist +
assumes
  class_nonneg: "0 \<le> \<^mcdist>{:x:}{:y:}" and
  class_refl: "\<^mcdist>{:x:}{:y:} = 0 \<Leftrightarrow> x = y"  and
  class_sym: "\<^mcdist>{:x:}{:y:} = \<^mcdist>{:y:}{:x:}" and
  class_subadd: "\<^mcdist>{:x:}{:z:} \<le> \<^mcdist>{:x:}{:y:} + \<^mcdist>{:y:}{:z:}"
begin

  lemma class_zero_dist:
  shows "\<^mcdist>{:x:}{:x:} = 0"
  by (auto simp add: class_refl)

  lemma metric_class_diff_triangle:
  "abs (\<^mcdist>{:x:}{:z:} - \<^mcdist>{:y:}{:z:})\<le> \<^mcdist>{:x:}{:y:}"
  proof-
    have
    "\<^mcdist>{:x:}{:z:} \<le> \<^mcdist>{:x:}{:y:} + \<^mcdist>{:y:}{:z:}"
    by (rule class_subadd)
    then have R1:
    "\<^mcdist>{:x:}{:z:} - \<^mcdist>{:y:}{:z:} \<le> \<^mcdist>{:x:}{:y:}"
    by auto
    have
    "\<^mcdist>{:z:}{:y:} \<le> \<^mcdist>{:z:}{:x:} + \<^mcdist>{:x:}{:y:}"
    by (rule class_subadd)
    then have
    "- \<^mcdist>{:x:}{:y:} \<le> \<^mcdist>{:z:}{:x:} - \<^mcdist>{:z:}{:y:}"
    by auto
    then have R2:
    "- \<^mcdist>{:x:}{:y:} \<le> \<^mcdist>{:x:}{:z:} - \<^mcdist>{:y:}{:z:}"
    by (auto simp add: class_sym)
    from R1 R2 show
      ?thesis
    by (auto simp add: abs_if)
  qed

end

lemmas metric_class_defs = class_nonneg class_refl class_sym class_subadd class_zero_dist

theorem metric_classI:
  assumes
    a1: "\<^metricspace>{:\<univ>-[('a::dist)]:}{:distance:}"
  shows
  "OFCLASS('a::dist, metric_class)"
  apply (intro_classes)
  apply (auto intro!:
         metric_space.nonneg [OF a1]
         metric_space.strict [OF a1]
         metric_space.symmetric [OF a1]
         metric_space.subadd [OF a1])
done

lemma metric_classD:
  "\<^metricspace>{:\<univ>-[('a::metric)]:}{:distance:}"
  apply (unfold_locales)
  apply simp
  apply (intro metric_class_defs)+
done

end


(*
    $Id: sol.thy,v 1.3 2011/06/28 18:11:37 webertj Exp $
    Author: Gerwin Klein
*)

header {* Sorting with Lists and Trees *}

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

text {*
  For simplicity we sort natural numbers.
*}

subsubsection {* Sorting with lists *}

text {*
  The task is to define insertion sort and prove its correctness.  The
  following functions are required:

  @{text "insort :: nat \<Rightarrow> nat list \<Rightarrow> nat list"}\\
  @{text "sort   :: nat list \<Rightarrow> nat list"}\\
  @{text "le     :: nat \<Rightarrow> nat list \<Rightarrow> bool"}\\
  @{text "sorted :: nat list \<Rightarrow> bool"}

  In your definition, @{term "insort x xs"} should insert a number @{term x}
  into an already sorted list @{text xs}, and @{term "sort ys"} should build on
  @{text insort} to produce the sorted version of @{text ys}.

  To show that the resulting list is indeed sorted we need a predicate @{term
  sorted} that checks if each element in the list is less or equal to the
  following ones; @{term "le n xs"} should be true iff @{term n} is less or
  equal to all elements of @{text xs}.
*}

primrec le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "le a []     = True"
| "le a (x#xs) = (a <= x & le a xs)"

primrec sorted :: "nat list \<Rightarrow> bool" where
  "sorted []     = True"
| "sorted (x#xs) = (le x xs & sorted xs)"

primrec insort :: "nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "insort a []     = [a]"
| "insort a (x#xs) = (if a <= x then a#x#xs else x # insort a xs)"

primrec sort :: "nat list \<Rightarrow> nat list" where
  "sort []     = []"
| "sort (x#xs) = insort x (sort xs)"

text {*
  Start out by showing a monotonicity property of @{term le}.  For technical
  reasons the lemma should be phrased as follows:
*}

text {*
  Now show the following correctness theorem:
*}

lemma [simp]:
  "le x (insort a xs) = (x <= a & le x xs)"
  apply (induct_tac xs)
  apply auto
done

lemma [simp]:
  "sorted (insort a xs) = sorted xs"
  apply (induct_tac xs)
  apply auto
done

theorem "sorted (sort xs)"
  apply (induct_tac xs)
  apply auto
done

text {*
  This theorem alone is too weak.  It does not guarantee that the sorted list
  contains the same elements as the input.  In the worst case, @{term sort}
  might always return @{term"[]"}~-- surely an undesirable implementation of
  sorting.

  Define a function @{term "count xs x"} that counts how often @{term x} occurs
  in @{term xs}.
*}

primrec count :: "nat list => nat => nat" where
  "count []     y = 0"
| "count (x#xs) y = (if x=y then Suc(count xs y) else count xs y)"

text {*
  Show that
*}

lemma [simp]:
  "count (insort x xs) y =
  (if x=y then Suc (count xs y) else count xs y)"
  apply (induct_tac xs)
  apply auto
done

theorem "count (sort xs) x = count xs x"
  apply (induct_tac xs)
  apply auto
done

subsubsection {* Sorting with trees *}

text {*
  Our second sorting algorithm uses trees.  Thus you should first define a data
  type @{text bintree} of binary trees that are either empty or consist of a
  node carrying a natural number and two subtrees.
*}

datatype bintree = Empty | Node nat bintree bintree

text {*
  Define a function @{text tsorted} that checks if a binary tree is sorted.  It
  is convenient to employ two auxiliary functions @{text tge}/@{text tle} that
  test whether a number is greater-or-equal/less-or-equal to all elements of a
  tree.

  Finally define a function @{text tree_of} that turns a list into a sorted
  tree.  It is helpful to base @{text tree_of} on a function @{term "ins n b"}
  that inserts a number @{term n} into a sorted tree @{term b}.
*}

primrec tge :: "nat \<Rightarrow> bintree \<Rightarrow> bool" where
  "tge x Empty          = True"
| "tge x (Node n t1 t2) = (n \<le> x \<and> tge x t1 \<and> tge x t2)"

primrec tle :: "nat \<Rightarrow> bintree \<Rightarrow> bool" where
  "tle x Empty          = True"
| "tle x (Node n t1 t2) = (x \<le> n \<and> tle x t1 \<and> tle x t2)"

primrec tsorted :: "bintree \<Rightarrow> bool" where
  "tsorted Empty          = True"
| "tsorted (Node n t1 t2) = (tsorted t1 \<and> tsorted t2 \<and> tge n t1 \<and> tle n t2)"

primrec ins :: "nat \<Rightarrow> bintree \<Rightarrow> bintree" where
  "ins x Empty          = Node x Empty Empty"
| "ins x (Node n t1 t2) = (if x \<le> n then Node n (ins x t1) t2 else Node n t1 (ins x t2))"

primrec tree_of :: "nat list \<Rightarrow> bintree" where
  "tree_of []     = Empty"
| "tree_of (x#xs) = ins x (tree_of xs)"

text {*
  Show
*}

lemma [simp]: "tge a (ins x t) = (x \<le> a \<and> tge a t)"
  apply (induct_tac t)
  apply auto
done

lemma [simp]: "tle a (ins x t) = (a \<le> x \<and> tle a t)"
  apply (induct_tac t)
  apply auto
done

lemma [simp]: "tsorted (ins x t) = tsorted t"
  apply (induct_tac t)
  apply auto
done

theorem [simp]: "tsorted (tree_of xs)"
  apply (induct_tac xs)
  apply auto
done

text {*
  Again we have to show that no elements are lost (or added).  As for lists,
  define a function @{term "tcount x b"} that counts the number of occurrences
  of the number @{term x} in the tree @{term b}.
*}

primrec tcount :: "bintree => nat => nat" where
  "tcount Empty          y = 0"
| "tcount (Node x t1 t2) y = (if x=y then
                                Suc (tcount t1 y + tcount t2 y)
                              else
                                tcount t1 y + tcount t2 y)"

text {*
  Show
*}

lemma [simp]: "tcount (ins x t) y =
  (if x=y then Suc (tcount t y) else tcount t y)"
  apply(induct_tac t)
  apply auto
done

theorem "tcount (tree_of xs) x = count xs x"
  apply (induct_tac xs)
  apply auto
done

text {*
  Now we are ready to sort lists.  We know how to produce an ordered tree from
  a list.  Thus we merely need a function @{text list_of} that turns an
  (ordered) tree into an (ordered) list.  Define this function and prove
*}

theorem "sorted (list_of (tree_of xs))"
(*<*) oops (*>*)

theorem "count (list_of (tree_of xs)) n = count xs n"
(*<*) oops (*>*)

text {*
  Hints:
  \begin{itemize}
  \item
  Try to formulate all your lemmas as equations rather than implications
  because that often simplifies their proof.  Make sure that the right-hand
  side is (in some sense) simpler than the left-hand side.
  \item
  Eventually you need to relate @{text sorted} and @{text tsorted}.  This is
  facilitated by a function @{text ge} on lists (analogously to @{text tge} on
  trees) and the following lemma (that you will need to prove):\\
  @{term[display] "sorted (a@x#b) = (sorted a \<and> sorted b \<and> ge x a
  \<and> le x b)"}
  \end{itemize}
*}

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

primrec list_of :: "bintree \<Rightarrow> nat list" where
  "list_of Empty          = []"
| "list_of (Node n t1 t2) = list_of t1 @ [n] @ list_of t2"

lemma [simp]: "le x (a@b) = (le x a \<and> le x b)"
  apply (induct_tac a)
  apply auto
done

lemma [simp]: "ge x (a@b) = (ge x a \<and> ge x b)"
  apply (induct_tac a)
  apply auto
done

lemma [simp]:
  "sorted (a@x#b) = (sorted a \<and> sorted b \<and> ge x a \<and> le x b)"
  apply (induct_tac a)
  apply auto
done

lemma [simp]: "ge n (list_of t) = tge n t"
  apply (induct_tac t)
  apply auto
done

lemma [simp]: "le n (list_of t) = tle n t"
  apply (induct_tac t)
  apply auto
done

lemma [simp]: "sorted (list_of t) = tsorted t"
  apply (induct_tac t)
  apply auto
done

theorem "sorted (list_of (tree_of xs))"
  by auto

lemma count_append [simp]: "count (a@b) n = count a n + count b n"
  apply (induct a)
  apply auto
done

lemma [simp]: "count (list_of b) n = tcount b n"
  apply (induct b)
  apply auto
done

theorem "count (list_of (tree_of xs)) n = count xs n"
  apply (induct xs)
  apply auto
done

(*<*) end (*>*)


section \<open>Trees\<close>

theory Tree imports Main begin

text \<open>Sometimes it is nice to think of @{typ bool}s as directions in a binary tree\<close>
hide_const (open) Left Right
type_synonym dir = bool
definition Left :: bool where "Left = True"
definition Right :: bool where "Right = False"
declare Left_def [simp]
declare Right_def [simp]

datatype tree =
  Leaf
| Branching (ltree: tree) (rtree: tree)

subsection \<open>Sizes\<close>

fun treesize :: "tree \<Rightarrow> nat" where
  "treesize Leaf = 0"
| "treesize (Branching l r) = 1 + treesize l + treesize r"

lemma treesize_Leaf:
  assumes "treesize T = 0"
  shows "T = Leaf"
  using assms by (cases T) auto

lemma treesize_Branching:
  assumes "treesize T = Suc n"
  shows "\<exists>l r. T = Branching l r"
  using assms by (cases T) auto

subsection \<open>Paths\<close>

fun path :: "dir list \<Rightarrow> tree \<Rightarrow> bool" where
  "path [] T \<longleftrightarrow> True"
| "path (d#ds) (Branching T1 T2) \<longleftrightarrow> (if d then path ds T1 else path ds T2)"
| "path _ _ \<longleftrightarrow> False"

lemma path_inv_Leaf: "path p Leaf \<longleftrightarrow> p = []"
  by (induction p)  auto

lemma path_inv_Cons: "path (a#ds) T \<longrightarrow> (\<exists>l r. T=Branching l r)"
  by  (cases T) (auto simp add: path_inv_Leaf)

lemma path_inv_Branching_Left: "path (Left#p) (Branching l r) \<longleftrightarrow> path p l"
  using Left_def Right_def path.cases by (induction p) auto

lemma path_inv_Branching_Right: "path (Right#p) (Branching l r) \<longleftrightarrow> path p r"
using Left_def Right_def path.cases by (induction p)  auto

lemma path_inv_Branching:
  "path p (Branching l r) \<longleftrightarrow> (p=[] \<or> (\<exists>a p'. p=a#p'\<and> (a \<longrightarrow> path p' l) \<and> (\<not>a \<longrightarrow> path p' r)))" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L then show ?R by (induction p) auto
next
  assume r: ?R
  then show ?L
    proof
      assume "p = []" then show ?L by auto
    next
      assume "\<exists>a p'. p=a#p'\<and> (a \<longrightarrow> path p' l) \<and> (\<not>a \<longrightarrow> path p' r)"
      then obtain a p' where "p=a#p'\<and> (a \<longrightarrow> path p' l) \<and> (\<not>a \<longrightarrow> path p' r)" by auto
      then show ?L by (cases a) auto
    qed
qed

lemma path_prefix:
  assumes "path (ds1@ds2) T"
  shows "path ds1 T"
using assms proof (induction ds1 arbitrary: T)
  case (Cons a ds1)
  then have "\<exists>l r. T = Branching l r" using path_inv_Leaf by (cases T) auto
  then obtain l r where p_lr: "T = Branching l r" by auto
  show ?case
    proof (cases a)
      assume atrue: "a"
      then have "path ((ds1) @ ds2) l" using p_lr Cons(2) path_inv_Branching by auto
      then have "path ds1 l" using Cons(1) by auto
      then show "path (a # ds1) T" using p_lr atrue by auto
    next
      assume afalse: "\<not>a"
      then have "path ((ds1) @ ds2) r" using p_lr Cons(2) path_inv_Branching by auto
      then have "path ds1 r" using Cons(1) by auto
      then show "path (a # ds1) T" using p_lr afalse by auto
    qed
next
  case (Nil) then show ?case  by auto
qed

subsection \<open>Branches\<close>

fun branch :: "dir list \<Rightarrow> tree \<Rightarrow> bool" where
  "branch [] Leaf \<longleftrightarrow> True"
| "branch (d # ds) (Branching l r) \<longleftrightarrow> (if d then branch ds l else branch ds r)"
| "branch _ _ \<longleftrightarrow> False"

lemma has_branch: "\<exists>b. branch b T"
proof (induction T)
  case (Leaf)
  have "branch [] Leaf" by auto
  then show ?case by blast
next
  case (Branching T\<^sub>1 T\<^sub>2)
  then obtain b where "branch b T\<^sub>1" by auto
  then have "branch (Left#b) (Branching T\<^sub>1 T\<^sub>2)"  by auto
  then show ?case by blast
qed

lemma branch_inv_Leaf: "branch b Leaf \<longleftrightarrow> b = []"
by (cases b) auto

lemma branch_inv_Branching_Left:
  "branch (Left#b) (Branching l r) \<longleftrightarrow> branch b l"
by auto

lemma branch_inv_Branching:
  "branch b (Branching l r) \<longleftrightarrow>
     (\<exists>a b'. b=a#b'\<and> (a \<longrightarrow> branch b' l) \<and> (\<not>a \<longrightarrow>  branch b' r))"
by (induction b) auto

lemma branch_inv_Leaf2:
  "T = Leaf \<longleftrightarrow> (\<forall>b. branch b T \<longrightarrow> b = [])"
proof -
  {
    assume "T=Leaf"
    then have "\<forall>b. branch b T \<longrightarrow> b = []" using branch_inv_Leaf by auto
  }
  moreover
  {
    assume "\<forall>b. branch b T \<longrightarrow> b = []"
    then have "\<forall>b. branch b T \<longrightarrow> \<not>(\<exists>a b'. b = a # b')" by auto
    then have "\<forall>b. branch b T \<longrightarrow> \<not>(\<exists>l r. branch b (Branching l r))"
      using branch_inv_Branching by auto
    then have "T=Leaf" using has_branch[of T] by (metis branch.elims(2))
  }
  ultimately show "T = Leaf \<longleftrightarrow> (\<forall>b. branch b T \<longrightarrow> b = [])" by auto
qed

lemma branch_is_path:
  assumes"branch ds T"
  shows "path ds T"
using assms proof (induction T arbitrary: ds)
  case Leaf
  then have "ds = []" using branch_inv_Leaf by auto
  then show ?case  by auto
next
  case (Branching T\<^sub>1 T\<^sub>2)
  then obtain a b where ds_p: "ds = a # b \<and> (a \<longrightarrow> branch b T\<^sub>1) \<and> (\<not> a \<longrightarrow> branch b T\<^sub>2)" using branch_inv_Branching[of ds] by blast
  then have "(a \<longrightarrow> path b T\<^sub>1) \<and> (\<not>a \<longrightarrow> path b T\<^sub>2)" using Branching by auto
  then show "?case" using ds_p by (cases a) auto
qed

lemma Branching_Leaf_Leaf_Tree:
  assumes "T = Branching T1 T2"
  shows "(\<exists>B. branch (B@[True]) T \<and> branch (B@[False]) T)"
using assms proof (induction T arbitrary: T1 T2)
  case Leaf then show ?case by auto
next
  case (Branching T1' T2')
  {
    assume "T1'=Leaf \<and> T2'=Leaf"
    then have "branch ([] @ [True]) (Branching T1' T2') \<and> branch ([] @ [False]) (Branching T1' T2')" by auto
    then have ?case by metis
  }
  moreover
  {
    fix T11 T12
    assume "T1' = Branching T11 T12"
    then obtain B where "branch (B @ [True]) T1'
                       \<and> branch (B @ [False]) T1'" using Branching by blast
    then have "branch (([True] @ B) @ [True]) (Branching T1' T2')
             \<and> branch (([True] @ B) @ [False]) (Branching T1' T2')" by auto
    then have ?case by blast
  }
  moreover
  {
    fix T11 T12
    assume "T2' = Branching T11 T12"
    then obtain B where "branch (B @ [True]) T2'
                       \<and> branch (B @ [False]) T2'" using Branching by blast
    then have "branch (([False] @ B) @ [True]) (Branching T1' T2')
             \<and> branch (([False] @ B) @ [False]) (Branching T1' T2')" by auto
    then have ?case by blast
  }
  ultimately show ?case using tree.exhaust by blast
qed

subsection \<open>Internal Paths\<close>

fun internal :: "dir list \<Rightarrow> tree \<Rightarrow> bool" where
  "internal [] (Branching l r) \<longleftrightarrow> True"
| "internal (d#ds) (Branching l r) \<longleftrightarrow> (if d then internal ds l else internal ds r)"
| "internal _ _ \<longleftrightarrow> False"

lemma internal_inv_Leaf: "\<not>internal b Leaf" using internal.simps by blast

lemma internal_inv_Branching_Left:
  "internal (Left#b) (Branching l r) \<longleftrightarrow> internal b l" by auto

lemma internal_inv_Branching_Right:
  "internal (Right#b) (Branching l r) \<longleftrightarrow> internal b r"
by auto

lemma internal_inv_Branching:
  "internal p (Branching l r) \<longleftrightarrow> (p=[] \<or> (\<exists>a p'. p=a#p'\<and> (a \<longrightarrow> internal p' l) \<and> (\<not>a \<longrightarrow> internal p' r)))" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L then show ?R by (metis internal.simps(2) neq_Nil_conv)
next
  assume r: ?R
  then show ?L
    proof
      assume "p = []" then show ?L by auto
    next
      assume "\<exists>a p'. p=a#p'\<and> (a \<longrightarrow> internal p' l) \<and> (\<not>a \<longrightarrow> internal p' r)"
      then obtain a p' where "p=a#p'\<and> (a \<longrightarrow> internal p' l) \<and> (\<not>a \<longrightarrow> internal p' r)" by auto
      then show ?L by (cases a) auto
    qed
qed

lemma internal_is_path:
  assumes "internal ds T"
  shows "path ds T"
using assms proof (induction T arbitrary: ds)
  case Leaf
  then have "False" using internal_inv_Leaf by auto
  then show ?case by auto
next
  case (Branching T\<^sub>1 T\<^sub>2)
  then obtain a b where ds_p: "ds=[] \<or> ds = a # b \<and> (a \<longrightarrow> internal b T\<^sub>1) \<and> (\<not> a \<longrightarrow> internal b T\<^sub>2)" using internal_inv_Branching by blast
  then have "ds = [] \<or> (a \<longrightarrow> path b T\<^sub>1) \<and> (\<not>a \<longrightarrow> path b T\<^sub>2)" using Branching by auto
  then show "?case" using ds_p by (cases a) auto
qed

lemma internal_prefix:
  assumes "internal (ds1@ds2@[d]) T"
  shows "internal ds1 T" (* more or less copy paste of path_prefix *)
using assms proof (induction ds1 arbitrary: T)
  case (Cons a ds1)
  then have "\<exists>l r. T = Branching l r" using internal_inv_Leaf by (cases T) auto
  then obtain l r where p_lr: "T = Branching l r" by auto
  show ?case
    proof (cases a)
      assume atrue: "a"
      then have "internal ((ds1) @ ds2 @[d]) l" using p_lr Cons(2) internal_inv_Branching by auto
      then have "internal ds1 l" using Cons(1) by auto
      then show "internal (a # ds1) T" using p_lr atrue by auto
    next
      assume afalse: "~a"
      then have "internal ((ds1) @ ds2 @[d]) r" using p_lr Cons(2) internal_inv_Branching by auto
      then have "internal ds1 r" using Cons(1) by auto
      then show "internal (a # ds1) T" using p_lr afalse by auto
    qed
next
  case (Nil)
  then have "\<exists>l r. T = Branching l r" using internal_inv_Leaf by (cases T) auto
  then show ?case by auto
qed

lemma internal_branch:
  assumes "branch (ds1@ds2@[d]) T"
  shows "internal ds1 T" (* more or less copy paste of path_prefix *)
using assms proof (induction ds1 arbitrary: T)
  case (Cons a ds1)
  then have "\<exists>l r. T = Branching l r" using branch_inv_Leaf by (cases T) auto
  then obtain l r where p_lr: "T = Branching l r" by auto
  show ?case
    proof (cases a)
      assume atrue: "a"
      then have "branch (ds1 @ ds2 @ [d]) l" using p_lr Cons(2) branch_inv_Branching by auto
      then have "internal ds1 l" using Cons(1) by auto
      then show "internal (a # ds1) T" using p_lr atrue by auto
    next
      assume afalse: "~a"
      then have "branch ((ds1) @ ds2 @[d]) r" using p_lr Cons(2) branch_inv_Branching by auto
      then have "internal ds1 r" using Cons(1) by auto
      then show "internal (a # ds1) T" using p_lr afalse by auto
    qed
next
  case (Nil)
  then have "\<exists>l r. T = Branching l r" using branch_inv_Leaf by (cases T) auto
  then show ?case by auto
qed

fun parent :: "dir list \<Rightarrow> dir list" where
  "parent ds = tl ds"

subsection \<open>Deleting Nodes\<close>

fun delete :: "dir list \<Rightarrow> tree \<Rightarrow> tree" where
  "delete [] T = Leaf"
| "delete (True#ds)  (Branching T\<^sub>1 T\<^sub>2) = Branching (delete ds T\<^sub>1) T\<^sub>2"
| "delete (False#ds) (Branching T\<^sub>1 T\<^sub>2) = Branching T\<^sub>1 (delete ds T\<^sub>2)"
| "delete (a#ds) Leaf = Leaf"

lemma delete_Leaf: "delete T Leaf = Leaf" by (cases T) auto

lemma path_delete:
  assumes "path p (delete ds T)"
  shows "path p T " (* What a huge proof... But the four cases can be proven shorter *)
using assms proof (induction p arbitrary: T ds)
  case Nil
  then show ?case by simp
next
  case (Cons a p)
  then obtain b ds' where bds'_p: "ds=b#ds'" by (cases ds) auto

  have "\<exists>dT1 dT2. delete ds T = Branching dT1 dT2" using Cons path_inv_Cons by auto
  then obtain dT1 dT2 where "delete ds T = Branching dT1 dT2" by auto

  then have "\<exists>T1 T2. T=Branching T1 T2" (* Is there a lemma hidden here that I could extract? *)
        by (cases T; cases ds) auto
  then obtain T1 T2 where T1T2_p: "T=Branching T1 T2" by auto

  {
    assume a_p: "a"
    assume b_p: "\<not>b"
    have "path (a # p) (delete ds T)" using Cons by -
    then have "path (a # p) (Branching (T1) (delete ds' T2))" using b_p bds'_p T1T2_p by auto
    then have "path p T1" using a_p by auto
    then have ?case using T1T2_p a_p by auto
  }
  moreover
  {
    assume a_p: "\<not>a"
    assume b_p: "b"
    have "path (a # p) (delete ds T)" using Cons by -
    then have "path (a # p) (Branching (delete ds' T1) T2)" using b_p bds'_p T1T2_p by auto
    then have "path p T2" using a_p by auto
    then have ?case using T1T2_p a_p by auto
  }
  moreover
  {
    assume a_p: "a"
    assume b_p: "b"
    have "path (a # p) (delete ds T)" using Cons by -
    then have "path (a # p) (Branching (delete ds' T1) T2)" using b_p bds'_p T1T2_p by auto
    then have "path p (delete ds' T1)" using a_p by auto
    then have "path p T1" using Cons by auto
    then have ?case using T1T2_p a_p by auto
  }
  moreover
  {
    assume a_p: "\<not>a"
    assume b_p: "\<not>b"
    have "path (a # p) (delete ds T)" using Cons by -
    then have "path (a # p) (Branching T1 (delete ds' T2))" using b_p bds'_p T1T2_p by auto
    then have "path p (delete ds' T2)" using a_p by auto
    then have "path p T2" using Cons by auto
    then have ?case using T1T2_p a_p by auto
  }
  ultimately show ?case by blast
qed

lemma branch_delete:
  assumes "branch p (delete ds T)"
  shows "branch p T \<or> p=ds" (* Adapted from above *)
using assms proof (induction p arbitrary: T ds)
  case Nil
  then have "delete ds T = Leaf" by (cases "delete ds T") auto
  then have "ds = [] \<or> T = Leaf" using delete.elims by blast
  then show ?case by auto
next
  case (Cons a p)
  then obtain b ds' where bds'_p: "ds=b#ds'" by (cases ds) auto

  have "\<exists>dT1 dT2. delete ds T = Branching dT1 dT2" using Cons path_inv_Cons branch_is_path by blast
  then obtain dT1 dT2 where "delete ds T = Branching dT1 dT2" by auto

  then have "\<exists>T1 T2. T=Branching T1 T2" (* Is there a lemma hidden here that I could extract? *)
        by (cases T; cases ds) auto
  then obtain T1 T2 where T1T2_p: "T=Branching T1 T2" by auto

  {
    assume a_p: "a"
    assume b_p: "\<not>b"
    have "branch (a # p) (delete ds T)" using Cons by -
    then have "branch (a # p) (Branching (T1) (delete ds' T2))" using b_p bds'_p T1T2_p by auto
    then have "branch p T1" using a_p by auto
    then have ?case using T1T2_p a_p by auto
  }
  moreover
  {
    assume a_p: "\<not>a"
    assume b_p: "b"
    have "branch (a # p) (delete ds T)" using Cons by -
    then have "branch (a # p) (Branching (delete ds' T1) T2)" using b_p bds'_p T1T2_p by auto
    then have "branch p T2" using a_p by auto
    then have ?case using T1T2_p a_p by auto
  }
  moreover
  {
    assume a_p: "a"
    assume b_p: "b"
    have "branch (a # p) (delete ds T)" using Cons by -
    then have "branch (a # p) (Branching (delete ds' T1) T2)" using b_p bds'_p T1T2_p by auto
    then have "branch p (delete ds' T1)" using a_p by auto
    then have "branch p T1 \<or> p = ds'" using Cons by metis
    then have ?case using T1T2_p a_p using bds'_p a_p b_p by auto
  }
  moreover
  {
    assume a_p: "\<not>a"
    assume b_p: "\<not>b"
    have "branch (a # p) (delete ds T)" using Cons by -
    then have "branch (a # p) (Branching T1 (delete ds' T2))" using b_p bds'_p T1T2_p by auto
    then have "branch p (delete ds' T2)" using a_p by auto
    then have "branch p T2 \<or> p = ds'" using Cons by metis
    then have ?case using T1T2_p a_p using bds'_p a_p b_p by auto
  }
  ultimately show ?case by blast
qed

lemma branch_delete_postfix:
  assumes "path p (delete ds T)"
  shows "\<not>(\<exists>c cs. p = ds @ c#cs)" (* Adapted from previous proof *)
using assms proof (induction p arbitrary: T ds)
  case Nil then show ?case by simp
next
  case (Cons a p)
  then obtain b ds' where bds'_p: "ds=b#ds'" by (cases ds) auto

  have "\<exists>dT1 dT2. delete ds T = Branching dT1 dT2" using Cons path_inv_Cons by auto
  then obtain dT1 dT2 where "delete ds T = Branching dT1 dT2" by auto

  then have "\<exists>T1 T2. T=Branching T1 T2" (* Is there a lemma hidden here that I could extract? *)
        by (cases T; cases ds) auto
  then obtain T1 T2 where T1T2_p: "T=Branching T1 T2" by auto

  {
    assume a_p: "a"
    assume b_p: "\<not>b"
    then have ?case using T1T2_p a_p b_p bds'_p by auto
  }
  moreover
  {
    assume a_p: "\<not>a"
    assume b_p: "b"
    then have ?case using T1T2_p a_p b_p bds'_p by auto
  }
  moreover
  {
    assume a_p: "a"
    assume b_p: "b"
    have "path (a # p) (delete ds T)" using Cons by -
    then have "path (a # p) (Branching (delete ds' T1) T2)" using b_p bds'_p T1T2_p by auto
    then have "path p (delete ds' T1)" using a_p by auto
    then have "\<not> (\<exists>c cs. p = ds' @ c # cs)" using Cons by auto
    then have ?case using T1T2_p a_p b_p bds'_p by auto
  }
  moreover
  {
    assume a_p: "\<not>a"
    assume b_p: "\<not>b"
    have "path (a # p) (delete ds T)" using Cons by -
    then have "path (a # p) (Branching T1 (delete ds' T2))" using b_p bds'_p T1T2_p by auto
    then have "path p (delete ds' T2)" using a_p by auto
    then have "\<not> (\<exists>c cs. p = ds' @ c # cs)" using Cons by auto
    then have ?case using T1T2_p a_p b_p bds'_p by auto
  }
  ultimately show ?case by blast
qed

lemma treezise_delete:
  assumes "internal p T"
  shows "treesize (delete p T) < treesize T"
using assms proof (induction p arbitrary: T)
  case (Nil)
  then have "\<exists>T1 T2. T = Branching T1 T2" by (cases T) auto
  then obtain T1 T2 where T1T2_p: "T = Branching T1 T2" by auto
  then show ?case by auto
next
  case (Cons a p)
  then have "\<exists>T1 T2. T = Branching T1 T2" using path_inv_Cons internal_is_path by blast
  then obtain T1 T2 where T1T2_p: "T = Branching T1 T2" by auto
  show ?case
    proof (cases a)
      assume a_p: a
      from a_p have "delete (a#p) T = (Branching (delete p T1) T2)" using T1T2_p by auto
      moreover
      from a_p have "internal p T1" using T1T2_p Cons by auto
      then have "treesize (delete p T1) < treesize T1" using Cons by auto
      ultimately
      show ?thesis using T1T2_p by auto
    next
      assume a_p: "\<not>a"
      from a_p have "delete (a#p) T = (Branching T1 (delete p T2))" using T1T2_p by auto
      moreover
      from a_p have "internal p T2" using T1T2_p Cons by auto
      then have "treesize (delete p T2) < treesize T2" using Cons by auto
      ultimately
      show ?thesis using T1T2_p by auto
    qed
qed

fun cutoff :: "(dir list \<Rightarrow> bool) \<Rightarrow> dir list \<Rightarrow> tree \<Rightarrow> tree" where
  "cutoff red ds (Branching T\<^sub>1 T\<^sub>2) =
     (if red ds then Leaf else Branching (cutoff red (ds@[Left])  T\<^sub>1) (cutoff red (ds@[Right]) T\<^sub>2))"
| "cutoff red ds Leaf = Leaf"
text \<open>Initially you should call @{const cutoff} with @{term "ds = []"}.
 If all branches are red, then @{const cutoff} gives a subtree.
 If all branches are red, then so are the ones in @{const cutoff}.
 The internal paths of @{const cutoff} are not red.\<close>

lemma treesize_cutoff: "treesize (cutoff red ds T) \<le> treesize T"
proof (induction T arbitrary: ds)
  case Leaf then show ?case by auto
next
  case (Branching T1 T2)
  then have "treesize (cutoff red (ds@[Left]) T1) + treesize (cutoff red (ds@[Right]) T2) \<le> treesize T1 + treesize T2" using add_mono by blast
  then show ?case by auto
qed

abbreviation anypath :: "tree \<Rightarrow> (dir list \<Rightarrow> bool) \<Rightarrow> bool" where
  "anypath T P \<equiv> \<forall>p. path p T \<longrightarrow> P p"

abbreviation anybranch :: "tree \<Rightarrow> (dir list \<Rightarrow> bool) \<Rightarrow> bool" where
  "anybranch T P \<equiv> \<forall>p. branch p T \<longrightarrow> P p"

abbreviation anyinternal :: "tree \<Rightarrow> (dir list \<Rightarrow> bool) \<Rightarrow> bool" where
  "anyinternal T P \<equiv> \<forall>p. internal p T \<longrightarrow> P p"

  from Branching have "\<forall>p. branch (Right#p) (Branching T\<^sub>1 T\<^sub>2) \<longrightarrow> red (ds @ (Right#p))" by blast
  then have "\<forall>p. branch p T\<^sub>2 \<longrightarrow> red (ds @ (Right#p))" by auto
  then have "anybranch T\<^sub>2 (\<lambda>p. red ((ds @ [Right]) @ p))" by auto
  then have bb: "anybranch (cutoff red (ds @ [Right]) T\<^sub>2) (\<lambda>p. red ((ds @ [Right]) @ p))
         " using Branching by blast
  {
    fix b
    assume b_p: "branch b ?T"
    have "red ds \<or> \<not>red ds" by auto
    then have "red(ds@b)"
      proof
        assume ds_p: "red ds"
        then have "?T = Leaf" by auto
        then have "b = []" using b_p branch_inv_Leaf by auto
        then show "red(ds@b)" using ds_p by auto
      next
        assume ds_p: "\<not>red ds"
        let ?T\<^sub>1' = "cutoff red (ds@[Left])  T\<^sub>1"
        let ?T\<^sub>2' = "cutoff red (ds@[Right]) T\<^sub>2"
        from ds_p have "?T = Branching ?T\<^sub>1' ?T\<^sub>2'" by auto
        from this b_p obtain a b' where "b = a # b' \<and> (a \<longrightarrow> branch b' ?T\<^sub>1') \<and> (\<not>a \<longrightarrow> branch b' ?T\<^sub>2' )" using branch_inv_Branching[of b ?T\<^sub>1' ?T\<^sub>2'] by auto
        then show "red(ds@b)" using aa bb by (cases a) auto
      qed
  }
  then show ?case by blast
qed

lemma cutoff_branch:
  assumes "anybranch T (\<lambda>p. red p)"
  shows "anybranch (cutoff red [] T) (\<lambda>p. red p)"
  using assms cutoff_branch'[of T red "[]"] by auto

lemma cutoff_internal':
  assumes "anybranch T (\<lambda>b. red(ds@b))"
  shows "anyinternal (cutoff red ds T) (\<lambda>b. \<not>red(ds@b))"
using assms proof (induction T arbitrary: ds) (* This proof seems a bit excessive for such a simple theorem *)
  case (Leaf) then show ?case using internal_inv_Leaf by simp
next
  case (Branching T\<^sub>1 T\<^sub>2)
  let ?T = "cutoff red ds (Branching T\<^sub>1 T\<^sub>2)"
  from Branching have "\<forall>p. branch (Left#p) (Branching T\<^sub>1 T\<^sub>2) \<longrightarrow> red (ds @ (Left#p))" by blast
  then have "\<forall>p. branch p T\<^sub>1 \<longrightarrow> red (ds @ (Left#p))" by auto
  then have "anybranch T\<^sub>1 (\<lambda>p. red ((ds @ [Left]) @ p))" by auto
  then have aa: "anyinternal (cutoff red (ds @ [Left]) T\<^sub>1) (\<lambda>p. \<not> red ((ds @ [Left]) @ p))" using Branching by blast

  from Branching have "\<forall>p. branch (Right#p) (Branching T\<^sub>1 T\<^sub>2) \<longrightarrow> red (ds @ (Right#p))" by blast
  then have "\<forall>p. branch p T\<^sub>2 \<longrightarrow> red (ds @ (Right#p))" by auto
  then have "anybranch T\<^sub>2 (\<lambda>p. red ((ds @ [Right]) @ p))" by auto
  then have bb: "anyinternal (cutoff red (ds @ [Right]) T\<^sub>2) (\<lambda>p. \<not> red ((ds @ [Right]) @ p))" using Branching by blast
  {
    fix p
    assume b_p: "internal p ?T"
    then have ds_p: "\<not>red ds" using internal_inv_Leaf by auto
    have "p=[] \<or> p\<noteq>[]" by auto
    then have "\<not>red(ds@p)"
      proof
        assume "p=[]" then show "\<not>red(ds@p)" using ds_p by auto
      next
        let ?T\<^sub>1' = "cutoff red (ds@[Left])  T\<^sub>1"
        let ?T\<^sub>2' = "cutoff red (ds@[Right]) T\<^sub>2"
        assume "p\<noteq>[]"
        moreover
        have "?T = Branching ?T\<^sub>1' ?T\<^sub>2'" using ds_p by auto
        ultimately
        obtain a p' where b_p: "p = a # p' \<and>
             (a \<longrightarrow> internal p' (cutoff red (ds @ [Left]) T\<^sub>1)) \<and>
             (\<not> a \<longrightarrow> internal p' (cutoff red (ds @ [Right]) T\<^sub>2))"
          using b_p internal_inv_Branching[of p ?T\<^sub>1' ?T\<^sub>2'] by auto
        then have "\<not>red(ds @ [a] @ p')" using aa bb by (cases a) auto
        then show "\<not>red(ds @ p)" using b_p by simp
      qed
  }
  then show ?case by blast
qed

lemma cutoff_internal:
  assumes  "anybranch T red"
  shows "anyinternal (cutoff red [] T) (\<lambda>p. \<not>red p)"
  using assms cutoff_internal'[of T red "[]"] by auto

lemma cutoff_branch_internal':
  assumes "anybranch T red"
  shows "anyinternal (cutoff red [] T) (\<lambda>p. \<not>red p) \<and> anybranch (cutoff red [] T) (\<lambda>p. red p)"
  using assms cutoff_internal[of T] cutoff_branch[of T] by blast

lemma cutoff_branch_internal:
  assumes "anybranch T red"
  shows "\<exists>T'. anyinternal T' (\<lambda>p. \<not>red p) \<and> anybranch T' (\<lambda>p. red p)"
  using assms cutoff_branch_internal' by blast

section \<open>Possibly Infinite Trees\<close>
text \<open>Possibly infinite trees are of type @{typ "dir list set"}.\<close>

abbreviation wf_tree :: "dir list set \<Rightarrow> bool" where
  "wf_tree T \<equiv> (\<forall>ds d. (ds @ d) \<in> T \<longrightarrow> ds \<in> T)"

text \<open>The subtree in with root r\<close>
fun subtree :: "dir list set \<Rightarrow> dir list \<Rightarrow> dir list set" where
  "subtree T r = {ds \<in> T. \<exists>ds'. ds = r @ ds'}"

text \<open>A subtree of a tree is either in the left branch, the right branch, or is the tree itself\<close>
lemma subtree_pos:
  "subtree T ds \<subseteq> subtree T (ds @ [Left]) \<union> subtree T (ds @ [Right]) \<union> {ds}"
proof (rule subsetI; rule Set.UnCI)
  let ?subtree = "subtree T"
  fix x
  assume asm: "x \<in> ?subtree ds"
  assume "x \<notin> {ds}"
  then have "x \<noteq> ds" by simp
  then have "\<exists>e d. x = ds @ [d] @ e" using asm list.exhaust by auto
  then have "(\<exists>e. x = ds @ [Left] @ e) \<or> (\<exists>e. x = ds @ [Right] @ e)" using bool.exhaust by auto
  then show "x \<in> ?subtree (ds @ [Left]) \<union> ?subtree (ds @ [Right])" using asm by auto
qed

subsection \<open>Infinite Paths\<close>

abbreviation wf_infpath :: "(nat \<Rightarrow> 'a list) \<Rightarrow> bool" where
  "wf_infpath f \<equiv> (f 0 = []) \<and> (\<forall>n. \<exists>a. f (Suc n) = (f n) @ [a])"

lemma chain_prefix:
  assumes "wf_infpath f"
  assumes "n\<^sub>1 \<le> n\<^sub>2"
  shows "\<exists>a. (f n\<^sub>1) @ a = (f n\<^sub>2)"
using assms proof (induction n\<^sub>2)
  case (Suc n\<^sub>2)
  then have "n\<^sub>1 \<le> n\<^sub>2 \<or> n\<^sub>1 = Suc n\<^sub>2" by auto
  then show ?case
    proof
      assume "n\<^sub>1 \<le> n\<^sub>2"
      then obtain a where a: "f n\<^sub>1 @ a = f n\<^sub>2" using Suc by auto
      have b: "\<exists>b. f (Suc n\<^sub>2) = f n\<^sub>2 @ [b]" using Suc by auto
      from a b have "\<exists>b. f n\<^sub>1 @ (a @ [b]) = f (Suc n\<^sub>2)" by auto
      then show "\<exists>c. f n\<^sub>1 @ c = f (Suc n\<^sub>2)" by blast
    next
      assume "n\<^sub>1 = Suc n\<^sub>2"
      then have "f n\<^sub>1 @ [] = f (Suc n\<^sub>2)" by auto
      then show "\<exists>a. f n\<^sub>1 @ a = f (Suc n\<^sub>2)" by auto
    qed
qed auto

text \<open>If we make a lookup in a list, then looking up in an extension gives us the same value.\<close>
lemma ith_in_extension:
  assumes chain: "wf_infpath f"
  assumes smalli: "i < length (f n\<^sub>1)"
  assumes n\<^sub>1n\<^sub>2: "n\<^sub>1 \<le> n\<^sub>2"
  shows "f n\<^sub>1 ! i = f n\<^sub>2 ! i"
proof -
  from chain n\<^sub>1n\<^sub>2 have "\<exists>a. f n\<^sub>1 @ a = f n\<^sub>2" using chain_prefix by blast
  then obtain a where a_p: "f n\<^sub>1 @ a = f n\<^sub>2" by auto
  have "(f n\<^sub>1 @ a) ! i = f n\<^sub>1 ! i" using smalli by (simp add: nth_append)
  then show ?thesis using a_p by auto
qed

section \<open>König's Lemma\<close>

lemma inf_subs:
  assumes inf: "\<not>finite(subtree T ds)"
  shows "\<not>finite(subtree T (ds @ [Left])) \<or> \<not>finite(subtree T (ds @ [Right]))"
proof -
  let ?subtree = "subtree T"
  {
    assume asms: "finite(?subtree(ds @ [Left]))"
                 "finite(?subtree(ds @ [Right]))"
    have "?subtree ds \<subseteq> ?subtree (ds @ [Left] ) \<union> ?subtree (ds @ [Right]) \<union> {ds} "
      using subtree_pos by auto
    then have "finite(?subtree (ds))" using asms by (simp add: finite_subset)
  }
  then show "\<not>finite(?subtree (ds @ [Left])) \<or> \<not>finite(?subtree (ds @ [Right]))" using inf by auto
qed

fun buildchain :: "(dir list \<Rightarrow> dir list) \<Rightarrow> nat \<Rightarrow> dir list" where
  "buildchain next 0 = []"
| "buildchain next (Suc n) = next (buildchain next n)"

lemma konig:
  assumes inf: "\<not>finite T"
  assumes wellformed: "wf_tree T"
  shows "\<exists>c. wf_infpath c \<and> (\<forall>n. (c n) \<in> T)"
proof
  let ?subtree = "subtree T"
  let ?nextnode = "\<lambda>ds. (if \<not>finite (?subtree (ds @ [Left])) then ds @ [Left] else ds @ [Right])"

  let ?c = "buildchain ?nextnode"

  have is_chain: "wf_infpath ?c" by auto

  from wellformed have prefix: "\<forall>ds d. (ds @ d) \<in> T \<longrightarrow> ds \<in> T" by blast

  {
    fix n
    have "(?c n) \<in> T \<and> \<not>finite (?subtree (?c n))"
      proof (induction n)
        case 0
        have "\<exists>ds. ds \<in> T" using inf by (simp add: not_finite_existsD)
        then obtain ds where "ds \<in> T" by auto
        then have "([]@ds) \<in> T" by auto
        then have "[] \<in> T" using prefix by blast
        then show ?case using inf by auto
      next
        case (Suc n)
        from Suc have next_in:  "(?c n) \<in> T" by auto
        from Suc have next_inf: "\<not>finite (?subtree (?c n))" by auto

        from next_inf have next_next_inf:
           "\<not>finite (?subtree (?nextnode (?c n)))"
              using inf_subs by auto
        then have "\<exists>ds. ds \<in> ?subtree (?nextnode (?c n))"
          by (simp add: not_finite_existsD)
        then obtain ds where dss: "ds \<in> ?subtree (?nextnode (?c n))" by auto
        then have "ds \<in> T" "\<exists>suf. ds = (?nextnode (?c n)) @ suf" by auto
        then obtain suf where "ds \<in> T \<and> ds = (?nextnode (?c n)) @ suf" by auto
        then have "(?nextnode (?c n)) \<in> T"
          using prefix by blast

        then have "(?c (Suc n)) \<in> T" by auto
        then show ?case using next_next_inf by auto
      qed
  }
  then show "wf_infpath ?c \<and> (\<forall>n. (?c n)\<in> T) " using is_chain by auto
qed

end


theory Logic
  imports Tactics
begin

section {* Logic *}

(* definition plus_fact where "2 + 2 = 4" *)

subsection {* Logical Connectives *}

subsubsection {* Conjunction *}

lemma and_example: "3 + 4 = 7 \<and> (2::nat) * 2 = 4"
  apply (simp)
  done

lemma and_intro: "A \<longrightarrow> B \<longrightarrow> A \<and> B"
  apply (simp)
  done

lemma and_exercise: "\<forall> n m::nat. n + m = 0 \<longrightarrow> n = 0 \<and> m = 0"
  apply (simp)
  done

lemma and_example2: "\<forall> n m::nat. n = 0 \<and> m = 0 \<longrightarrow> n + m = 0"
  apply (simp)
  done

lemma and_example3: "\<forall> n m::nat. n + m = 0 \<longrightarrow> n * m = 0"
  apply (simp)
  done

lemma proj1: "P \<and> Q \<longrightarrow> P"
  apply (simp)
  done

lemma proj2: "P \<and> Q \<longrightarrow> Q"
  apply (simp)
  done

theorem and_commut: "P \<and> Q \<longrightarrow> Q \<and> P"
  apply (simp)
  done

theorem and_assoc: "P \<and> (Q \<and> R) \<longrightarrow> (P \<and> Q) \<and> R"
  apply (simp)
  done

subsubsection {* Disjunction *}

lemma or_example: "\<forall> n m :: nat. n = 0 \<or> m = 0 \<longrightarrow> n * m = 0"
  apply (simp)
  done

lemma or_intro: "A \<longrightarrow> A \<or> B"
  apply (simp)
  done

lemma zero_or_succ: "n = 0 \<or> n = Suc (pred n)"
  apply (induction n)
   apply (simp_all)
  done

lemma mult_eq_0: "\<forall> n m::nat. n * m = 0 \<longrightarrow> n = 0 \<or> m = 0"
  apply (simp)
  done

theorem or_commut: "P \<or> Q \<longrightarrow> Q \<or> P"
  apply (simp)
  done

subsubsection {* Falsehood and Negation *}

theorem ex_falso_quodlibet: "HOL.False \<longrightarrow> P"
  apply (simp)
  done

theorem not_implies_our_not: "\<forall> P. \<not>P \<longrightarrow> (\<forall> Q. P \<longrightarrow> Q)"
  apply (simp)
  done

(* theorem zero_not_one: "\<not> (0 = 1)" *)

(* theorem zero_not_one': "0 \<noteq> 1" *)

theorem not_False: "\<not> HOL.False"
  apply (simp)
  done

theorem contradiction_implies_anything: "(P \<and> \<not>P) \<longrightarrow> Q"
  apply (simp)
  done

theorem double_neg: "P \<longrightarrow> \<not>\<not>P"
  apply (simp)
  done

theorem contrapositive: "(P \<longrightarrow> Q) \<longrightarrow> (\<not>Q \<longrightarrow> \<not>P)"
  apply (auto)
  done

theorem not_both_true_and_false: "\<not>(P \<and> \<not>P)"
  apply (simp)
  done

theorem not_true_is_false: "b \<noteq> True \<longrightarrow> b = False"
  apply (cases b)
   apply (simp_all)
  done

subsubsection {* Truth *}

(* True is true. *)
theorem True_is_true: "HOL.True"
  apply (simp)
  done

subsubsection {* Logical Equivalance *}

definition iff :: "HOL.bool \<Rightarrow> HOL.bool \<Rightarrow> HOL.bool" where
   "iff P Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)"

theorem iff_sym: "\<forall> P Q. iff P Q \<longrightarrow> iff Q P"
  unfolding iff_def
  apply (simp)
  done

lemma not_true_iff_false: "b \<noteq> bool.True \<longleftrightarrow> b = bool.False"
  apply (cases b)
   apply (simp_all)
  done

theorem iff_refl: "\<forall> P. P \<longleftrightarrow> P"
  apply (simp)
  done

theorem iff_trans: "\<forall> P Q R. (P \<longleftrightarrow> Q) \<longrightarrow> (Q \<longleftrightarrow> R) \<longrightarrow> (P \<longleftrightarrow> R)"
  apply (simp)
  done

theorem or_distributes_over_and: "\<forall> P Q R. P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)"
  using [[simp_trace]]
  apply (auto)
  done

lemma mult_0: "\<forall> n m::nat. n * m = 0 \<longleftrightarrow> n = 0 \<or> m = 0"
  apply (simp)
  done

lemma or_assoc: "\<forall> P Q R. P \<or> (Q \<or> R) \<longleftrightarrow> (P \<or> Q) \<or> R"
  apply (simp)
  done

subsubsection {* Existential Quantification*}

lemma four_is_even: "\<exists> n::nat. n + n = 4"
  apply presburger
  done

subsubsection {* Programming with Propisition *}

fun In :: "'a \<Rightarrow> 'a list \<Rightarrow> HOL.bool" where
  "In _ [] = HOL.False"
| "In a (x # xs) = (x = a \<or> In a xs)"

lemma In_example_1: "In 4 (1 # 2 # 3 # 4 # 5 # [])"
  apply (simp)
  done

lemma In_example_2: "\<forall> n. In n (2 # 4 # []) \<longrightarrow> (\<exists> n'. n = 2 * n')"
  oops

lemma In_map: "In a xs \<longrightarrow> In (f a) (map f xs)"
  apply (induction xs)
   apply (simp_all)
  done

lemma In_map_iff: "In y (map f xs) \<longleftrightarrow> exists x f x = y \<and> In a xs"
  apply (induction xs)
   apply (simp)
  oops

lemma In_app_iff: "In a (xs @ ys) \<longrightarrow> In a xs \<or> In a ys"
  apply (induction xs)
   apply (simp_all)
  done

end


(*  Title:      Util_MinMax.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

section \<open>Order and linear order: min and max\<close>

theory Util_MinMax
imports Main
begin

subsection \<open>Additional lemmata about @{term min} and @{term max}\<close>

lemma min_less_imp_conj: "(z::'a::linorder) < min x y \<Longrightarrow> z < x \<and> z < y" by simp
lemma conj_less_imp_min: "\<lbrakk> z < x; z < y \<rbrakk> \<Longrightarrow> (z::'a::linorder) < min x y" by simp

(*lemma min_le_iff_conj: "((z::'a::linorder) \<le> min x y) = (z \<le> x \<and> z \<le> y)"*)
lemmas min_le_iff_conj = min.bounded_iff
lemma min_le_imp_conj: "(z::'a::linorder) \<le> min x y \<Longrightarrow> z \<le> x \<and> z \<le> y" by simp
(*lemma conj_le_imp_min: "\<lbrakk> z \<le> x; z \<le> y \<rbrakk> \<Longrightarrow> (z::'a::linorder) \<le> min x y"*)
lemmas conj_le_imp_min = min.boundedI

(*lemma min_eqL:"\<lbrakk> (x::('a::linorder)) \<le> y \<rbrakk> \<Longrightarrow> min x y = x"*)
lemmas min_eqL = min.absorb1
(*lemma min_eqR:"\<lbrakk> (y::('a::linorder)) \<le> x \<rbrakk> \<Longrightarrow> min x y = y"*)
lemmas min_eqR = min.absorb2
lemmas min_eq = min_eqL min_eqR

lemma max_less_imp_conj:"max x y < b \<Longrightarrow> x < (b::('a::linorder)) \<and> y < b" by simp

(*lemma max_le_iff_conj: "(max x y \<le> b) = (x \<le> (b::('a::linorder)) \<and> y \<le> b)"*)
lemmas max_le_iff_conj = max.bounded_iff
lemma max_le_imp_conj:"max x y \<le> b \<Longrightarrow> x \<le> (b::('a::linorder)) \<and> y \<le> b" by simp
(*lemma conj_le_imp_max:"\<lbrakk> x \<le> (b::('a::linorder)); y \<le> b \<rbrakk> \<Longrightarrow> max x y \<le> b"*)
lemmas conj_le_imp_max =  max.boundedI

(*lemma max_eqL:"\<lbrakk> (y::('a::linorder)) \<le> x \<rbrakk> \<Longrightarrow> max x y = x"*)
lemmas max_eqL = max.absorb1
(*lemma max_eqR:"\<lbrakk> (x::('a::linorder)) \<le> y \<rbrakk> \<Longrightarrow> max x y = y"*)
lemmas max_eqR =  max.absorb2
lemmas max_eq = max_eqL max_eqR

(*lemma le_minI1:"min x y \<le> (x::('a::linorder))"*)
lemmas le_minI1 = min.cobounded1
(*lemma le_minI2:"min x y \<le> (y::('a::linorder))"*)
lemmas le_minI2 = min.cobounded2

lemma
  min_le_monoR: "(a::'a::linorder) \<le> b \<Longrightarrow> min x a \<le> min x b" and
  min_le_monoL: "(a::'a::linorder) \<le> b \<Longrightarrow> min a x \<le> min b x"
by (fastforce simp: min.mono min_def)+
lemma
  max_le_monoR: "(a::'a::linorder) \<le> b \<Longrightarrow> max x a \<le> max x b" and
  max_le_monoL: "(a::'a::linorder) \<le> b \<Longrightarrow> max a x \<le> max b x"
by (fastforce simp: max.mono max_def)+

end


section \<open>Generators\<close>

theory "Generators"
imports
   "HOL-Algebra.Group"
   "HOL-Algebra.Lattice"
begin

text \<open>This theory is not specific to Free Groups and could be moved to a more
general place. It defines the subgroup generated by a set of generators and
that homomorphisms agree on the generated subgroup if they agree on the
generators.\<close>

notation subgroup (infix "\<le>" 80)

subsection \<open>The subgroup generated by a set\<close>

text \<open>The span of a set of subgroup generators, i.e. the generated subgroup, can
be defined inductively or as the intersection of all subgroups containing the
generators. Here, we define it inductively and proof the equivalence\<close>

inductive_set gen_span :: "('a,'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set" ("\<langle>_\<rangle>\<index>")
  for G and gens
where gen_one [intro!, simp]: "\<one>\<^bsub>G\<^esub> \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    | gen_gens: "x \<in> gens \<Longrightarrow> x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    | gen_inv: "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> inv\<^bsub>G\<^esub> x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    | gen_mult: "\<lbrakk> x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>; y \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<rbrakk> \<Longrightarrow>  x \<otimes>\<^bsub>G\<^esub> y \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"

lemma (in group) gen_span_closed:
  assumes "gens \<subseteq> carrier G"
  shows "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G"
proof (* How can I do this in one "by" line? *)
  fix x
  from assms show "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> x \<in> carrier G"
    by -(induct rule:gen_span.induct, auto)
qed

lemma (in group) gen_subgroup_is_subgroup:
      "gens \<subseteq> carrier G \<Longrightarrow> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<le> G"
by(rule subgroupI)(auto intro:gen_span.intros simp add:gen_span_closed)

lemma (in group) gen_subgroup_is_smallest_containing:
  assumes "gens \<subseteq> carrier G"
    shows "\<Inter>{H. H \<le> G \<and> gens \<subseteq> H} = \<langle>gens\<rangle>\<^bsub>G\<^esub>"
proof
  show "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> \<Inter>{H. H \<le> G \<and> gens \<subseteq> H}"
  proof(rule Inf_greatest)
    fix H
    assume "H \<in> {H. H \<le> G \<and> gens \<subseteq> H}"
    hence "H \<le> G" and "gens \<subseteq> H" by auto
    show "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> H"
    proof
      fix x
      from \<open>H \<le> G\<close> and \<open>gens \<subseteq> H\<close>
      show "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> x \<in> H"
       unfolding subgroup_def
       by -(induct rule:gen_span.induct, auto)
    qed
  qed
next
  from \<open>gens \<subseteq> carrier G\<close>
  have "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<le> G" by (rule gen_subgroup_is_subgroup)
  moreover
  have "gens \<subseteq> \<langle>gens\<rangle>\<^bsub>G\<^esub>" by (auto intro:gen_span.intros)
  ultimately
  show "\<Inter>{H. H \<le> G \<and> gens \<subseteq> H} \<subseteq> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    by(auto intro:Inter_lower)
qed

subsection \<open>Generators and homomorphisms\<close>

text \<open>Two homorphisms agreeing on some elements agree on the span of those elements.\<close>

lemma hom_unique_on_span:
  assumes "group G"
      and "group H"
      and "gens \<subseteq> carrier G"
      and "h \<in> hom G H"
      and "h' \<in> hom G H"
      and "\<forall>g \<in> gens. h g = h' g"
  shows "\<forall>x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>. h x = h' x"
proof
  interpret G: group G by fact
  interpret H: group H by fact
  interpret h: group_hom G H h by unfold_locales fact
  interpret h': group_hom G H h' by unfold_locales fact

  fix x
  from \<open>gens \<subseteq> carrier G\<close> have "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G" by (rule G.gen_span_closed)
  with assms show "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> h x = h' x" apply -
  proof(induct rule:gen_span.induct)
    case (gen_mult x y)
      hence x: "x \<in> carrier G" and y: "y \<in> carrier G" and
            hx: "h x = h' x" and hy: "h y = h' y" by auto
      thus "h (x \<otimes>\<^bsub>G\<^esub> y) = h' (x \<otimes>\<^bsub>G\<^esub> y)" by simp
  qed auto
qed

subsection \<open>Sets of generators\<close>

text \<open>There is no definition for ``\<open>gens\<close> is a generating set of
\<open>G\<close>''. This is easily expressed by \<open>\<langle>gens\<rangle> = carrier G\<close>.\<close>

text \<open>The following is an application of \<open>hom_unique_on_span\<close> on a
generating set of the whole group.\<close>

lemma (in group) hom_unique_by_gens:
  assumes "group H"
      and gens: "\<langle>gens\<rangle>\<^bsub>G\<^esub> = carrier G"
      and "h \<in> hom G H"
      and "h' \<in> hom G H"
      and "\<forall>g \<in> gens. h g = h' g"
  shows "\<forall>x \<in> carrier G. h x = h' x"
proof
  fix x

  from gens have "gens \<subseteq> carrier G" by (auto intro:gen_span.gen_gens)
  with assms and group_axioms have r: "\<forall>x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>. h x = h' x"
    by -(erule hom_unique_on_span, auto)
  with gens show "x \<in> carrier G \<Longrightarrow> h x = h' x" by auto
qed

lemma (in group_hom) hom_span:
  assumes "gens \<subseteq> carrier G"
  shows "h ` (\<langle>gens\<rangle>\<^bsub>G\<^esub>) = \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
proof(rule Set.set_eqI, rule iffI)
  from \<open>gens \<subseteq> carrier G\<close>
  have "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G" by (rule G.gen_span_closed)

  fix y
  assume "y \<in> h ` \<langle>gens\<rangle>\<^bsub>G\<^esub>"
  then obtain x where "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>" and "y = h x" by auto
  from \<open>x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>\<close>
  have "h x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
  proof(induct x)
    case (gen_inv x)
    hence "x \<in> carrier G" and "h x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
      using \<open>\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G\<close>
      by auto
    thus ?case by (auto intro:gen_span.intros)
  next
    case (gen_mult x y)
    hence "x \<in> carrier G" and "h x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
    and   "y \<in> carrier G" and "h y \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
      using \<open>\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G\<close>
      by auto
    thus ?case by (auto intro:gen_span.intros)
  qed(auto intro: gen_span.intros)
  with \<open>y = h x\<close>
  show "y \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>" by simp
next
  fix x
  show "x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub> \<Longrightarrow> x \<in> h ` \<langle>gens\<rangle>"
  proof(induct x rule:gen_span.induct)
    case (gen_inv y)
      then  obtain x where "y = h x" and "x \<in> \<langle>gens\<rangle>" by auto
      moreover
      hence "x \<in> carrier G"  using \<open>gens \<subseteq> carrier G\<close>
        by (auto dest:G.gen_span_closed)
      ultimately show ?case
        by (auto intro:hom_inv[THEN sym] rev_image_eqI gen_span.gen_inv simp del:group_hom.hom_inv hom_inv)
  next
   case (gen_mult y y')
      then  obtain x and x'
        where "y = h x" and "x \<in> \<langle>gens\<rangle>"
        and "y' = h x'" and "x' \<in> \<langle>gens\<rangle>" by auto
      moreover
      hence "x \<in> carrier G" and "x' \<in> carrier G" using \<open>gens \<subseteq> carrier G\<close>
        by (auto dest:G.gen_span_closed)
      ultimately show ?case
        by (auto intro:hom_mult[THEN sym] rev_image_eqI gen_span.gen_mult simp del:group_hom.hom_mult hom_mult)
  qed(auto intro:rev_image_eqI intro:gen_span.intros)
qed

subsection \<open>Product of a list of group elements\<close>

text \<open>Not strictly related to generators of groups, this is still a general
group concept and not related to Free Groups.\<close>

abbreviation (in monoid) m_concat
  where "m_concat l \<equiv> foldr (\<otimes>) l \<one>"

lemma (in monoid) m_concat_closed[simp]:
 "set l \<subseteq> carrier G \<Longrightarrow> m_concat l \<in> carrier G"
  by (induct l, auto)

lemma (in monoid) m_concat_append[simp]:
  assumes "set a \<subseteq> carrier G"
      and "set b \<subseteq> carrier G"
  shows "m_concat (a@b) = m_concat a \<otimes> m_concat b"
using assms
by(induct a)(auto simp add: m_assoc)

lemma (in monoid) m_concat_cons[simp]:
  "\<lbrakk> x \<in> carrier G ; set xs \<subseteq> carrier G \<rbrakk> \<Longrightarrow> m_concat (x#xs) = x \<otimes> m_concat xs"
by(induct xs)(auto simp add: m_assoc)

lemma (in monoid) m_concat_power[simp]: "x \<in> carrier G \<Longrightarrow> m_concat (replicate n x) = x [^] n"
by(induct n, auto simp add:nat_pow_mult1l)

subsection \<open>Isomorphisms\<close>

text \<open>A nicer way of proving that something is a group homomorphism or
isomorphism.\<close>

lemma group_homI[intro]:
  assumes range: "h ` (carrier g1) \<subseteq> carrier g2"
      and hom: "\<forall>x\<in>carrier g1. \<forall>y\<in>carrier g1. h (x \<otimes>\<^bsub>g1\<^esub> y) = h x \<otimes>\<^bsub>g2\<^esub> h y"
  shows "h \<in> hom g1 g2"
proof-
  have "h \<in> carrier g1 \<rightarrow> carrier g2" using range  by auto
  thus "h \<in> hom g1 g2" using hom unfolding hom_def by auto
qed

lemma (in group_hom) hom_injI:
  assumes "\<forall>x\<in>carrier G. h x = \<one>\<^bsub>H\<^esub> \<longrightarrow> x = \<one>\<^bsub>G\<^esub>"
  shows "inj_on h (carrier G)"
unfolding inj_on_def
proof(rule ballI, rule ballI, rule impI)
  fix x
  fix y
  assume x: "x\<in>carrier G"
     and y: "y\<in>carrier G"
     and "h x = h y"
  hence "h (x \<otimes> inv y) = \<one>\<^bsub>H\<^esub>" and "x \<otimes> inv y \<in> carrier G"
    by auto
  with assms
  have "x \<otimes> inv y = \<one>" by auto
  thus "x = y" using x and y
    by(auto dest: G.inv_equality)
qed

lemma (in group_hom) group_hom_isoI:
  assumes inj1: "\<forall>x\<in>carrier G. h x = \<one>\<^bsub>H\<^esub> \<longrightarrow> x = \<one>\<^bsub>G\<^esub>"
      and surj: "h ` (carrier G) = carrier H"
  shows "h \<in> iso G H"
proof-
  from inj1
  have "inj_on h (carrier G)"
    by(auto intro: hom_injI)
  hence bij: "bij_betw h (carrier G) (carrier H)"
    using surj  unfolding bij_betw_def by auto
  thus ?thesis
    unfolding iso_def by auto
qed

lemma group_isoI[intro]:
  assumes G: "group G"
      and H: "group H"
      and inj1: "\<forall>x\<in>carrier G. h x = \<one>\<^bsub>H\<^esub> \<longrightarrow> x = \<one>\<^bsub>G\<^esub>"
      and surj: "h ` (carrier G) = carrier H"
      and hom: "\<forall>x\<in>carrier G. \<forall>y\<in>carrier G. h (x \<otimes>\<^bsub>G\<^esub> y) = h x \<otimes>\<^bsub>H\<^esub> h y"
  shows "h \<in> iso G H"
proof-
  from surj
  have "h \<in> carrier G \<rightarrow> carrier H"
    by auto
  then interpret group_hom G H h using G and H and hom
    by (auto intro!: group_hom.intro group_hom_axioms.intro)
  show ?thesis
  using assms unfolding hom_def by (auto intro: group_hom_isoI)
qed
end


(* Title:      Minkowski Integral Inequality
   Author:     Omar A. Jasim <oajasim1@sheffield.ac.uk>, Sandor M. Veres <s.veres@sheffield.ac.uk>
   Maintainer: Omar A. Jasim <oajasim1@sheffield.ac.uk>, Sandor M. Veres <s.veres@sheffield.ac.uk>
*)

theory Minkowski_Integral_Inequality
imports  Complex_Main
"~~/src/HOL/Probability/Set_Integral"
"~~/src/HOL/library/Quadratic_Discriminant"
begin

lemma nonnegative_of_quadratic_polynomial:
  fixes a b c x :: real
  assumes  "a > 0"
  and  "\<And>x. a*x^2 + b*x + c\<ge>0 "
  shows "discrim a b c \<le>0"
proof -
have "\<exists>x. a*x^2 + b*x + c<0 " when "discrim a b c > 0" "a>0"
  proof -
    let ?P="\<lambda>x. a*x^2 + b*x +c"
   have "?P (- b / (2*a)) =  (4*a*c-b^2)/(4*a)" using \<open>a>0\<close>
   apply (auto simp add:field_simps)
      by algebra
   also have "... <0"
      using that unfolding discrim_def by (simp add: divide_neg_pos)
   finally show ?thesis by blast
   qed
then show ?thesis using assms
  using not_less by blast
qed

lemma  schwaz_integral_ineq:
  fixes f g :: "real \<Rightarrow> real"
  assumes "\<And>t. t \<in> A"
          "set_integrable M A f"
          "set_integrable M A g "
          "set_integrable M A (\<lambda>t. (f t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. (g t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. f t * g t)"
          "(LINT t:A|M. (g t)\<^sup>2) > 0"
  shows "(LINT t:A|M. f t * g t) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)"
proof -
  fix  \<alpha>:: "real"
  let ?a ="(LINT t:A|M. (g t)\<^sup>2)" and ?b="2*(LINT t:A|M. f t * g t)" and ?c="(LINT t:A|M. (f t)\<^sup>2)"
  have "\<And>\<alpha>. (LINT t:A|M. (f t + \<alpha>* g t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  then have "\<And>\<alpha>. (LINT t:A|M. (f t)\<^sup>2 + 2 * (f t *(\<alpha> * g t)) + (\<alpha> * g t)\<^sup>2 ) \<ge> 0"
    by (simp add: add.commute add.left_commute mult.assoc power2_sum)
  then have "\<And>\<alpha>. (LINT t:A|M. (f t)\<^sup>2 + 2*\<alpha>* (f t * g t) + (\<alpha>)\<^sup>2*(g t)\<^sup>2) \<ge> 0 "
    by (simp add: diff_add_eq mult.assoc mult.left_commute semiring_normalization_rules(30))
  then have "\<And>\<alpha>. (LINT t:A|M. (f t)\<^sup>2) + 2*\<alpha>*(LINT t:A|M. f t * g t) + (\<alpha>)\<^sup>2* (LINT t:A|M.(g t)\<^sup>2) \<ge> 0"
    using assms by force
  then have "\<And>\<alpha>. ?c + ?b*\<alpha> + ?a*(\<alpha>)\<^sup>2 \<ge> 0"
    by (simp add: mult.assoc mult.commute)
  then have "\<And>\<alpha>. ?a*(\<alpha>)\<^sup>2 + ?b*\<alpha> + ?c \<ge>0"
    by (metis (lifting) add.assoc add.commute)
  then have "discrim ?a ?b ?c \<le> 0"
    using assms nonnegative_of_quadratic_polynomial by presburger
  then have s1: "?b\<^sup>2 \<le> 4 * ?a * ?c"
    by (simp add: discrim_def)
  have "?b\<^sup>2\<ge>0"
    by simp
  then have "?b \<le> sqrt(4 * ?a * ?c)"
    using s1 by (simp add: real_le_rsqrt)
  then have "?b \<le> 2 * sqrt(?a) * sqrt(?c)"
    by (simp add: real_sqrt_mult_distrib2)
  then have "2*(LINT t:A|M. f t * g t) \<le> 2 * sqrt(LINT t:A|M. (g t)\<^sup>2) * sqrt(LINT t:A|M. (f t)\<^sup>2)"
    by blast
  then have "(LINT t:A|M. f t * g t) \<le> sqrt(LINT t:A|M. (g t)\<^sup>2) * sqrt(LINT t:A|M. (f t)\<^sup>2)"
    by linarith
  then have "(LINT t:A|M. f t * g t) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)"
    by (simp add: semiring_normalization_rules(7))
  from this assms show "(LINT t:A|M. f t * g t) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)"
    by fastforce
qed

lemma minkowski_integral_ineq:
  fixes f g :: "real \<Rightarrow> real"
  assumes "\<And>t. t \<in> A"
          "set_integrable M A f"
          "set_integrable M A g"
          "set_integrable M A (\<lambda>t. (f t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. (g t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. f t * g t)"
          "(LINT t:A|M. (g t)\<^sup>2) > 0"
  shows "sqrt(LINT t:A|M. (f t + g t)\<^sup>2) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2)"
proof -
  have "(LINT t:A|M. (f t + g t)\<^sup>2) = (LINT t:A|M. (f t)\<^sup>2 + 2 * (f t * g t) + (g t)\<^sup>2)"
    by (simp add: add.commute add.left_commute mult.assoc power2_sum)
  then have "(LINT t:A|M. (f t + g t)\<^sup>2) = (LINT t:A|M. (f t)\<^sup>2) + 2*(LINT t:A|M. (f t * g t)) + (LINT t:A|M. (g t)\<^sup>2)"
    using assms by auto
  then have "(LINT t:A|M. (f t + g t)\<^sup>2) \<le>
   (LINT t:A|M. (f t)\<^sup>2) + 2*(sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)) + (LINT t:A|M. (g t)\<^sup>2)"
    using schwaz_integral_ineq assms by auto
  then have "(LINT t:A|M. (f t + g t)\<^sup>2) \<le>
   (sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2)) * (sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2))"
    by (simp add: add.commute distrib_right sum_squares_ge_zero semiring_normalization_rules(34))
  then have m:"(LINT t:A|M. (f t + g t)\<^sup>2) \<le> (sqrt(LINT t:A|M. (f t)\<^sup>2)+ sqrt(LINT t:A|M. (g t)\<^sup>2))\<^sup>2"
    by (simp add: power2_eq_square)
(* to get rid of asb *)
  have lhs: "sqrt(LINT t:A|M. (f t + g t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  have rhs: "sqrt(LINT t:A|M. (f t)\<^sup>2) \<ge> 0 \<and> sqrt(LINT t:A|M. (g t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  from lhs rhs m have "sqrt(LINT t:A|M. (f t + g t)\<^sup>2) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2)+ sqrt(LINT t:A|M. (g t)\<^sup>2)"
    using real_le_lsqrt by force
  thus ?thesis.
qed

(*for negative*)

lemma  schwaz_integral_ineq_ng:
  fixes f g :: "real \<Rightarrow> real"
  assumes "\<And>t. t \<in> A"
          "set_integrable M A f"
          "set_integrable M A g "
          "set_integrable M A (\<lambda>t. (f t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. (g t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. f t * g t)"
          "(LINT t:A|M. (g t)\<^sup>2) > 0"
  shows "(LINT t:A|M. f t * - g t) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)"
proof -
  fix  \<alpha>:: "real"
  let ?a ="(LINT t:A|M. (g t)\<^sup>2)" and ?b="2*(LINT t:A|M. f t * -g t)" and ?c="(LINT t:A|M. (f t)\<^sup>2)"
  have "\<And>\<alpha>. (LINT t:A|M. (f t - \<alpha>* g t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  then have "\<And>\<alpha>. (LINT t:A|M. (f t)\<^sup>2 + (\<alpha>*g t)\<^sup>2 - 2*\<alpha>*(f t * g t)) \<ge> 0"
    by (simp add:  power2_diff linordered_field_class.sign_simps(24) mult.left_commute)
  then have "\<And>\<alpha>. (LINT t:A|M. (f t)\<^sup>2) + 2*\<alpha>*(LINT t:A|M. f t * - g t) + (\<alpha>)\<^sup>2*(LINT t:A|M. (g t)\<^sup>2) \<ge> 0"
    using assms by (simp add: diff_add_eq semiring_normalization_rules(30))
  then have " \<And>\<alpha>. ?c + ?b*\<alpha> + ?a*(\<alpha>)\<^sup>2 \<ge> 0"
    by (simp add: mult.assoc mult.commute)
  then have "\<And>\<alpha>. ?a*(\<alpha>)\<^sup>2 + ?b*\<alpha> + ?c \<ge>0"
    by (metis (lifting) add.assoc add.commute)
  then have " discrim ?a ?b ?c \<le> 0"
    using assms  nonnegative_of_quadratic_polynomial by presburger
  then have m:" ?b\<^sup>2 \<le> 4 * ?a * ?c"
    by (simp add: discrim_def)
  have "?b\<^sup>2\<ge>0" by simp
  from this m have "?b \<le> sqrt(4 * ?a * ?c)"
    by (simp add: real_le_rsqrt)
  then have "?b \<le> 2 * sqrt(?a) * sqrt(?c)"
    by (simp add: linordered_field_class.sign_simps(24) mult.left_commute real_sqrt_mult_distrib2)
  from this assms show "(LINT t:A|M. f t * -g t) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)"
    by (simp add: linordered_field_class.sign_simps(24) mult.left_commute)
qed

lemma  minkowski_integral_ineq_ng:
  fixes f g :: "real \<Rightarrow> real"
  assumes "\<And>t. t \<in> A"
          "set_integrable M A f"
          "set_integrable M A g "
          "set_integrable M A (\<lambda>t. (f t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. (g t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. f t * g t)"
          "(LINT t:A|M. (g t)\<^sup>2) > 0"
  shows "sqrt(LINT t:A|M. (f t - g t)\<^sup>2) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2)"
proof -
  have "(LINT t:A|M. (f t + -g t)\<^sup>2) = (LINT t:A|M. (f t)\<^sup>2 + 2*(f t * -g t) + (g t)\<^sup>2)"
    by (simp add: diff_add_eq power2_diff mult.assoc)
  then have mn1: "(LINT t:A|M. (f t + -g t)\<^sup>2) =
    (LINT t:A|M. (f t)\<^sup>2) + 2*(LINT t:A|M. f t * -g t) + (LINT t:A|M. (g t)\<^sup>2)"
    using assms by auto
  have "(LINT t:A|M. f t * -g t) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * sqrt(LINT t:A|M. (g t)\<^sup>2)"
    using schwaz_integral_ineq_ng assms by blast
  from this mn1  have "(LINT t:A|M. (f t + -g t)\<^sup>2) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) * (sqrt(LINT t:A|M. (f t)\<^sup>2)
    + sqrt(LINT t:A|M. (g t)\<^sup>2)) + sqrt(LINT t:A|M. (g t)\<^sup>2) * (sqrt(LINT t:A|M. (g t)\<^sup>2) + sqrt(LINT t:A|M. (f t)\<^sup>2))"
    by (simp add: sum_squares_ge_zero semiring_normalization_rules(34))
  then have mn2: "(LINT t:A|M. (f t + -g t)\<^sup>2) \<le>
    (sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2))\<^sup>2"
    by (simp add: add.commute distrib_right power2_eq_square)
(* to get rid of asb *)
  have lhs: "sqrt(LINT t:A|M. (f t + -g t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  have rhs: "sqrt(LINT t:A|M. (f t)\<^sup>2) \<ge> 0 \<and> sqrt(LINT t:A|M. (g t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  show ?thesis using lhs rhs mn2 real_le_lsqrt by force
qed

end


(*  Title:      Card_Lemmas.thy
    Author:     Ata Keskin, TU München
*)

section "Lemmas involving the cardinality of sets"

text \<open>In this section, we prove some lemmas that make use of the term @{term card} or provide bounds for it.\<close>

theory Card_Lemmas
  imports Main
begin

lemma card_Int_copy:
  assumes "finite X" and "A \<union> B \<subseteq> X" and "\<exists>f. inj_on f (A \<inter> B) \<and> (A \<union> B) \<inter> (f ` (A \<inter> B)) = {} \<and> f ` (A \<inter> B) \<subseteq> X"
  shows "card A + card B \<le> card X"
proof -
  from rev_finite_subset[OF assms(1), of A] rev_finite_subset[OF assms(1), of B] assms(2)
  have finite_A: "finite A" and finite_B: "finite B" by blast+
  then have finite_A_Un_B: "finite (A \<union> B)" and finite_A_Int_B: "finite (A \<inter> B)" by blast+
  from assms(3) obtain f where f_inj_on: "inj_on f (A \<inter> B)"
                           and f_disjnt: "(A \<union> B) \<inter> (f ` (A \<inter> B)) = {}"
                           and f_imj_in: "f ` (A \<inter> B) \<subseteq> X" by blast
  from finite_A_Int_B have finite_f_img: "finite (f ` (A \<inter> B))" by blast
  from assms(2) f_imj_in have union_in: "(A \<union> B) \<union> f ` (A \<inter> B) \<subseteq> X" by blast

  from card_Un_Int[OF finite_A finite_B] have "card A + card B = card (A \<union> B) + card (A \<inter> B)" .
  also from card_image[OF f_inj_on] have "... = card (A \<union> B) + card (f ` (A \<inter> B))" by presburger
  also from card_Un_disjoint[OF finite_A_Un_B finite_f_img f_disjnt] have "... = card ((A \<union> B) \<union> f ` (A \<inter> B))" by argo
  also from card_mono[OF assms(1) union_in] have "... \<le> card X" by blast
  finally show ?thesis .
qed

lemma finite_diff_not_empty:
  assumes "finite Y" and "card Y < card X"
  shows "X - Y \<noteq> {}"
proof
  assume "X - Y = {}"
  hence "X \<subseteq> Y" by simp
  from card_mono[OF assms(1) this] assms(2) show False by linarith
qed

lemma obtain_difference_element:
  fixes F :: "'a set set"
  assumes "2 \<le> card F"
  obtains "x" where "x\<in> \<Union>F" "x \<notin> \<Inter>F"
proof -
  from assms card_le_Suc_iff[of 1 F] obtain A F' where 0: "F = insert A F'" and 1: "A \<notin> F'" and 2: "1 \<le> card F'" by auto
  from 2 card_le_Suc_iff[of 0 F'] obtain B F'' where 3: "F' = insert B F''" by auto
  from 1 3 have A_noteq_B: "A \<noteq> B" by blast
  from 0 3 have A_in_F: "A \<in> F" and B_in_F: "B \<in> F" by blast+
  from A_noteq_B have "(A - B) \<union> (B - A) \<noteq> {}" by simp
  with A_in_F B_in_F that show thesis by blast
qed

end


section "Arithmetic and Boolean Expressions"

subsection "Arithmetic Expressions"

theory AExp imports Main begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{AExpaexpdef}{2}{1}{%\<close>
datatype aexp = N int | V vname | Plus aexp aexp
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{AExpavaldef}{1}{2}{%\<close>
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
text_raw\<open>}%endsnip\<close>

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text \<open>The same state more concisely:\<close>
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text \<open>A little syntax magic to write larger states compactly:\<close>

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text \<open>\noindent
  We can now write a series of updates to the function \<open>\<lambda>x. 0\<close> compactly:
\<close>
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text \<open>In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
\<close>
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text\<open>Note that this \<open><\<dots>>\<close> syntax works for any function space
\<open>\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2\<close> where \<open>\<tau>\<^sub>2\<close> has a \<open>0\<close>.\<close>

subsection "Constant Folding"

text\<open>Evaluate constant subsexpressions:\<close>

text_raw\<open>\snip{AExpasimpconstdef}{0}{2}{%\<close>
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw\<open>}%endsnip\<close>

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text\<open>Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors:\<close>

text_raw\<open>\snip{AExpplusdef}{0}{2}{%\<close>
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw\<open>}%endsnip\<close>

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw\<open>\snip{AExpasimpdef}{2}{0}{%\<close>
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw\<open>}%endsnip\<close>

text\<open>Note that in \<^const>\<open>asimp_const\<close> the optimized constructor was
inlined. Making it a separate function \<^const>\<open>plus\<close> improves modularity of
the code and the proofs.\<close>

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end