theory Term31
imports Main
begin

chapter \<open>3.5 Evaluation\<close>

section \<open>definition\<close>

datatype t
  = true
  | false
  | Cond t t t ("If _ Then _ Else _" [95,95,95] 90)

inductive eval :: "t \<Rightarrow> t \<Rightarrow> bool" ("_ \<mapsto> _" [50,50] 40)
  where
    E_IfTrue: "If true Then t2 Else t3 \<mapsto> t2"
  | E_IfFalse: "If false Then t2 Else t3 \<mapsto> t3"
  | E_If:  "t1 \<mapsto> t1' \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto> If t1' Then t2 Else t3"

definition is_value :: "t \<Rightarrow> bool"
  where "is_value t \<longleftrightarrow> (t = true \<or> t = false)"

lemma true_is_value[intro]: "is_value true" using is_value_def by simp
lemma false_is_value[intro]: "is_value false" using is_value_def by simp
lemma if_isnot_value: "is_value (If t1 Then t2 Else t3) \<Longrightarrow> False" using is_value_def by simp

lemma ex_353:
  assumes s: "s = If true Then false Else false"
  assumes t: "t = If s Then true Else true"
  assumes u: "u = If false Then true Else true"
  shows "If t Then false Else false \<mapsto> If u Then false Else false"
  apply (simp add: s t u)
  apply (rule E_If)
  apply (rule E_If)
  apply (rule E_IfTrue)
  done

lemma true_cannot_eval: "\<not>(\<exists>t. true \<mapsto> t)"
  using eval.cases by blast

lemma false_cannot_eval: "\<not>(\<exists>t. false \<mapsto> t)"
  using eval.cases by blast

lemma eval_IfTrue_eq_then: "If true Then t2 Else t3 \<mapsto> t2' \<Longrightarrow> t2' = t2"
  using eval.cases true_cannot_eval by auto

lemma eval_IfFalse_eq_else: "If false Then t2 Else t3 \<mapsto> t3' \<Longrightarrow> t3' = t3"
  using eval.cases false_cannot_eval by auto

section \<open>3.5.4 deterministic of eval\<close>

