(*  Title:      HOL/Nominal/Examples/Standardization.thy
    Author:     Stefan Berghofer and Tobias Nipkow
    Copyright   2005, 2008 TU Muenchen
*)

section {* Standardization *}

theory Standardization
imports "../Nominal"
begin

text {*
The proof of the standardization theorem, as well as most of the theorems about
lambda calculus in the following sections, are taken from @{text "HOL/Lambda"}.
*}

subsection {* Lambda terms *}

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam" (infixl "\<degree>" 200)
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [0, 10] 10)

instantiation lam :: size
begin

nominal_primrec size_lam
where
  "size (Var n) = 0"
| "size (t \<degree> u) = size t + size u + 1"
| "size (Lam [x].t) = size t + 1"
  apply finite_guess+
  apply (rule TrueI)+
  apply (simp add: fresh_nat)
  apply fresh_guess+
  done

instance ..

end

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [300, 0, 0] 300)
where
  subst_Var: "(Var x)[y::=s] = (if x=y then s else (Var x))"
| subst_App: "(t\<^sub>1 \<degree> t\<^sub>2)[y::=s] = t\<^sub>1[y::=s] \<degree> t\<^sub>2[y::=s]"
| subst_Lam: "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]:
  "(pi::name prm) \<bullet> (t[x::=u]) = (pi \<bullet> t)[(pi \<bullet> x)::=(pi \<bullet> u)]"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (perm_simp add: fresh_bij)+

lemma subst_rename:
  "y \<sharp> t \<Longrightarrow> ([(y, x)] \<bullet> t)[y::=u] = t[x::=u]"
  by (nominal_induct t avoiding: x y u rule: lam.strong_induct)
    (simp_all add: fresh_atm calc_atm abs_fresh)