(* 3.5.4 *)
theorem eval_deterministic: "\<lbrakk> t \<mapsto> t'; t \<mapsto> t'' \<rbrakk> \<Longrightarrow> t' = t''"
proof(induct t arbitrary: t' t'')
  case true thus ?case using true_cannot_eval by blast
next
  case false thus ?case using false_cannot_eval by blast
next
  case Cond
  fix t1 t2 t3 t t''
  assume t1_induct: "\<And>t' t''. t1 \<mapsto> t' \<Longrightarrow> t1 \<mapsto> t'' \<Longrightarrow> t' = t''"
  assume et': "If t1 Then t2 Else t3 \<mapsto> t'"
  assume et'': "If t1 Then t2 Else t3 \<mapsto> t''"
  show "t' = t''"
  proof (cases t1)
    case true
    have "t' = t2" using true eval_IfTrue_eq_then et' by simp
    also have "t'' = t2" using true eval_IfTrue_eq_then et'' by simp
    finally show "t' = t''" by simp
  next
    case false
    have "t' = t3" using false eval_IfFalse_eq_else et' by simp
    also have "t'' = t3" using false eval_IfFalse_eq_else et'' by simp
    finally show "t' = t''" by simp
  next
    case Cond
    obtain t1' where t1t1': "t1 \<mapsto> t1'" and t'if: "t' = (If t1' Then t2 Else t3)"
      using Cond et' eval.cases by blast
    obtain t1'' where t1t1'': "t1 \<mapsto> t1''" and t''if: "t'' = (If t1'' Then t2 Else t3)"
      using Cond et'' eval.cases by blast
    have "t1' = t1''" using t1_induct t1t1' t1t1'' by simp
    with t'if t''if show "t' = t''" by simp
  qed
qed

definition is_normal_form :: "t \<Rightarrow> bool"
  where "is_normal_form t \<longleftrightarrow> \<not>(\<exists>t'. t \<mapsto> t')"

lemma is_normal_formE[intro]: "\<not>(\<exists>t'. t \<mapsto> t') \<Longrightarrow> is_normal_form t" using is_normal_form_def by simp
lemma is_normal_formI[elim]: "is_normal_form t \<Longrightarrow> \<not>(\<exists>t'. t \<mapsto> t')" using is_normal_form_def by simp

lemma true_is_normal_form[intro]: "is_normal_form true" using true_cannot_eval is_normal_form_def by simp
lemma false_is_normal_form[intro]: "is_normal_form false" using false_cannot_eval is_normal_form_def by simp
lemma normal_form_cannot_eval: "\<lbrakk> is_normal_form t; t \<mapsto> t' \<rbrakk> \<Longrightarrow> False" using is_normal_form_def by blast
lemma if_isnot_normal_form: "\<not>(is_normal_form (If t1 Then t2 Else t3))"
  apply (induct t1 arbitrary: t2 t3)
  using E_IfTrue is_normal_form_def apply blast
  using E_IfFalse is_normal_form_def apply blast
  using E_If is_normal_form_def by metis

section \<open>3.5.7 value is normal form\<close>

(* 3.5.7 *)
theorem value_is_normal_form: "is_value t \<Longrightarrow> is_normal_form t"
  using is_value_def by fastforce

section \<open>3.5.8 normal form is value\<close>

(* 3.5.8 *)
theorem normal_form_is_value: "is_normal_form t \<Longrightarrow> is_value t"
  apply (rule t.exhaust[of t], blast, blast)
  apply (simp add: if_isnot_normal_form)
  done

section \<open>3.5.9 definition of eval*\<close>

(* 3.5.9 *)
inductive eval_star :: "t \<Rightarrow> t \<Rightarrow> bool" ("_ \<mapsto>* _" [50,50] 40) where
    EsRefl: "t \<mapsto>* t"
  | EsStep: "\<lbrakk> t \<mapsto> t' \<rbrakk> \<Longrightarrow> t \<mapsto>* t'"
  | EsTrans: "\<lbrakk> t \<mapsto>* t'; t' \<mapsto>* t'' \<rbrakk> \<Longrightarrow> t \<mapsto>* t''"

lemma eval_star_refl[intro]: "t = t' \<Longrightarrow> t \<mapsto>* t'" using EsRefl by simp
lemma eval_star_step[intro]: "t \<mapsto> t' \<Longrightarrow> t \<mapsto>* t'" by (rule EsStep)
lemma eval_star_trans1[intro]: "\<lbrakk> t \<mapsto>* t'; t' \<mapsto>* t'' \<rbrakk> \<Longrightarrow> t \<mapsto>* t''" by (rule EsTrans)
lemma eval_star_trans2[intro]: "\<lbrakk> t \<mapsto> t'; t' \<mapsto>* t'' \<rbrakk>  \<Longrightarrow> t \<mapsto>* t''" using EsStep EsTrans by blast
lemma eval_star_trans3[intro]: "\<lbrakk> t \<mapsto>* t'; t' \<mapsto> t'' \<rbrakk>  \<Longrightarrow> t \<mapsto>* t''" using EsStep EsTrans by blast

lemma eval_starI1: "\<lbrakk> t = t' \<or> t \<mapsto> t' \<or> (\<exists>t''. t \<mapsto>* t'' \<and> t'' \<mapsto>* t') \<rbrakk> \<Longrightarrow> t \<mapsto>* t'"
  using EsRefl EsStep EsTrans by blast
lemma eval_starI2: "\<lbrakk> t = t' \<or> t \<mapsto> t' \<or> (\<exists>t''. t \<mapsto>* t'' \<and> t'' \<mapsto> t') \<rbrakk> \<Longrightarrow> t \<mapsto>* t'"
  using EsRefl EsStep EsTrans by blast
lemma eval_starI3: "\<lbrakk> t = t' \<or> t \<mapsto> t' \<or> (\<exists>t''. t \<mapsto> t'' \<and> t'' \<mapsto>* t') \<rbrakk> \<Longrightarrow> t \<mapsto>* t'"
  using EsRefl EsStep EsTrans by blast

lemma E_If_star: "t1 \<mapsto>* t1' \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>* If t1' Then t2 Else t3"
proof (induct rule: eval_star.induct)
  case (EsRefl t)
  then show ?case by (rule eval_star_refl, rule refl)
next
  case (EsStep t t')
  show ?case by (rule eval_star_step, rule E_If, rule EsStep)
next
  case (EsTrans t t' t'')
  show ?case by (rule eval_star_trans1, rule EsTrans(2), rule EsTrans(4))
qed

lemma eval_star_IfTrue: "\<lbrakk> t1 \<mapsto>* true \<rbrakk> \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>* t2"
  using E_If_star[of t1, of true] E_IfTrue eval_star_trans2 eval_star_trans3 by blast

lemma eval_star_IfFalse: "\<lbrakk> t1 \<mapsto>* false \<rbrakk> \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>* t3"
  using E_If_star[of t1, of false] E_IfFalse eval_star_trans2 eval_star_trans3 by blast

lemma normal_form_eval_star_refl:
  assumes es: "t \<mapsto>* t'"
  assumes vt: "is_normal_form t"
  shows "t = t'"
  using es vt
  apply (induct rule: eval_star.induct)
    apply simp
    using normal_form_cannot_eval apply blast
    using normal_form_cannot_eval by blast

section \<open>3.5.11 deterministic of eval*\<close>

(* 3.5.11 *)
lemma eval_star_deterministic: "\<lbrakk> t \<mapsto>* t'; is_normal_form t'; t \<mapsto> t''; is_normal_form t'' \<rbrakk> \<Longrightarrow> t' = t''"
proof (induct rule: eval_star.induct)
  case (EsRefl t)
  then show ?case
    using normal_form_cannot_eval by blast
next
  case (EsStep t t')
  then show ?case
    using eval_deterministic by blast
next
  case (EsTrans t tmid' t')
  then show ?case
    oops

section \<open>3.5.11' definition of eval n\<close>

inductive eval_n :: "t \<Rightarrow> nat \<Rightarrow> t \<Rightarrow> bool" ("_ \<mapsto>^_ _" [50,90,50] 40) where
  En0: "t \<mapsto>^0 t"
| EnN: "\<lbrakk> t \<mapsto>^n t'; t' \<mapsto> t'' \<rbrakk> \<Longrightarrow> t \<mapsto>^(Suc n) t''"

lemma eval_0_refl[elim]: "t \<mapsto>^0 t' \<Longrightarrow> t = t'"
  by (metis Zero_neq_Suc eval_n.simps)
lemma eval_1_step[elim]: "t \<mapsto>^1 t' \<Longrightarrow> t \<mapsto> t'"
  by (metis eval_n.simps lessI less_one nat.simps(3) one_neq_zero)
lemma eval_n_star[elim]: "t \<mapsto>^n t' \<Longrightarrow> t \<mapsto>* t'"
proof (induct rule: eval_n.induct)
  case (En0 t)
  then show ?case by (rule EsRefl)
next
  case (EnN t t' n t'')
  then show ?case by blast
qed

lemma exist_last_step: "\<lbrakk> t \<mapsto>^(Suc n) t' \<rbrakk> \<Longrightarrow> \<exists>t''. t \<mapsto>^n t'' \<and> t'' \<mapsto> t'"
  by (metis eval_n.simps nat.inject old.nat.distinct(2))
lemma exist_mid_step: "\<lbrakk> t \<mapsto>^(n + m) t' \<rbrakk> \<Longrightarrow> \<exists>t''. t \<mapsto>^n t'' \<and> t'' \<mapsto>^m t'"
proof (induct m arbitrary: n t t')
  case 0
  then show ?case
    using En0 by auto
next
  case (Suc m)
  then show ?case
    by (metis EnN exist_last_step nat_arith.suc1)
qed
lemma exist_mid_step2: "\<lbrakk> t \<mapsto>^n t'; m < n \<rbrakk> \<Longrightarrow> \<exists>t''. t \<mapsto>^m t'' \<and> t'' \<mapsto>^(n - m) t'"
  using exist_mid_step by force
lemma exist_first_step: "\<lbrakk> t \<mapsto>^(Suc n) t' \<rbrakk> \<Longrightarrow> \<exists>t''. t \<mapsto> t'' \<and> t'' \<mapsto>^n t'"
  using exist_mid_step[where n=1, where m=n] by fastforce

lemma eval_n_plus_1: "\<lbrakk> t \<mapsto>^n t'; t' \<mapsto> t'' \<rbrakk> \<Longrightarrow> t \<mapsto>^(Suc n) t''" by (simp add: EnN)
lemma eval_n_plus_m: "\<lbrakk> t \<mapsto>^n t'; t' \<mapsto>^m t'' \<rbrakk> \<Longrightarrow> t \<mapsto>^(n+m) t''"
proof (induct m arbitrary: n t t' t'')
  case 0
  then show ?case
    using eval_0_refl by auto
next
  case (Suc n)
  then show ?case
    by (metis eval_n.simps nat.inject nat.simps(3) nat_arith.suc1)
qed
lemma eval_1_plus_n: "\<lbrakk> t \<mapsto> t'; t' \<mapsto>^n t'' \<rbrakk> \<Longrightarrow> t \<mapsto>^(Suc n) t''"
  by (metis One_nat_def Suc_eq_plus1_left eval_n.simps eval_n_plus_m)

lemma refl_eval_0[intro]: "t = t' \<Longrightarrow> t \<mapsto>^0 t'"
  using En0 by presburger
lemma step_eval_1[intro]: "t \<mapsto> t' \<Longrightarrow> t \<mapsto>^1 t'"
  using En0 EnN by force
lemma eval_star_eval_n[intro]: "t \<mapsto>* t' \<Longrightarrow> \<exists>n. t \<mapsto>^n t'"
proof (induct rule: eval_star.induct)
  case (EsRefl t)
  then show ?case
    using En0 by blast
next
  case (EsStep t t')
  then show ?case
    using step_eval_1 by blast
next
  case (EsTrans t t' t'')
  then show ?case
    using eval_n_plus_m by blast
qed

lemma can_eval_suc_inot_normal_form: "\<lbrakk> t \<mapsto>^n t'; n > 0 \<rbrakk> \<Longrightarrow> \<not>(is_normal_form t)"
  by (metis Suc_eq_plus1_left eval_1_step exist_mid_step is_normal_formI less_numeral_extra(3) not0_implies_Suc)

section \<open>3.5.11'' deterministic of eval n\<close>

theorem eval_n_deterministic: "\<lbrakk> t \<mapsto>^n t'; t \<mapsto>^n t'' \<rbrakk> \<Longrightarrow> t' = t''"
proof (induct n arbitrary: t t' t'')
  case 0
  then show ?case
    using eval_0_refl by blast
next
  case (Suc n)
  assume "t \<mapsto>^(Suc n) t'"
  with exist_last_step obtain tp' where tp'n:"t \<mapsto>^n tp'" and tp'next:"tp' \<mapsto> t'" by blast
  assume "t \<mapsto>^(Suc n) t''"
  with exist_last_step obtain tp'' where tp''n:"t \<mapsto>^n tp''" and tp''next:"tp'' \<mapsto> t''" by blast
  have eq:"tp' = tp''" using tp'n tp''n Suc(1) by blast
  show "t' = t''"
    using tp'next tp''next eq eval_deterministic by simp
qed

lemma eval_mid_isnot_normal_form: "\<lbrakk> t \<mapsto>^n t'; is_normal_form t'; t \<mapsto>^m t''; m < n \<rbrakk> \<Longrightarrow> \<not>(is_normal_form t'')"
proof -
  assume "t \<mapsto>^n t'" and mn: "m < n"
  then obtain t''' where pre:"t \<mapsto>^m t'''" and post:"t''' \<mapsto>^(n-m) t'" using exist_mid_step2 by blast
  have nv: "\<not>(is_normal_form t''')" apply (rule can_eval_suc_inot_normal_form[OF post]) using mn by arith
  assume "t \<mapsto>^m t''"  hence "t'' = t'''" using pre eval_n_deterministic by blast
  with nv
  show "\<not>(is_normal_form t'')" by simp
qed
lemma eval_mid_isnot_normal_form2: "\<lbrakk> t \<mapsto>^n t'; is_normal_form t'; t \<mapsto>^m t''; is_normal_form t'' \<rbrakk> \<Longrightarrow> \<not>(m < n)"
  using eval_mid_isnot_normal_form by blast

lemma eval_n_normal_exist_only_one: "\<lbrakk> t \<mapsto>^n t'; is_normal_form t'; t \<mapsto>^m t''; is_normal_form t'' \<rbrakk> \<Longrightarrow> n = m"
  using eval_mid_isnot_normal_form2[where n=n] eval_mid_isnot_normal_form2[where n=m] nat_neq_iff by blast

lemma eval_n_deterministic_on_normal_form: "\<lbrakk> t \<mapsto>^n t'; is_normal_form t'; t \<mapsto>^m t''; is_normal_form t'' \<rbrakk> \<Longrightarrow> t' = t''"
  using eval_n_normal_exist_only_one eval_n_deterministic by blast

section \<open>3.5.11 deterministic of eval*\<close>

(* 3.5.11 *)
theorem eval_star_deterministic: "\<lbrakk> t \<mapsto>* t'; is_normal_form t'; t \<mapsto>* t''; is_normal_form t'' \<rbrakk> \<Longrightarrow> t' = t''"
  apply (drule eval_star_eval_n, drule eval_star_eval_n)
  using eval_n_deterministic_on_normal_form by blast

section \<open>3.5.12 eval* halt\<close>

primrec size :: "t \<Rightarrow> nat" where
  size_true: "size true = 1"
| size_false: "size false = 1"
| size_if: "size (If t1 Then t2 Else t3) = 1 + size t1 + size t2 + size t3"

lemma normal_form_size_is_one: "is_normal_form t \<Longrightarrow> size t = 1"
proof (cases t)
  case true
  then show ?thesis by simp
next
  case false
  then show ?thesis by simp
next
  assume tv: "is_normal_form t"
  case (Cond x31 x32 x33)
  then show ?thesis using tv if_isnot_normal_form by simp
qed

lemma can_eval_size_two_or_more: "size t > 1 \<Longrightarrow> \<exists>t'. t \<mapsto> t'"
  by (metis is_normal_form_def less_numeral_extra(4) normal_form_size_is_one)

lemma size_eval_mono: "t \<mapsto> t' \<Longrightarrow> size t > size t'"
proof (induct rule: eval.induct)
  case (E_IfTrue t2 t3)
  then show ?case using size_if by arith
next
  case (E_IfFalse t2 t3)
  then show ?case using size_if by arith
next
  case (E_If t1 t1' t2 t3)
  then show ?case using size_if by arith
qed

(* 3.5.12 *)
theorem eval_star_stop: "\<exists>t'. t \<mapsto>* t' \<and> is_normal_form t'"
proof (induct t)
  case true
  then show ?case by blast
next
  case false
  then show ?case by blast
next
  case (Cond t1 t2 t3)
  obtain t1' where t1t1': "t1 \<mapsto>* t1'" and "is_normal_form t1'" using Cond.hyps(1) by blast
  hence t1_true_false: "t1' = true \<or> t1' = false" using normal_form_is_value is_value_def by simp
  hence "If t1 Then t2 Else t3 \<mapsto>* t2 \<or> If t1 Then t2 Else t3 \<mapsto>* t3"
    using eval_star_IfTrue eval_star_IfFalse t1t1' by blast
  with Cond.hyps(2) Cond.hyps(3) eval_star_trans3
  show "\<exists>t'. If t1 Then t2 Else t3 \<mapsto>* t' \<and> is_normal_form t'" by blast
qed

section \<open>3.5.13 (1)\<close>

inductive eval_funny1 :: "t \<Rightarrow> t \<Rightarrow>  bool" ("_ \<mapsto>f1 _" [50,50] 40)
  where
    E_IfTrueF1: "If true Then t2 Else t3 \<mapsto>f1 t2"
  | E_IfFalseF1: "If false Then t2 Else t3 \<mapsto>f1 t3"
  | E_IfF1:  "t1 \<mapsto>f1 t1' \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f1 If t1' Then t2 Else t3"
  | E_Funny1: "If true Then t2 Else t3 \<mapsto>f1 t3"

definition is_normal_form_f1 :: "t \<Rightarrow> bool"
  where "is_normal_form_f1 t \<longleftrightarrow> \<not>(\<exists>t'. t \<mapsto>f1 t')"

inductive eval_star_f1 :: "t \<Rightarrow> t \<Rightarrow> bool" ("_ \<mapsto>f1* _" [50,50] 40) where
    EsReflF1: "t \<mapsto>f1* t"
  | EsStepF1: "\<lbrakk> t \<mapsto>f1 t' \<rbrakk> \<Longrightarrow> t \<mapsto>f1* t'"
  | EsTransF1: "\<lbrakk> t \<mapsto>f1* t'; t' \<mapsto>f1* t'' \<rbrakk> \<Longrightarrow> t \<mapsto>f1* t''"

subsection \<open>lemmas\<close>

lemma eval_funny1_is_eval: "t \<mapsto> t' \<Longrightarrow> t \<mapsto>f1 t'"
  by (simp add: E_IfF1 E_IfFalseF1 E_IfTrueF1 eval.inducts)

lemma is_normal_f1_formE[intro]: "\<not>(\<exists>t'. t \<mapsto>f1 t') \<Longrightarrow> is_normal_form_f1 t" using is_normal_form_f1_def by simp
lemma is_normal_f1_formI[elim]: "is_normal_form_f1 t \<Longrightarrow> \<not>(\<exists>t'. t \<mapsto>f1 t')" using is_normal_form_f1_def by simp

lemma true_is_normal_form_f1[intro]: "is_normal_form_f1 true" using eval_funny1.cases by blast
lemma false_is_normal_form_f1[intro]: "is_normal_form_f1 false" using eval_funny1.cases by blast
lemma normal_form_f1_cannot_eval: "\<lbrakk> is_normal_form_f1 t; t \<mapsto>f1 t' \<rbrakk> \<Longrightarrow> False" using eval_funny1_is_eval is_normal_f1_formI by blast
lemma if_isnot_normal_form_f1: "\<not>(is_normal_form_f1 (If t1 Then t2 Else t3))" using eval_funny1_is_eval if_isnot_normal_form normal_form_f1_cannot_eval by blast

lemma eval_star_f1_refl[intro]: "t = t' \<Longrightarrow> t \<mapsto>f1* t'" using EsReflF1 by simp
lemma eval_star_f1_step[intro]: "t \<mapsto>f1 t' \<Longrightarrow> t \<mapsto>f1* t'" by (rule EsStepF1)
lemma eval_star_f1_trans1[intro]: "\<lbrakk> t \<mapsto>f1* t'; t' \<mapsto>f1* t'' \<rbrakk> \<Longrightarrow> t \<mapsto>f1* t''" by (rule EsTransF1)
lemma eval_star_f1_trans2[intro]: "\<lbrakk> t \<mapsto>f1 t'; t' \<mapsto>f1* t'' \<rbrakk>  \<Longrightarrow> t \<mapsto>f1* t''" using EsStepF1 EsTransF1 by blast
lemma eval_star_f1_trans3[intro]: "\<lbrakk> t \<mapsto>f1* t'; t' \<mapsto>f1 t'' \<rbrakk>  \<Longrightarrow> t \<mapsto>f1* t''" using EsStepF1 EsTransF1 by blast

lemma E_If_star_f1: "t1 \<mapsto>f1* t1' \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f1* If t1' Then t2 Else t3"
proof (induct rule: eval_star_f1.induct)
  case (EsReflF1 t)
  then show ?case by force
next
  case (EsStepF1 t t')
  show ?case by (simp add: E_IfF1 eval_star_f1_step local.EsStepF1)
next
  case (EsTransF1 t t' t'')
  show ?case using EsTransF1.hyps(2) EsTransF1.hyps(4) by blast
qed

lemma eval_star_f1_IfTrue: "\<lbrakk> t1 \<mapsto>f1* true \<rbrakk> \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f1* t2"
  using E_If_star_f1[of t1, of true] E_IfTrueF1 eval_star_f1_trans2 eval_star_f1_trans3 by blast

lemma eval_star_f1_IfFalse: "\<lbrakk> t1 \<mapsto>f1* false \<rbrakk> \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f1* t3"
  using E_If_star_f1[of t1, of false] E_IfFalseF1 eval_star_f1_trans2 eval_star_f1_trans3 by blast

subsection \<open>proofs\<close>

(* 3.5.4 *)
theorem eval_deterministic_f1: "\<lbrakk> t \<mapsto>f1 t'; t \<mapsto>f1 t'' \<rbrakk> \<Longrightarrow> t' = t''"
  nitpick
  oops
theorem eval_deterministic_f1_not: "\<exists>t t' t''. \<not>((t \<mapsto>f1 t' \<and> t \<mapsto>f1 t'') \<longrightarrow> t' = t'')"
  apply (rule exI[where x="If true Then true Else (If true Then true Else true)"])
  apply (rule exI[where x="If true Then true Else true"])
  apply (rule exI[where x="true"])
  by (simp add: E_Funny1 E_IfTrueF1)

(* 3.5.7 *)
theorem value_is_normal_form_f1: "is_value t \<Longrightarrow> is_normal_form_f1 t"
  using is_value_def by fastforce

(* 3.5.8 *)
theorem normal_form_f1_is_value: "is_normal_form_f1 t \<Longrightarrow> is_value t"
  apply (rule t.exhaust[of t], blast, blast)
  apply (simp add: if_isnot_normal_form_f1)
  done

(* 3.5.11 *)
lemma eval_star_deterministic_f1: "\<lbrakk> t \<mapsto>f1* t'; is_normal_form_f1 t'; t \<mapsto>f1* t''; is_normal_form_f1 t'' \<rbrakk> \<Longrightarrow> t' = t''"
  nitpick
  oops
theorem eval_star_deterministic_f1_not: "\<exists>t t' t''. \<not>((t \<mapsto>f1* t' \<and> is_normal_form_f1 t' \<and> t \<mapsto>f1* t'' \<and> is_normal_form_f1 t'') \<longrightarrow> t' = t'')"
  apply (rule exI[where x="If true Then true Else false"])
  apply (rule exI[where x="false"])
  apply (rule exI[where x="true"])
  using E_Funny1 E_IfTrueF1 eval_star_f1_step false_is_normal_form_f1 t.distinct(1) true_is_normal_form_f1 by presburger

(* 3.5.12 *)
theorem eval_star_f1_stop: "\<exists>t'. t \<mapsto>f1* t' \<and> is_normal_form_f1 t'"
proof (induct t)
  case true
  then show ?case
    using EsReflF1 by blast
next
  case false
  then show ?case
    using EsReflF1 by blast
next
  case (Cond t1 t2 t3)
  obtain t1' where t1t1': "t1 \<mapsto>f1* t1'" and "is_normal_form_f1 t1'" using Cond.hyps(1) by blast
  hence t1_true_false: "t1' = true \<or> t1' = false" using normal_form_f1_is_value is_value_def by simp
  hence "If t1 Then t2 Else t3 \<mapsto>f1* t2 \<or> If t1 Then t2 Else t3 \<mapsto>f1* t3"
    using eval_star_f1_IfTrue eval_star_f1_IfFalse t1t1' by blast
  with Cond.hyps(2) Cond.hyps(3) eval_star_trans3
  show "\<exists>t'. If t1 Then t2 Else t3 \<mapsto>f1* t' \<and> is_normal_form_f1 t'" by blast
qed

section \<open>3.5.13 (2)\<close>

inductive eval_funny2 :: "t \<Rightarrow> t \<Rightarrow>  bool" ("_ \<mapsto>f2 _" [50,50] 40)
  where
    E_IfTrueF2: "If true Then t2 Else t3 \<mapsto>f2 t2"
  | E_IfFalseF2: "If false Then t2 Else t3 \<mapsto>f2 t3"
  | E_IfF2:  "t1 \<mapsto>f2 t1' \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f2 If t1' Then t2 Else t3"
  | E_Funny2: "t2 \<mapsto>f2 t2' \<Longrightarrow> If true Then t2 Else t3 \<mapsto>f2 If true Then t2' Else t3"

definition is_normal_form_f2 :: "t \<Rightarrow> bool"
  where "is_normal_form_f2 t \<longleftrightarrow> \<not>(\<exists>t'. t \<mapsto>f2 t')"

inductive eval_star_f2 :: "t \<Rightarrow> t \<Rightarrow> bool" ("_ \<mapsto>f2* _" [50,50] 40) where
    EsReflF2: "t \<mapsto>f2* t"
  | EsStepF2: "\<lbrakk> t \<mapsto>f2 t' \<rbrakk> \<Longrightarrow> t \<mapsto>f2* t'"
  | EsTransF2: "\<lbrakk> t \<mapsto>f2* t'; t' \<mapsto>f2* t'' \<rbrakk> \<Longrightarrow> t \<mapsto>f2* t''"

subsection \<open>lemmas\<close>

lemma eval_funny2_is_eval: "t \<mapsto> t' \<Longrightarrow> t \<mapsto>f2 t'"
  by (simp add: E_IfF2 E_IfFalseF2 E_IfTrueF2 eval.inducts)

lemma is_normal_f2_formE[intro]: "\<not>(\<exists>t'. t \<mapsto>f2 t') \<Longrightarrow> is_normal_form_f2 t" using is_normal_form_f2_def by simp
lemma is_normal_f2_formI[elim]: "is_normal_form_f2 t \<Longrightarrow> \<not>(\<exists>t'. t \<mapsto>f2 t')" using is_normal_form_f2_def by simp

lemma true_is_normal_form_f2[intro]: "is_normal_form_f2 true" using eval_funny2.cases by blast
lemma false_is_normal_form_f2[intro]: "is_normal_form_f2 false" using eval_funny2.cases by blast
lemma normal_form_f2_cannot_eval: "\<lbrakk> is_normal_form_f2 t; t \<mapsto>f2 t' \<rbrakk> \<Longrightarrow> False" using eval_funny2_is_eval is_normal_f2_formI by blast
lemma if_isnot_normal_form_f2: "\<not>(is_normal_form_f2 (If t1 Then t2 Else t3))" using eval_funny2_is_eval if_isnot_normal_form normal_form_f2_cannot_eval by blast

lemma eval_star_f2_refl[intro]: "t = t' \<Longrightarrow> t \<mapsto>f2* t'" using EsReflF2 by simp
lemma eval_star_f2_step[intro]: "t \<mapsto>f2 t' \<Longrightarrow> t \<mapsto>f2* t'" by (rule EsStepF2)
lemma eval_star_f2_trans1[intro]: "\<lbrakk> t \<mapsto>f2* t'; t' \<mapsto>f2* t'' \<rbrakk> \<Longrightarrow> t \<mapsto>f2* t''" by (rule EsTransF2)
lemma eval_star_f2_trans2[intro]: "\<lbrakk> t \<mapsto>f2 t'; t' \<mapsto>f2* t'' \<rbrakk>  \<Longrightarrow> t \<mapsto>f2* t''" using EsStepF2 EsTransF2 by blast
lemma eval_star_f2_trans3[intro]: "\<lbrakk> t \<mapsto>f2* t'; t' \<mapsto>f2 t'' \<rbrakk>  \<Longrightarrow> t \<mapsto>f2* t''" using EsStepF2 EsTransF2 by blast

lemma E_If_star_f2: "t1 \<mapsto>f2* t1' \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f2* If t1' Then t2 Else t3"
proof (induct rule: eval_star_f2.induct)
  case (EsReflF2 t)
  then show ?case by force
next
  case (EsStepF2 t t')
  show ?case by (simp add: E_IfF2 eval_star_f2_step local.EsStepF2)
next
  case (EsTransF2 t t' t'')
  show ?case using EsTransF2.hyps(2) EsTransF2.hyps(4) by blast
qed

lemma eval_star_f2_IfTrue: "\<lbrakk> t1 \<mapsto>f2* true \<rbrakk> \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f2* t2"
  using E_If_star_f2[of t1, of true] E_IfTrueF2 eval_star_f2_trans2 eval_star_f2_trans3 by blast

lemma eval_star_f2_IfFalse: "\<lbrakk> t1 \<mapsto>f2* false \<rbrakk> \<Longrightarrow> If t1 Then t2 Else t3 \<mapsto>f2* t3"
  using E_If_star_f2[of t1, of false] E_IfFalseF2 eval_star_f2_trans2 eval_star_f2_trans3 by blast

subsection \<open>proofs\<close>

(* 3.5.4 *)
theorem eval_deterministic_f2: "\<lbrakk> t \<mapsto>f2 t'; t \<mapsto>f2 t'' \<rbrakk> \<Longrightarrow> t' = t''"
  nitpick
  oops
theorem eval_deterministic_f2_not: "\<exists>t t' t''. \<not>((t \<mapsto>f2 t' \<and> t \<mapsto>f2 t'') \<longrightarrow> t' = t'')"
  apply (rule exI[where x="If true Then (If true Then true Else true) Else (If true Then true Else true)"])
  apply (rule exI[where x="If true Then true Else true"])
  apply (rule exI[where x="If true Then true Else (If true Then true Else true)"])
  by (simp add: E_Funny2 E_IfTrueF2)

(* 3.5.7 *)
theorem value_is_normal_form_f2: "is_value t \<Longrightarrow> is_normal_form_f2 t"
  using is_value_def by fastforce

(* 3.5.8 *)
theorem normal_form_f2_is_value: "is_normal_form_f2 t \<Longrightarrow> is_value t"
  apply (rule t.exhaust[of t], blast, blast)
  apply (simp add: if_isnot_normal_form_f2)
  done

(* 3.5.11 *)
lemma eval_star_deterministic_f2: "\<lbrakk> t \<mapsto>f2* t'; is_normal_form_f2 t'; t \<mapsto>f2 t''; is_normal_form_f2 t'' \<rbrakk> \<Longrightarrow> t' = t''"
(* proof should be changed *)
  oops

(* 3.5.12 *)
theorem eval_star_f2_stop: "\<exists>t'. t \<mapsto>f2* t' \<and> is_normal_form_f2 t'"
proof (induct t)
  case true
  then show ?case
    using EsReflF2 by blast
next
  case false
  then show ?case
    using EsReflF2 by blast
next
  case (Cond t1 t2 t3)
  obtain t1' where t1t1': "t1 \<mapsto>f2* t1'" and "is_normal_form_f2 t1'" using Cond.hyps(1) by blast
  hence t1_true_false: "t1' = true \<or> t1' = false" using normal_form_f2_is_value is_value_def by simp
  hence "If t1 Then t2 Else t3 \<mapsto>f2* t2 \<or> If t1 Then t2 Else t3 \<mapsto>f2* t3"
    using eval_star_f2_IfTrue eval_star_f2_IfFalse t1t1' by blast
  with Cond.hyps(2) Cond.hyps(3) eval_star_trans3
  show "\<exists>t'. If t1 Then t2 Else t3 \<mapsto>f2* t' \<and> is_normal_form_f2 t'" by blast
qed

end


theory badaxiom_soln
imports Main

begin

text {* This exercise shows an example of how a bad axiomatization can
destroy Isabelle's guarantee of soundness. We will add to Isabelle's
existing theory the axioms of Naive Set Theory presented in Lecture
6. *}

text {* First, we declare the existence of a new type 'SET', which
represents the sets of our Naive Set Theory. We do this in Isabelle
with the following declaration. *}

typedecl SET

text {* Now we declare the membership predicate (written "\<in>" in the
lecture, but this clashes with Isabelle's existing set membership
predicate), and the axiom. The 'axiomatization' declaration first
lists the new function symbols we are adding, and then lists the
axioms.

Here, we state 'comprehension' as a single axioms, but really it is an
axiom schema, representing infinitely many axioms, one for every 'P'.
*}

axiomatization
  Member :: "SET => SET => bool"
where
  comprehension : "\<exists>y. \<forall>x. Member x y \<longleftrightarrow> P x"

text {* You can use the axiom comprehension in a proof by using the
command:

apply (cut_tac P="\<lambda>x. XXXX" in comprehension)

where XXXX is the predicate (with free variable 'x') that you want to
instantiate the axiom with. *}

text {* You can now prove the paradoxical statement shown in the
lecture. *}

lemma member_iff_not_member : "\<exists>y. Member y y \<longleftrightarrow> \<not> Member y y"
apply (cut_tac P="\<lambda>x. \<not> (Member x x)" in comprehension)
apply (erule exE)
apply (rule_tac x=y in exI)
apply (erule_tac x=y in allE)
apply assumption
done

text {* Using the lemma, it is now possible to prove 'False', showing
that we have definitely introduced an inconsistency. You will have to
use the rule 'excluded_middle' or one of the other axioms in order to
complete the proof. It may be easier to try to work out how to prove
this theorem on paper first, before attempting it on the computer.

(Note: Isabelle's built-in QuickCheck will attempt to show you a
counterexample to this theorem, because it 'knows' that False is not
provable. The QuickCheck facility doesn't take into account any axioms
that have been added.) *}

theorem inconsistency : False
apply (cut_tac member_iff_not_member)
apply (erule exE)
apply (cut_tac P="Member y y" in excluded_middle)
apply (erule disjE)
apply (rule_tac P="Member y y" in notE)
apply assumption
apply (erule iffD2)
apply assumption
apply (rule_tac P="Member y y" in notE)
apply (erule iffD1)
apply assumption
apply assumption
done

text {* After we have proved False, we can prove all sorts of
nonsense: *}

theorem "1 = 0"
apply (rule FalseE)
apply (rule inconsistency)
done

end


theory Lists1_7
imports Main
begin

primrec list_union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "list_union [] ys = ys"
| "list_union (x#xs) ys = (let result = list_union xs ys in if x : set result then result else x#result)"

value "list_union [] []"
value "list_union [] [1]"
value "list_union [1] []"
value "list_union [1::int,2,3] [2,3,4]"

lemma "set (list_union xs ys) = set xs \<union> set ys"
  apply (induct xs)
  apply simp
  apply (simp add:Let_def)
  apply auto
done

value "distinct [1::int,1]"

lemma [rule_format]:"distinct xs \<longrightarrow> distinct ys \<longrightarrow> distinct (list_union xs ys)"
  apply (induct xs)
  apply (simp add:Let_def)+
done

lemma "((\<forall>x \<in> A. P x) \<and> (\<forall>x \<in> B. P x)) \<longrightarrow> (\<forall>x \<in> A \<union> B. P x)"
  by auto

lemma "\<forall>x \<in> A. Q (f x) \<Longrightarrow> \<forall>y \<in> f ` A. Q y"
  by auto

end


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

section \<open>Theory of the natural numbers: Peano's axioms, primitive recursion\<close>

theory Nat
  imports FOL
begin

typedecl nat
instance nat :: \<open>term\<close> ..

axiomatization
  Zero :: \<open>nat\<close>  (\<open>0\<close>) and
  Suc :: \<open>nat \<Rightarrow> nat\<close> and
  rec :: \<open>[nat, 'a, [nat, 'a] \<Rightarrow> 'a] \<Rightarrow> 'a\<close>
where
  induct: \<open>\<lbrakk>P(0); \<And>x. P(x) \<Longrightarrow> P(Suc(x))\<rbrakk> \<Longrightarrow> P(n)\<close> and
  Suc_inject: \<open>Suc(m)=Suc(n) \<Longrightarrow> m=n\<close> and
  Suc_neq_0: \<open>Suc(m)=0 \<Longrightarrow> R\<close> and
  rec_0: \<open>rec(0,a,f) = a\<close> and
  rec_Suc: \<open>rec(Suc(m), a, f) = f(m, rec(m,a,f))\<close>

definition add :: \<open>[nat, nat] \<Rightarrow> nat\<close>  (infixl \<open>+\<close> 60)
  where \<open>m + n \<equiv> rec(m, n, \<lambda>x y. Suc(y))\<close>

subsection \<open>Proofs about the natural numbers\<close>

lemma Suc_n_not_n: \<open>Suc(k) \<noteq> k\<close>
apply (rule_tac n = \<open>k\<close> in induct)
apply (rule notI)
apply (erule Suc_neq_0)
apply (rule notI)
apply (erule notE)
apply (erule Suc_inject)
done

lemma \<open>(k+m)+n = k+(m+n)\<close>
apply (rule induct)
back
back
back
back
back
back
oops

lemma add_0 [simp]: \<open>0+n = n\<close>
apply (unfold add_def)
apply (rule rec_0)
done

lemma add_Suc [simp]: \<open>Suc(m)+n = Suc(m+n)\<close>
apply (unfold add_def)
apply (rule rec_Suc)
done

lemma add_0_right: \<open>m+0 = m\<close>
apply (rule_tac n = \<open>m\<close> in induct)
apply simp
apply simp
done

lemma add_Suc_right: \<open>m+Suc(n) = Suc(m+n)\<close>
apply (rule_tac n = \<open>m\<close> in induct)
apply simp_all
done

lemma
  assumes prem: \<open>\<And>n. f(Suc(n)) = Suc(f(n))\<close>
  shows \<open>f(i+j) = i+f(j)\<close>
apply (rule_tac n = \<open>i\<close> in induct)
apply simp
apply (simp add: prem)
done

end


theory Type_Preservation
  imports "../Nominal"
begin

text \<open>

  This theory shows how to prove the type preservation
  property for the simply-typed lambda-calculus and
  beta-reduction.

\<close>

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._")

text \<open>Capture-Avoiding Substitution\<close>

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]")
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

lemma  subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t1[x::=t2]) = (pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)]"
by (nominal_induct t1 avoiding: x t2 rule: lam.strong_induct)
   (auto simp add: perm_bij fresh_atm fresh_bij)

lemma fresh_fact:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

text \<open>Types\<close>

nominal_datatype ty =
    TVar "string"
  | TArr "ty" "ty" ("_ \<rightarrow> _")

lemma ty_fresh:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_string)

text \<open>Typing Contexts\<close>

type_synonym ctx = "(name\<times>ty) list"

abbreviation
  "sub_ctx" :: "ctx \<Rightarrow> ctx \<Rightarrow> bool" ("_ \<subseteq> _")
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^sub>1 \<longrightarrow> x \<in> set \<Gamma>\<^sub>2"

text \<open>Validity of Typing Contexts\<close>

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
    v1[intro]: "valid []"
  | v2[intro]: "\<lbrakk>valid \<Gamma>; x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

lemma valid_elim[dest]:
  assumes a: "valid ((x,T)#\<Gamma>)"
  shows "x\<sharp>\<Gamma> \<and> valid \<Gamma>"
using a by (cases) (auto)

lemma valid_insert:
  assumes a: "valid (\<Delta>@[(x,T)]@\<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)"
using a
by (induct \<Delta>)
   (auto simp add:  fresh_list_append fresh_list_cons dest!: valid_elim)

lemma fresh_set:
  shows "y\<sharp>xs = (\<forall>x\<in>set xs. y\<sharp>x)"
by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes a1: "valid \<Gamma>"
  and     a2: "(x,T) \<in> set \<Gamma>"
  and     a3: "(x,U) \<in> set \<Gamma>"
  shows "T = U"
using a1 a2 a3
by (induct) (auto simp add: fresh_set fresh_prod fresh_atm)

text \<open>Typing Relation\<close>

inductive
  typing :: "ctx \<Rightarrow> lam \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _")
where
  t_Var[intro]: "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| t_App[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| t_Lam[intro]: "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2"

equivariance typing
nominal_inductive typing
  by (simp_all add: abs_fresh ty_fresh)

lemma t_Lam_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> Lam [x].t : T"
  and     fc: "x\<sharp>\<Gamma>"
  shows "\<exists>T\<^sub>1 T\<^sub>2. T = T\<^sub>1 \<rightarrow> T\<^sub>2 \<and> (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2"
using ty fc
by (cases rule: typing.strong_cases)
   (auto simp add: alpha lam.inject abs_fresh ty_fresh)

lemma t_App_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> App t1 t2 : T"
  shows "\<exists>T'. \<Gamma> \<turnstile> t1 : T' \<rightarrow> T \<and> \<Gamma> \<turnstile> t2 : T'"
using ty
by (cases) (auto simp add: lam.inject)

lemma weakening:
  fixes \<Gamma>1 \<Gamma>2::"ctx"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

lemma type_substitution_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct "\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: x e' \<Delta> rule: typing.strong_induct)
  case (t_Var y T x e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" by blast
qed (force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitution:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b
by (auto intro: type_substitution_aux[where \<Delta>="[]",simplified])

text \<open>Beta Reduction\<close>

inductive
  "beta" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _")
where
  b1[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> App t1 s \<longrightarrow>\<^sub>\<beta> App t2 s"
| b2[intro]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App t s1 \<longrightarrow>\<^sub>\<beta> App t s2"
| b3[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>\<^sub>\<beta> Lam [x].t2"
| b4[intro]: "x\<sharp>s \<Longrightarrow> App (Lam [x].t) s \<longrightarrow>\<^sub>\<beta> t[x::=s]"

equivariance beta
nominal_inductive beta
  by (auto simp add: abs_fresh fresh_fact)

theorem type_preservation:
  assumes a: "t \<longrightarrow>\<^sub>\<beta> t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
proof (nominal_induct avoiding: \<Gamma> T rule: beta.strong_induct)
  case (b1 t1 t2 s \<Gamma> T)
  have "\<Gamma> \<turnstile> App t1 s : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T" and a2: "\<Gamma> \<turnstile> s : T'" by auto
  have ih: "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T \<Longrightarrow> \<Gamma> \<turnstile> t2 : T' \<rightarrow> T" by fact
  with a1 a2 show "\<Gamma> \<turnstile> App t2 s : T" by auto
next
  case (b2 s1 s2 t \<Gamma> T)
  have "\<Gamma> \<turnstile> App t s1 : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> t : T' \<rightarrow> T" and a2: "\<Gamma> \<turnstile> s1 : T'" by auto
  have ih: "\<Gamma> \<turnstile> s1 : T' \<Longrightarrow> \<Gamma> \<turnstile> s2 : T'" by fact
  with a1 a2 show "\<Gamma> \<turnstile> App t s2 : T" by auto
next
  case (b3 t1 t2 x \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> Lam [x].t1 : T" by fact
  then obtain T1 T2 where a1: "(x,T1)#\<Gamma> \<turnstile> t1 : T2" and a2: "T = T1 \<rightarrow> T2" using vc by auto
  have ih: "(x,T1)#\<Gamma> \<turnstile> t1 : T2 \<Longrightarrow> (x,T1)#\<Gamma> \<turnstile> t2 : T2" by fact
  with a1 a2 show "\<Gamma> \<turnstile> Lam [x].t2 : T" using vc by auto
next
  case (b4 x s t \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> App (Lam [x].t) s : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> Lam [x].t : T' \<rightarrow> T" and a2: "\<Gamma> \<turnstile> s : T'" by auto
  from a1 obtain T1 T2 where a3: "(x,T')#\<Gamma> \<turnstile> t : T" using vc by (auto simp add: ty.inject)
  from a3 a2 show "\<Gamma> \<turnstile> t[x::=s] : T" by (simp add: type_substitution)
qed

theorem type_preservation_automatic:
  assumes a: "t \<longrightarrow>\<^sub>\<beta> t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
by (nominal_induct avoiding: \<Gamma> T rule: beta.strong_induct)
   (auto dest!: t_Lam_inversion t_App_inversion simp add: ty.inject type_substitution)

end


(*
  File:     KDTree.thy
  Author:   Martin Rau, TU München
*)

section "Definition of the \<open>k\<close>-d Tree"

theory KDTree
imports
  Complex_Main
  "HOL-Analysis.Finite_Cartesian_Product"
  "HOL-Analysis.Topology_Euclidean_Space"
begin

text \<open>
  A \<open>k\<close>-d tree is a space-partitioning data structure for organizing points in a \<open>k\<close>-dimensional space.
  In principle the \<open>k\<close>-d tree is a binary tree. The leafs hold the \<open>k\<close>-dimensional points and the nodes
  contain left and right subtrees as well as a discriminator \<open>v\<close> at a particular axis \<open>k\<close>.
  Every node divides the space into two parts by splitting along a hyperplane.
  Consider a node \<open>n\<close> with associated discriminator \<open>v\<close> at axis \<open>k\<close>.
  All points in the left subtree must have a value at axis \<open>k\<close> that is less than or
  equal to \<open>v\<close> and all points in the right subtree must have a value at axis \<open>k\<close> that is
  greater than \<open>v\<close>.

  Deviations from the papers:

  The chosen tree representation is taken from @{cite "DBLP:journals/toms/FriedmanBF77"} with one minor
  adjustment. Originally the leafs hold buckets of points of size \<open>b\<close>. This representation fixes the
  bucket size to \<open>b = 1\<close>, a single point per Leaf. This is only a minor adjustment since the paper
  proves that \<open>b = 1\<close> is the optimal bucket size for minimizing the running time of the nearest neighbor
  algorithm @{cite "DBLP:journals/toms/FriedmanBF77"}, only simplifies building the optimized
  \<open>k\<close>-d trees @{cite "DBLP:journals/toms/FriedmanBF77"} and has little influence on the
  search algorithm @{cite "DBLP:journals/cacm/Bentley75"}.
\<close>

type_synonym 'k point = "(real, 'k) vec"

lemma dist_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "dist p\<^sub>0 p\<^sub>1 = sqrt (\<Sum>k \<in> UNIV. (p\<^sub>0$k - p\<^sub>1$k)\<^sup>2)"
  unfolding dist_vec_def L2_set_def dist_real_def by simp

datatype 'k kdt =
  Leaf "'k point"
| Node 'k real "'k kdt" "'k kdt"

subsection \<open>Definition of the \<open>k\<close>-d Tree Invariant and Related Functions\<close>

fun set_kdt :: "'k kdt \<Rightarrow> ('k point) set" where
  "set_kdt (Leaf p) = { p }"
| "set_kdt (Node _ _ l r) = set_kdt l \<union> set_kdt r"

definition spread :: "('k::finite) \<Rightarrow> 'k point set \<Rightarrow> real" where
  "spread k P = (if P = {} then 0 else let V = (\<lambda>p. p$k) ` P in Max V - Min V)"

definition widest_spread_axis :: "('k::finite) \<Rightarrow> 'k set \<Rightarrow> 'k point set \<Rightarrow> bool" where
  "widest_spread_axis k K ps \<longleftrightarrow> (\<forall>k' \<in> K. spread k' ps \<le> spread k ps)"

fun invar :: "('k::finite) kdt \<Rightarrow> bool" where
  "invar (Leaf p) \<longleftrightarrow> True"
| "invar (Node k v l r) \<longleftrightarrow> (\<forall>p \<in> set_kdt l. p$k \<le> v) \<and> (\<forall>p \<in> set_kdt r. v < p$k) \<and>
    widest_spread_axis k UNIV (set_kdt l \<union> set_kdt r) \<and> invar l \<and> invar r"

fun size_kdt :: "'k kdt \<Rightarrow> nat" where
  "size_kdt (Leaf _) = 1"
| "size_kdt (Node _ _ l r) = size_kdt l + size_kdt r"

fun height :: "'k kdt \<Rightarrow> nat" where
  "height (Leaf _) = 0"
| "height (Node _ _ l r) = max (height l) (height r) + 1"

fun min_height :: "'k kdt \<Rightarrow> nat" where
  "min_height (Leaf _) = 0"
| "min_height (Node _ _ l r) = min (min_height l) (min_height r) + 1"

definition balanced :: "'k kdt \<Rightarrow> bool" where
  "balanced kdt \<longleftrightarrow> height kdt - min_height kdt \<le> 1"

fun complete :: "'k kdt \<Rightarrow> bool" where
  "complete (Leaf _) = True"
| "complete (Node _ _ l r) \<longleftrightarrow> complete l \<and> complete r \<and> height l = height r"

lemma invar_r:
  "invar (Node k v l r) \<Longrightarrow> invar r"
  by simp

lemma invar_l_le_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt l. p$k \<le> v"
  by simp

lemma invar_r_ge_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt r. v < p$k"
  by simp

lemma invar_set:
  "set_kdt (Node k v l r) = set_kdt l \<union> set_kdt r"
  by simp

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree\<close> to \<open>k\<close>-d Tree\<close>

lemma size_ge0[simp]:
  "0 < size_kdt kdt"
  by (induction kdt) auto

lemma eq_size_1[simp]:
  "size_kdt kdt = 1 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  apply (induction kdt)
  apply (auto)
  using size_ge0 nat_less_le apply blast+
  done

lemma eq_1_size[simp]:
  "1 = size_kdt kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  using eq_size_1 by metis

lemma neq_Leaf_iff:
  "(\<nexists>p. kdt = Leaf p) = (\<exists>k v l r. kdt = Node k v l r)"
  by (cases kdt) auto

lemma eq_height_0[simp]:
  "height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_height[simp]:
  "0 = height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_min_height_0[simp]:
  "min_height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_min_height[simp]:
  "0 = min_height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma size_height:
  "size_kdt kdt \<le> 2 ^ height kdt"
proof(induction kdt)
  case (Node k v l r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node k v l r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

lemma min_height_le_height:
  "min_height kdt \<le> height kdt"
  by (induction kdt) auto

lemma min_height_size:
  "2 ^ min_height kdt \<le> size_kdt kdt"
proof(induction kdt)
  case (Node k v l r)
  have "(2::nat) ^ min_height (Node k v l r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size_kdt (Node k v l r)" using Node.IH by simp
  finally show ?case .
qed simp

lemma complete_iff_height:
  "complete kdt \<longleftrightarrow> (min_height kdt = height kdt)"
  apply (induction kdt)
  apply simp
  apply (simp add: min_def max_def)
  by (metis le_antisym le_trans min_height_le_height)

lemma size_if_complete:
  "complete kdt \<Longrightarrow> size_kdt kdt = 2 ^ height kdt"
  by (induction kdt) auto

lemma complete_if_size_height:
  "size_kdt kdt = 2 ^ height kdt \<Longrightarrow> complete kdt"
proof (induction "height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
  have 3: "\<not> height l < h"
  proof
    assume 0: "height l < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ h + 2 ^ height r" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 2 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  have 4: "\<not> height r < h"
  proof
    assume 0: "height r < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ height l + 2 ^ h" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 1 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
  hence "size_kdt l = 2 ^ height l" "size_kdt r = 2 ^ height r"
    using Suc(3) size_height[of l] size_height[of r] by (auto)
  with * Suc(1) show ?case by simp
qed

lemma complete_if_size_min_height:
  "size_kdt kdt = 2 ^ min_height kdt \<Longrightarrow> complete kdt"
proof (induct "min_height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "h \<le> min_height l" and 2: "h \<le> min_height r" using Suc(2) by (auto)
  have 3: "\<not> h < min_height l"
  proof
    assume 0: "h < min_height l"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height l > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height r \<ge> 2 ^ h" using 2 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  have 4: "\<not> h < min_height r"
  proof
    assume 0: "h < min_height r"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height r > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height l \<ge> 2 ^ h" using 1 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  from 1 2 3 4 have *: "min_height l = h" "min_height r = h" by linarith+
  hence "size_kdt l = 2 ^ min_height l" "size_kdt r = 2 ^ min_height r"
    using Suc(3) min_height_size[of l] min_height_size[of r] by (auto)
  with * Suc(1) show ?case
    by (simp add: complete_iff_height)
qed

lemma complete_iff_size:
  "complete kdt \<longleftrightarrow> size_kdt kdt = 2 ^ height kdt"
  using complete_if_size_height size_if_complete by blast

lemma size_height_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> size_kdt kdt < 2 ^ height kdt"
  by (meson antisym_conv complete_iff_size not_le size_height)

lemma min_height_size_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> 2 ^ min_height kdt < size_kdt kdt"
  by (metis complete_if_size_min_height le_less min_height_size)

lemma balanced_subtreeL:
  "balanced (Node k v l r) \<Longrightarrow> balanced l"
  by (simp add: balanced_def)

lemma balanced_subtreeR:
  "balanced (Node k v l r) \<Longrightarrow> balanced r"
  by (simp add: balanced_def)

lemma balanced_optimal:
  assumes "balanced kdt" "size_kdt kdt \<le> size_kdt kdt'"
  shows "height kdt \<le> height kdt'"
proof (cases "complete kdt")
  case True
  have "(2::nat) ^ height kdt \<le> 2 ^ height kdt'"
  proof -
    have "2 ^ height kdt = size_kdt kdt"
      using True by (simp add: complete_iff_height size_if_complete)
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'" by (rule size_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height kdt < 2 ^ height kdt'"
  proof -
    have "(2::nat) ^ min_height kdt < size_kdt kdt"
      by(rule min_height_size_if_incomplete[OF False])
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'"  by(rule size_height)
    finally have "(2::nat) ^ min_height kdt < (2::nat) ^ height kdt'" .
    thus ?thesis .
  qed
  hence *: "min_height kdt < height kdt'" by simp
  have "min_height kdt + 1 = height kdt"
    using min_height_le_height[of kdt] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree_Real\<close> to \<open>k\<close>-d Tree\<close>

lemma size_height_log:
  "log 2 (size_kdt kdt) \<le> height kdt"
  by (simp add: log2_of_power_le size_height)

lemma min_height_size_log:
  "min_height kdt \<le> log 2 (size_kdt kdt)"
  by (simp add: le_log2_of_power min_height_size)

lemma size_log_if_complete:
  "complete kdt \<Longrightarrow> height kdt = log 2 (size_kdt kdt)"
  by (simp add: log2_of_power_eq size_if_complete)

lemma min_height_size_log_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> min_height kdt < log 2 (size_kdt kdt)"
  by (simp add: less_log2_of_power min_height_size_if_incomplete)

lemma min_height_balanced:
  assumes "balanced kdt"
  shows "min_height kdt = nat(floor(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ min_height kdt"
    by (simp add: complete_iff_height size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete kdt"
  hence "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt < 2 ^ (min_height kdt + 1)"
    by (metis * size_height_if_incomplete)
  hence "log 2 (size_kdt kdt) < min_height kdt + 1"
    using log2_of_power_less size_ge0 by blast
  thus ?thesis using min_height_size_log[of kdt] by linarith
qed

lemma height_balanced:
  assumes "balanced kdt"
  shows "height kdt = nat(ceiling(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ height kdt"
    by (simp add: size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis
    by linarith
next
  assume *: "\<not> complete kdt"
  hence **: "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt \<le> 2 ^ (min_height kdt + 1)" by (metis size_height)
  from  log2_of_power_le[OF this size_ge0] min_height_size_log_if_incomplete[OF *] **
  show ?thesis by linarith
qed

lemma balanced_Node_if_wbal1:
  assumes "balanced l" "balanced r" "size_kdt l = size_kdt r + 1"
  shows "balanced (Node k v l r)"
proof -
  from assms(3) have [simp]: "size_kdt l = size_kdt r + 1" by simp
  have "nat \<lceil>log 2 (1 + size_kdt r)\<rceil> \<ge> nat \<lceil>log 2 (size_kdt r)\<rceil>"
    by(rule nat_mono[OF ceiling_mono]) simp
  hence 1: "height(Node k v l r) = nat \<lceil>log 2 (1 + size_kdt r)\<rceil> + 1"
    using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
    by (simp del: nat_ceiling_le_eq add: max_def)
  have "nat \<lfloor>log 2 (1 + size_kdt r)\<rfloor> \<ge> nat \<lfloor>log 2 (size_kdt r)\<rfloor>"
    by(rule nat_mono[OF floor_mono]) simp
  hence 2: "min_height(Node k v l r) = nat \<lfloor>log 2 (size_kdt r)\<rfloor> + 1"
    using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
    by (simp)
  have "size_kdt r \<ge> 1" by (simp add: Suc_leI)
  then obtain i where i: "2 ^ i \<le> size_kdt r" "size_kdt r < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 "size_kdt r"] by auto
  hence i1: "2 ^ i < size_kdt r + 1" "size_kdt r + 1 \<le> 2 ^ (i + 1)" by auto
  from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
  show ?thesis by(simp add:balanced_def)
qed

lemma balanced_sym:
  "balanced (Node k v l r) \<Longrightarrow> balanced (Node k' v' r l)"
  by (auto simp: balanced_def)

lemma balanced_Node_if_wbal2:
  assumes "balanced l" "balanced r" "abs(int(size_kdt l) - int(size_kdt r)) \<le> 1"
  shows "balanced (Node k v l r)"
proof -
  have "size_kdt l = size_kdt r \<or> (size_kdt l = size_kdt r + 1 \<or> size_kdt r = size_kdt l + 1)" (is "?A \<or> ?B")
    using assms(3) by linarith
  thus ?thesis
  proof
    assume "?A"
    thus ?thesis using assms(1,2)
      apply(simp add: balanced_def min_def max_def)
      by (metis assms(1,2) balanced_optimal le_antisym le_less)
  next
    assume "?B"
    thus ?thesis
      by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
  qed
qed

end


theory hw09
  imports Main "HOL-Data_Structures.RBT_Set"
begin

fun min_height :: "('a,'b) tree \<Rightarrow> nat" where
"min_height Leaf = 0" |
"min_height (Node _ l _ r) = min (min_height l) (min_height r) + 1"

definition "balanced t \<equiv> height t - min_height t \<le> 1"

fun mk_rbt :: "('a,unit) tree \<Rightarrow> 'a rbt" where
  "mk_rbt Leaf = Leaf"
| "mk_rbt (Node _ l a r) = (let
    l'=mk_rbt l;
    r'=mk_rbt r
  in
    if min_height l > min_height r then
      B (paint Red l') a r'
    else if min_height l < min_height r then
      B l' a (paint Red r')
    else
      B l' a r'
  )"

text \<open>
  \subsection*{Warmup}

\<close>

lemma balanced_subt: "balanced (Node c l a r) \<Longrightarrow> balanced l \<and> balanced r"
  unfolding balanced_def by auto

lemma aux1:"height t \<ge> min_height t"
  apply(induction t)
  by auto

lemma balanced_alt:
  "balanced t \<longleftrightarrow> height t = min_height t \<or> height t = min_height t + 1"
  unfolding balanced_def
  by (metis One_nat_def add_diff_cancel_left' aux1 cancel_comm_monoid_add_class.diff_cancel le_Suc_eq le_add_diff_inverse le_zero_eq order_refl)

text \<open>
  \subsection*{The Easy Parts}
\<close>

lemma mk_rbt_inorder: "inorder (mk_rbt t) = inorder t"
  apply(induction t)
   apply(auto)
  by (smt inorder.simps(2) inorder_paint)

lemma mk_rbt_color: "color (mk_rbt t) = Black"
  apply(induction t)
   apply(auto)
  by (smt RBT_Set.color.simps(2))

text \<open>
  \subsection*{Medium Complex Parts}

\<close>

lemma mk_rbt_bheight: "balanced t \<Longrightarrow> bheight (mk_rbt t) = min_height t"
proof(induction t)
  case Leaf
  then show ?case by auto
next
  case (Node x1 t1 x3 t2)
  note IH = Node.IH
  have "min_height t1 = min_height t2 \<or> min_height t1 < min_height t2 \<or> min_height t1 > min_height t2" (is "?C1 \<or> ?C2 \<or> ?C3")
    by auto
  moreover
  {
    assume ?C1
    have ?case using IH Node.prems \<open>?C1\<close>
      apply(cases "min_height t1")
       apply(auto)
       apply (meson balanced_subt)
      by (meson balanced_subt)
    }
    moreover
    {
      assume ?C2
      have ?case using IH Node.prems \<open>?C2\<close>
        apply(cases "min_height t1")
         apply(auto)
         apply (meson balanced_subt)
        by (metis balanced_subt min.strict_order_iff)
    }
    moreover
    {
      assume ?C3
      then have h0:"min_height (Node x1 t1 x3 t2) = min_height t2 + 1" using IH Node.prems by force
      then have h1:"min_height t2 = 0 \<Longrightarrow> bheight (paint Red (mk_rbt t1)) = 0" using IH Node.prems
        by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Suc_leI \<open>min_height t2 < min_height t1\<close> add_diff_cancel_right' aux1 balanced_def bheight_paint_Red height.simps(2) le_trans max.commute max_def mk_rbt_color)
      then have h2: "min_height t1 > min_height t2 \<Longrightarrow> min_height t1 = Suc (min_height t2)" using IH Node.prems
        by (smt Suc_eq_plus1 Suc_leI Suc_mono balanced_alt balanced_subt h0 height.simps(2) less_Suc_eq max.commute max_def not_le)
      then have h3: " min_height t1 > min_height t2 \<Longrightarrow> bheight (paint Red (mk_rbt t1)) = min_height t2" using IH Node.prems
        apply(cases "min_height t1")
         apply(auto)
        by (metis Suc_eq_plus1 add_diff_cancel_right' balanced_subt bheight_paint_Red mk_rbt_color)

      then have ?case using IH Node.prems \<open>?C3\<close>
        apply(cases "min_height t2")
        by (auto)

      }
      ultimately show ?case by blast
qed

lemma mk_rbt_invh: "balanced t \<Longrightarrow> invh (mk_rbt t)"
  apply(induction t rule:mk_rbt.induct)
   apply(simp add: balanced_alt mk_rbt_color mk_rbt_inorder mk_rbt_bheight)
  apply(simp split:if_splits)
  by (smt Suc_eq_plus1 Suc_le_mono add_diff_cancel_right' antisym_conv balanced_alt balanced_subt bheight_paint_Red height.simps(2) invh.simps(2) le_Suc_eq le_simps(3) max_def min_def invh_paint min_height.simps(2) mk_rbt_bheight mk_rbt_color)

fun mk_rbt' :: "('a,unit) tree \<Rightarrow> 'a rbt \<times> nat"
where
  "mk_rbt' Leaf = (Leaf, 0)"
| "mk_rbt' (Node _ l a r) = (let
    (l',lx)=mk_rbt' l;
    (r',rx)=mk_rbt' r
  in
    if lx > rx then
      (B (paint Red l') a r', Suc(rx))
    else if lx < rx then
      (B l' a (paint Red r'), Suc(lx))
    else
      (B l' a r', Suc(lx))
  )"

lemma mk_rbt'_refine_aux: "mk_rbt' t = (mk_rbt t, min_height t)"
  apply(induction t)
  apply(auto)
  done

lemma mk_rbt'_refine: "fst (mk_rbt' t) = mk_rbt t"
  apply(induction t)
  by(auto simp:mk_rbt'_refine_aux)

end


(*  Title:      HOL/Quotient_Examples/Quotient_Rat.thy
    Author:     Cezary Kaliszyk

Rational numbers defined with the quotient package, based on 'HOL/Rat.thy' by Makarius.
*)

theory Quotient_Rat imports HOL.Archimedean_Field
  "HOL-Library.Quotient_Product"
begin

definition
  ratrel :: "(int \<times> int) \<Rightarrow> (int \<times> int) \<Rightarrow> bool" (infix "\<approx>" 50)
where
  [simp]: "x \<approx> y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"

lemma ratrel_equivp:
  "part_equivp ratrel"
proof (auto intro!: part_equivpI reflpI sympI transpI exI[of _ "1 :: int"])
  fix a b c d e f :: int
  assume nz: "d \<noteq> 0" "b \<noteq> 0"
  assume y: "a * d = c * b"
  assume x: "c * f = e * d"
  then have "c * b * f = e * d * b" using nz by simp
  then have "a * d * f = e * d * b" using y by simp
  then show "a * f = e * b" using nz by simp
qed

quotient_type rat = "int \<times> int" / partial: ratrel
 using ratrel_equivp .

instantiation rat :: "{zero, one, plus, uminus, minus, times, ord, abs, sgn}"
begin

quotient_definition
  "0 :: rat" is "(0::int, 1::int)" by simp

quotient_definition
  "1 :: rat" is "(1::int, 1::int)" by simp

fun times_rat_raw where
  "times_rat_raw (a :: int, b :: int) (c, d) = (a * c, b * d)"

quotient_definition
  "((*)) :: (rat \<Rightarrow> rat \<Rightarrow> rat)" is times_rat_raw by (auto simp add: mult.assoc mult.left_commute)

fun plus_rat_raw where
  "plus_rat_raw (a :: int, b :: int) (c, d) = (a * d + c * b, b * d)"

quotient_definition
  "(+) :: (rat \<Rightarrow> rat \<Rightarrow> rat)" is plus_rat_raw
  by (auto simp add: mult.commute mult.left_commute int_distrib(2))

fun uminus_rat_raw where
  "uminus_rat_raw (a :: int, b :: int) = (-a, b)"

quotient_definition
  "(uminus :: (rat \<Rightarrow> rat))" is "uminus_rat_raw" by fastforce

definition
  minus_rat_def: "a - b = a + (-b::rat)"

fun le_rat_raw where
  "le_rat_raw (a :: int, b) (c, d) \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"

quotient_definition
  "(\<le>) :: rat \<Rightarrow> rat \<Rightarrow> bool" is "le_rat_raw"
proof -
  {
    fix a b c d e f g h :: int
    assume "a * f * (b * f) \<le> e * b * (b * f)"
    then have le: "a * f * b * f \<le> e * b * b * f" by simp
    assume nz: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0" "h \<noteq> 0"
    then have b2: "b * b > 0"
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
    have f2: "f * f > 0" using nz(3)
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
    assume eq: "a * d = c * b" "e * h = g * f"
    have "a * f * b * f * d * d \<le> e * b * b * f * d * d" using le nz(2)
      by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
    then have "c * f * f * d * (b * b) \<le> e * f * d * d * (b * b)" using eq
      by (metis (no_types) mult.assoc mult.commute)
    then have "c * f * f * d \<le> e * f * d * d" using b2
      by (metis leD linorder_le_less_linear mult_strict_right_mono)
    then have "c * f * f * d * h * h \<le> e * f * d * d * h * h" using nz(4)
      by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
    then have "c * h * (d * h) * (f * f) \<le> g * d * (d * h) * (f * f)" using eq
      by (metis (no_types) mult.assoc mult.commute)
    then have "c * h * (d * h) \<le> g * d * (d * h)" using f2
      by (metis leD linorder_le_less_linear mult_strict_right_mono)
  }
  then show "\<And>x y xa ya. x \<approx> y \<Longrightarrow> xa \<approx> ya \<Longrightarrow> le_rat_raw x xa = le_rat_raw y ya" by auto
qed

definition
  less_rat_def: "(z::rat) < w = (z \<le> w \<and> z \<noteq> w)"

definition
  rabs_rat_def: "\<bar>i::rat\<bar> = (if i < 0 then - i else i)"

definition
  sgn_rat_def: "sgn (i::rat) = (if i = 0 then 0 else if 0 < i then 1 else - 1)"

instance ..

end

definition
  Fract_raw :: "int \<Rightarrow> int \<Rightarrow> (int \<times> int)"
where [simp]: "Fract_raw a b = (if b = 0 then (0, 1) else (a, b))"

quotient_definition "Fract :: int \<Rightarrow> int \<Rightarrow> rat" is
  Fract_raw by simp

lemmas [simp] = Respects_def

(* FIXME: (partiality_)descending raises exception TYPE_MATCH

instantiation rat :: comm_ring_1
begin

instance proof
  fix a b c :: rat
  show "a * b * c = a * (b * c)"
    by partiality_descending auto
  show "a * b = b * a"
    by partiality_descending auto
  show "1 * a = a"
    by partiality_descending auto
  show "a + b + c = a + (b + c)"
    by partiality_descending (auto simp add: mult.commute distrib_left)
  show "a + b = b + a"
    by partiality_descending auto
  show "0 + a = a"
    by partiality_descending auto
  show "- a + a = 0"
    by partiality_descending auto
  show "a - b = a + - b"
    by (simp add: minus_rat_def)
  show "(a + b) * c = a * c + b * c"
    by partiality_descending (auto simp add: mult.commute distrib_left)
  show "(0 :: rat) \<noteq> (1 :: rat)"
    by partiality_descending auto
qed

end

lemma add_one_Fract: "1 + Fract (int k) 1 = Fract (1 + int k) 1"
  by descending auto

lemma of_nat_rat: "of_nat k = Fract (of_nat k) 1"
  apply (induct k)
  apply (simp add: zero_rat_def Fract_def)
  apply (simp add: add_one_Fract)
  done

lemma of_int_rat: "of_int k = Fract k 1"
  apply (cases k rule: int_diff_cases)
  apply (auto simp add: of_nat_rat minus_rat_def)
  apply descending
  apply auto
  done

instantiation rat :: field begin

fun rat_inverse_raw where
  "rat_inverse_raw (a :: int, b :: int) = (if a = 0 then (0, 1) else (b, a))"

quotient_definition
  "inverse :: rat \<Rightarrow> rat" is rat_inverse_raw by (force simp add: mult.commute)

definition
  divide_rat_def: "q / r = q * inverse (r::rat)"

instance proof
  fix q :: rat
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by partiality_descending auto
next
  fix q r :: rat
  show "q / r = q * inverse r" by (simp add: divide_rat_def)
next
  show "inverse 0 = (0::rat)" by partiality_descending auto
qed

end

instantiation rat :: linorder
begin

instance proof
  fix q r s :: rat
  {
    assume "q \<le> r" and "r \<le> s"
    then show "q \<le> s"
    proof (partiality_descending, auto simp add: mult.assoc[symmetric])
      fix a b c d e f :: int
      assume nz: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
      then have d2: "d * d > 0"
        by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
      assume le: "a * d * b * d \<le> c * b * b * d" "c * f * d * f \<le> e * d * d * f"
      then have a: "a * d * b * d * f * f \<le> c * b * b * d * f * f" using nz(3)
        by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
      have "c * f * d * f * b * b \<le> e * d * d * f * b * b" using nz(1) le
        by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
      then have "a * f * b * f * (d * d) \<le> e * b * b * f * (d * d)" using a
        by (simp add: algebra_simps)
      then show "a * f * b * f \<le> e * b * b * f" using d2
        by (metis leD linorder_le_less_linear mult_strict_right_mono)
    qed
  next
    assume "q \<le> r" and "r \<le> q"
    then show "q = r"
      apply (partiality_descending, auto)
      apply (case_tac "b > 0", case_tac [!] "ba > 0")
      apply simp_all
      done
  next
    show "q \<le> q" by partiality_descending auto
    show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
      unfolding less_rat_def
      by partiality_descending (auto simp add: le_less mult.commute)
    show "q \<le> r \<or> r \<le> q"
      by partiality_descending (auto simp add: mult.commute linorder_linear)
  }
qed

end

instance rat :: archimedean_field
proof
  fix q r s :: rat
  show "q \<le> r ==> s + q \<le> s + r"
  proof (partiality_descending, auto simp add: algebra_simps, simp add: mult.assoc[symmetric])
    fix a b c d e :: int
    assume "e \<noteq> 0"
    then have e2: "e * e > 0"
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
      assume "a * b * d * d \<le> b * b * c * d"
      then show "a * b * d * d * e * e * e * e \<le> b * b * c * d * e * e * e * e"
        using e2 by (metis mult_left_mono mult.commute linorder_le_cases
          mult_left_mono_neg)
    qed
  show "q < r ==> 0 < s ==> s * q < s * r" unfolding less_rat_def
    proof (partiality_descending, auto simp add: algebra_simps, simp add: mult.assoc[symmetric])
    fix a b c d e f :: int
    assume a: "e \<noteq> 0" "f \<noteq> 0" "0 \<le> e * f" "a * b * d * d \<le> b * b * c * d"
    have "a * b * d * d * (e * f) \<le> b * b * c * d * (e * f)" using a
      by (simp add: mult_right_mono)
    then show "a * b * d * d * e * f * f * f \<le> b * b * c * d * e * f * f * f"
      by (simp add: mult.assoc[symmetric]) (metis a(3) mult_left_mono
        mult.commute mult_left_mono_neg zero_le_mult_iff)
  qed
  show "\<exists>z. r \<le> of_int z"
    unfolding of_int_rat
  proof (partiality_descending, auto)
    fix a b :: int
    assume "b \<noteq> 0"
    then have "a * b \<le> (a div b + 1) * b * b"
      by (metis mult.commute nonzero_mult_div_cancel_left less_int_def linorder_le_cases zdiv_mono1 zdiv_mono1_neg zle_add1_eq_le)
    then show "\<exists>z::int. a * b \<le> z * b * b" by auto
  qed
qed
*)

end


(*
  Author: Fred Kurz
*)
theory CNF_Semantics_Supplement
  imports "Propositional_Proof_Systems.CNF_Formulas_Sema" "CNF_Supplement"
begin

lemma not_model_if_exists_unmodeled_singleton_clause:
  assumes "is_cnf F"
    and "{L} \<in> cnf F"
    and "\<not>lit_semantics \<nu> L"
  shows "\<not>\<nu> \<Turnstile> F"
proof (rule ccontr)
  assume "\<not>\<not>\<nu> \<Turnstile> F"
  then have a: "\<nu> \<Turnstile> F"
    by blast
  moreover have "is_nnf F"
    using is_nnf_cnf[OF assms(1)]
    by simp
  moreover {
    let ?C = "{L}"
    have "\<not>(\<exists>L'. L' \<in> ?C \<and> lit_semantics \<nu> L')"
      using assms(3)
      by fast
    then have "\<not>(\<forall>C \<in> cnf F. \<exists>L. L \<in> C \<and> lit_semantics \<nu> L)"
      using assms(2)
      by blast
    hence "\<not>cnf_semantics \<nu> (cnf F)"
      unfolding cnf_semantics_def clause_semantics_def
      by fast
  }
  ultimately have "\<not> \<nu> \<Turnstile> F"
    using cnf_semantics
    by blast
  thus False
    using a
    by blast
qed

\<comment> \<open> NOTE This follows by contraposition from the previous lemma
\<open>not_model_if_exists_unmodeled_singleton_clause\<close>. \<close>
corollary model_then_all_singleton_clauses_modelled:
  assumes "is_cnf F"
    and "{L} \<in> cnf F"
    and "\<nu> \<Turnstile> F"
  shows "lit_semantics \<nu> L"
  using not_model_if_exists_unmodeled_singleton_clause[OF assms(1, 2)] assms(3)
  by blast

\<comment> \<open> NOTE This is essentially the \<open>\<Rightarrow>\<close> direction of the compactness theorem when treating CNFs as sets
of formulas (sets of disjunctions in this case). \<close>
lemma model_for_cnf_is_model_of_all_subsets:
  assumes "cnf_semantics \<nu> \<F>"
    and "\<F>' \<subseteq> \<F>"
  shows "cnf_semantics \<nu> \<F>'"
proof -
  {
    fix C
    assume "C \<in> \<F>'"
    then have "C \<in> \<F>"
      using assms(2)
      by blast
    then have "clause_semantics \<nu> C"
      using assms(1)
      unfolding cnf_semantics_def
      by blast
  }
  thus ?thesis
    unfolding cnf_semantics_def
    by blast
qed

lemma cnf_semantics_monotonous_in_cnf_subsets_if:
  assumes "\<A> \<Turnstile> \<Phi>"
    and "is_cnf \<Phi>"
    and "cnf \<Phi>' \<subseteq> cnf \<Phi>"
  shows "cnf_semantics \<A> (cnf \<Phi>')"
proof -
  {
    have "is_nnf \<Phi>"
      using is_nnf_cnf[OF assms(2)].
    hence "cnf_semantics \<A> (cnf \<Phi>)"
      using cnf_semantics assms(1)
      by blast
  }
  thus ?thesis
    using model_for_cnf_is_model_of_all_subsets[OF _ assms(3)]
    by simp
qed

corollary modelling_relation_monotonous_in_cnf_subsets_if:
  assumes "\<A> \<Turnstile> \<Phi>"
    and "is_cnf \<Phi>"
    and "is_cnf \<Phi>'"
    and "cnf \<Phi>' \<subseteq> cnf \<Phi>"
  shows "\<A> \<Turnstile> \<Phi>'"
proof -
  have "cnf_semantics \<A> (cnf \<Phi>')"
    using cnf_semantics_monotonous_in_cnf_subsets_if[OF assms(1, 2, 4)].
  thus ?thesis
    using cnf_semantics is_nnf_cnf[OF assms(3)]
    by blast
qed

\<comment> \<open> NOTE Show that any clause \<open>C\<close> containing a subset \<open>C\<close> for which all literals
  \<open>L\<close> evaluate to \<open>False\<close> for the given valuation \<open>\<A>\<close>, then the clause
  semantics evaluation can be reduced to the set \<open>C - C'\<close> where all literals of
  \<open>C'\<close> have been removed. \<close>
lemma lit_semantics_reducible_to_subset_if:
  assumes "C' \<subseteq> C"
    and "\<forall>L \<in> C'. \<not>lit_semantics \<A> L"
  shows "clause_semantics \<A> C = clause_semantics \<A> (C - C')"
  unfolding clause_semantics_def
  using assms
  by fast

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Matrix Conversions\<close>

text \<open>Essentially, the idea is to use the JNF results to estimate the growth rates of
  matrices. Since the results in JNF are only applicable for real normed fields,
  we cannot directly use them for matrices over the integers or the rational numbers.
  To this end, we define a homomorphism which allows us to first convert all numbers
  to real numbers, and then do the analysis.\<close>

theory Ring_Hom_Matrix
imports
  Matrix
  Polynomial_Interpolation.Ring_Hom
begin

locale ord_ring_hom = idom_hom hom for
  hom :: "'a :: linordered_idom \<Rightarrow> 'b :: floor_ceiling" +
  assumes hom_le: "hom x \<le> z \<Longrightarrow> x \<le> of_int \<lceil>z\<rceil>"

text \<open>Now a class based variant especially for homomorphisms into the reals.\<close>
class real_embedding = linordered_idom +
  fixes real_of :: "'a \<Rightarrow> real"
  assumes
    real_add: "real_of ((x :: 'a) + y) = real_of x + real_of y" and
    real_mult: "real_of (x * y) = real_of x * real_of y" and
    real_zero: "real_of 0 = 0" and
    real_one: "real_of 1 = 1" and
    real_le: "real_of x \<le> z \<Longrightarrow> x \<le> of_int \<lceil>z\<rceil>"

interpretation real_embedding: ord_ring_hom "(real_of :: 'a :: real_embedding \<Rightarrow> real)"
  by (unfold_locales; fact real_add real_mult real_zero real_one real_le)

instantiation real :: real_embedding
begin
definition real_of_real :: "real \<Rightarrow> real" where
  "real_of_real x = x"

instance
  by (intro_classes, auto simp: real_of_real_def, linarith)
end

instantiation int :: real_embedding
begin

definition real_of_int :: "int \<Rightarrow> real" where
  "real_of_int x = x"

instance
  by (intro_classes, auto simp: real_of_int_def, linarith)
end

lemma real_of_rat_ineq: assumes "real_of_rat x \<le> z"
  shows "x \<le> of_int \<lceil>z\<rceil>"
proof -
  have "z \<le> of_int \<lceil>z\<rceil>" by linarith
  from order_trans[OF assms this]
  have "real_of_rat x \<le> real_of_rat (of_int \<lceil>z\<rceil>)" by auto
  thus "x \<le> of_int \<lceil>z\<rceil>" using of_rat_less_eq by blast
qed

instantiation rat :: real_embedding
begin
definition real_of_rat :: "rat \<Rightarrow> real" where
  "real_of_rat x = of_rat x"

instance
  by (intro_classes, auto simp: real_of_rat_def of_rat_add of_rat_mult real_of_rat_ineq)
end

abbreviation mat_real ("mat\<^sub>\<real>") where "mat\<^sub>\<real> \<equiv> map_mat (real_of :: 'a :: real_embedding \<Rightarrow> real)"

end


theory P14 imports Main begin

primrec zip1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
zip1FstEmp: "zip1 Nil ys = ys" |
zip1Indt: "zip1 (x # xs) ys = x # (take 1 ys) @ (zip1 xs (drop 1 ys))"

primrec zip2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
zip2SndEmp: "zip2 xs Nil = xs" |
zip2Indt: "zip2 xs (y # ys) = (take 1 xs)@ [y] @ (zip2 (drop 1 xs) ys)"

fun zipr :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"zipr Nil ys = ys" |
"zipr xs Nil = xs" |
"zipr (x # xs) (y # ys) = [x, y] @ (zipr xs ys)"

lemma [simp]: "zip1 xs Nil = xs"
  apply (induct xs)
  apply auto
  done

lemma [simp]: "zip2 Nil ys = ys"
  apply (induct ys)
  apply auto
  done

lemma [simp]: "zipr xs Nil = xs"
  apply (induct xs)
  apply auto
  done

lemma "zip1 xs ys = zipr xs ys"
proof (induct ys arbitrary: xs)
  case Nil
  then show ?case by simp
next
  case (Cons a ys)
  then show ?case
  proof (cases "xs = Nil")
    case True
  then show ?thesis by simp
  next
    case False
    then obtain a as where "xs = (a # as)"
      using list.exhaust_sel by blast
    then show ?thesis using Cons.hyps by simp
  qed
qed

lemma "zip2 xs ys = zipr xs ys"
proof (induct xs arbitrary: ys)
  case Nil
  then show ?case by simp
next
  case (Cons a ys)
  then show ?case
  proof (cases "ys = Nil")
    case True
  then show ?thesis by simp
  next
    case False
    then obtain a as where "ys = (a # as)"
      using list.exhaust_sel by blast
    then show ?thesis using Cons.hyps by simp
  qed
qed

lemma "\<lbrakk>length p = length u; length q = length v\<rbrakk> \<Longrightarrow> zipr (p@q) (u@v) = zipr p u @ zipr q v"
  apply (induct p arbitrary: u q v)
   apply auto
  done

end