lemma fresh_subst:
  "(x::name) \<sharp> t \<Longrightarrow> x \<sharp> u \<Longrightarrow> x \<sharp> t[y::=u]"
  by (nominal_induct t avoiding: x y u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma fresh_subst':
  "(x::name) \<sharp> u \<Longrightarrow> x \<sharp> t[x::=u]"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma subst_forget: "(x::name) \<sharp> t \<Longrightarrow> t[x::=u] = t"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma subst_subst:
  "x \<noteq> y \<Longrightarrow> x \<sharp> v \<Longrightarrow> t[y::=v][x::=u[y::=v]] = t[x::=u][y::=v]"
  by (nominal_induct t avoiding: x y u v rule: lam.strong_induct)
    (auto simp add: fresh_subst subst_forget)

declare subst_Var [simp del]

lemma subst_eq [simp]: "(Var x)[x::=u] = u"
  by (simp add: subst_Var)

lemma subst_neq [simp]: "x \<noteq> y \<Longrightarrow> (Var x)[y::=u] = Var x"
  by (simp add: subst_Var)

inductive beta :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta: "x \<sharp> t \<Longrightarrow> (Lam [x].s) \<degree> t \<rightarrow>\<^sub>\<beta> s[x::=t]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> (Lam [x].s) \<rightarrow>\<^sub>\<beta> (Lam [x].t)"

equivariance beta
nominal_inductive beta
  by (simp_all add: abs_fresh fresh_subst')

lemma better_beta [simp, intro!]: "(Lam [x].s) \<degree> t \<rightarrow>\<^sub>\<beta> s[x::=t]"
proof -
  obtain y::name where y: "y \<sharp> (x, s, t)"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> t" by simp
  then have "(Lam [y]. [(y, x)] \<bullet> s) \<degree> t \<rightarrow>\<^sub>\<beta> ([(y, x)] \<bullet> s)[y::=t]"
    by (rule beta)
  moreover from y have "(Lam [x].s) = (Lam [y]. [(y, x)] \<bullet> s)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis using y by (simp add: subst_rename)
qed

abbreviation
  beta_reds :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<equiv> beta\<^sup>*\<^sup>* s t"

subsection {* Application of a term to a list of terms *}

abbreviation
  list_application :: "lam \<Rightarrow> lam list \<Rightarrow> lam"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts \<equiv> foldl (op \<degree>) t ts"

lemma apps_eq_tail_conv [iff]: "(r \<degree>\<degree> ts = s \<degree>\<degree> ts) = (r = s)"
  by (induct ts rule: rev_induct) (auto simp add: lam.inject)

lemma Var_eq_apps_conv [iff]: "(Var m = s \<degree>\<degree> ss) = (Var m = s \<and> ss = [])"
  by (induct ss arbitrary: s) auto

lemma Var_apps_eq_Var_apps_conv [iff]:
    "(Var m \<degree>\<degree> rs = Var n \<degree>\<degree> ss) = (m = n \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply (simp add: lam.inject)
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply (auto simp add: lam.inject)
  done

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply (auto simp add: lam.inject)
  done

lemma Abs_eq_apps_conv [iff]:
    "((Lam [x].r) = s \<degree>\<degree> ss) = ((Lam [x].r) = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma apps_eq_Abs_conv [iff]: "(s \<degree>\<degree> ss = (Lam [x].r)) = (s = (Lam [x].r) \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_App_neq_Var_apps [iff]:
    "(Lam [x].s) \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) (auto simp add: lam.inject)

lemma Var_apps_neq_Abs_apps [iff]:
    "Var n \<degree>\<degree> ts \<noteq> (Lam [x].r) \<degree>\<degree> ss"
  apply (induct ss arbitrary: ts rule: rev_induct)
   apply simp
  apply (induct_tac ts rule: rev_induct)
   apply (auto simp add: lam.inject)
  done

lemma ex_head_tail:
  "\<exists>ts h. t = h \<degree>\<degree> ts \<and> ((\<exists>n. h = Var n) \<or> (\<exists>x u. h = (Lam [x].u)))"
  apply (induct t rule: lam.induct)
    apply (metis foldl_Nil)
   apply (metis foldl_Cons foldl_Nil foldl_append)
  apply (metis foldl_Nil)
  done

lemma size_apps [simp]:
  "size (r \<degree>\<degree> rs) = size r + foldl (op +) 0 (map size rs) + length rs"
  by (induct rs rule: rev_induct) auto

lemma lem0: "(0::nat) < k \<Longrightarrow> m \<le> n \<Longrightarrow> m < n + k"
  by simp

lemma subst_map [simp]:
    "(t \<degree>\<degree> ts)[x::=u] = t[x::=u] \<degree>\<degree> map (\<lambda>t. t[x::=u]) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

lemma perm_apps [eqvt]:
  "(pi::name prm) \<bullet> (t \<degree>\<degree> ts) = ((pi \<bullet> t) \<degree>\<degree> (pi \<bullet> ts))"
  by (induct ts rule: rev_induct) (auto simp add: append_eqvt)

lemma fresh_apps [simp]: "(x::name) \<sharp> (t \<degree>\<degree> ts) = (x \<sharp> t \<and> x \<sharp> ts)"
  by (induct ts rule: rev_induct)
    (auto simp add: fresh_list_append fresh_list_nil fresh_list_cons)

text {* A customized induction schema for @{text "\<degree>\<degree>"}. *}

lemma lem:
  assumes "\<And>n ts (z::'a::fs_name). (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z (Var n \<degree>\<degree> ts)"
    and "\<And>x u ts z. x \<sharp> z \<Longrightarrow> (\<And>z. P z u) \<Longrightarrow> (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z ((Lam [x].u) \<degree>\<degree> ts)"
  shows "size t = n \<Longrightarrow> P z t"
  apply (induct n arbitrary: t z rule: nat_less_induct)
  apply (cut_tac t = t in ex_head_tail)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply (rule assms)
   apply clarify
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule impE, rule refl, erule spec)
    apply simp
    apply (simp only: foldl_conv_fold add.commute fold_plus_listsum_rev)
    apply (fastforce simp add: listsum_map_remove1)
  apply clarify
  apply (subgoal_tac "\<exists>y::name. y \<sharp> (x, u, z)")
   prefer 2
   apply (blast intro: exists_fresh' fin_supp)
  apply (erule exE)
  apply (subgoal_tac "(Lam [x].u) = (Lam [y].([(y, x)] \<bullet> u))")
  prefer 2
  apply (auto simp add: lam.inject alpha' fresh_prod fresh_atm)[]
  apply (simp (no_asm_simp))
  apply (rule assms)
  apply (simp add: fresh_prod)
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule impE, rule refl, erule spec)
   apply simp
  apply clarify
  apply (erule allE, erule impE)
   prefer 2
   apply blast
  apply simp
  apply (simp only: foldl_conv_fold add.commute fold_plus_listsum_rev)
  apply (fastforce simp add: listsum_map_remove1)
  done

theorem Apps_lam_induct:
  assumes "\<And>n ts (z::'a::fs_name). (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z (Var n \<degree>\<degree> ts)"
    and "\<And>x u ts z. x \<sharp> z \<Longrightarrow> (\<And>z. P z u) \<Longrightarrow> (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z ((Lam [x].u) \<degree>\<degree> ts)"
  shows "P z t"
  apply (rule_tac t = t and z = z in lem)
    prefer 3
    apply (rule refl)
    using assms apply blast+
  done

subsection {* Congruence rules *}

lemma apps_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> r \<degree>\<degree> ss \<rightarrow>\<^sub>\<beta> s \<degree>\<degree> ss"
  by (induct ss rule: rev_induct) auto

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> (Lam [x].s) \<rightarrow>\<^sub>\<beta>\<^sup>* (Lam [x].s')"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection {* Lifting an order to lists of elements *}

definition
  step1 :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "step1 r =
    (\<lambda>ys xs. \<exists>us z z' vs. xs = us @ z # vs \<and> r z' z \<and> ys =
      us @ z' # vs)"

lemma not_Nil_step1 [iff]: "\<not> step1 r [] xs"
  apply (unfold step1_def)
  apply blast
  done

lemma not_step1_Nil [iff]: "\<not> step1 r xs []"
  apply (unfold step1_def)
  apply blast
  done

lemma Cons_step1_Cons [iff]:
    "(step1 r (y # ys) (x # xs)) =
      (r y x \<and> xs = ys \<or> x = y \<and> step1 r ys xs)"
  apply (unfold step1_def)
  apply (rule iffI)
   apply (erule exE)
   apply (rename_tac ts)
   apply (case_tac ts)
    apply fastforce
   apply force
  apply (erule disjE)
   apply blast
  apply (blast intro: Cons_eq_appendI)
  done

lemma append_step1I:
  "step1 r ys xs \<and> vs = us \<or> ys = xs \<and> step1 r vs us
    \<Longrightarrow> step1 r (ys @ vs) (xs @ us)"
  apply (unfold step1_def)
  apply auto
   apply blast
  apply (blast intro: append_eq_appendI)
  done

lemma Cons_step1E [elim!]:
  assumes "step1 r ys (x # xs)"
    and "\<And>y. ys = y # xs \<Longrightarrow> r y x \<Longrightarrow> R"
    and "\<And>zs. ys = x # zs \<Longrightarrow> step1 r zs xs \<Longrightarrow> R"
  shows R
  using assms
  apply (cases ys)
   apply (simp add: step1_def)
  apply blast
  done

lemma Snoc_step1_SnocD:
  "step1 r (ys @ [y]) (xs @ [x])
    \<Longrightarrow> (step1 r ys xs \<and> y = x \<or> ys = xs \<and> r y x)"
  apply (unfold step1_def)
  apply (clarify del: disjCI)
  apply (rename_tac vs)
  apply (rule_tac xs = vs in rev_exhaust)
   apply force
  apply simp
  apply blast
  done

subsection {* Lifting beta-reduction to lists *}

abbreviation
  list_beta :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>\<beta>]\<^sub>1" 50) where
  "rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<equiv> step1 beta rs ss"

lemma head_Var_reduction:
  "Var n \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> v \<Longrightarrow> \<exists>ss. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<and> v = Var n \<degree>\<degree> ss"
  apply (induct u \<equiv> "Var n \<degree>\<degree> rs" v arbitrary: rs set: beta)
     apply simp
    apply (rule_tac xs = rs in rev_exhaust)
     apply simp
    apply (atomize, force intro: append_step1I iff: lam.inject)
   apply (rule_tac xs = rs in rev_exhaust)
    apply simp
    apply (auto 0 3 intro: disjI2 [THEN append_step1I] simp add: lam.inject)
  done

lemma apps_betasE [case_names appL appR beta, consumes 1]:
  assumes major: "r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> s"
    and cases: "\<And>r'. r \<rightarrow>\<^sub>\<beta> r' \<Longrightarrow> s = r' \<degree>\<degree> rs \<Longrightarrow> R"
      "\<And>rs'. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs' \<Longrightarrow> s = r \<degree>\<degree> rs' \<Longrightarrow> R"
      "\<And>t u us. (x \<sharp> r \<Longrightarrow> r = (Lam [x].t) \<and> rs = u # us \<and> s = t[x::=u] \<degree>\<degree> us) \<Longrightarrow> R"
  shows R
proof -
  from major have
   "(\<exists>r'. r \<rightarrow>\<^sub>\<beta> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    (\<exists>rs'. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs' \<and> s = r \<degree>\<degree> rs') \<or>
    (\<exists>t u us. x \<sharp> r \<longrightarrow> r = (Lam [x].t) \<and> rs = u # us \<and> s = t[x::=u] \<degree>\<degree> us)"
    apply (nominal_induct u \<equiv> "r \<degree>\<degree> rs" s avoiding: x r rs rule: beta.strong_induct)
    apply (simp add: App_eq_foldl_conv)
    apply (split split_if_asm)
    apply simp
    apply blast
    apply simp
    apply (rule impI)+
    apply (rule disjI2)
    apply (rule disjI2)
    apply (subgoal_tac "r = [(xa, x)] \<bullet> (Lam [x].s)")
    prefer 2
    apply (simp add: perm_fresh_fresh)
    apply (drule conjunct1)
    apply (subgoal_tac "r = (Lam [xa]. [(xa, x)] \<bullet> s)")
    prefer 2
    apply (simp add: calc_atm)
    apply (thin_tac "r = ?t")
    apply simp
    apply (rule exI)
    apply (rule conjI)
    apply (rule refl)
    apply (simp add: abs_fresh fresh_atm fresh_left calc_atm subst_rename)
      apply (drule App_eq_foldl_conv [THEN iffD1])
      apply (split split_if_asm)
       apply simp
       apply blast
      apply (force intro!: disjI1 [THEN append_step1I] simp add: fresh_list_append)
     apply (drule App_eq_foldl_conv [THEN iffD1])
     apply (split split_if_asm)
      apply simp
      apply blast
     apply (clarify, auto 0 3 intro!: exI intro: append_step1I)
    done
  with cases show ?thesis by blast
qed

lemma apps_preserves_betas [simp]:
    "rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<Longrightarrow> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> r \<degree>\<degree> ss"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
  apply simp
  apply (rule_tac xs = ss in rev_exhaust)
   apply simp
  apply simp
  apply (drule Snoc_step1_SnocD)
  apply blast
  done

subsection {* Standard reduction relation *}

text {*
Based on lecture notes by Ralph Matthes,
original proof idea due to Ralph Loader.
*}

declare listrel_mono [mono_set]

lemma listrelp_eqvt [eqvt]:
  fixes f :: "'a::pt_name \<Rightarrow> 'b::pt_name \<Rightarrow> bool"
  assumes xy: "listrelp f (x::'a::pt_name list) y"
  shows "listrelp ((pi::name prm) \<bullet> f) (pi \<bullet> x) (pi \<bullet> y)" using xy
  by induct (simp_all add: listrelp.intros perm_app [symmetric])

inductive
  sred :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>s" 50)
  and sredlist :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>s]" 50)
where
  "s [\<rightarrow>\<^sub>s] t \<equiv> listrelp op \<rightarrow>\<^sub>s s t"
| Var: "rs [\<rightarrow>\<^sub>s] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> rs'"
| Abs: "x \<sharp> (ss, ss') \<Longrightarrow> r \<rightarrow>\<^sub>s r' \<Longrightarrow> ss [\<rightarrow>\<^sub>s] ss' \<Longrightarrow> (Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> ss'"
| Beta: "x \<sharp> (s, ss, t) \<Longrightarrow> r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t \<Longrightarrow> (Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"

equivariance sred
nominal_inductive sred
  by (simp add: abs_fresh)+

lemma better_sred_Abs:
  assumes H1: "r \<rightarrow>\<^sub>s r'"
  and H2: "ss [\<rightarrow>\<^sub>s] ss'"
  shows "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> ss'"
proof -
  obtain y::name where y: "y \<sharp> (x, r, r', ss, ss')"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> (ss, ss')" by simp
  moreover from H1 have "[(y, x)] \<bullet> (r \<rightarrow>\<^sub>s r')" by (rule perm_boolI)
  then have "([(y, x)] \<bullet> r) \<rightarrow>\<^sub>s ([(y, x)] \<bullet> r')" by (simp add: eqvts)
  ultimately have "(Lam [y]. [(y, x)] \<bullet> r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [y]. [(y, x)] \<bullet> r') \<degree>\<degree> ss'" using H2
    by (rule sred.Abs)
  moreover from y have "(Lam [x].r) = (Lam [y]. [(y, x)] \<bullet> r)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  moreover from y have "(Lam [x].r') = (Lam [y]. [(y, x)] \<bullet> r')"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis by simp
qed

lemma better_sred_Beta:
  assumes H: "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
  shows "(Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
proof -
  obtain y::name where y: "y \<sharp> (x, r, s, ss, t)"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> (s, ss, t)" by simp
  moreover from y H have "([(y, x)] \<bullet> r)[y::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
    by (simp add: subst_rename)
  ultimately have "(Lam [y].[(y, x)] \<bullet> r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
    by (rule sred.Beta)
  moreover from y have "(Lam [x].r) = (Lam [y]. [(y, x)] \<bullet> r)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis by simp
qed

lemmas better_sred_intros = sred.Var better_sred_Abs better_sred_Beta

lemma refl_listrelp: "\<forall>x\<in>set xs. R x x \<Longrightarrow> listrelp R xs xs"
  by (induct xs) (auto intro: listrelp.intros)

lemma refl_sred: "t \<rightarrow>\<^sub>s t"
  by (nominal_induct t rule: Apps_lam_induct) (auto intro: refl_listrelp better_sred_intros)

lemma listrelp_conj1: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp R x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_conj2: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp S x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_app:
  assumes xsys: "listrelp R xs ys"
  shows "listrelp R xs' ys' \<Longrightarrow> listrelp R (xs @ xs') (ys @ ys')" using xsys
  by (induct arbitrary: xs' ys') (auto intro: listrelp.intros)

lemma lemma1:
  assumes r: "r \<rightarrow>\<^sub>s r'" and s: "s \<rightarrow>\<^sub>s s'"
  shows "r \<degree> s \<rightarrow>\<^sub>s r' \<degree> s'" using r
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "rs @ [s] [\<rightarrow>\<^sub>s] rs' @ [s']" by (rule listrelp_app)
  hence "Var x \<degree>\<degree> (rs @ [s]) \<rightarrow>\<^sub>s Var x \<degree>\<degree> (rs' @ [s'])" by (rule sred.Var)
  thus ?case by (simp only: app_last)
next
  case (Abs x ss ss' r r')
  from Abs(4) have "ss [\<rightarrow>\<^sub>s] ss'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "ss @ [s] [\<rightarrow>\<^sub>s] ss' @ [s']" by (rule listrelp_app)
  with `r \<rightarrow>\<^sub>s r'` have "(Lam [x].r) \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> (ss' @ [s'])"
    by (rule better_sred_Abs)
  thus ?case by (simp only: app_last)
next
  case (Beta x u ss t r)
  hence "r[x::=u] \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (simp only: app_last)
  hence "(Lam [x].r) \<degree> u \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (rule better_sred_Beta)
  thus ?case by (simp only: app_last)
qed

lemma lemma1':
  assumes ts: "ts [\<rightarrow>\<^sub>s] ts'"
  shows "r \<rightarrow>\<^sub>s r' \<Longrightarrow> r \<degree>\<degree> ts \<rightarrow>\<^sub>s r' \<degree>\<degree> ts'" using ts
  by (induct arbitrary: r r') (auto intro: lemma1)

lemma listrelp_betas:
  assumes ts: "listrelp op \<rightarrow>\<^sub>\<beta>\<^sup>* ts ts'"
  shows "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<degree>\<degree> ts'" using ts
  by induct auto

lemma lemma2:
  assumes t: "t \<rightarrow>\<^sub>s u"
  shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using t
  by induct (auto dest: listrelp_conj2
    intro: listrelp_betas apps_preserves_beta converse_rtranclp_into_rtranclp)

lemma lemma3:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "s \<rightarrow>\<^sub>s s' \<Longrightarrow> r[x::=s] \<rightarrow>\<^sub>s r'[x::=s']" using r
proof (nominal_induct avoiding: x s s' rule: sred.strong_induct)
  case (Var rs rs' y)
  hence "map (\<lambda>t. t[x::=s]) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. t[x::=s']) rs'"
    by induct (auto intro: listrelp.intros Var)
  moreover have "Var y[x::=s] \<rightarrow>\<^sub>s Var y[x::=s']"
    by (cases "y = x") (auto simp add: Var intro: refl_sred)
  ultimately show ?case by simp (rule lemma1')
next
  case (Abs y ss ss' r r')
  then have "r[x::=s] \<rightarrow>\<^sub>s r'[x::=s']" by fast
  moreover from Abs(8) `s \<rightarrow>\<^sub>s s'` have "map (\<lambda>t. t[x::=s]) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. t[x::=s']) ss'"
    by induct (auto intro: listrelp.intros Abs)
  ultimately show ?case using Abs(6) `y \<sharp> x` `y \<sharp> s` `y \<sharp> s'`
    by simp (rule better_sred_Abs)
next
  case (Beta y u ss t r)
  thus ?case by (auto simp add: subst_subst fresh_atm intro: better_sred_Beta)
qed

lemma lemma4_aux:
  assumes rs: "listrelp (\<lambda>t u. t \<rightarrow>\<^sub>s u \<and> (\<forall>r. u \<rightarrow>\<^sub>\<beta> r \<longrightarrow> t \<rightarrow>\<^sub>s r)) rs rs'"
  shows "rs' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<Longrightarrow> rs [\<rightarrow>\<^sub>s] ss" using rs
proof (induct arbitrary: ss)
  case Nil
  thus ?case by cases (auto intro: listrelp.Nil)
next
  case (Cons x y xs ys)
  note Cons' = Cons
  show ?case
  proof (cases ss)
    case Nil with Cons show ?thesis by simp
  next
    case (Cons y' ys')
    hence ss: "ss = y' # ys'" by simp
    from Cons Cons' have "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys \<or> y' = y \<and> ys [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ys'" by simp
    hence "x # xs [\<rightarrow>\<^sub>s] y' # ys'"
    proof
      assume H: "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from Cons' have "xs [\<rightarrow>\<^sub>s] ys" by (iprover dest: listrelp_conj1)
      ultimately have "x # xs [\<rightarrow>\<^sub>s] y' # ys" by (rule listrelp.Cons)
      with H show ?thesis by simp
    next
      assume H: "y' = y \<and> ys [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ys'"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from H have "xs [\<rightarrow>\<^sub>s] ys'" by (blast intro: Cons')
      ultimately show ?thesis by (rule listrelp.Cons)
    qed
    with ss show ?thesis by simp
  qed
qed

lemma lemma4:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "r' \<rightarrow>\<^sub>\<beta> r'' \<Longrightarrow> r \<rightarrow>\<^sub>s r''" using r
proof (nominal_induct avoiding: r'' rule: sred.strong_induct)
  case (Var rs rs' x)
  then obtain ss where rs: "rs' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss" and r'': "r'' = Var x \<degree>\<degree> ss"
    by (blast dest: head_Var_reduction)
  from Var(1) [simplified] rs have "rs [\<rightarrow>\<^sub>s] ss" by (rule lemma4_aux)
  hence "Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> ss" by (rule sred.Var)
  with r'' show ?case by simp
next
  case (Abs x ss ss' r r')
  from `(Lam [x].r') \<degree>\<degree> ss' \<rightarrow>\<^sub>\<beta> r''` show ?case
  proof (cases rule: apps_betasE [where x=x])
    case (appL s)
    then obtain r''' where s: "s = (Lam [x].r''')" and r''': "r' \<rightarrow>\<^sub>\<beta> r'''" using `x \<sharp> r''`
      by (cases rule: beta.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
    from r''' have "r \<rightarrow>\<^sub>s r'''" by (blast intro: Abs)
    moreover from Abs have "ss [\<rightarrow>\<^sub>s] ss'" by (iprover dest: listrelp_conj1)
    ultimately have "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r''') \<degree>\<degree> ss'" by (rule better_sred_Abs)
    with appL s show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    case (appR rs')
    from Abs(6) [simplified] `ss' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs'`
    have "ss [\<rightarrow>\<^sub>s] rs'" by (rule lemma4_aux)
    with `r \<rightarrow>\<^sub>s r'` have "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> rs'" by (rule better_sred_Abs)
    with appR show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    case (beta t u' us')
    then have Lam_eq: "(Lam [x].r') = (Lam [x].t)" and ss': "ss' = u' # us'"
      and r'': "r'' = t[x::=u'] \<degree>\<degree> us'"
      by (simp_all add: abs_fresh)
    from Abs(6) ss' obtain u us where
      ss: "ss = u # us" and u: "u \<rightarrow>\<^sub>s u'" and us: "us [\<rightarrow>\<^sub>s] us'"
      by cases (auto dest!: listrelp_conj1)
    have "r[x::=u] \<rightarrow>\<^sub>s r'[x::=u']" using `r \<rightarrow>\<^sub>s r'` and u by (rule lemma3)
    with us have "r[x::=u] \<degree>\<degree> us \<rightarrow>\<^sub>s r'[x::=u'] \<degree>\<degree> us'" by (rule lemma1')
    hence "(Lam [x].r) \<degree> u \<degree>\<degree> us \<rightarrow>\<^sub>s r'[x::=u'] \<degree>\<degree> us'" by (rule better_sred_Beta)
    with ss r'' Lam_eq show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by (simp add: lam.inject alpha)
  qed
next
  case (Beta x s ss t r)
  show ?case
    by (rule better_sred_Beta) (rule Beta)+
qed

lemma rtrancl_beta_sred:
  assumes r: "r \<rightarrow>\<^sub>\<beta>\<^sup>* r'"
  shows "r \<rightarrow>\<^sub>s r'" using r
  by induct (iprover intro: refl_sred lemma4)+

subsection {* Terms in normal form *}

lemma listsp_eqvt [eqvt]:
  assumes xs: "listsp p (xs::'a::pt_name list)"
  shows "listsp ((pi::name prm) \<bullet> p) (pi \<bullet> xs)" using xs
  apply induct
  apply simp
  apply simp
  apply (rule listsp.intros)
  apply (drule_tac pi=pi in perm_boolI)
  apply perm_simp
  apply assumption
  done

inductive NF :: "lam \<Rightarrow> bool"
where
  App: "listsp NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
| Abs: "NF t \<Longrightarrow> NF (Lam [x].t)"

equivariance NF
nominal_inductive NF
  by (simp add: abs_fresh)

lemma Abs_NF:
  assumes NF: "NF ((Lam [x].t) \<degree>\<degree> ts)"
  shows "ts = []" using NF
proof cases
  case (App us i)
  thus ?thesis by (simp add: Var_apps_neq_Abs_apps [THEN not_sym])
next
  case (Abs u)
  thus ?thesis by simp
qed

text {*
@{term NF} characterizes exactly the terms that are in normal form.
*}

lemma NF_eq: "NF t = (\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t')"
proof
  assume H: "NF t"
  show "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  proof
    fix t'
    from H show "\<not> t \<rightarrow>\<^sub>\<beta> t'"
    proof (nominal_induct avoiding: t' rule: NF.strong_induct)
      case (App ts t)
      show ?case
      proof
        assume "Var t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> t'"
        then obtain rs where "ts [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs"
          by (iprover dest: head_Var_reduction)
        with App show False
          by (induct rs arbitrary: ts) (auto del: in_listspD)
      qed
    next
      case (Abs t x)
      show ?case
      proof
        assume "(Lam [x].t) \<rightarrow>\<^sub>\<beta> t'"
        then show False using Abs
          by (cases rule: beta.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
      qed
    qed
  qed
next
  assume H: "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  then show "NF t"
  proof (nominal_induct t rule: Apps_lam_induct)
    case (1 n ts)
    then have "\<forall>ts'. \<not> ts [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ts'"
      by (iprover intro: apps_preserves_betas)
    with 1(1) have "listsp NF ts"
      by (induct ts) (auto simp add: in_listsp_conv_set)
    then show ?case by (rule NF.App)
  next
    case (2 x u ts)
    show ?case
    proof (cases ts)
      case Nil thus ?thesis by (metis 2 NF.Abs abs foldl_Nil)
    next
      case (Cons r rs)
      have "(Lam [x].u) \<degree> r \<rightarrow>\<^sub>\<beta> u[x::=r]" ..
      then have "(Lam [x].u) \<degree> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> u[x::=r] \<degree>\<degree> rs"
        by (rule apps_preserves_beta)
      with Cons have "(Lam [x].u) \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> u[x::=r] \<degree>\<degree> rs"
        by simp
      with 2 show ?thesis by iprover
    qed
  qed
qed

subsection {* Leftmost reduction and weakly normalizing terms *}

inductive
  lred :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>l" 50)
  and lredlist :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>l]" 50)
where
  "s [\<rightarrow>\<^sub>l] t \<equiv> listrelp op \<rightarrow>\<^sub>l s t"
| Var: "rs [\<rightarrow>\<^sub>l] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>l Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>l r' \<Longrightarrow> (Lam [x].r) \<rightarrow>\<^sub>l (Lam [x].r')"
| Beta: "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>l t \<Longrightarrow> (Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>l t"

lemma lred_imp_sred:
  assumes lred: "s \<rightarrow>\<^sub>l t"
  shows "s \<rightarrow>\<^sub>s t" using lred
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (rule sred.Var)
next
  case (Abs r r' x)
  from `r \<rightarrow>\<^sub>s r'`
  have "(Lam [x].r) \<degree>\<degree> [] \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> []" using listrelp.Nil
    by (rule better_sred_Abs)
  then show ?case by simp
next
  case (Beta r x s ss t)
  from `r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t`
  show ?case by (rule better_sred_Beta)
qed

inductive WN :: "lam \<Rightarrow> bool"
  where
    Var: "listsp WN rs \<Longrightarrow> WN (Var n \<degree>\<degree> rs)"
  | Lambda: "WN r \<Longrightarrow> WN (Lam [x].r)"
  | Beta: "WN ((r[x::=s]) \<degree>\<degree> ss) \<Longrightarrow> WN (((Lam [x].r) \<degree> s) \<degree>\<degree> ss)"

lemma listrelp_imp_listsp1:
  assumes H: "listrelp (\<lambda>x y. P x) xs ys"
  shows "listsp P xs" using H
  by induct auto

lemma listrelp_imp_listsp2:
  assumes H: "listrelp (\<lambda>x y. P y) xs ys"
  shows "listsp P ys" using H
  by induct auto

lemma lemma5:
  assumes lred: "r \<rightarrow>\<^sub>l r'"
  shows "WN r" and "NF r'" using lred
  by induct
    (iprover dest: listrelp_conj1 listrelp_conj2
     listrelp_imp_listsp1 listrelp_imp_listsp2 intro: WN.intros
     NF.intros)+

lemma lemma6:
  assumes wn: "WN r"
  shows "\<exists>r'. r \<rightarrow>\<^sub>l r'" using wn
proof induct
  case (Var rs n)
  then have "\<exists>rs'. rs [\<rightarrow>\<^sub>l] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (iprover intro: lred.Var)
qed (iprover intro: lred.intros)+

lemma lemma7:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "NF r' \<Longrightarrow> r \<rightarrow>\<^sub>l r'" using r
proof induct
  case (Var rs rs' x)
  from `NF (Var x \<degree>\<degree> rs')` have "listsp NF rs'"
    by cases simp_all
  with Var(1) have "rs [\<rightarrow>\<^sub>l] rs'"
  proof induct
    case Nil
    show ?case by (rule listrelp.Nil)
  next
    case (Cons x y xs ys)
    hence "x \<rightarrow>\<^sub>l y" and "xs [\<rightarrow>\<^sub>l] ys" by (auto del: in_listspD)
    thus ?case by (rule listrelp.Cons)
  qed
  thus ?case by (rule lred.Var)
next
  case (Abs x ss ss' r r')
  from `NF ((Lam [x].r') \<degree>\<degree> ss')`
  have ss': "ss' = []" by (rule Abs_NF)
  from Abs(4) have ss: "ss = []" using ss'
    by cases simp_all
  from ss' Abs have "NF (Lam [x].r')" by simp
  hence "NF r'" by (cases rule: NF.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
  with Abs have "r \<rightarrow>\<^sub>l r'" by simp
  hence "(Lam [x].r) \<rightarrow>\<^sub>l (Lam [x].r')" by (rule lred.Abs)
  with ss ss' show ?case by simp
next
  case (Beta x s ss t r)
  hence "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>l t" by simp
  thus ?case by (rule lred.Beta)
qed

lemma WN_eq: "WN t = (\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
proof
  assume "WN t"
  then have "\<exists>t'. t \<rightarrow>\<^sub>l t'" by (rule lemma6)
  then obtain t' where t': "t \<rightarrow>\<^sub>l t'" ..
  then have NF: "NF t'" by (rule lemma5)
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule lred_imp_sred)
  then have "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" by (rule lemma2)
  with NF show "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by iprover
next
  assume "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  then obtain t' where t': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and NF: "NF t'"
    by iprover
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule rtrancl_beta_sred)
  then have "t \<rightarrow>\<^sub>l t'" using NF by (rule lemma7)
  then show "WN t" by (rule lemma5)
qed

end


theory Discrete_log imports
  CryptHOL.CryptHOL
begin

locale dis_log =
  fixes \<G> :: "'grp cyclic_group" (structure)
begin

type_synonym 'grp' dislog_adv = "'grp' \<Rightarrow> nat spmf"

definition dis_log :: "'grp dislog_adv \<Rightarrow> bool spmf"
where "dis_log \<A> = TRY do {
  x \<leftarrow> sample_uniform (Coset.order \<G>);
  let h = \<^bold>g (^) x;
  x'\<leftarrow> \<A> h;
  return_spmf (x = x')} ELSE return_spmf False"

definition advantage :: "'grp dislog_adv \<Rightarrow> real"
where "advantage \<A> \<equiv> spmf (dis_log \<A>) True"

lemma lossless_dis_log: "\<lbrakk>0 < order \<G>; \<forall> h. lossless_spmf (\<A> h)\<rbrakk> \<Longrightarrow> lossless_spmf (dis_log \<A>)"
by(auto simp add:  dis_log_def)

end

end


theory ModTrans
imports AT
begin

(* Improvement possibility:
The first two conditions in mod_trans could be part of Kripke type_def and thus become implicit *)
definition refinement :: "[('a::state) kripke,('a'::state) \<Rightarrow> 'a, 'a' kripke] \<Rightarrow> bool" ("(_ \<sqsubseteq>\<^sub>_ _)" 50)
  where "K \<sqsubseteq>\<^sub>E K' = (init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and>
    (\<forall> s' \<in> (states K'). (\<forall> s \<in> (init K'). (s \<rightarrow>\<^sub>i* s') \<longrightarrow> (E s) \<in> (init K) \<and> (E s) \<rightarrow>\<^sub>i* (E s'))))"

lemma init_ref: "K \<sqsubseteq>\<^sub>E K' \<Longrightarrow> E ` (init K') \<subseteq> (init K)"
  apply (simp add: refinement_def)
  apply (rule subsetI)
  apply (erule imageE)
  apply (rotate_tac -2)
  apply (erule ssubst)
  apply (erule conjE)+
  apply (drule_tac x = xa in bspec)
  apply (erule subsetD, assumption)
  apply (drule_tac x = xa in bspec)
  apply assumption
  apply (erule impE)
  apply (simp add: state_transition_refl_def)
by (erule conjE, assumption)

(* This version allows that the init in the refinement "deletes" some initial states *)
theorem prop_pres:  "K \<sqsubseteq>\<^sub>E K' \<Longrightarrow> (\<forall> s' \<in> (Pow (states K')).
                      (K' \<turnstile> EF s') \<longrightarrow> (Kripke (states K)(E ` (init K')) \<turnstile> EF (E ` s')))"
  apply clarify
  apply (frule init_ref)
  apply (unfold refinement_def)
  apply (erule conjE)+
  apply (simp add: check_def)
  apply (rule subsetI)
  apply (rule CollectI)
  apply (rule conjI)
  apply (rule_tac A = "init K" in subsetD, assumption)
   apply (rule_tac A = "E ` init K'" in subsetD, assumption+)
  apply (subgoal_tac "? y. y \<in> init K' \<and> E y = x")
   prefer 2
  apply force
  apply (erule exE)
  apply (erule conjE)
   apply (rotate_tac 1)
   apply (drule subsetD, assumption)
   apply (erule CollectE)
  apply (erule conjE)
   apply (drule EF_step_star_rev)
  apply (erule bexE)
  apply (drule_tac x = ya in bspec)
  apply (erule subsetD, assumption)
  apply (drule_tac x = y in bspec, assumption)
  apply (drule mp, assumption)
  apply (erule conjE)
  apply (rule_tac y = "E ya" in EF_step_star)
   apply (erule subst, assumption)
by simp

(* In this version of the property preservation theorem, the init_ref condition is
   stronger so it will be disallowed to "delete" initial states during refinement.
   Then the second more complex Kripke structure in prop_pres becomes simply K *)
lemma Kripke_self: "K = Kripke (states K) (init K)"
  apply (case_tac K)
by simp

theorem prop_pres':  "K \<sqsubseteq>\<^sub>E K' \<Longrightarrow> init K \<subseteq> E ` (init K') \<Longrightarrow> (\<forall> s' \<in> (Pow (states K')).
                      (K' \<turnstile> EF s') \<longrightarrow> (K \<turnstile> EF (E ` s')))"
  apply (subgoal_tac "init K = E ` (init K')")
   apply (subgoal_tac "K = Kripke (states K)(init K)")
  apply (rotate_tac -1)
  apply (erule ssubst)
    apply (erule ssubst)
  apply (rule prop_pres, assumption)
   apply (rule Kripke_self)
  apply (rule subset_antisym, assumption)
by (erule init_ref)

theorem strong_mt[rule_format]:
"init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and> E ` (init K') \<subseteq> (init K) \<and> (\<forall> s s'. s \<rightarrow>\<^sub>i s' \<longrightarrow> (E s) \<rightarrow>\<^sub>i (E s')) \<Longrightarrow>
                                K \<sqsubseteq>\<^sub>E K'"
  apply (unfold refinement_def)
  apply simp
  apply (erule conjE)+
  apply (rule ballI)+
  apply (rule impI)
  apply (rule conjI)
   apply (erule subsetD)
   apply (erule imageI)
  apply (subgoal_tac "(\<forall>s::'a. s \<rightarrow>\<^sub>i s' \<longrightarrow> E s \<rightarrow>\<^sub>i E s') \<longrightarrow> s \<rightarrow>\<^sub>i* s' \<longrightarrow> E s \<rightarrow>\<^sub>i* E s'")
   apply simp
  apply (simp add: state_transition_refl_def)
  apply (erule_tac rtrancl_induct)
   apply simp
  apply (drule_tac x = y in spec)
  apply (drule_tac x = z in spec)
  apply (drule mp, simp)
  apply (erule rtrancl_into_rtrancl)
  apply (rule CollectI)
  by simp

theorem strong_mt'[rule_format]:
"init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and> E ` (init K') \<subseteq> (init K) \<and>
     (\<forall> s s'. (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i s' \<longrightarrow> (E s) \<rightarrow>\<^sub>i (E s')) \<Longrightarrow>
                                K \<sqsubseteq>\<^sub>E K'"
  apply (unfold refinement_def)
  apply simp
  apply (erule conjE)+
  apply (rule ballI)+
  apply (rule impI)
  apply (rule conjI)
   apply (erule subsetD)
   apply (erule imageI)
  apply (subgoal_tac "(\<forall>s::'a. (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i s' \<longrightarrow> E s \<rightarrow>\<^sub>i E s') \<longrightarrow>
                                  (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i* s' \<longrightarrow> E s \<rightarrow>\<^sub>i* E s'")
   apply simp
   apply (erule mp)
   apply (rule_tac x = s in bexI)
    apply (simp add: state_transition_refl_def, assumption)
     apply (simp add: state_transition_refl_def)
  apply (erule_tac rtrancl_induct)
   apply simp
  apply (rule impI)
  apply (drule mp)
  apply assumption
   apply (drule_tac x = y in spec)
(* *)
  apply (rotate_tac -1)
   apply (drule mp)
    apply (rule_tac x = s in bexI)
  apply assumption+
  apply (erule rtrancl_into_rtrancl)
   apply (rule CollectI)
by simp

end


theory Sorting_Strings
imports "HOL-Library.List_Lexorder" Sorting_Setup
begin

  text \<open>The string comparison algorithm from libstdc++, abstractly: Compare min-length first, then compare lengths to break tie\<close>
  lemma list_lexorder_alt: "xs < ys \<longleftrightarrow> (let n=min (length xs) (length ys) in (take n xs < take n ys) \<or> (take n xs = take n ys \<and> length xs < length ys))"
  proof (cases "length xs < length ys")
    case True
    then show ?thesis
      apply (simp add: Let_def)
    proof (induction xs arbitrary: ys)
      case Nil
      then show ?case by (cases ys) auto
    next
      case (Cons a xs)
      then show ?case by (cases ys) auto
    qed
  next
    case False
    then show ?thesis
      apply (simp add: Let_def)
    proof (induction xs arbitrary: ys)
      case Nil
      then show ?case by (cases ys) auto
    next
      case (Cons a xs)
      then show ?case by (cases ys) auto
    qed
  qed

  definition cmpi :: "'a::preorder \<Rightarrow> 'a \<Rightarrow> int" where "cmpi x y \<equiv> if x = y then 0 else if x < y then -1 else (1::int)"

  lemma cmpi_simps[simp]:
    "cmpi x y = 0 \<longleftrightarrow> x=y"
    "cmpi x y = -1 \<longleftrightarrow> x<y"
    "cmpi x y = 1 \<longleftrightarrow> x\<noteq>y \<and> (\<not>x<y)"
    "0 = cmpi x y \<longleftrightarrow> x=y"
    "-1 = cmpi x y \<longleftrightarrow> x<y"
    "1 = cmpi x y \<longleftrightarrow> x\<noteq>y \<and> (\<not>x<y)"
    "x=y \<Longrightarrow> cmpi x y = 0"
    "x<y \<Longrightarrow> cmpi x y = -1"
    unfolding cmpi_def by auto

  definition "compare_spec xs ys n \<equiv> doN {ASSERT (n\<le>length xs \<and> n\<le>length ys); RETURN (cmpi (take n xs) (take n ys))}"

  definition "compare1 xs ys n \<equiv> doN {
    ASSERT (n\<le>length xs \<and> n\<le>length ys);
    (i,r)\<leftarrow>WHILEIT (\<lambda>(i,r). i\<le>n \<and> r=cmpi (take i xs) (take i ys) ) (\<lambda>(i,r). i<n \<and> r=0) (\<lambda>(i,r). doN {
      x \<leftarrow> mop_list_get xs i;
      y \<leftarrow> mop_list_get ys i;
      ASSERT (i<n);
      if x=y then RETURN (i+1,0)
      else if x<y then RETURN (i+1,-1)
      else RETURN (i+1,1)
    }) (0,0);
    RETURN r
  }"

  (* TODO: Move *)
  lemma irreflD: "irrefl R \<Longrightarrow> (x,x)\<notin>R" by (auto simp: irrefl_def)

  (* TODO: Move *)
  lemma lexord_append: "length u = length w \<Longrightarrow> (u@v,w@x)\<in>lexord R \<longleftrightarrow> (u,w)\<in>lexord R \<or> (u=w \<and> (v,x)\<in>lexord R)"
    by (induction u w rule: list_induct2) auto

  lemma lexord_irreflD: "irrefl R \<Longrightarrow> \<not>(u,u)\<in>lexord R"
    by (simp add: irreflD lexord_irrefl)

  lemma lexord_irrefl_common_prefix: "irrefl R \<Longrightarrow> (u@v,u@w)\<in>lexord R \<longleftrightarrow> (v,w)\<in>lexord R"
    by (auto simp: lexord_append lexord_irreflD)

  context begin
    private lemma take_smaller: "m\<le>n \<Longrightarrow> take n xs = take m xs @ (take (n-m) (drop m xs))"
      by (metis le_add_diff_inverse take_add)

    private lemma compare_impl_aux1:  "\<lbrakk>aa\<le>n; aa \<le> length xs; aa\<le>length ys; take aa xs \<noteq> take aa ys\<rbrakk> \<Longrightarrow> cmpi (take n xs) (take n ys) = cmpi (take aa xs) (take aa ys)"
      by (auto simp: take_smaller cmpi_def list_less_def lexord_append)

    private lemma preorder_less_irrefl: "irrefl {(x, y::_::preorder). x < y}" by (auto simp: irrefl_def)

    lemma compare1_refine: "(compare1, compare_spec) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro fun_relI, clarsimp)
      subgoal for xs ys n
        unfolding compare1_def compare_spec_def
        apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(i,_). n-i)"])
        by (auto simp: take_Suc_conv_app_nth list_less_def lexord_append compare_impl_aux1 lexord_irreflD[OF preorder_less_irrefl])
      done

  end

  abbreviation "string_assn' TYPE('size_t::len2) TYPE('w::len) \<equiv> al_assn' TYPE('size_t::len2) (unat_assn' TYPE('w::len))"

  sepref_definition compare_impl [llvm_inline, llvm_code] is "uncurry2 compare1" ::
    "(string_assn' TYPE('size_t::len2) TYPE('w::len))\<^sup>k *\<^sub>a (string_assn' TYPE('size_t) TYPE('w))\<^sup>k *\<^sub>a (snat_assn' TYPE('size_t))\<^sup>k \<rightarrow>\<^sub>a sint_assn' TYPE('r::len2)"
    unfolding compare1_def
    apply (annot_snat_const "TYPE('size_t)")
    apply (annot_sint_const "TYPE('r)")
    by sepref

  lemmas compare_hnr[sepref_fr_rules] = compare_impl.refine[FCOMP compare1_refine]

  definition "strcmp xs ys \<equiv> doN {
    let n = min (length xs) (length ys);
    i \<leftarrow> compare_spec xs ys n;
    if i=-1 then RETURN True
    else if i=0 then RETURN (length xs < length ys)
    else RETURN False
  }"

  lemma strcmp_correct: "strcmp xs ys \<le> RETURN (xs<ys)"
    unfolding strcmp_def compare_spec_def
    apply (rewrite in "_ \<le> \<hole>" list_lexorder_alt)
    apply refine_vcg
    by (simp_all)

  lemma strcmp_refines_aux: "(strcmp,RETURN oo (<)) \<in> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
    using strcmp_correct by (force intro!: nres_relI)

  sepref_def strcmp_impl is "uncurry strcmp" :: "(string_assn' TYPE('size_t::len2) TYPE('w::len))\<^sup>k *\<^sub>a (string_assn' TYPE('size_t) TYPE('w))\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding strcmp_def min_def
    apply (annot_sint_const "TYPE(2)")
    by sepref

  export_llvm "strcmp_impl :: 64 word \<times> 64 word \<times> 8 word ptr \<Rightarrow> 64 word \<times> 64 word \<times> 8 word ptr \<Rightarrow> 1 word llM"

  lemma strcmp_refines_relp: "GEN_ALGO strcmp_impl (refines_relp (al_assn unat_assn) (<))"
    apply rule
    using strcmp_impl.refine[FCOMP strcmp_refines_aux] .

  lemma strcmp_sort_impl_context: "sort_impl_context (\<le>) (<) strcmp_impl (string_assn' TYPE('size_t::len2) TYPE('w::len))"
    apply unfold_locales
    apply (auto simp: strcmp_refines_relp)
    done

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype 'a Maybe = Nothing | Just "'a"

datatype 'a Seq = Nil | Cons "'a" "(('a, ('a Maybe)) pair) Seq"

fun y :: "('a => 'b) => 'a Maybe => 'b Maybe" where
"y z (Nothing) = Nothing"
| "y z (Just z2) = Just (z z2)"

fun x :: "('a => 'b Maybe) => 'a Maybe => 'b Maybe" where
"x z (Nothing) = Nothing"
| "x z (Just z2) = z z2"

fun pair3 :: "'a list => (('a, ('a Maybe)) pair) list" where
"pair3 (nil2) = nil2"
| "pair3 (cons2 y2 (nil2)) = cons2 (pair2 y2 (Nothing)) (nil2)"
| "pair3 (cons2 y2 (cons2 y22 xs)) =
     cons2 (pair2 y2 (Just y22)) (pair3 xs)"

fun lookup :: "int => 'a list => 'a Maybe" where
"lookup z (nil2) = Nothing"
| "lookup z (cons2 z2 x2) =
     (if (z = 0) then Just z2 else lookup (z - 1) x2)"

fun index :: "int => 'a Seq => 'a Maybe" where
"index z (Nil) = Nothing"
| "index z (Cons z2 x2) =
     (if (z = 0) then Just z2 else
        (if ((mod z 2) = 0) then
           (case index ((op div) (z - 1) 2) x2 of
              Nothing => Nothing
              | Just x5 => (case x5 of pair2 x6 y3 => y3))
           else
           (case index ((op div) (z - 1) 2) x2 of
              Nothing => Nothing
              | Just x3 => (case x3 of pair2 x4 y22 => Just x4))))"

fun fromList :: "'a list => 'a Seq" where
"fromList (nil2) = Nil"
| "fromList (cons2 y2 xs) = Cons y2 (fromList (pair3 xs))"

theorem property0 :
  "((n >= 0) ==> ((lookup n xs) = (index n (fromList xs))))"
  oops

end


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Examples.thy
    Author:     Stefan Berghofer, Lukas Bulwahn
    Copyright   2004 - 2010 TU Muenchen
*)

section {* Examples for the 'quickcheck' command *}

theory Quickcheck_Examples
imports Complex_Main "~~/src/HOL/Library/Dlist" "~~/src/HOL/Library/DAList_Multiset"
begin

text {*
The 'quickcheck' command allows to find counterexamples by evaluating
formulae.
Currently, there are two different exploration schemes:
- random testing: this is incomplete, but explores the search space faster.
- exhaustive testing: this is complete, but increasing the depth leads to
  exponentially many assignments.

quickcheck can handle quantifiers on finite universes.

*}

declare [[quickcheck_timeout = 3600]]

subsection {* Lists *}

theorem "map g (map f xs) = map (g o f) xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, size = 3, expect = no_counterexample]
  oops

theorem "map g (map f xs) = map (f o g) xs"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

theorem "rev (xs @ ys) = rev ys @ rev xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  quickcheck[exhaustive, size = 1000, timeout = 0.1]
  oops

theorem "rev (xs @ ys) = rev xs @ rev ys"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

theorem "rev (rev xs) = xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  oops

theorem "rev xs = xs"
  quickcheck[tester = random, finite_types = true, report = false, expect = counterexample]
  quickcheck[tester = random, finite_types = false, report = false, expect = counterexample]
  quickcheck[tester = random, finite_types = true, report = true, expect = counterexample]
  quickcheck[tester = random, finite_types = false, report = true, expect = counterexample]
  quickcheck[tester = exhaustive, finite_types = true, expect = counterexample]
  quickcheck[tester = exhaustive, finite_types = false, expect = counterexample]
oops

text {* An example involving functions inside other data structures *}

primrec app :: "('a \<Rightarrow> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "app [] x = x"
  | "app (f # fs) x = app fs (f x)"

lemma "app (fs @ gs) x = app gs (app fs x)"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, size = 2, expect = no_counterexample]
  by (induct fs arbitrary: x) simp_all

lemma "app (fs @ gs) x = app fs (app gs x)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

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

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

text {* A lemma, you'd think to be true from our experience with delAll *}
lemma "Suc (occurs a (del1 a xs)) = occurs a xs"
  -- {* Wrong. Precondition needed.*}
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

lemma "xs ~= [] \<longrightarrow> Suc (occurs a (del1 a xs)) = occurs a xs"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    -- {* Also wrong.*}
  oops

lemma "0 < occurs a xs \<longrightarrow> Suc (occurs a (del1 a xs)) = occurs a xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  by (induct xs) auto

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

lemma "occurs a xs = occurs b (replace a b xs)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  -- {* Wrong. Precondition needed.*}
  oops

lemma "occurs b xs = 0 \<or> a=b \<longrightarrow> occurs a xs = occurs b (replace a b xs)"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  by (induct xs) simp_all

subsection {* Trees *}

datatype 'a tree = Twig |  Leaf 'a | Branch "'a tree" "'a tree"

primrec leaves :: "'a tree \<Rightarrow> 'a list" where
  "leaves Twig = []"
  | "leaves (Leaf a) = [a]"
  | "leaves (Branch l r) = (leaves l) @ (leaves r)"

primrec plant :: "'a list \<Rightarrow> 'a tree" where
  "plant [] = Twig "
  | "plant (x#xs) = Branch (Leaf x) (plant xs)"

primrec mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror (Twig) = Twig "
  | "mirror (Leaf a) = Leaf a "
  | "mirror (Branch l r) = Branch (mirror r) (mirror l)"

theorem "plant (rev (leaves xt)) = mirror xt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    --{* Wrong! *}
  oops

theorem "plant((leaves xt) @ (leaves yt)) = Branch xt yt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    --{* Wrong! *}
  oops

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

primrec inOrder :: "'a ntree \<Rightarrow> 'a list" where
  "inOrder (Tip a)= [a]"
  | "inOrder (Node f x y) = (inOrder x)@[f]@(inOrder y)"

primrec root :: "'a ntree \<Rightarrow> 'a" where
  "root (Tip a) = a"
  | "root (Node f x y) = f"

theorem "hd (inOrder xt) = root xt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  --{* Wrong! *}
  oops

subsection {* Exhaustive Testing beats Random Testing *}

text {* Here are some examples from mutants from the List theory
where exhaustive testing beats random testing *}

lemma
  "[] ~= xs ==> hd xs = last (x # xs)"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  assumes "!!i. [| i < n; i < length xs |] ==> P (xs ! i)" "n < length xs ==> ~ P (xs ! n)"
  shows "drop n xs = takeWhile P xs"
quickcheck[random, iterations = 10000, quiet]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < length (List.transpose (List.transpose xs)) ==> xs ! i = map (%xs. xs ! i) [ys<-xs. i < length ys]"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < n - m ==> f (lcm m i) = map f [m..<n] ! i"
quickcheck[random, iterations = 10000, finite_types = false]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "i < n - m ==> f (lcm m i) = map f [m..<n] ! i"
quickcheck[random, iterations = 10000, finite_types = false]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "ns ! k < length ns ==> k <= listsum ns"
quickcheck[random, iterations = 10000, finite_types = false, quiet]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "[| ys = x # xs1; zs = xs1 @ xs |] ==> ys @ zs = x # xs"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
"i < length xs ==> take (Suc i) xs = [] @ xs ! i # take i xs"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < length xs ==> take (Suc i) xs = (xs ! i # xs) @ take i []"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| sorted (rev (map length xs)); i < length xs |] ==> xs ! i = map (%ys. ys ! i) [ys<-remdups xs. i < length ys]"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| sorted (rev (map length xs)); i < length xs |] ==> xs ! i = map (%ys. ys ! i) [ys<-List.transpose xs. length ys \<in> {..<i}]"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "(ys = zs) = (xs @ ys = splice xs zs)"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Random Testing beats Exhaustive Testing *}

lemma mult_inj_if_coprime_nat:
  "inj_on f A \<Longrightarrow> inj_on g B
   \<Longrightarrow> inj_on (%(a,b). f a * g b::nat) (A \<times> B)"
quickcheck[exhaustive]
quickcheck[random]
oops

subsection {* Examples with quantifiers *}

text {*
  These examples show that we can handle quantifiers.
*}

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
  quickcheck[random, expect = counterexample]
  quickcheck[expect = counterexample]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (EX! x. P x)"
  quickcheck[random, expect = counterexample]
  quickcheck[expect = counterexample]
oops

subsection {* Examples with sets *}

lemma
  "{} = A Un - A"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| bij_betw f A B; bij_betw f C D |] ==> bij_betw f (A Un C) (B Un D)"
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Examples with relations *}

lemma
  "acyclic (R :: ('a * 'a) set) ==> acyclic S ==> acyclic (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "acyclic (R :: (nat * nat) set) ==> acyclic S ==> acyclic (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

(* FIXME: some dramatic performance decrease after changing the code equation of the ntrancl *)
lemma
  "(x, z) : rtrancl (R Un S) ==> \<exists> y. (x, y) : rtrancl R & (y, z) : rtrancl S"
(*quickcheck[exhaustive, expect = counterexample]*)
oops

lemma
  "wf (R :: ('a * 'a) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "wf (R :: (nat * nat) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "wf (R :: (int * int) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Examples with the descriptive operator *}

lemma
  "(THE x. x = a) = b"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Examples with Multisets *}

lemma
  "X + Y = Y + (Z :: 'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "X - Y = Y - (Z :: 'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "N + M - N = (N::'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Examples with numerical types *}

text {*
Quickcheck supports the common types nat, int, rat and real.
*}

lemma
  "(x :: nat) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma
  "(x :: int) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma
  "(x :: rat) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma "(x :: rat) >= 0"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "(x :: real) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma "(x :: real) >= 0"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsubsection {* floor and ceiling functions *}

lemma
  "floor x + floor y = floor (x + y :: rat)"
quickcheck[expect = counterexample]
oops

lemma
  "floor x + floor y = floor (x + y :: real)"
quickcheck[expect = counterexample]
oops

lemma
  "ceiling x + ceiling y = ceiling (x + y :: rat)"
quickcheck[expect = counterexample]
oops

lemma
  "ceiling x + ceiling y = ceiling (x + y :: real)"
quickcheck[expect = counterexample]
oops

subsection {* Examples with abstract types *}

lemma
  "Dlist.length (Dlist.remove x xs) = Dlist.length xs - 1"
quickcheck[exhaustive]
quickcheck[random]
oops

lemma
  "Dlist.length (Dlist.insert x xs) = Dlist.length xs + 1"
quickcheck[exhaustive]
quickcheck[random]
oops

subsection {* Examples with Records *}

record point =
  xpos :: nat
  ypos :: nat

lemma
  "xpos r = xpos r' ==> r = r'"
quickcheck[exhaustive, expect = counterexample]
quickcheck[random, expect = counterexample]
oops

datatype colour = Red | Green | Blue

record cpoint = point +
  colour :: colour

lemma
  "xpos r = xpos r' ==> ypos r = ypos r' ==> (r :: cpoint) = r'"
quickcheck[exhaustive, expect = counterexample]
quickcheck[random, expect = counterexample]
oops

subsection {* Examples with locales *}

locale Truth

context Truth
begin

lemma "False"
quickcheck[exhaustive, expect = counterexample]
oops

end

interpretation Truth .

context Truth
begin

lemma "False"
quickcheck[exhaustive, expect = counterexample]
oops

end

locale antisym =
  fixes R
  assumes "R x y --> R y x --> x = y"

interpretation equal : antisym "op =" by default simp
interpretation order_nat : antisym "op <= :: nat => _ => _" by default simp

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, finite_type_size = 2, expect = no_counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

declare [[quickcheck_locale = "interpret"]]

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, expect = no_counterexample]
oops

declare [[quickcheck_locale = "expand"]]

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, finite_type_size = 2, expect = no_counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Examples with HOL quantifiers *}

lemma
  "\<forall> xs ys. xs = [] --> xs = ys"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "ys = [] --> (\<forall>xs. xs = [] --> xs = y # ys)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "\<forall>xs. (\<exists> ys. ys = []) --> xs = ys"
quickcheck[exhaustive, expect = counterexample]
oops

subsection {* Examples with underspecified/partial functions *}

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

text {* with the simple testing scheme *}

setup Exhaustive_Generators.setup_exhaustive_datatype_interpretation
declare [[quickcheck_full_support = false]]

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[exhaustive, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[exhaustive, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[exhaustive, expect = no_counterexample]
oops

declare [[quickcheck_full_support = true]]

subsection {* Equality Optimisation *}

lemma
  "f x = y ==> y = (0 :: nat)"
quickcheck
oops

lemma
  "y = f x ==> y = (0 :: nat)"
quickcheck
oops

lemma
  "f y = zz # zzs ==> zz = (0 :: nat) \<and> zzs = []"
quickcheck
oops

lemma
  "f y = x # x' # xs ==> x = (0 :: nat) \<and> x' = 0 \<and> xs = []"
quickcheck
oops

lemma
  "x = f x \<Longrightarrow> x = (0 :: nat)"
quickcheck
oops

lemma
  "f y = x # x # xs ==> x = (0 :: nat) \<and> xs = []"
quickcheck
oops

lemma
  "m1 k = Some v \<Longrightarrow> (m1 ++ m2) k = Some v"
quickcheck
oops

end


theory P08
  imports Main
begin

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

lemma "length (p08 ls) \<le> length ls"
  using [[simp_trace_new mode=full]]
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume a:"length (p08 ls) \<le> length ls"
  show ?case
  proof (cases ls)
    case Nil
    assume "ls = []"
    then show ?thesis by simp
  next
    case (Cons aa list)
    assume b:"ls = aa # list"
    with a show ?thesis by simp
  qed
qed

lemma "x \<in> \<nat> \<Longrightarrow> x < length ls - 1 \<Longrightarrow>  ls ! x = ls ! (x+1) \<Longrightarrow> length ls \<ge> 2 \<Longrightarrow> length (p08 ls) < length ls"
proof (cases ls rule : p08.cases)
  case 1
  then show ?thesis
next
  case (2 x)
  then show ?thesis sorry
next
  case (3 x y xs)
  then show ?thesis sorry
qed

lemma "x \<in> \<nat> \<Longrightarrow> x < length ls - 1 \<Longrightarrow>  ls ! x = ls ! (x+1) \<Longrightarrow> length ls \<ge> 2 \<Longrightarrow> length (p08 ls) < length ls"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume a:"x \<in> \<nat> \<Longrightarrow> x < length ls - 1 \<Longrightarrow> ls ! x = ls ! (x + 1) \<Longrightarrow> 2 \<le> length ls \<Longrightarrow> length (p08 ls) < length ls"
  assume b:"x \<in> \<nat>"
  assume c:"x < length (a # ls) - 1"
  assume d:"(a # ls) ! x = (a # ls) ! (x + 1)"
  assume e:"2 \<le> length (a # ls)"
  show ?case
  proof (cases ls)
    case Nil
    with e show ?thesis by simp
  next
    case (Cons aa list)
    assume f:"ls = aa # list"
    show ?thesis
    proof (cases "aa = a")
      case True
      with f show ?thesis
    next
      case False
      then show ?thesis sorry
    qed
  qed
qed

    lemma "\<not>(\<exists>x. )"


theory Real_Alg_Imp imports
  Complex_Main
  "../Sturm_Tarski/Pseudo_Remainder_Sequence"
  "Polynomial_Interpolation.Ring_Hom_Poly"
  "../Budan_Fourier/Descartes_Roots_Test"
  Float_Misc
begin

section \<open>Cauchy sequences for the reals\<close>

abbreviation "Real \<equiv> Real.Real"
abbreviation "cauchy \<equiv> Real.cauchy"
abbreviation "vanishes \<equiv> Real.vanishes"

fun to_cauchy:: "rat poly \<times> rat \<times> rat \<Rightarrow> nat \<Rightarrow> rat" where
  "to_cauchy (_, lb, ub) 0 = (lb+ub)/2"|
  "to_cauchy (p, lb, ub) (Suc n) = (
    let c=(lb+ub)/2
    in if  poly p lb * poly p c \<le>0 then to_cauchy (p, lb, c) n
                                    else to_cauchy (p, c, ub) n)"

lemma to_cauchy_bound_aux:
  fixes p::"rat poly"
  assumes "lb<ub"
  defines "X\<equiv>to_cauchy (p,lb,ub)"
  shows "lb< X n \<and> X n<ub" using assms(1) unfolding X_def
proof (induct n arbitrary:lb ub)
  case 0
  thus ?case by auto
next
  case (Suc n)
  define c where "c\<equiv>(lb+ub)/2"
  have "c>lb" and "c<ub" using `lb<ub` unfolding c_def by auto thm Suc.hyps[OF `c>lb`]
  hence "lb<to_cauchy (p, lb, c) n" and "to_cauchy (p, lb, c) n<ub"
      and "lb < to_cauchy (p, c, ub) n" and "to_cauchy (p, c, ub) n<ub"
    using Suc.hyps[OF `c>lb`] Suc.hyps[OF `c<ub`] by auto
  thus ?case
    by (cases "poly p lb * poly p c \<le>0",auto simp add:c_def)
qed

lemma to_cauchy_converge:
  fixes p::"rat poly"
  assumes "lb<ub"
  defines "X\<equiv>to_cauchy (p,lb,ub)"
  shows "\<bar> X (i+1) - X i\<bar> < (ub - lb) / 2^(i+1)" unfolding X_def using `lb<ub`
proof (induct i arbitrary:lb ub)
  case 0
  thus ?case by (auto simp add:Let_def field_simps)
next
  case (Suc n)
  define r where "r\<equiv>(lb+ub)/2"
  hence "r>lb" and "r<ub" using `lb<ub` by auto
  show ?case (is "?L<?R")
  proof (cases "poly p lb * poly p r \<le>0")
    case True
    hence "?L=\<bar>to_cauchy (p, lb, r) (n + 1) - to_cauchy (p, lb, r) n\<bar>"
      by (simp add:Let_def r_def)
    also have "...< (r - lb) / 2 ^ (n + 1)"
      using Suc.hyps[OF `lb<r`] .
    also have "... =  ?R"
      unfolding r_def by (auto simp add:field_simps)
    finally show ?thesis .
  next
    case False
    hence "?L=\<bar>to_cauchy (p, r, ub) (n + 1) - to_cauchy (p, r, ub) n\<bar>"
      by (simp add:Let_def r_def)
    also have "...< (ub - r) / 2 ^ (n + 1)"
      using Suc.hyps[OF `r<ub`] .
    also have "... =  ?R"
      unfolding r_def by (auto simp add:field_simps)
    finally show ?thesis .
  qed
qed

lemma power_Archimedean:
  fixes x::"rat"
  assumes "x>0" "a>1"
  shows "\<forall>y. \<exists>n. y < a^n * x"
proof (rule,case_tac "y>0")
  fix y::rat  assume "\<not> 0 < y"
  thus " \<exists>n. y < a ^ n * x" using assms
    apply (rule_tac x=0 in exI)
    by auto
next
  fix y::rat assume "y>0"
  obtain n::nat where "n> log (of_rat a) (of_rat (y/x))"
    using reals_Archimedean2 by blast
  hence  "(of_rat a) powr n > (of_rat a) powr (log (of_rat a) (of_rat (y/x)))"
    by (intro powr_less_mono,auto simp add:`a>1`)
  hence "a ^ n > y/x"  using `y>0` `x>0` `a>1`
    apply (subst (asm) powr_realpow,simp)
    apply (subst (asm) powr_log_cancel,auto)
    apply (subst (asm) of_rat_power[symmetric])
    by (simp add:of_rat_less)
  thus "\<exists>n. y < a ^ n * x" by (auto simp add:field_simps `x>0`)
qed

lemma to_cauchy_cauchy:
  fixes p::"rat poly"
  assumes "lb<ub"
  defines "X\<equiv>to_cauchy (p,lb,ub)"
  shows "cauchy X"
proof (rule Real.cauchyI)
  fix r::rat assume "r>0"
  define d where "d\<equiv>ub-lb"
  hence "d>0" using `lb<ub` by simp
  obtain k::nat where k:"2*d/2^k<r"
    using power_Archimedean[OF `r>0`,of 2,simplified] by (auto simp add:field_simps)
  { fix m n::nat assume "m>n"
    hence "\<bar>X m - X n\<bar> < (d/2^n - d/2^m)"
    proof (induct "m - n" arbitrary:m n)
      case 0
      thus ?case by simp
    next
      case (Suc diff) print_cases
      have "\<bar>X m - X n\<bar> \<le> \<bar>X m - X (m - 1)\<bar> + \<bar>X (m - 1) - X n\<bar>" by auto
      also have "... \<le> \<bar>X m - X (m - 1)\<bar> + (d / 2 ^ n - d / 2 ^ (m - 1))"
        using Suc.hyps(1)[of "m - 1" n] Suc(2,3) by (cases "n=m - 1",simp,force)
      also have "... <  d / 2 ^ m + (d / 2 ^ n - d / 2 ^ (m - 1))"
        using to_cauchy_converge[OF `lb<ub`,of p "m - 1", folded X_def d_def] `m>n` by auto
      also have "... = (d / 2 ^ n - d / 2 ^ m)"
        by (auto simp add:field_simps, metis Suc.prems Suc_pred not_gr0 not_less0 power_Suc)
      finally show ?case .
    qed }
  note diff=this
  have "\<forall>m\<ge>k. \<forall>n\<ge>k. \<bar>X m - X n\<bar> < r"
  proof (rule+)
    fix m n assume "k \<le> m" "k \<le> n"
    have "\<bar>X m - X n\<bar> \<le> \<bar>d / 2 ^ n - d / 2 ^ m\<bar>"
      by (cases rule:linorder_cases[of m n], (drule diff|auto)+)
    also have "... \<le> \<bar>d / 2 ^ n\<bar> + \<bar>d / 2 ^ m\<bar>" by linarith
    also have "... = (d / 2 ^ n + d / 2 ^ m)"
      using \<open>d>0\<close> by fastforce
    also have "... \<le> 2 *d / 2^k"
    proof -
      have "d / 2 ^ n \<le> d / 2 ^ k" and "d / 2 ^ m \<le> d / 2 ^ k"
        using `k\<le>n` `k\<le>m` order.strict_implies_order[OF `d>0`]
         by (intro divide_left_mono,auto)+
      thus ?thesis by auto
    qed
    also have "...<r" using k .
    finally show "\<bar>X m - X n\<bar> < r" .
  qed
  thus "\<exists>k. \<forall>m\<ge>k. \<forall>n\<ge>k. \<bar>X m - X n\<bar> < r" by auto
qed

lemma to_cauchy_bound:
  fixes p::"rat poly" and lb ub ::rat
  defines "X\<equiv>to_cauchy (p,lb,ub)"
  assumes "lb<ub"
  shows "of_rat lb\<le> Real X" "Real X\<le>of_rat ub"
using le_RealI Real_leI  to_cauchy_cauchy[OF `lb<ub`,of p, folded X_def]
  to_cauchy_bound_aux[OF `lb<ub`,of p,folded X_def]
by (metis less_eq_rat_def of_rat_less_eq)+

lemma "Real.vanishes X \<Longrightarrow> Real.cauchy X \<Longrightarrow> Real.Real X = 0"
by (metis (poly_guards_query) cauchy_diff diff_Real diff_self eq_Real vanishes_diff)

lemma cauchy_imp_poly_cauchy:
  assumes "Real.cauchy X"
  shows "Real.cauchy (\<lambda>i. poly p (X i))"
by (induct p,auto intro!: Real.cauchy_add Real.cauchy_mult simp add: assms)

lemma real_poly_eq_poly_real:
  fixes p::"rat poly"
  assumes "Real.cauchy X"
  shows "Real.Real (\<lambda>i. poly (map_poly of_rat p) (X i))
              = poly (map_poly of_rat p) (Real.Real X)"
proof (induct p)
  case 0
  thus ?case by (simp add:zero_real_def)
next
  case (pCons a p)
  let ?mp = "map_poly of_rat"
  have "Real (\<lambda>i. poly (?mp (pCons a p)) (X i)) = Real (\<lambda>i. a + X i * poly p (X i))"
    by simp
  also have "... = Real (\<lambda>i. a) + Real (\<lambda>i. X i * poly p (X i))"
    apply (subst Real.add_Real[symmetric])
    by (auto simp add: assms cauchy_imp_poly_cauchy)
  also have "... = Real (\<lambda>i. a) + Real X * Real (\<lambda>i. poly p (X i)) "
    apply (subst Real.mult_Real[symmetric])
    using assms by (auto simp add: cauchy_imp_poly_cauchy)
  also have "... = Real (\<lambda>i. a) + Real X * poly (?mp p) (Real X)"
    using pCons by simp
  also have "... = poly (map_poly real_of_rat (pCons a p)) (Real X)"
    unfolding of_rat_hom.map_poly_pCons_hom
    by (simp add: of_rat_Real)
  finally show ?case .
qed

lemma vanishes_imp_cauchy:
  assumes "Real.vanishes X"
  shows "Real.cauchy X" unfolding Real.cauchy_def
proof (rule,rule)
  fix r::rat assume "0 < r"
  then obtain k where k:"\<forall>n\<ge>k. \<bar>X n\<bar> < r / 2"
    using assms[unfolded Real.vanishes_def,THEN spec,of "r/2"] by auto
  { fix m n assume "m\<ge>k" "n\<ge>k"
    have "\<bar>X m - X n\<bar> \<le> \<bar>X m\<bar> + \<bar>X n\<bar>" by simp
    also have "... <r/2 + r/2" using k `m\<ge>k` `n\<ge>k`
      by (metis add_mono_thms_linordered_field(5))
    also have "... = r" by simp
    finally have "\<bar>X m - X n\<bar> < r" . }
  thus "\<exists>k. \<forall>m\<ge>k. \<forall>n\<ge>k. \<bar>X m - X n\<bar> < r" by auto
qed

lemma power2_valishes:
  assumes "r>0"
  shows "vanishes (\<lambda>i. r/2^i)"
proof (rule vanishesI)
  fix \<epsilon>::rat assume "\<epsilon>>0"
  obtain k::nat where k:"r/2^k<\<epsilon>"
    using power_Archimedean[THEN spec,of \<epsilon> 2 "r",OF `\<epsilon>>0`] by (auto simp add:field_simps)
  { fix n assume "n\<ge>k"
    hence "r/2^n \<le> r/2^k" using `r>0` by (auto simp add:field_simps)
    hence "r/2^n < \<epsilon>" using k by auto }
  thus " \<exists>k. \<forall>n\<ge>k. \<bar>r / 2 ^ n\<bar> < \<epsilon>" using `r>0` by auto
qed

lemmas power2_cauchy = power2_valishes[THEN vanishes_imp_cauchy]

lemma to_cauchy_root:
  fixes p::"rat poly"
  assumes "lb<ub" "poly p lb * poly p ub \<le> 0"
  defines "X\<equiv>to_cauchy (p,lb,ub)"
  shows "poly (map_poly of_rat p) (Real X) = 0" using assms(2)
proof -
  define r where "r\<equiv>(ub-lb)/2"
  hence "r>0" and cauchy_X:"Real.cauchy X"
    unfolding X_def  using to_cauchy_cauchy `lb<ub` by auto
  { fix i
    have "poly p (X i+r/2^i) * poly p (X i - r/2^i) \<le>0"
        unfolding r_def X_def using assms(2)
      proof (induct i arbitrary:lb ub)
        case 0
        thus ?case unfolding X_def r_def by (simp add:field_simps)
      next
        case (Suc n)
        have "poly p lb * poly p ((lb+ub)/2) \<le> 0 \<Longrightarrow> ?case"
          by (frule Suc.hyps,auto simp add:Let_def field_simps)
        moreover have "\<not> poly p lb * poly p ((lb+ub)/2) \<le> 0 \<Longrightarrow> poly p ((lb+ub)/2) * poly p ub \<le> 0"
          using Suc.prems unfolding not_le
          apply (unfold mult_le_0_iff zero_less_mult_iff)
          by auto
        hence "\<not> poly p lb * poly p ((lb+ub)/2) \<le> 0 \<Longrightarrow> ?case"
            by (frule Suc.hyps,auto simp add:Let_def field_simps)
        ultimately show ?case by blast
      qed }
  hence "Real (\<lambda>i. poly p (X i+r/2^i) * poly p (X i - r/2^i)) \<le>0"
    using power2_cauchy[OF `r>0`] cauchy_X
    by (auto intro!: Real_leI cauchy_mult cauchy_imp_poly_cauchy cauchy_add to_cauchy_cauchy )
  hence "poly (map_poly of_rat p) (Real (\<lambda>i. X i+r/2^i))
          * poly (map_poly of_rat p) (Real (\<lambda>i. X i - r/2^i)) \<le>0"
    using power2_cauchy[OF `r>0`] cauchy_X
    apply (subst (asm) Real.mult_Real[symmetric])
    subgoal by (simp add: cauchy_imp_poly_cauchy)
    subgoal by (simp add: cauchy_imp_poly_cauchy)
    subgoal using real_poly_eq_poly_real by auto
    done
  moreover have "Real (\<lambda>i. X i+r/2^i) = Real X" and "Real (\<lambda>i. X i-r/2^i) = Real X"
    using cauchy_X power2_valishes power2_cauchy `r>0`
    by (subst Real.eq_Real,auto intro:vanishes_minus)+
  ultimately have "poly (map_poly of_rat p) (Real X)
                        * poly (map_poly of_rat p) (Real X) \<le>0"
    by auto
  thus ?thesis by (metis linorder_neqE_linordered_idom mult_le_0_iff not_less)
qed

lemma to_cauchy_bound':
  fixes p::"rat poly" and lb ub ::rat
  defines "X\<equiv>to_cauchy (p,lb,ub)"
  assumes "lb<ub" and sgn_diff:"poly p lb * poly p ub<0"
  shows "of_rat lb< Real X" "Real X < of_rat ub"
proof -
  define x where"x=Real X"
  have "poly (map_poly of_rat p) x=0" using to_cauchy_root[OF `lb<ub`, of p] sgn_diff
    apply (fold X_def x_def)
    by auto
  hence "x\<noteq>of_rat lb" "x\<noteq>of_rat ub" using sgn_diff by auto
  moreover have "of_rat lb\<le>x" and "x\<le>of_rat ub"
    using to_cauchy_bound[OF `lb<ub`] unfolding x_def X_def by auto
  ultimately show "of_rat lb< Real X" "Real X < of_rat ub" unfolding x_def by auto
qed

section \<open>Validity checks for representations of real algebraic numbers\<close>

(*
definition one_root_btw::"int poly \<Rightarrow> float \<Rightarrow> float \<Rightarrow> bool" where
  "one_root_btw p lb ub = (card {x. poly (map_poly real_of_int p) x=0 \<and> lb<x \<and> x<ub} = 1)"
*)

definition one_root_test::"int poly \<Rightarrow> float \<Rightarrow> float \<Rightarrow> bool" where
  "one_root_test p lb ub = (descartes_roots_test lb ub (map_poly real_of_int p) = 1)"

term descartes_roots_test

(*
definition valid_alg::"int poly \<Rightarrow> float \<Rightarrow> float \<Rightarrow> bool" where
  "valid_alg p lb ub = (lb<ub \<and> poly (of_int_poly p) lb * poly (of_int_poly p) ub <0
    \<and> one_root_btw (map_poly of_int p) lb ub)"
*)

definition valid_alg::"int poly \<Rightarrow> float \<Rightarrow> float \<Rightarrow> bool" where
  "valid_alg p lb ub = (lb<ub \<and> poly (of_int_poly p) lb
      * poly (of_int_poly p) ub <0
    \<and> one_root_test p lb ub)"

lemma valid_alg_code[code]:
  "valid_alg p lb ub = (lb<ub \<and> sgn (eval_poly of_int p lb)
      * sgn (eval_poly of_int p ub) <0 \<and> one_root_test p lb ub)"
proof -
  have "poly (of_int_poly p) lb * poly (of_int_poly p) ub <0
        \<longleftrightarrow> sgn (eval_poly of_int p lb) * sgn (eval_poly of_int p ub) <0"
    unfolding eval_poly_def by (metis sgn_less sgn_mult)
  then show ?thesis unfolding valid_alg_def by auto
qed

global_interpretation float_int:hom_pseudo_smods float_of_int real_of_int real_of_float
  defines
    fi_changes_hpoly_at  = float_int.changes_hpoly_at and
    fi_changes_itv_spmods = float_int.changes_itv_spmods and
    fi_changes_gt_spmods = float_int.changes_gt_spmods and
    fi_changes_le_spmods = float_int.changes_le_spmods and
    fi_changes_R_spmods = float_int.changes_R_spmods
  apply unfold_locales
  apply (simp_all add: of_rat_less of_rat_less_eq)
  using real_of_float_eq by force

global_interpretation rat_float:hom_pseudo_smods rat_of_float real_of_float real_of_rat
  apply unfold_locales
  by (simp_all add: of_rat_less of_rat_less_eq rat_of_float_add rat_of_float_mult)

section \<open>Representation of a real algebraic number\<close>

definition Alg:: "int poly \<Rightarrow> float \<Rightarrow> float \<Rightarrow> real" where
  [code del]:"Alg p lb ub = (if valid_alg p lb ub
                    then Real (to_cauchy (map_poly of_int p,rat_of_float lb,rat_of_float ub))
                    else undefined)"

lemma alg_bound_and_root:
  fixes p::"int poly" and lb ub::float
  assumes "valid_alg p lb ub"
  shows "lb<Alg p lb ub" and "Alg p lb ub<ub" and "poly (of_int_poly p) (Alg p lb ub) = 0"
proof -
  let ?p = "of_int_poly p"
  have less:"rat_of_float lb<rat_of_float ub"
      and "poly ?p lb * poly ?p ub<0"
      and "one_root_test p lb ub"
    using assms unfolding valid_alg_def eval_poly_def
    apply auto
    by (metis rat_float.R_hom rat_float.r2.hom_less)
  define x where "x\<equiv>Alg p lb ub"
  hence x:"x= Real (to_cauchy (of_int_poly p, rat_of_float lb, rat_of_float ub))"
    using assms Alg_def valid_alg_def by auto
  have "poly (of_int_poly p) (rat_of_float lb) * poly (of_int_poly p) (rat_of_float ub) \<le> 0"
  proof -
    have "rat_of_float (poly (of_int_poly p) lb * poly (of_int_poly p) ub) < 0"
      using \<open>poly ?p lb * poly ?p ub<0\<close> by (simp add: rat_float.r2.hom_less)
    then have "poly (of_int_poly p) (rat_of_float lb)
                    * poly (of_int_poly p) (rat_of_float ub) < 0"
      unfolding rat_of_float_mult
      by  (simp flip:rat_float.poly_map_poly add:map_poly_map_poly comp_def)
    then show ?thesis by auto
  qed
  from to_cauchy_root[OF _ this,folded x] less
  have "poly (map_poly real_of_rat (of_int_poly p)) x = 0"
    by simp
  then show "poly (of_int_poly p) x=0"
    by (simp add:map_poly_map_poly comp_def)
  then show "lb<x" and "x<ub"
    using to_cauchy_bound[OF less,of ?p,folded x] \<open>poly ?p lb * poly ?p ub<0\<close>
    by (metis float_int.map_poly_R_hom_commute float_int.r2.hom_0_iff le_less
        less_irrefl mult_eq_0_iff real_of_rat_of_float)+
qed

lemma card_1_imp_eq:"card S=1 \<Longrightarrow> x\<in>S \<Longrightarrow> y\<in>S \<Longrightarrow> x=y"
  by (metis One_nat_def card_eq_SucD singletonD)

lemma card_eq_count_leq_1:
  assumes "p\<noteq>0" "proots_count p s \<le> 1"
  shows "card (proots_within p s) = proots_count p s"
proof -
  have "card (proots_within p s) \<le> 1"
    using card_proots_within_leq[OF \<open>p\<noteq>0\<close>,of s] \<open>proots_count p s \<le> 1\<close>
    by auto
  then have "card (proots_within p s) = 0 \<or> card (proots_within p s) = 1"
    by auto
  moreover have ?thesis if "card (proots_within p s) = 0"
  proof -
    have "proots_within p s = {}"
      using that by (meson assms(1) card_0_eq finite_proots)
    then show ?thesis unfolding proots_count_def by auto
  qed
  moreover have ?thesis if "card (proots_within p s) = 1"
  proof -
    obtain a where "proots_within p s = {a}"
      using \<open>card (proots_within p s) = 1\<close> card_1_singletonE by blast
    then have "order a p = proots_count p s"
      unfolding proots_count_def by auto
    then have "order a p \<le> 1" using \<open>proots_count p s \<le> 1\<close> by auto
    moreover have "order a p\<noteq>0"
      using \<open>proots_within p s = {a}\<close> order_root \<open>p\<noteq>0\<close> unfolding proots_within_def
      by auto
    ultimately have "order a p=1" by auto
    then have "proots_count p s = 1"
      using \<open>order a p = proots_count p s\<close> by auto
    with that show ?thesis by auto
  qed
  ultimately show ?thesis by auto
qed

lemma alg_eq:
  assumes valid:"valid_alg p lb ub" and "poly (of_int_poly p) x = 0" and "x>lb" and "x<ub"
  shows "x=Alg p lb ub"
proof -
  define S where "S={x::real. poly (of_int_poly p) x = 0 \<and> lb < x \<and> x < ub}"
  have "card S  = 1"
  proof -
    define ll uu pp where "ll=real_of_float lb" and "uu = real_of_float ub"
                      and "pp=map_poly real_of_int p"
    have "descartes_roots_test ll uu pp = 1" and "ll < uu" and "pp\<noteq>0"
      using valid unfolding valid_alg_def one_root_test_def ll_def uu_def pp_def
      by auto
    then have "proots_count pp {x. ll < x \<and> x < uu} = 1"
      using descartes_roots_test_one by auto
    then have "card (proots_within pp {x. ll < x \<and> x <  uu})
                  = proots_count pp {x. ll < x \<and> x < uu}"
      using card_eq_count_leq_1[OF \<open>pp\<noteq>0\<close>] by auto
    also have "... = 1"
      using descartes_roots_test_one[OF \<open>pp\<noteq>0\<close> \<open>ll < uu\<close>]
            \<open>descartes_roots_test ll uu pp = 1\<close>
      by auto
    finally have "card (proots_within pp {x. ll < x \<and> x < uu}) = 1" .
    moreover have "proots_within pp {x. ll < x \<and> x < uu} = S"
      unfolding S_def pp_def ll_def uu_def proots_within_def
      by auto
    ultimately show ?thesis by auto
  qed
  moreover have "x\<in>S"
    using assms unfolding S_def by auto
  moreover have "Alg p lb ub\<in> S"
    using alg_bound_and_root[OF valid] unfolding S_def by auto
  ultimately show ?thesis apply (elim card_1_imp_eq) by auto
qed

lemma valid_alg_deg:
  assumes valid:"valid_alg p lb ub"
  shows "degree p\<noteq>0"
proof (cases "p=0")
  case True
  thus ?thesis using valid by (auto simp add:valid_alg_def)
next
  case False
  have False when "degree p=0"
  proof -
    obtain c where "p=[:c:]" "c\<noteq>0" using False
      by (metis \<open>degree p = 0\<close> degree_eq_zeroE pCons_0_0)
    thus False using valid
      using alg_bound_and_root(3) by fastforce
  qed
  thus ?thesis by auto
qed

datatype alg_imp =
     Floatalg float
   | Ratalg rat float float
   | Polyalg "int poly" float float

fun real_of_alg_imp :: "alg_imp \<Rightarrow> real" where
  "real_of_alg_imp (Ratalg r _ _) = (Ratreal r)"|
  "real_of_alg_imp (Floatalg f) = real_of_float f"|
  "real_of_alg_imp (Polyalg p lb ub) = Alg p lb ub"

definition valid_Ratalg:: "rat \<Rightarrow> float \<Rightarrow> float \<Rightarrow> bool" where
  "valid_Ratalg r lb ub = (lb < of_rat r \<and> of_rat r < ub)"

fun valid_alg_imp :: "alg_imp \<Rightarrow> bool" where
  "valid_alg_imp (Ratalg r lb ub) = valid_Ratalg r lb ub"
| "valid_alg_imp (Floatalg _ ) = True "
| "valid_alg_imp (Polyalg p lb ub) = valid_alg p lb ub"

section \<open>A number between and upper/lower bounds of real algebraic numbers\<close>

definition mid_fl::"float \<Rightarrow> float \<Rightarrow> float" where
  "mid_fl a b = (a+b)*Float 1 (- 1)"

lemma mid_fl_strict_between[intro]:
  assumes "a<b"
  shows "a < mid_fl a b" "mid_fl a b < b"
  using assms unfolding mid_fl_def by (auto simp:powr_neg_one)

fun btw_alg :: "alg_imp \<Rightarrow> alg_imp \<Rightarrow> alg_imp" where
   "btw_alg (Ratalg _ _ ub1) (Ratalg r2 lb2 _) = Floatalg (mid_fl ub1 lb2)"
 | "btw_alg (Ratalg _ _ ub1) (Floatalg f) = Floatalg (mid_fl ub1 f)"
 | "btw_alg (Ratalg _ _ ub1) (Polyalg p lb2 _) = Floatalg (mid_fl ub1 lb2)"
 | "btw_alg (Floatalg f) (Ratalg r2 lb2 _) = Floatalg (mid_fl f lb2)"
 | "btw_alg (Floatalg f1) (Floatalg f2) = Floatalg (mid_fl f1 f2)"
 | "btw_alg (Floatalg f) (Polyalg p lb2 _) = Floatalg (mid_fl f lb2)"
 | "btw_alg (Polyalg _ _ ub1) (Ratalg r2 lb2 _) = Floatalg (mid_fl ub1 lb2)"
 | "btw_alg (Polyalg _ _ ub1) (Floatalg f) = Floatalg (mid_fl ub1 f)"
 | "btw_alg (Polyalg _ _ ub1) (Polyalg p lb2 _) = Floatalg (mid_fl ub1 lb2)"

fun strict_less_alg_imp :: "alg_imp \<Rightarrow> alg_imp \<Rightarrow> bool" where
   "strict_less_alg_imp (Ratalg _ _ ub1) (Ratalg _ lb2 _) = (ub1 < lb2)"
 | "strict_less_alg_imp (Ratalg _ _ ub1) (Floatalg f) = (ub1 < f)"
 | "strict_less_alg_imp (Ratalg _ _ ub1) (Polyalg p lb2 _) = (ub1 < lb2)"
 | "strict_less_alg_imp (Floatalg f) (Ratalg r2 lb2 _) = (f < lb2)"
 | "strict_less_alg_imp (Floatalg f1) (Floatalg f2) = (f1 < f2)"
 | "strict_less_alg_imp (Floatalg f) (Polyalg p lb2 _) = (f < lb2)"
 | "strict_less_alg_imp (Polyalg _ _ ub1) (Ratalg r2 lb2 _) = (ub1 < lb2)"
 | "strict_less_alg_imp (Polyalg _ _ ub1) (Floatalg f) = (ub1 < f)"
 | "strict_less_alg_imp (Polyalg _ _ ub1) (Polyalg p lb2 _) = (ub1 < lb2)"

lemma alg_imp_less:
  assumes "valid_alg_imp a" "valid_alg_imp b" "strict_less_alg_imp a b"
  shows "real_of_alg_imp a < real_of_alg_imp b"
  using assms
  apply (cases a;cases b)
  apply (auto simp:valid_Ratalg_def dest:alg_bound_and_root)
  using alg_bound_and_root(1) alg_bound_and_root(2) by fastforce

lemma btw_alg_between:
  assumes "valid_alg_imp a" "valid_alg_imp b" "strict_less_alg_imp a b"
  shows "real_of_alg_imp a < real_of_alg_imp (btw_alg a b)"
        "real_of_alg_imp (btw_alg a b) < real_of_alg_imp b"
proof -
  show "real_of_alg_imp a < real_of_alg_imp (btw_alg a b)"
  proof (cases a)
    case (Floatalg f)
    then show ?thesis
      using assms
      by (cases b) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
  next
    case (Ratalg r1 lb1 ub1)
    then have "real_of_alg_imp a = real_of_rat r1" by auto
    also have "... < ub1"
      using Ratalg assms(1) valid_Ratalg_def valid_alg_imp.simps(1) by blast
    also have "... < real_of_alg_imp (btw_alg a b)"
      using Ratalg assms
      by (cases b) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
    finally show ?thesis .
  next
    case (Polyalg p1 lb1 ub1)
    then have  "real_of_alg_imp a < ub1"
      using alg_bound_and_root(2) assms(1) by force
    also have "... < real_of_alg_imp (btw_alg a b)"
      using Polyalg assms
      by (cases b) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
    finally show ?thesis .
  qed

  show "real_of_alg_imp (btw_alg a b) < real_of_alg_imp b"
  proof (cases b)
    case (Floatalg f)
    then show ?thesis
      using assms
      by (cases a) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
  next
    case (Ratalg r1 lb1 ub1)
    then have "real_of_alg_imp (btw_alg a b) < lb1"
      using assms
      by (cases a)  (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
    also have "... < real_of_alg_imp b"
      using Ratalg assms(2) valid_Ratalg_def by auto
    finally show ?thesis .
  next
    case (Polyalg p1 lb1 ub1)
    then have "real_of_alg_imp (btw_alg a b) < lb1"
      using assms
      by (cases a) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
    also have "... < real_of_alg_imp b"
      using Polyalg alg_bound_and_root(1) assms(2) by auto
    finally show ?thesis .
  qed
qed

lemma btw_alg_imp_between:
  assumes "strict_less_alg_imp a b"
  shows "strict_less_alg_imp a (btw_alg a b)"
        "strict_less_alg_imp (btw_alg a b) b"
  subgoal using assms
    by (cases a;cases b) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
  subgoal using assms
    by (cases a;cases b) (auto simp flip:float_int.r2.hom_less simp del:less_float.rep_eq)
  done

lemma valid_btw_alg:
  assumes "valid_alg_imp a" "valid_alg_imp b"
  shows "valid_alg_imp (btw_alg a b)"
  using assms by (cases a;cases b) auto

fun upper_alg :: "alg_imp \<Rightarrow> alg_imp" where
  "upper_alg (Ratalg _ _ ub1) = Floatalg (ub1+1)"
| "upper_alg (Floatalg f) = Floatalg (f+1)"
| "upper_alg (Polyalg _ _ ub1) = Floatalg (ub1+1)"

fun lower_alg :: "alg_imp \<Rightarrow> alg_imp" where
  "lower_alg (Ratalg _ lb1 _) = Floatalg (lb1 - 1)"
| "lower_alg (Floatalg f) = Floatalg (f-1)"
| "lower_alg (Polyalg _ lb1 _) = Floatalg (lb1 - 1)"

lemma valid_upper_alg:"valid_alg_imp x \<Longrightarrow> valid_alg_imp (upper_alg x)"
  by (cases x) auto

lemma valid_lower_alg:"valid_alg_imp x \<Longrightarrow> valid_alg_imp (lower_alg x)"
  by (cases x) auto

lemma upper_alg_less_imp:"valid_alg_imp x
        \<Longrightarrow> strict_less_alg_imp x (upper_alg x)"
  by (cases x) auto

lemma lower_alg_less_imp:"valid_alg_imp x
        \<Longrightarrow> strict_less_alg_imp (lower_alg x) x"
  by (cases x) auto

lemma upper_alg_less:"valid_alg_imp x
        \<Longrightarrow> real_of_alg_imp x < real_of_alg_imp (upper_alg x)"
  apply (cases x)
  by (auto simp:valid_Ratalg_def add.commute alg_bound_and_root(2) pos_add_strict)

lemma lower_alg_less:"valid_alg_imp x
        \<Longrightarrow> real_of_alg_imp (lower_alg x) < real_of_alg_imp x"
  apply (cases x)
  apply (auto simp:valid_Ratalg_def)
  using alg_bound_and_root(1) by force

end


theory T185
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory Chapter10_1
imports "HOL-IMP.Def_Init"
begin

text\<open>
\section*{Chapter 10}

\exercise
Define the definite initialisation analysis as two recursive functions
\<close>

fun ivars :: "com \<Rightarrow> vname set" where
(* your definition/proof here *)

fun ok :: "vname set \<Rightarrow> com \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
such that @{const ivars} computes the set of definitely initialised variables
and @{const ok} checks that only initialised variable are accessed.
Prove
\<close>

lemma "D A c A' \<Longrightarrow> A' = A \<union> ivars c \<and> ok A c"
(* your definition/proof here *)

lemma "ok A c \<Longrightarrow> D A c (A \<union> ivars c)"
(* your definition/proof here *)

text\<open>
\endexercise
\<close>

end