(*  Title:      Down.ty
    Author:     Franz Regensburger
    Author:     Brian Huffman
    Author:     Joachim Breitner
*)

header {* The type of lifted values *}

theory Down
imports "HOLCF-Top" "HOLCF-Join"
begin

default_sort cpo

datatype 'a d = Itop | Idown 'a

type_notation (xsymbols)
  u  ("(_\<^sub>\<top>)" [1000] 999)

primrec Ifdown :: "('a \<rightarrow> 'b::Top_cpo) \<Rightarrow> 'a d \<Rightarrow> 'b" where
    "Ifdown f Itop = \<top>"
 |  "Ifdown f (Idown x) = f\<cdot>x"

subsection {* Ordering on lifted cpo *}

instantiation d :: (cpo) below
begin

definition
  below_down_def:
    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case y of Itop \<Rightarrow> True | Idown a \<Rightarrow>
      (case x of Itop \<Rightarrow> False | Idown b \<Rightarrow> b \<sqsubseteq> a))"

instance ..
end

lemma maximal_down [iff]: "z \<sqsubseteq> Itop"
by (simp add: below_down_def)

lemma not_Idown_above [iff]: "Itop \<notsqsubseteq> Idown x "
by (simp add: below_down_def)

lemma Idown_below [iff]: "(Idown x \<sqsubseteq> Idown y) = (x \<sqsubseteq> y)"
by (simp add: below_down_def)

subsection {* Lifted cpo is a partial order *}

instance d :: (cpo) po
proof
  fix x :: "'a d"
  show "x \<sqsubseteq> x"
    unfolding below_down_def by (simp split: d.split)
next
  fix x y :: "'a d"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
    unfolding below_down_def
    by (auto split: d.split_asm intro: below_antisym)
next
  fix x y z :: "'a d"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    unfolding below_down_def
    by (auto split: d.split_asm intro: below_trans)
qed

subsection {* Lifted cpo is a cpo *}

lemma is_lub_Iup:
  "range S <<| x \<Longrightarrow> range (\<lambda>i. Idown (S i)) <<| Idown x"
unfolding is_lub_def is_ub_def ball_simps
by (auto simp add: below_down_def split: d.split)

lemma down_chain_lemma:
  assumes Y: "chain Y" obtains
    i where "Y i = Itop"
  | A where "\<forall>i. Idown (A i) = Y i" and "chain A" and "range Y <<| Idown (\<Squnion>i. A i)"
proof (cases "\<forall>k. Y k \<noteq> Itop")
  case True
  def A \<equiv> "\<lambda>i. THE a. Idown a = Y i"
  have Idown_A: "\<forall>i. Idown (A i) = Y i"
  proof
    fix i :: nat
    have "Y i \<noteq> Itop" using True by (auto)
    thus "Idown (A i) = Y i"
      by (cases "Y i", simp_all add: A_def)
  qed
  from Y have chain_A: "chain A"
    unfolding chain_def Idown_below [symmetric]
    by (simp add: Idown_A)
  hence "range A <<| (\<Squnion>i. A i)"
    by (rule cpo_lubI)
  hence "range (\<lambda>i. Idown (A i)) <<| Idown (\<Squnion>i. A i)"
    by (rule is_lub_Iup)
  hence "range (\<lambda>i. Y i) <<| Idown (\<Squnion>i. A i)"
    by (simp only: Idown_A)
  with Idown_A chain_A show ?thesis ..
next
  case False
  then obtain i where "Y i = Itop" by auto
  then show ?thesis ..
qed

lemma is_lub_maximal_Itop: "Y i = Itop \<Longrightarrow> range Y <<| Itop"
    by (metis  is_lub_maximal is_ubI  maximal_down rangeI)

instance d :: (cpo) cpo
proof
  fix S :: "nat \<Rightarrow> 'a d"
  assume S: "chain S"
  thus "\<exists>x. range (\<lambda>i. S i) <<| x"
  proof (rule down_chain_lemma)
    fix i
    assume "S i = Itop"
    hence "range (\<lambda>i. S i) <<| Itop"
      by (rule is_lub_maximal_Itop)
    thus ?thesis ..
  next
    fix A :: "nat \<Rightarrow> 'a"
    assume "range S <<| Idown (\<Squnion>i. A i)"
    thus ?thesis ..
  qed
qed

subsection {* Lifted cpo is pointed *}

instance d :: (cpo) Top_cpo
by intro_classes fast

text {* for compatibility with old HOLCF-Version *}
lemma inst_down_Top_cpo: "\<top> = Itop"
by (rule maximal_down [THEN topI, symmetric])

subsection {* Continuity of \emph{Idown} and \emph{Ifdown} *}

text {* continuity for @{term Idown} *}

lemma cont_Idown: "cont Idown"
apply (rule contI)
apply (rule is_lub_Iup)
apply (erule cpo_lubI)
done

text {* continuity for @{term Ifdown} *}

lemma cont_Ifdown1: "cont (\<lambda>f. Ifdown f x)"
by (induct x, simp_all)

lemma monofun_Ifdown2: "monofun (\<lambda>x. Ifdown f x)"
apply (rule monofunI)
apply (case_tac y, simp)
apply (case_tac x, simp)
apply (simp add: monofun_cfun_arg)
done

lemma cont_Ifdown2: "cont (\<lambda>x. Ifdown f x)"
proof (rule contI2)
  fix Y assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifdown f (Y i))"
  from Y show "Ifdown f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifdown f (Y i))"
  proof (rule down_chain_lemma)
    fix A
    assume A: "\<forall>i. Idown (A i) = Y i"
    assume "chain A" and "range Y <<| Idown (\<Squnion>i. A i)"
    hence "Ifdown f (\<Squnion>i. Y i) = (\<Squnion>i. Ifdown f (Idown (A i)))"
      by (simp add: lub_eqI contlub_cfun_arg)
    also have "\<dots> = (\<Squnion>i. Ifdown f (Y i))"
      by (simp add: A)
    finally show ?thesis by simp
  next
    fix i
    assume "Y i = Itop"
    hence "range Y <<| Itop"
      by (rule is_lub_maximal_Itop)
    hence "(\<Squnion>i. Y i) = Itop"
      by (metis lub_eqI)
    moreover
    assume "Y i = Itop"
    hence "Ifdown f (Y i) = \<top>" by simp
    hence "range (\<lambda>i. Ifdown f (Y i)) <<| \<top>"
      by (metis (mono_tags) Y' above_top_iff cpo_class.thelubE is_ub_thelub)
    hence "(\<Squnion>i. Ifdown f (Y i)) = \<top>"
      by (metis lub_eqI)
    ultimately
    show ?thesis by simp
  qed
qed (rule monofun_Ifdown2)

subsection {* Continuous versions of constants *}

definition
  down  :: "'a \<rightarrow> 'a d" where
  "down = (\<Lambda> x. Idown x)"

definition
  fdown :: "('a \<rightarrow> 'b::Top_cpo) \<rightarrow> 'a d \<rightarrow> 'b" where
  "fdown = (\<Lambda> f p. Ifdown f p)"

translations
  "case l of XCONST down\<cdot>x \<Rightarrow> t" == "CONST fdown\<cdot>(\<Lambda> x. t)\<cdot>l"
  "case l of (XCONST down :: 'a)\<cdot>x \<Rightarrow> t" => "CONST fdown\<cdot>(\<Lambda> x. t)\<cdot>l"
  "\<Lambda>(XCONST down\<cdot>x). t" == "CONST fdown\<cdot>(\<Lambda> x. t)"

text {* continuous versions of lemmas for @{typ "('a)d"} *}

lemma Exh_Down: "z = \<top> \<or> (\<exists>x. z = down\<cdot>x)"
apply (induct z)
apply (simp add: inst_down_Top_cpo)
apply (simp add: down_def cont_Idown)
done

lemma down_eq [simp]: "(down\<cdot>x = down\<cdot>y) = (x = y)"
by (simp add: down_def cont_Idown)

lemma down_inject: "down\<cdot>x = down\<cdot>y \<Longrightarrow> x = y"
by simp

lemma down_defined [simp]: "down\<cdot>x \<noteq> \<top>"
by (simp add: down_def cont_Idown inst_down_Top_cpo)

lemma not_down_less_UU: "\<top> \<notsqsubseteq> down\<cdot>x "
by simp (* FIXME: remove? *)

lemma down_above [simp]: "down\<cdot>x \<sqsubseteq> down\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
by (simp add: down_def cont_Idown)

lemma downE [case_names top down, cases type: d]:
  "\<lbrakk>p = \<top> \<Longrightarrow> Q; \<And>x. p = down\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
apply (cases p)
apply (simp add: inst_down_Top_cpo)
apply (simp add: down_def cont_Idown)
done

lemma down_induct [case_names top down, induct type: d]:
  "\<lbrakk>P \<top>; \<And>x. P (down\<cdot>x)\<rbrakk> \<Longrightarrow> P x"
by (cases x, simp_all)

(*
text {* lifting preserves chain-finiteness *}

lemma up_chain_cases:
  assumes Y: "chain Y" obtains "\<forall>i. Y i = \<bottom>"
  | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
apply (rule up_chain_lemma [OF Y])
apply (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)
done

lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
apply (rule compactI2)
apply (erule up_chain_cases)
apply simp
apply (drule (1) compactD2, simp)
apply (erule exE)
apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
apply (simp, erule exI)
done

lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
unfolding compact_def
by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)

lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
by (safe elim!: compact_up compact_upD)

instance u :: (chfin) chfin
apply intro_classes
apply (erule compact_imp_max_in_chain)
apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
done
*)

text {* properties of fup *}

lemma fdown1 [simp]: "fdown\<cdot>f\<cdot>\<top> = \<top>"
by (simp add: fdown_def cont_Ifdown1 cont_Ifdown2 inst_down_Top_cpo cont2cont_LAM)

lemma fdown2 [simp]: "fdown\<cdot>f\<cdot>(down\<cdot>x) = f\<cdot>x"
by (simp add: down_def fdown_def cont_Idown cont_Ifdown1 cont_Ifdown2 cont2cont_LAM)

lemma fdown3 [simp]: "fdown\<cdot>down\<cdot>x = x"
by (cases x, simp_all)

(* End of dual of Up.thy, now various lemmas of later HOLCF theories follow. *)

subsection {* Map function for top-adjoint cpo *}

definition
  d_map :: "('a -> 'b) -> 'a d -> 'b d"
where
  "d_map = (\<Lambda> f. fdown\<cdot>(down oo f))"

lemma d_map_strict [simp]: "d_map\<cdot>f\<cdot>\<top> = \<top>"
unfolding d_map_def by simp

lemma d_map_up [simp]: "d_map\<cdot>f\<cdot>(down\<cdot>x) = down\<cdot>(f\<cdot>x)"
unfolding d_map_def by simp

lemma d_map_ID: "d_map\<cdot>ID = ID"
unfolding d_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma d_map_map: "d_map\<cdot>f\<cdot>(d_map\<cdot>g\<cdot>p) = d_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
by (induct p) simp_all

lemma d_map_oo: "d_map\<cdot>(f oo g) = d_map\<cdot>f oo d_map\<cdot>g"
by (simp add: cfcomp1 d_map_map eta_cfun)

lemma ep_pair_d_map: "ep_pair e p \<Longrightarrow> ep_pair (d_map\<cdot>e) (d_map\<cdot>p)"
apply default
apply (case_tac x, simp, simp add: ep_pair.e_inverse)
apply (case_tac y, simp, simp add: ep_pair.e_p_below)
done

lemma deflation_d_map: "deflation d \<Longrightarrow> deflation (d_map\<cdot>d)"
apply default
apply (case_tac x, simp, simp add: deflation.idem)
apply (case_tac x, simp, simp add: deflation.below)
done

lemma finite_deflation_d_map:
  assumes "finite_deflation d" shows "finite_deflation (d_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  have "deflation d" by fact
  thus "deflation (d_map\<cdot>d)" by (rule deflation_d_map)
  have "{x. d_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<top> ((\<lambda>x. down\<cdot>x) ` {x. d\<cdot>x = x})"
    by (rule subsetI, case_tac x, simp_all)
  thus "finite {x. d_map\<cdot>d\<cdot>x = x}"
    by (rule finite_subset, simp add: d.finite_fixes)
qed

subsubsection {* top-adjoint cpo *}

lemma approx_chain_d_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. d_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP d_map_ID finite_deflation_d_map)

instance d :: (pcpo) pcpo
  apply default
  apply (rule_tac x = "Idown \<bottom>" in exI)
  apply rule
  apply (case_tac y rule:d.exhaust)
  apply auto
  done

instance d :: (bifinite) bifinite
  apply default
  using bifinite
  by (auto dest: approx_chain_d_map)

definition "d_emb = udom_emb (\<lambda>i. d_map\<cdot>(udom_approx i))"
definition "d_prj = udom_prj (\<lambda>i. d_map\<cdot>(udom_approx i))"

lemma ep_pair_d: "ep_pair d_emb d_prj"
  unfolding d_emb_def d_prj_def
  by (simp add: ep_pair_udom approx_chain_d_map)

definition d_defl :: "udom defl \<rightarrow> udom defl"
  where "d_defl = defl_fun1 d_emb d_prj d_map"

lemma cast_d_defl:
  "cast\<cdot>(d_defl\<cdot>A) =
    d_emb oo d_map\<cdot>(cast\<cdot>A) oo d_prj"
using ep_pair_d finite_deflation_d_map
unfolding d_defl_def by (rule cast_defl_fun1)

instantiation d :: ("domain") "domain"
begin

definition
  "emb = d_emb oo d_map \<cdot> emb"

definition
  "prj = d_map \<cdot> prj oo d_prj"

definition
  "defl (t::'a d itself) = d_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a d u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a d u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a d itself) = liftdefl_of\<cdot>DEFL('a d)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a d)"
    unfolding emb_d_def prj_d_def
    by (intro ep_pair_comp ep_pair_d ep_pair_d_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a d) = emb oo (prj :: udom \<rightarrow> 'a d)"
    unfolding emb_d_def prj_d_def defl_d_def cast_d_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff d_map_map)
qed (fact liftemb_d_def liftprj_d_def liftdefl_d_def)+

end

lemma DEFL_d:
  "DEFL(('a::domain) d) = d_defl\<cdot>DEFL('a)"
by (rule defl_d_def)

lemma isodefl_d:
  "isodefl d1 t1  \<Longrightarrow>  isodefl (d_map\<cdot>d1) (d_defl\<cdot>t1)"
apply (rule isodeflI)
apply (simp add: cast_d_defl cast_isodefl)
apply (simp add: emb_d_def prj_d_def)
apply (simp add: d_map_map isodefl_strict)
done

lemmas [domain_defl_simps] = DEFL_d

lemmas [domain_map_ID] = d_map_ID

lemmas [domain_isodefl] = isodefl_d

lemmas [domain_deflation] = deflation_d_map

setup {*
  Domain_Take_Proofs.add_rec_type (@{type_name "d"}, [true])
*}

(* Complete cpos; Meet is sufficient *)

class Meet_cpo = Top_cpo + Nonempty_Meet_cpo
begin
  lemma  meet_exists: "\<exists>x. S >>| (x::'a)"
  using [[show_types]] [[show_sorts]]
   apply (cases "S = {}")
   thm nonempty_meet_exists maximal top_def
   apply (rule_tac x = "\<top>" in exI)
   apply (rule is_glbI)
   apply (rule is_lbI)
   apply auto[1]
   apply (rule maximal)
   apply (metis nonempty_meet_exists)
   done

  text {* Properties of the glb *}

  lemma glbI: "S >>| (\<Sqinter>S :: 'a)"
    by (metis meet_exists is_glb_glb)

  lemma thelubE: "\<lbrakk>(\<Sqinter>S) = l\<rbrakk> \<Longrightarrow> S  >>| (l::'a)"
    by (metis meet_exists is_glb_glb)

  lemma is_lb_theglb: "x \<in> S \<Longrightarrow> \<Sqinter> S \<sqsubseteq> x"
    by (metis meet_exists is_lbD is_glb_glb[THEN is_glbD1])

  lemma is_glb_theglb:
    "[|S >| x|] ==> x \<sqsubseteq> (\<Sqinter>S)"
    by (metis meet_exists is_glb_glb[THEN is_glbD2])

  lemma glb_above_iff: "x \<sqsubseteq> (\<Sqinter>S) <-> (\<forall>y \<in> S. x \<sqsubseteq> y)"
    by (simp add: is_glb_above_iff [OF glbI] is_lb_def)

  lemma glb_above: "[| \<And>y. y \<in> S \<Longrightarrow> x \<sqsubseteq> y|] ==> x \<sqsubseteq> (\<Sqinter>S)"
    by (simp add: glb_above_iff)

  lemma above_glb: "[|y \<in> S ; y \<sqsubseteq> x|] ==> (\<Sqinter>S) \<sqsubseteq> y"
    by (metis is_lb_theglb)

end

class complete_cpo = Meet_cpo + Join_cpo

instance Meet_cpo \<subseteq> Join_cpo
  apply default
  apply (rule_tac x = "lub {}" in exI)
  apply (metis is_lub_thelub_ex is_ub_empty ub_implies_lub_exists)
  apply (metis is_lubI is_ubI glb_above is_ubD is_lb_theglb mem_Collect_eq)
  done

lemma (in Top_cpo) meet_empty[simp]: "\<Sqinter>{} = (\<top>::'a)"
    by (metis glb_eqI is_glbI is_lb_empty maximal)

(* Stuff for the down type *)

lemma down_set_cases:
  fixes S  :: "'a d set"
  obtains Stop and  Sbelow
  where "Stop \<subseteq> {Itop}" and "Stop \<union> Idown ` Sbelow = S"
proof-
  have "S \<inter> {Itop} \<subseteq> {Itop}" by auto
  moreover
  have "Idown ` ((\<lambda>x. THE z. x = Idown z) ` (S - {Itop})) = S - {Itop}"
    apply (intro set_eqI)
    apply (case_tac x rule:d.exhaust)
    apply auto[1]

    apply rule

    apply (erule imageE)
    apply auto[1]
    apply (rule classical)
    apply (erule notE)
    apply (rule the1I2)
    apply auto[1]
    apply (metis d.exhaust)
    apply simp

    apply (simp only:)
    apply (rule imageI)
    apply (erule rev_image_eqI)
    apply (rule the1I2)
    apply auto
    done
  hence "(S \<inter> {Itop}) \<union> Idown ` ((\<lambda>x. THE z. x = Idown z) ` (S - {Itop})) = S" by auto
  ultimately
  show thesis ..
qed

instance d :: (Nonempty_Meet_cpo) Nonempty_Meet_cpo
proof(default)
  fix S :: "'a d set"
  assume "S \<noteq> {}"

  obtain S1 S2 where "S1 \<subseteq> {Itop}" and "S1 \<union> Idown ` S2 = S" by (rule down_set_cases)

  show "\<exists> x. S >>| x"
  proof (cases "S2 = {}")
  case True
    hence "S = S1" using `_ \<union> _ = _` by (metis Un_empty_right image_empty)
    hence "S = {Itop}" using  `S \<noteq> {}` `S1 \<subseteq> _` by (metis subset_singletonD)
    hence "S >>| Itop"
      by (metis is_glb_singleton)
    thus ?thesis..
  next
  case False
    then obtain u where "S2 >>| u" by (metis nonempty_meet_exists)

    from `S2 \<noteq> {}` obtain a where "Idown a \<in> S"  using `_ \<union> _ = _` by auto

    have lb: "S >| Idown u"
      using `_ \<union> _ = _` `S1 \<subseteq> _` is_lbD[OF is_glbD1[OF `S2 >>| u`]]
      by (auto intro: is_lbI)

    have "S >>| Idown u"
      apply(rule is_glbI[OF lb])
      apply (case_tac ua rule:d.exhaust)
      apply (drule is_lbD[OF _ `Idown a \<in> S`])
      apply simp
      apply simp
      apply (rule is_glbD2[OF `S2 >>| u`])
      apply (rule is_lbI)
      apply (drule is_lbD)
      using  `_ \<union> _ = _`
      apply auto
      done
    thus ?thesis ..
  qed
qed

class Finite_Meet_bifinite_cpo = Finite_Meet_cpo + bifinite

lemma is_ub_range:
     "S >| u \<Longrightarrow> Rep_cfun f ` S >| f \<cdot> u"
  apply (rule is_lbI)
  apply (erule imageE)
  by (metis monofun_cfun_arg is_lbD)

lemma (in approx_chain) lub_approx_arg: "(\<Squnion>i. approx i \<cdot> u ) = u"
  by (metis chain_approx lub_ID_reach lub_approx)

instance Finite_Meet_bifinite_cpo \<subseteq> Nonempty_Meet_cpo
proof (default)
  from bifinite obtain approx :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where "approx_chain approx" by auto
  fix S
  assume "(S :: 'a set) \<noteq> {}"
  have "\<And>i. \<exists> l . Rep_cfun (approx i) ` S >>|l"
    apply (rule finite_meet_exists)
    using `S \<noteq> {}` apply auto[1]
    using  finite_deflation.finite_range[OF approx_chain.finite_deflation_approx[OF `approx_chain approx`]]
    by (metis (full_types) image_mono rev_finite_subset top_greatest)
  then obtain Y where Y_is_glb: "\<And>i. Rep_cfun (approx i) ` S >>| Y i" by metis

  have "chain Y"
    apply (rule chainI)
    apply (subst is_glb_above_iff[OF Y_is_glb])
    apply (rule is_lbI)
    apply (erule imageE)
    apply (erule ssubst)
    apply (rule rev_below_trans[OF monofun_cfun_fun[OF chainE[OF approx_chain.chain_approx[OF `approx_chain approx`]]]])
    apply (rule is_lbD[OF is_glbD1[OF Y_is_glb]])
    apply (erule imageI)
    done

  have "S >| Lub Y"
  proof(rule is_lbI, rule lub_below[OF `chain Y`])
    fix x i
    assume "x \<in> S"
    hence "Y i \<sqsubseteq> approx i \<cdot> x"
      by (rule imageI[THEN is_lbD[OF is_glbD1[OF Y_is_glb]]])
    also have "approx i \<cdot> x \<sqsubseteq> x"
      by (rule  approx_chain.approx_below[OF `approx_chain approx`])
    finally
    show "Y i \<sqsubseteq> x".
  qed

  have "S >>| Lub Y"
  proof (rule is_glbI[OF `S >| Lub Y`])
    fix u
    assume "S >| u"
    hence "\<And> i. Rep_cfun (approx i) ` S >| approx i \<cdot> u"
      by (rule is_ub_range)
    hence "\<And> i.  approx i \<cdot> u \<sqsubseteq> Y i"
      by (rule is_glbD2[OF Y_is_glb])
    hence "(\<Squnion>i. approx i \<cdot> u ) \<sqsubseteq> Lub Y"
      by (rule lub_mono[OF
            ch2ch_Rep_cfunL[OF approx_chain.chain_approx[OF `approx_chain approx`]]
            `chain Y`
            ])
    thus "u \<sqsubseteq> Lub Y"
      by (metis approx_chain.lub_approx_arg[OF `approx_chain approx`])
  qed
  thus "\<exists>x. S >>| x"..
qed

end


(*  Title:      HOL/Nitpick_Examples/Core_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's functional core.
*)

section \<open>Examples Featuring Nitpick's Functional Core\<close>

theory Core_Nits
imports Main
begin

nitpick_params [verbose, card = 1-6, unary_ints, max_potential = 0,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

subsection \<open>Curry in a Hurry\<close>

lemma "(\<lambda>f x y. (curry o case_prod) f x y) = (\<lambda>f x y. (\<lambda>x. x) f x y)"
nitpick [card = 1-12, expect = none]
by auto

lemma "(\<lambda>f p. (case_prod o curry) f p) = (\<lambda>f p. (\<lambda>x. x) f p)"
nitpick [card = 1-12, expect = none]
by auto

lemma "case_prod (curry f) = f"
nitpick [card = 1-12, expect = none]
by auto

lemma "curry (case_prod f) = f"
nitpick [card = 1-12, expect = none]
by auto

lemma "case_prod (\<lambda>x y. f (x, y)) = f"
nitpick [card = 1-12, expect = none]
by auto

subsection \<open>Representations\<close>

lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y = y"
nitpick [expect = none]
by auto

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nitpick [card 'a = 25, card 'b = 24, expect = genuine]
nitpick [card = 1-10, mono, expect = none]
oops

lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y \<noteq> y"
nitpick [card = 1, expect = genuine]
oops

lemma "P (\<lambda>x. x)"
nitpick [card = 1, expect = genuine]
oops

lemma "{(a::'a\<times>'a, b::'b)}\<inverse> = {(b, a)}"
nitpick [card = 1-12, expect = none]
by auto

lemma "fst (a, b) = a"
nitpick [card = 1-20, expect = none]
by auto

lemma "\<exists>P. P = Id"
nitpick [card = 1-20, expect = none]
by auto

lemma "(a::'a\<Rightarrow>'b, a) \<in> Id\<^sup>*"
nitpick [card = 1-2, expect = none]
by auto

lemma "(a::'a\<times>'a, a) \<in> Id\<^sup>* \<union> {(a, b)}\<^sup>*"
nitpick [card = 1-4, expect = none]
by auto

lemma "(a, a) \<in> Id"
nitpick [card = 1-50, expect = none]
by (auto simp: Id_def)

lemma "((a::'a, b::'a), (a, b)) \<in> Id"
nitpick [card = 1-10, expect = none]
by (auto simp: Id_def)

lemma "(x::'a\<times>'a) \<in> UNIV"
nitpick [card = 1-50, expect = none]
sorry

lemma "{} = A - A"
nitpick [card = 1-100, expect = none]
by auto

lemma "g = Let (A \<or> B)"
nitpick [card = 1, expect = none]
nitpick [card = 12, expect = genuine]
oops

lemma "(let a_or_b = A \<or> B in a_or_b \<or> \<not> a_or_b)"
nitpick [expect = none]
by auto

lemma "A \<subseteq> B"
nitpick [card = 100, expect = genuine]
oops

lemma "A = {b}"
nitpick [card = 100, expect = genuine]
oops

lemma "{a, b} = {b}"
nitpick [card = 50, expect = genuine]
oops

lemma "(a::'a\<times>'a, a::'a\<times>'a) \<in> R"
nitpick [card = 1, expect = genuine]
nitpick [card = 10, expect = genuine]
nitpick [card = 5, dont_box, expect = genuine]
oops

lemma "f (g::'a\<Rightarrow>'a) = x"
nitpick [card = 3, dont_box, expect = genuine]
nitpick [card = 8, expect = genuine]
oops

lemma "f (a, b) = x"
nitpick [card = 10, expect = genuine]
oops

lemma "f (a, a) = f (c, d)"
nitpick [card = 10, expect = genuine]
oops

lemma "(x::'a) = (\<lambda>a. \<lambda>b. \<lambda>c. if c then a else b) x x True"
nitpick [card = 1-10, expect = none]
by auto

lemma "\<exists>F. F a b = G a b"
nitpick [card = 2, expect = none]
by auto

lemma "f = case_prod"
nitpick [card = 2, expect = genuine]
oops

lemma "(A::'a\<times>'a, B::'a\<times>'a) \<in> R \<Longrightarrow> (A, B) \<in> R"
nitpick [card = 15, expect = none]
by auto

lemma "(A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R) \<Longrightarrow>
       A = B \<or> (A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R)"
nitpick [card = 1-25, expect = none]
by auto

lemma "f = (\<lambda>x::'a\<times>'b. x)"
nitpick [card = 8, expect = genuine]
oops

subsection \<open>Quantifiers\<close>

lemma "x = y"
nitpick [card 'a = 1, expect = none]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<forall>x. x = y"
nitpick [card 'a = 1, expect = none]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<forall>x::'a \<Rightarrow> bool. x = y"
nitpick [card 'a = 1, expect = genuine]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<exists>x::'a \<Rightarrow> bool. x = y"
nitpick [card 'a = 1-15, expect = none]
by auto

lemma "\<exists>x y::'a \<Rightarrow> bool. x = y"
nitpick [card = 1-15, expect = none]
by auto

lemma "\<forall>x. \<exists>y. f x y = f x (g x)"
nitpick [card = 1-4, expect = none]
by auto

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-4, expect = none]
by auto

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u w) w (h u)"
nitpick [card = 3, expect = genuine]
oops

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u) w (h u w) y (k u w y)"
nitpick [card = 1-2, expect = none]
sorry

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u) w (h u w y) y (k u w y)"
nitpick [card = 1-2, expect = genuine]
oops

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u w) w (h u w) y (k u w y)"
nitpick [card = 1-2, expect = genuine]
oops

lemma "\<forall>u::'a \<times> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<times> 'f.
       f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-2, expect = none]
sorry

lemma "\<forall>u::'a \<times> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<times> 'f.
       f u v w x = f u (g u w) w (h u)"
nitpick [card = 1-2, dont_box, expect = genuine]
oops

lemma "\<forall>u::'a \<Rightarrow> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<Rightarrow> 'f.
       f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-2, dont_box, expect = none]
sorry

lemma "\<forall>u::'a \<Rightarrow> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<Rightarrow> 'f.
       f u v w x = f u (g u w) w (h u)"
nitpick [card = 1-2, dont_box, expect = genuine]
oops

lemma "\<forall>x. if (\<forall>y. x = y) then False else True"
nitpick [card = 1, expect = genuine]
nitpick [card = 2-5, expect = none]
oops

lemma "\<forall>x::'a\<times>'b. if (\<forall>y. x = y) then False else True"
nitpick [card = 1, expect = genuine]
nitpick [card = 2, expect = none]
oops

lemma "\<forall>x. if (\<exists>y. x = y) then True else False"
nitpick [expect = none]
sorry

lemma "(\<exists>x::'a. \<forall>y. P x y) \<or> (\<exists>x::'a \<times> 'a. \<forall>y. P y x)"
nitpick [card 'a = 1, expect = genuine]
oops

lemma "\<exists>x. if x = y then (\<forall>y. y = x \<or> y \<noteq> x)
           else (\<forall>y. y = (x, x) \<or> y \<noteq> (x, x))"
nitpick [expect = none]
by auto

lemma "\<exists>x. if x = y then (\<exists>y. y = x \<or> y \<noteq> x)
           else (\<exists>y. y = (x, x) \<or> y \<noteq> (x, x))"
nitpick [expect = none]
by auto

lemma "let x = (\<forall>x. P x) in if x then x else \<not> x"
nitpick [expect = none]
by auto

lemma "let x = (\<forall>x::'a \<times> 'b. P x) in if x then x else \<not> x"
nitpick [expect = none]
by auto

subsection \<open>Schematic Variables\<close>

schematic_goal "x = ?x"
nitpick [expect = none]
by auto

schematic_goal "\<forall>x. x = ?x"
nitpick [expect = genuine]
oops

schematic_goal "\<exists>x. x = ?x"
nitpick [expect = none]
by auto

schematic_goal "\<exists>x::'a \<Rightarrow> 'b. x = ?x"
nitpick [expect = none]
by auto

schematic_goal "\<forall>x. ?x = ?y"
nitpick [expect = none]
by auto

schematic_goal "\<exists>x. ?x = ?y"
nitpick [expect = none]
by auto

subsection \<open>Known Constants\<close>

lemma "x \<equiv> Pure.all \<Longrightarrow> False"
nitpick [card = 1, expect = genuine]
nitpick [card = 1, box "('a \<Rightarrow> prop) \<Rightarrow> prop", expect = genuine]
nitpick [card = 6, expect = genuine]
oops

lemma "\<And>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<And>x. f x y = f y x"
nitpick [expect = genuine]
oops

lemma "Pure.all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop True"
nitpick [expect = none]
by auto

lemma "Pure.all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop False"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> Pure.all P \<equiv> Pure.all (\<lambda>x. P (I x))"
nitpick [expect = none]
by auto

lemma "x \<equiv> (\<equiv>) \<Longrightarrow> False"
nitpick [card = 1, expect = genuine]
oops

lemma "P x \<equiv> P x"
nitpick [card = 1-10, expect = none]
by auto

lemma "P x \<equiv> Q x \<Longrightarrow> P x = Q x"
nitpick [card = 1-10, expect = none]
by auto

lemma "P x = Q x \<Longrightarrow> P x \<equiv> Q x"
nitpick [card = 1-10, expect = none]
by auto

lemma "x \<equiv> (\<Longrightarrow>) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "I \<equiv> (\<lambda>x. x) \<Longrightarrow> ((\<Longrightarrow>) x) \<equiv> (\<lambda>y. ((\<Longrightarrow>) x (I y)))"
nitpick [expect = none]
by auto

lemma "P x \<Longrightarrow> P x"
nitpick [card = 1-10, expect = none]
by auto

lemma "True \<Longrightarrow> True" "False \<Longrightarrow> True" "False \<Longrightarrow> False"
nitpick [expect = none]
by auto

lemma "True \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "x = Not"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> Not = (\<lambda>x. Not (I x))"
nitpick [expect = none]
by auto

lemma "x = True"
nitpick [expect = genuine]
oops

lemma "x = False"
nitpick [expect = genuine]
oops

lemma "x = undefined"
nitpick [expect = genuine]
oops

lemma "(False, ()) = undefined \<Longrightarrow> ((), False) = undefined"
nitpick [expect = genuine]
oops

lemma "undefined = undefined"
nitpick [expect = none]
by auto

lemma "f undefined = f undefined"
nitpick [expect = none]
by auto

lemma "f undefined = g undefined"
nitpick [card = 33, expect = genuine]
oops

lemma "\<exists>!x. x = undefined"
nitpick [card = 15, expect = none]
by auto

lemma "x = All \<Longrightarrow> False"
nitpick [card = 1, dont_box, expect = genuine]
oops

lemma "\<forall>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<forall>x. f x y = f y x"
nitpick [expect = genuine]
oops

lemma "All (\<lambda>x. f x y = f x y) = True"
nitpick [expect = none]
by auto

lemma "All (\<lambda>x. f x y = f x y) = False"
nitpick [expect = genuine]
oops

lemma "x = Ex \<Longrightarrow> False"
nitpick [card = 1, dont_box, expect = genuine]
oops

lemma "\<exists>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<exists>x. f x y = f y x"
nitpick [expect = none]
oops

lemma "Ex (\<lambda>x. f x y = f x y) = True"
nitpick [expect = none]
by auto

lemma "Ex (\<lambda>x. f x y = f y x) = True"
nitpick [expect = none]
by auto

lemma "Ex (\<lambda>x. f x y = f x y) = False"
nitpick [expect = genuine]
oops

lemma "Ex (\<lambda>x. f x y \<noteq> f x y) = False"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> Ex P = Ex (\<lambda>x. P (I x))"
nitpick [expect = none]
by auto

lemma "x = y \<Longrightarrow> y = x"
nitpick [expect = none]
by auto

lemma "x = y \<Longrightarrow> f x = f y"
nitpick [expect = none]
by auto

lemma "x = y \<and> y = z \<Longrightarrow> x = z"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<and>) = (\<lambda>x. (\<and>) (I x))"
      "I = (\<lambda>x. x) \<Longrightarrow> (\<and>) = (\<lambda>x y. x \<and> (I y))"
nitpick [expect = none]
by auto

lemma "(a \<and> b) = (\<not> (\<not> a \<or> \<not> b))"
nitpick [expect = none]
by auto

lemma "a \<and> b \<Longrightarrow> a" "a \<and> b \<Longrightarrow> b"
nitpick [expect = none]
by auto

lemma "(\<longrightarrow>) = (\<lambda>x. (\<longrightarrow>) x)" "((\<longrightarrow>) ) = (\<lambda>x y. x \<longrightarrow> y)"
nitpick [expect = none]
by auto

lemma "((if a then b else c) = d) = ((a \<longrightarrow> (b = d)) \<and> (\<not> a \<longrightarrow> (c = d)))"
nitpick [expect = none]
by auto

lemma "(if a then b else c) = (THE d. (a \<longrightarrow> (d = b)) \<and> (\<not> a \<longrightarrow> (d = c)))"
nitpick [expect = none]
by auto

lemma "fst (x, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x::'a\<Rightarrow>'b, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x::'a\<Rightarrow>'b, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x, y::'a\<Rightarrow>'b) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y::'a\<Rightarrow>'b) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x::'a\<times>'b, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x::'a\<times>'b, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x, y::'a\<times>'b) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y::'a\<times>'b) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "I = (\<lambda>x. x) \<Longrightarrow> fst = (\<lambda>x. fst (I x))"
nitpick [expect = none]
by auto

lemma "fst (x, y) = snd (y, x)"
nitpick [expect = none]
by auto

lemma "(x, x) \<in> Id"
nitpick [expect = none]
by auto

lemma "(x, y) \<in> Id \<Longrightarrow> x = y"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> Id = {x. I x \<in> Id}"
nitpick [expect = none]
by auto

lemma "{} = {x. False}"
nitpick [expect = none]
by (metis empty_def)

lemma "x \<in> {}"
nitpick [expect = genuine]
oops

lemma "{a, b} = {b}"
nitpick [expect = genuine]
oops

lemma "{a, b} \<noteq> {b}"
nitpick [expect = genuine]
oops

lemma "{a} = {b}"
nitpick [expect = genuine]
oops

lemma "{a} \<noteq> {b}"
nitpick [expect = genuine]
oops

lemma "{a, b, c} = {c, b, a}"
nitpick [expect = none]
by auto

lemma "UNIV = {x. True}"
nitpick [expect = none]
by (simp only: UNIV_def)

lemma "x \<in> UNIV \<longleftrightarrow> True"
nitpick [expect = none]
by (simp only: UNIV_def mem_Collect_eq)

lemma "x \<notin> UNIV"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<in>) = (\<lambda>x. ((\<in>) (I x)))"
nitpick [expect = none]
apply (rule ext)
apply (rule ext)
by simp

lemma "insert = (\<lambda>x y. insert x (y \<union> y))"
nitpick [expect = none]
by simp

lemma "I = (\<lambda>x. x) \<Longrightarrow> trancl = (\<lambda>x. trancl (I x))"
nitpick [card = 1-2, expect = none]
by auto

lemma "rtrancl = (\<lambda>x. rtrancl x \<union> {(y, y)})"
nitpick [card = 1-3, expect = none]
apply (rule ext)
by auto

lemma "(x, x) \<in> rtrancl {(y, y)}"
nitpick [expect = none]
by auto

lemma "((x, x), (x, x)) \<in> rtrancl {}"
nitpick [card = 1-5, expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<union>) = (\<lambda>x. (\<union>) (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "a \<in> A \<Longrightarrow> a \<in> (A \<union> B)" "b \<in> B \<Longrightarrow> b \<in> (A \<union> B)"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<inter>) = (\<lambda>x. (\<inter>) (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "a \<notin> A \<Longrightarrow> a \<notin> (A \<inter> B)" "b \<notin> B \<Longrightarrow> b \<notin> (A \<inter> B)"
nitpick [card = 1-5, expect = none]
by auto

lemma "x \<in> ((A::'a set) - B) \<longleftrightarrow> x \<in> A \<and> x \<notin> B"
nitpick [card = 1-5, expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<subset>) = (\<lambda>x. (\<subset>) (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subset> B \<Longrightarrow> (\<forall>a \<in> A. a \<in> B) \<and> (\<exists>b \<in> B. b \<notin> A)"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subseteq> B \<Longrightarrow> \<forall>a \<in> A. a \<in> B"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subseteq> B \<Longrightarrow> A \<subset> B"
nitpick [card = 5, expect = genuine]
oops

lemma "A \<subset> B \<Longrightarrow> A \<subseteq> B"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x::'a set. x) \<Longrightarrow> uminus = (\<lambda>x. uminus (I x))"
nitpick [card = 1-7, expect = none]
by auto

lemma "A \<union> - A = UNIV"
nitpick [expect = none]
by auto

lemma "A \<inter> - A = {}"
nitpick [expect = none]
by auto

lemma "A = -(A::'a set)"
nitpick [card 'a = 10, expect = genuine]
oops

lemma "finite A"
nitpick [expect = none]
oops

lemma "finite A \<Longrightarrow> finite B"
nitpick [expect = none]
oops

lemma "All finite"
nitpick [expect = none]
oops

subsection \<open>The and Eps\<close>

lemma "x = The"
nitpick [card = 5, expect = genuine]
oops

lemma "\<exists>x. x = The"
nitpick [card = 1-3]
by auto

lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> The P = x"
nitpick [expect = none]
by auto

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = z"
nitpick [expect = genuine]
oops

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = x \<or> The P = y"
nitpick [card = 2, expect = none]
nitpick [card = 3-5, expect = genuine]
oops

lemma "P x \<Longrightarrow> P (The P)"
nitpick [card = 1-2, expect = none]
nitpick [card = 8, expect = genuine]
oops

lemma "(\<forall>x. \<not> P x) \<longrightarrow> The P = y"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> The = (\<lambda>x. The (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "x = Eps"
nitpick [card = 5, expect = genuine]
oops

lemma "\<exists>x. x = Eps"
nitpick [card = 1-3, expect = none]
by auto

lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> Eps P = x"
nitpick [expect = none]
by auto

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> Eps P = z"
nitpick [expect = genuine]
apply auto
oops

lemma "P x \<Longrightarrow> P (Eps P)"
nitpick [card = 1-8, expect = none]
by (metis exE_some)

lemma "\<forall>x. \<not> P x \<longrightarrow> Eps P = y"
nitpick [expect = genuine]
oops

lemma "P (Eps P)"
nitpick [expect = genuine]
oops

lemma "Eps (\<lambda>x. x \<in> P) \<in> (P::nat set)"
nitpick [expect = genuine]
oops

lemma "\<not> P (Eps P)"
nitpick [expect = genuine]
oops

lemma "\<not> (P :: nat \<Rightarrow> bool) (Eps P)"
nitpick [expect = genuine]
oops

lemma "P \<noteq> bot \<Longrightarrow> P (Eps P)"
nitpick [expect = none]
sorry

lemma "(P :: nat \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> P (Eps P)"
nitpick [expect = none]
sorry

lemma "P (The P)"
nitpick [expect = genuine]
oops

lemma "(P :: nat \<Rightarrow> bool) (The P)"
nitpick [expect = genuine]
oops

lemma "\<not> P (The P)"
nitpick [expect = genuine]
oops

lemma "\<not> (P :: nat \<Rightarrow> bool) (The P)"
nitpick [expect = genuine]
oops

lemma "The P \<noteq> x"
nitpick [expect = genuine]
oops

lemma "The P \<noteq> (x::nat)"
nitpick [expect = genuine]
oops

lemma "P x \<Longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

lemma "P (x::nat) \<Longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

lemma "P = {x} \<Longrightarrow> (THE x. x \<in> P) \<in> P"
nitpick [expect = none]
oops

lemma "P = {x::nat} \<Longrightarrow> (THE x. x \<in> P) \<in> P"
nitpick [expect = none]
oops

consts Q :: 'a

lemma "Q (Eps Q)"
nitpick [expect = genuine]
oops

lemma "(Q :: nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none] (* unfortunate *)
oops

lemma "\<not> (Q :: nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = genuine]
oops

lemma "\<not> (Q :: nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = genuine]
oops

lemma "(Q::'a \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> (Q::'a \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none]
sorry

lemma "(Q::nat \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> (Q::nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none]
sorry

lemma "Q (The Q)"
nitpick [expect = genuine]
oops

lemma "(Q::nat \<Rightarrow> bool) (The Q)"
nitpick [expect = genuine]
oops

lemma "\<not> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "\<not> (Q::nat \<Rightarrow> bool) (The Q)"
nitpick [expect = genuine]
oops

lemma "The Q \<noteq> x"
nitpick [expect = genuine]
oops

lemma "The Q \<noteq> (x::nat)"
nitpick [expect = genuine]
oops

lemma "Q x \<Longrightarrow> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "Q (x::nat) \<Longrightarrow> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "Q = (\<lambda>x::'a. x = a) \<Longrightarrow> (Q::'a \<Rightarrow> bool) (The Q)"
nitpick [expect = none]
sorry

lemma "Q = (\<lambda>x::nat. x = a) \<Longrightarrow> (Q::nat \<Rightarrow> bool) (The Q)"
nitpick [expect = none]
sorry

nitpick_params [max_potential = 1]

lemma "(THE j. j > Suc 2 \<and> j \<le> 3) \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = potential] (* unfortunate *)
oops

lemma "(THE j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(THE j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x = 4"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(THE j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(THE j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4 \<or> x = 5"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 3) \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x = 4"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(SOME j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4 \<or> x = 5"
nitpick [card nat = 6, expect = none]
sorry

nitpick_params [max_potential = 0]

subsection \<open>Destructors and Recursors\<close>

lemma "(x::'a) = (case True of True \<Rightarrow> x | False \<Rightarrow> x)"
nitpick [card = 2, expect = none]
by auto

lemma "x = (case (x, y) of (x', y') \<Rightarrow> x')"
nitpick [expect = none]
sorry

end


(*  Title:      HOL/Proofs/Extraction/Euclid.thy
    Author:     Markus Wenzel, TU Muenchen
    Author:     Freek Wiedijk, Radboud University Nijmegen
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Euclid's theorem\<close>

theory Euclid
imports
  "HOL-Computational_Algebra.Primes"
  Util
  "HOL-Library.Code_Target_Numeral"
  "HOL-Library.Realizers"
begin

text \<open>
  A constructive version of the proof of Euclid's theorem by
  Markus Wenzel and Freek Wiedijk @{cite "Wenzel-Wiedijk-JAR2002"}.
\<close>

lemma factor_greater_one1: "n = m * k \<Longrightarrow> m < n \<Longrightarrow> k < n \<Longrightarrow> Suc 0 < m"
  by (induct m) auto

lemma factor_greater_one2: "n = m * k \<Longrightarrow> m < n \<Longrightarrow> k < n \<Longrightarrow> Suc 0 < k"
  by (induct k) auto

lemma prod_mn_less_k: "0 < n \<Longrightarrow> 0 < k \<Longrightarrow> Suc 0 < m \<Longrightarrow> m * n = k \<Longrightarrow> n < k"
  by (induct m) auto

lemma prime_eq: "prime (p::nat) \<longleftrightarrow> 1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> 1 < m \<longrightarrow> m = p)"
  apply (simp add: prime_nat_iff)
  apply (rule iffI)
  apply blast
  apply (erule conjE)
  apply (rule conjI)
  apply assumption
  apply (rule allI impI)+
  apply (erule allE)
  apply (erule impE)
  apply assumption
  apply (case_tac "m = 0")
  apply simp
  apply (case_tac "m = Suc 0")
  apply simp
  apply simp
  done

lemma prime_eq': "prime (p::nat) \<longleftrightarrow> 1 < p \<and> (\<forall>m k. p = m * k \<longrightarrow> 1 < m \<longrightarrow> m = p)"
  by (simp add: prime_eq dvd_def HOL.all_simps [symmetric] del: HOL.all_simps)

lemma not_prime_ex_mk:
  assumes n: "Suc 0 < n"
  shows "(\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k) \<or> prime n"
proof -
  from nat_eq_dec have "(\<exists>m<n. n = m * k) \<or> \<not> (\<exists>m<n. n = m * k)" for k
    by (rule search)
  then have "(\<exists>k<n. \<exists>m<n. n = m * k) \<or> \<not> (\<exists>k<n. \<exists>m<n. n = m * k)"
    by (rule search)
  then show ?thesis
  proof
    assume "\<exists>k<n. \<exists>m<n. n = m * k"
    then obtain k m where k: "k<n" and m: "m<n" and nmk: "n = m * k"
      by iprover
    from nmk m k have "Suc 0 < m" by (rule factor_greater_one1)
    moreover from nmk m k have "Suc 0 < k" by (rule factor_greater_one2)
    ultimately show ?thesis using k m nmk by iprover
  next
    assume "\<not> (\<exists>k<n. \<exists>m<n. n = m * k)"
    then have A: "\<forall>k<n. \<forall>m<n. n \<noteq> m * k" by iprover
    have "\<forall>m k. n = m * k \<longrightarrow> Suc 0 < m \<longrightarrow> m = n"
    proof (intro allI impI)
      fix m k
      assume nmk: "n = m * k"
      assume m: "Suc 0 < m"
      from n m nmk have k: "0 < k"
        by (cases k) auto
      moreover from n have n: "0 < n" by simp
      moreover note m
      moreover from nmk have "m * k = n" by simp
      ultimately have kn: "k < n" by (rule prod_mn_less_k)
      show "m = n"
      proof (cases "k = Suc 0")
        case True
        with nmk show ?thesis by (simp only: mult_Suc_right)
      next
        case False
        from m have "0 < m" by simp
        moreover note n
        moreover from False n nmk k have "Suc 0 < k" by auto
        moreover from nmk have "k * m = n" by (simp only: ac_simps)
        ultimately have mn: "m < n" by (rule prod_mn_less_k)
        with kn A nmk show ?thesis by iprover
      qed
    qed
    with n have "prime n"
      by (simp only: prime_eq' One_nat_def simp_thms)
    then show ?thesis ..
  qed
qed

lemma dvd_factorial: "0 < m \<Longrightarrow> m \<le> n \<Longrightarrow> m dvd fact n"
proof (induct n rule: nat_induct)
  case 0
  then show ?case by simp
next
  case (Suc n)
  from \<open>m \<le> Suc n\<close> show ?case
  proof (rule le_SucE)
    assume "m \<le> n"
    with \<open>0 < m\<close> have "m dvd fact n" by (rule Suc)
    then have "m dvd (fact n * Suc n)" by (rule dvd_mult2)
    then show ?thesis by (simp add: mult.commute)
  next
    assume "m = Suc n"
    then have "m dvd (fact n * Suc n)"
      by (auto intro: dvdI simp: ac_simps)
    then show ?thesis by (simp add: mult.commute)
  qed
qed

lemma dvd_prod [iff]: "n dvd (\<Prod>m::nat \<in># mset (n # ns). m)"
  by (simp add: prod_mset_Un)

definition all_prime :: "nat list \<Rightarrow> bool"
  where "all_prime ps \<longleftrightarrow> (\<forall>p\<in>set ps. prime p)"

lemma all_prime_simps:
  "all_prime []"
  "all_prime (p # ps) \<longleftrightarrow> prime p \<and> all_prime ps"
  by (simp_all add: all_prime_def)

lemma all_prime_append: "all_prime (ps @ qs) \<longleftrightarrow> all_prime ps \<and> all_prime qs"
  by (simp add: all_prime_def ball_Un)

lemma split_all_prime:
  assumes "all_prime ms" and "all_prime ns"
  shows "\<exists>qs. all_prime qs \<and>
    (\<Prod>m::nat \<in># mset qs. m) = (\<Prod>m::nat \<in># mset ms. m) * (\<Prod>m::nat \<in># mset ns. m)"
  (is "\<exists>qs. ?P qs \<and> ?Q qs")
proof -
  from assms have "all_prime (ms @ ns)"
    by (simp add: all_prime_append)
  moreover
  have "(\<Prod>m::nat \<in># mset (ms @ ns). m) = (\<Prod>m::nat \<in># mset ms. m) * (\<Prod>m::nat \<in># mset ns. m)"
    using assms by (simp add: prod_mset_Un)
  ultimately have "?P (ms @ ns) \<and> ?Q (ms @ ns)" ..
  then show ?thesis ..
qed

lemma all_prime_nempty_g_one:
  assumes "all_prime ps" and "ps \<noteq> []"
  shows "Suc 0 < (\<Prod>m::nat \<in># mset ps. m)"
  using \<open>ps \<noteq> []\<close> \<open>all_prime ps\<close>
  unfolding One_nat_def [symmetric]
  by (induct ps rule: list_nonempty_induct)
    (simp_all add: all_prime_simps prod_mset_Un prime_gt_1_nat less_1_mult del: One_nat_def)

lemma factor_exists: "Suc 0 < n \<Longrightarrow> (\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = n)"
proof (induct n rule: nat_wf_ind)
  case (1 n)
  from \<open>Suc 0 < n\<close>
  have "(\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k) \<or> prime n"
    by (rule not_prime_ex_mk)
  then show ?case
  proof
    assume "\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k"
    then obtain m k where m: "Suc 0 < m" and k: "Suc 0 < k" and mn: "m < n"
      and kn: "k < n" and nmk: "n = m * k"
      by iprover
    from mn and m have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = m"
      by (rule 1)
    then obtain ps1 where "all_prime ps1" and prod_ps1_m: "(\<Prod>m::nat \<in># mset ps1. m) = m"
      by iprover
    from kn and k have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = k"
      by (rule 1)
    then obtain ps2 where "all_prime ps2" and prod_ps2_k: "(\<Prod>m::nat \<in># mset ps2. m) = k"
      by iprover
    from \<open>all_prime ps1\<close> \<open>all_prime ps2\<close>
    have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) =
      (\<Prod>m::nat \<in># mset ps1. m) * (\<Prod>m::nat \<in># mset ps2. m)"
      by (rule split_all_prime)
    with prod_ps1_m prod_ps2_k nmk show ?thesis by simp
  next
    assume "prime n" then have "all_prime [n]" by (simp add: all_prime_simps)
    moreover have "(\<Prod>m::nat \<in># mset [n]. m) = n" by (simp)
    ultimately have "all_prime [n] \<and> (\<Prod>m::nat \<in># mset [n]. m) = n" ..
    then show ?thesis ..
  qed
qed

lemma prime_factor_exists:
  assumes N: "(1::nat) < n"
  shows "\<exists>p. prime p \<and> p dvd n"
proof -
  from N obtain ps where "all_prime ps" and prod_ps: "n = (\<Prod>m::nat \<in># mset ps. m)"
    using factor_exists by simp iprover
  with N have "ps \<noteq> []"
    by (auto simp add: all_prime_nempty_g_one)
  then obtain p qs where ps: "ps = p # qs"
    by (cases ps) simp
  with \<open>all_prime ps\<close> have "prime p"
    by (simp add: all_prime_simps)
  moreover from \<open>all_prime ps\<close> ps prod_ps have "p dvd n"
    by (simp only: dvd_prod)
  ultimately show ?thesis by iprover
qed

text \<open>Euclid's theorem: there are infinitely many primes.\<close>

lemma Euclid: "\<exists>p::nat. prime p \<and> n < p"
proof -
  let ?k = "fact n + (1::nat)"
  have "1 < ?k" by simp
  then obtain p where prime: "prime p" and dvd: "p dvd ?k"
    using prime_factor_exists by iprover
  have "n < p"
  proof -
    have "\<not> p \<le> n"
    proof
      assume pn: "p \<le> n"
      from \<open>prime p\<close> have "0 < p" by (rule prime_gt_0_nat)
      then have "p dvd fact n" using pn by (rule dvd_factorial)
      with dvd have "p dvd ?k - fact n" by (rule dvd_diff_nat)
      then have "p dvd 1" by simp
      with prime show False by auto
    qed
    then show ?thesis by simp
  qed
  with prime show ?thesis by iprover
qed

extract Euclid

text \<open>
  The program extracted from the proof of Euclid's theorem looks as follows.
  @{thm [display] Euclid_def}
  The program corresponding to the proof of the factorization theorem is
  @{thm [display] factor_exists_def}
\<close>

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation list :: (type) default
begin

definition "default = []"

instance ..

end

primrec iterate :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
where
  "iterate 0 f x = []"
| "iterate (Suc n) f x = (let y = f x in y # iterate n f y)"

lemma "factor_exists 1007 = [53, 19]" by eval
lemma "factor_exists 567 = [7, 3, 3, 3, 3]" by eval
lemma "factor_exists 345 = [23, 5, 3]" by eval
lemma "factor_exists 999 = [37, 3, 3, 3]" by eval
lemma "factor_exists 876 = [73, 3, 2, 2]" by eval

lemma "iterate 4 Euclid 0 = [2, 3, 7, 71]" by eval

end


(*
  File:    Pi_pmf.thy
  Authors: Manuel Eberl, Max W. Haslbeck
*)
section \<open>Theorems about the Geometric Distribution\<close>
theory Geometric_PMF
  imports
    "HOL-Probability.Probability"
    Pi_pmf
    "Monad_Normalisation.Monad_Normalisation"
begin

lemma nn_integral_geometric_pmf:
  assumes "p \<in> {0<..1}"
  shows   "nn_integral (geometric_pmf p) real = (1 - p) / p"
 using assms expectation_geometric_pmf integrable_real_geometric_pmf
  by (subst nn_integral_eq_integral) auto

lemma geometric_pmf_prob_atMost:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {..n} = (1 - (1 - p)^(n + 1))"
proof -
  have "(\<Sum>x\<le>n. (1 - p) ^ x * p) = 1 - (1 - p) * (1 - p) ^ n"
    by (induction n) (auto simp add: algebra_simps)
  then show ?thesis
  using assms by (auto simp add: measure_pmf_conv_infsetsum)
qed

lemma geometric_pmf_prob_lessThan:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {..<n} = 1 - (1 - p) ^ n"
proof -
  have "(\<Sum>x<n. (1 - p) ^ x * p) = 1 - (1 - p) ^ n"
    by (induction n) (auto simp add: algebra_simps)
  then show ?thesis
  using assms by (auto simp add: measure_pmf_conv_infsetsum)
qed

lemma geometric_pmf_prob_greaterThan:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {n<..} = (1 - p)^(n + 1)"
proof -
  have "(UNIV - {..n}) = {n<..}"
    by auto
  moreover have "measure_pmf.prob (geometric_pmf p) (UNIV - {..n}) = (1 - p) ^ (n + 1)"
    using assms by (subst measure_pmf.finite_measure_Diff)
                   (auto simp add: geometric_pmf_prob_atMost)
  ultimately show ?thesis
    by auto
qed

lemma geometric_pmf_prob_atLeast:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {n..} = (1 - p)^n"
proof -
  have "(UNIV - {..<n}) = {n..}"
    by auto
  moreover have "measure_pmf.prob (geometric_pmf p) (UNIV - {..<n}) = (1 - p) ^ n"
    using assms by (subst measure_pmf.finite_measure_Diff)
                   (auto simp add: geometric_pmf_prob_lessThan)
  ultimately show ?thesis
    by auto
qed

lemma bernoulli_pmf_of_set':
  assumes "finite A"
  shows "map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2))) = pmf_of_set (Pow A)"
proof -
  have *: "Pi_pmf A P (\<lambda>_. pmf_of_set (UNIV :: bool set)) = pmf_of_set (PiE_dflt A P (\<lambda>_. UNIV :: bool set))"
    using assms by (intro Pi_pmf_of_set) auto
  have "map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1 / 2))) =
        map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. pmf_of_set UNIV))"
    using bernoulli_pmf_half_conv_pmf_of_set by auto
  also have "\<dots> = map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (pmf_of_set (PiE_dflt A P (\<lambda>_. UNIV)))"
    using assms by (subst Pi_pmf_of_set) (auto)
  also have "\<dots> = pmf_of_set (Pow A)"
  proof -
    have "bij_betw (\<lambda>b. {x \<in> A. \<not> b x}) (PiE_dflt A P (\<lambda>_. UNIV)) (Pow A)"
      by (rule bij_betwI[of _ _ _ "\<lambda>B b. if b \<in> A then \<not> (b \<in> B) else P"]) (auto simp add: PiE_dflt_def)
    then show ?thesis
      using assms by (intro map_pmf_of_set_bij_betw) auto
  qed
  finally show ?thesis
    by simp
qed

lemma Pi_pmf_pmf_of_set_Suc:
  assumes "finite A"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
       do {
         B \<leftarrow> pmf_of_set (Pow A);
         Pi_pmf B 0 (\<lambda>_. map_pmf Suc (geometric_pmf (1/2))) }"
proof -
  have "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
        Pi_pmf A 0 (\<lambda>_. bernoulli_pmf (1/2) \<bind>
        (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst geometric_bind_pmf_unfold) auto
  also have "\<dots> =
             Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)) \<bind>
             (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst Pi_pmf_bind[of _ _ _ _ False]) auto
  also have "\<dots> =
             do {b \<leftarrow> Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2));
                 Pi_pmf {x \<in> A. ~b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    using assms by (subst Pi_pmf_if_set') auto
  also have "\<dots> =
             do {B \<leftarrow> map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)));
                 Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    unfolding map_pmf_def apply(subst bind_assoc_pmf) apply(subst bind_return_pmf) by auto
  also have "\<dots> = pmf_of_set (Pow A) \<bind> (\<lambda>B. Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1 / 2))))"
    unfolding assms using assms by (subst bernoulli_pmf_of_set') auto
  finally show ?thesis
    by simp
qed

lemma Pi_pmf_pmf_of_set_Suc':
  assumes "finite A"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
       do {
         B \<leftarrow> pmf_of_set (Pow A);
         Pi_pmf B 0 (\<lambda>_. map_pmf Suc (geometric_pmf (1/2))) }"
proof -
  have "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
        Pi_pmf A 0 (\<lambda>_. bernoulli_pmf (1/2) \<bind>
        (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst geometric_bind_pmf_unfold) auto
  also have "\<dots> =
             Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)) \<bind>
             (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst Pi_pmf_bind[of _ _ _ _ False]) auto
  also have "\<dots> =
             do {b \<leftarrow> Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2));
                 Pi_pmf {x \<in> A. ~b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    using assms by (subst Pi_pmf_if_set') auto
  also have "\<dots> =
             do {B \<leftarrow> map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)));
                 Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    unfolding map_pmf_def by (auto simp add: bind_assoc_pmf bind_return_pmf)
  also have "\<dots> = pmf_of_set (Pow A) \<bind> (\<lambda>B. Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1 / 2))))"
    unfolding assms using assms by (subst bernoulli_pmf_of_set') auto
  finally show ?thesis
    by simp
qed

lemma binomial_pmf_altdef':
  fixes A :: "'a set"
  assumes "finite A" and "card A = n" and p: "p \<in> {0..1}"
  shows   "binomial_pmf n p =
             map_pmf (\<lambda>f. card {x\<in>A. f x}) (Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p))" (is "?lhs = ?rhs")
proof -
  from assms have "?lhs = binomial_pmf (card A) p"
    by simp
  also have "\<dots> = ?rhs"
  using assms(1)
  proof (induction rule: finite_induct)
    case empty
    with p show ?case by (simp add: binomial_pmf_0)
  next
    case (insert x A)
    from insert.hyps have "card (insert x A) = Suc (card A)"
      by simp
    also have "binomial_pmf \<dots> p = do {
                                     b \<leftarrow> bernoulli_pmf p;
                                     f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                                     return_pmf ((if b then 1 else 0) + card {y \<in> A. f y})
                                   }"
      using p by (simp add: binomial_pmf_Suc insert.IH bind_map_pmf)
    also have "\<dots> = do {
                      b \<leftarrow> bernoulli_pmf p;
                      f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                      return_pmf (card {y \<in> insert x A. (f(x := b)) y})
                    }"
    proof (intro bind_pmf_cong refl, goal_cases)
      case (1 b f)
      have "(if b then 1 else 0) + card {y\<in>A. f y} = card ((if b then {x} else {}) \<union> {y\<in>A. f y})"
        using insert.hyps by auto
      also have "(if b then {x} else {}) \<union> {y\<in>A. f y} = {y\<in>insert x A. (f(x := b)) y}"
        using insert.hyps by auto
      finally show ?case by simp
    qed
    also have "\<dots> = map_pmf (\<lambda>f. card {y\<in>insert x A. f y})
                      (Pi_pmf (insert x A) dflt (\<lambda>_. bernoulli_pmf p))"
      using insert.hyps by (subst Pi_pmf_insert) (simp_all add: pair_pmf_def map_bind_pmf)
    finally show ?case .
  qed
  finally show ?thesis .
qed

lemma bernoulli_pmf_Not:
  assumes "p \<in> {0..1}"
  shows "bernoulli_pmf p = map_pmf Not (bernoulli_pmf (1 - p))"
proof -
  have *: "(Not -` {True}) = {False}" "(Not -` {False}) = {True}"
    by blast+
  have "pmf (bernoulli_pmf p) b = pmf (map_pmf Not (bernoulli_pmf (1 - p))) b" for b
    using assms by (cases b) (auto simp add: pmf_map * measure_pmf_single)
  then show ?thesis
    by (rule pmf_eqI)
qed

lemma binomial_pmf_altdef'':
  assumes p: "p \<in> {0..1}"
  shows   "binomial_pmf n p =
           map_pmf (\<lambda>f. card {x. x < n \<and> f x}) (Pi_pmf {..<n} dflt (\<lambda>_. bernoulli_pmf p))"
  using assms by (subst binomial_pmf_altdef'[of "{..<n}"]) (auto)

context includes monad_normalisation
begin

lemma Pi_pmf_geometric_filter:
  assumes "finite A" "p \<in> {0<..1}"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
       do {
         fb \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
         Pi_pmf {x \<in> A. \<not> fb x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) }"
proof -
  have "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
        Pi_pmf A 0 (\<lambda>_. bernoulli_pmf p \<bind>
                   (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))"
    using assms by (subst geometric_bind_pmf_unfold) auto
  also have "\<dots> =
             Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p) \<bind>
             (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf p)))"
    using assms by (subst Pi_pmf_bind[of _ _ _ _ dflt]) auto
  also have "\<dots> =
             do {b \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                 Pi_pmf {x \<in> A. \<not> b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf p))}"
    using assms by (subst Pi_pmf_if_set') (auto)
  finally show ?thesis
    by simp
qed

lemma Pi_pmf_geometric_filter':
  assumes "finite A" "p \<in> {0<..1}"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
       do {
         fb \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf (1 - p));
         Pi_pmf {x \<in> A. fb x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) }"
  using assms by (auto simp add: Pi_pmf_geometric_filter[of _ _ "\<not> dflt"] bernoulli_pmf_Not[of p]
      Pi_pmf_map[of _ _ dflt] map_pmf_def[of "((\<circ>) Not)"])

end

end


section "Arithmetic and Boolean Expressions"

theory AExp2 imports Main begin

subsection "Arithmetic Expressions"

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

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp2 = N int | V vname | Plus aexp2 aexp2 | Div aexp2 aexp2 | Inc vname
text_raw{*}%endsnip*}

text {* A little syntax magic to write larger states compactly: *}

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

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

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val * state) option" where
"aval2 (N n) s = Some(n, s)" |
"aval2 (V x) s = Some(s x, s)" |
"aval2 (Plus a\<^sub>1 a\<^sub>2) s =
    (case aval2 a\<^sub>1 s of
         Some(v1, s1) \<Rightarrow>
              (case aval2 a\<^sub>2 s1 of
                  Some(v2, s2) \<Rightarrow> Some(v1 + v2, s2) |
                  None \<Rightarrow> None) |
         None \<Rightarrow> None)" |
"aval2 (Div a\<^sub>1 a\<^sub>2) s =
    (case aval2 a\<^sub>1 s of
         Some(v1, s1) \<Rightarrow>
              (case aval2 a\<^sub>2 s1 of
                  Some(v2, s2) \<Rightarrow> Some(v1 div v2, s2) |
                  None \<Rightarrow> None) |
         None \<Rightarrow> None)" |
"aval2 (Inc x) s =
    (let v = s x + 1 in
        Some(v, s(x := v)))"
text_raw{*}%endsnip*}

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

text {* The same state more concisely: *}
value "aval2 (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

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

value "aval2 (Inc ''x'') <''x'' := 6>"
value "aval2 (Inc ''x'') <''y'' := 6>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

fun plus :: "aexp2 \<Rightarrow> aexp2 \<Rightarrow> aexp2" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus[simp]:
  "aval2 (plus a1 a2) s =
       (case aval2 a1 s of
           Some(v1, s1) \<Rightarrow>
               (case aval2 a2 s1 of
                   Some(v2, s2) \<Rightarrow> Some(v1 + v2, s2) |
                   None \<Rightarrow> None) |
           None \<Rightarrow> None)"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

end


(* Author: Dmitriy Traytel *)

section \<open>Normalization of M2L Formulas\<close>

(*<*)
theory M2L_Normalization
imports M2L
begin
(*>*)

fun nNot where
  "nNot (FNot \<phi>) = \<phi>"
| "nNot (FAnd \<phi>1 \<phi>2) = FOr (nNot \<phi>1) (nNot \<phi>2)"
| "nNot (FOr \<phi>1 \<phi>2) = FAnd (nNot \<phi>1) (nNot \<phi>2)"
| "nNot \<phi> = FNot \<phi>"

primrec norm where
  "norm (FQ a m) = FQ a m"
| "norm (FLess m n) = FLess m n"
| "norm (FIn m M) = FIn m M"
| "norm (FOr \<phi> \<psi>) = FOr (norm \<phi>) (norm \<psi>)"
| "norm (FAnd \<phi> \<psi>) = FAnd (norm \<phi>) (norm \<psi>)"
| "norm (FNot \<phi>) = nNot (norm \<phi>)"
| "norm (FExists \<phi>) = FExists (norm \<phi>)"
| "norm (FEXISTS \<phi>) = FEXISTS (norm \<phi>)"

context formula
begin

lemma satisfies_nNot[simp]: "satisfies (w, I) (nNot \<phi>) = satisfies (w,I) (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma FOV_nNot[simp]: "FOV (nNot \<phi>) = FOV (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma SOV_nNot[simp]: "SOV (nNot \<phi>) = SOV (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma pre_wf_formula_nNot[simp]: "pre_wf_formula n (nNot \<phi>) = pre_wf_formula n (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma FOV_norm[simp]: "FOV (norm \<phi>) = FOV \<phi>"
  by (induct \<phi>) auto

lemma SOV_norm[simp]: "SOV (norm \<phi>) = SOV \<phi>"
  by (induct \<phi>) auto

lemma pre_wf_formula_norm[simp]: "pre_wf_formula n (norm \<phi>) = pre_wf_formula n \<phi>"
  by (induct \<phi> arbitrary: n) auto

lemma satisfies_norm[simp]: "satisfies (w, I) (norm \<phi>) = satisfies (w, I) \<phi>"
  by (induct \<phi> arbitrary: I) auto

lemma lang\<^sub>M\<^sub>2\<^sub>L_norm[simp]: "lang\<^sub>M\<^sub>2\<^sub>L n (norm \<phi>) = lang\<^sub>M\<^sub>2\<^sub>L n \<phi>"
  unfolding lang\<^sub>M\<^sub>2\<^sub>L_def by auto

end

(*<*)
end
(*>*)


theory tree_Flatten1List
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil2

fun flatten1 :: "('a Tree) list => 'a list" where
"flatten1 (Nil2) = Nil2"
| "flatten1 (Cons2 (Node (Node x3 x4 x5) x2 q) ps) =
     flatten1 (Cons2 (Node x3 x4 x5) (Cons2 (Node (Nil2) x2 q) ps))"
| "flatten1 (Cons2 (Node (Nil2) x2 q) ps) =
     Cons2 x2 (flatten1 (Cons2 q ps))"
| "flatten1 (Cons2 (Nil2) ps) = flatten1 ps"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun concatMap :: "('t => 't2 list) => 't list => 't2 list" where
"concatMap x (Nil2) = Nil2"
| "concatMap x (Cons2 z xs) = append (x z) (concatMap x xs)"

fun flatten0 :: "'a Tree => 'a list" where
"flatten0 (Node p y q) =
   append (append (flatten0 p) (Cons2 y (Nil2))) (flatten0 q)"
| "flatten0 (Nil2) = Nil2"

(*hipster flatten1 append concatMap flatten0 *)

theorem x0 :
  "!! (ps :: ('a Tree) list) .
     (flatten1 ps) = (concatMap (% (x :: 'a Tree) => flatten0 x) ps)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* Title:      Monotonic Boolean Transformers
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Monotonic Boolean Transformers\<close>

theory Monotonic_Boolean_Transformers

imports MonoBoolTranAlgebra.Assertion_Algebra Base

begin

no_notation inf (infixl "\<sqinter>" 70)
no_notation uminus ("- _" [81] 80)

context mbt_algebra
begin

lemma directed_left_mult:
  "directed Y \<Longrightarrow> directed ((*) x ` Y)"
  apply (unfold directed_def)
  using le_comp by blast

lemma neg_assertion:
  "neg_assert x \<in> assertion"
  by (metis bot_comp neg_assert_def wpt_def wpt_is_assertion mult_assoc)

lemma assertion_neg_assert:
  "x \<in> assertion \<longleftrightarrow> x = neg_assert (neg_assert x)"
  by (metis neg_assertion uminus_uminus)

text \<open>extend and dualise part of Viorel Preoteasa's theory\<close>

definition "assumption \<equiv> {x . 1 \<le> x \<and> (x * bot) \<squnion> (x ^ o) = x}"

definition "neg_assume (x::'a) \<equiv> (x ^ o * top) \<squnion> 1"

lemma neg_assume_assert:
  "neg_assume x = (neg_assert (x ^ o)) ^ o"
  using dual_bot dual_comp dual_dual dual_inf dual_one neg_assert_def neg_assume_def by auto

lemma assert_iff_assume:
  "x \<in> assertion \<longleftrightarrow> x ^ o \<in> assumption"
  by (smt assertion_def assumption_def dual_bot dual_comp dual_dual dual_inf dual_le dual_one mem_Collect_eq)

lemma assertion_iff_assumption_subseteq:
  "X \<subseteq> assertion \<longleftrightarrow> dual ` X \<subseteq> assumption"
  using assert_iff_assume by blast

lemma assumption_iff_assertion_subseteq:
  "X \<subseteq> assumption \<longleftrightarrow> dual ` X \<subseteq> assertion"
  using assert_iff_assume by auto

lemma assumption_prop:
  "x \<in> assumption \<Longrightarrow> (x * bot) \<squnion> 1 = x"
  by (smt assert_iff_assume assertion_prop dual_comp dual_dual dual_neg_top dual_one dual_sup dual_top)

lemma neg_assumption:
  "neg_assume x \<in> assumption"
  using assert_iff_assume neg_assertion neg_assume_assert by auto

lemma assumption_neg_assume:
  "x \<in> assumption \<longleftrightarrow> x = neg_assume (neg_assume x)"
  by (smt assert_iff_assume assertion_neg_assert dual_dual neg_assume_assert)

lemma assumption_sup_comp_eq:
  "x \<in> assumption \<Longrightarrow> y \<in> assumption \<Longrightarrow> x \<squnion> y = x * y"
  by (smt assert_iff_assume assertion_inf_comp_eq dual_comp dual_dual dual_sup)

lemma sup_uminus_assume[simp]:
  "x \<in> assumption \<Longrightarrow> x \<sqinter> neg_assume x = 1"
  by (smt assert_iff_assume dual_dual dual_one dual_sup neg_assume_assert sup_uminus)

lemma inf_uminus_assume[simp]:
  "x \<in> assumption \<Longrightarrow> x \<squnion> neg_assume x = top"
  by (smt assert_iff_assume dual_dual dual_sup dual_top inf_uminus neg_assume_assert sup_bot_right)

lemma uminus_assumption[simp]:
  "x \<in> assumption \<Longrightarrow> neg_assume x \<in> assumption"
  by (simp add: neg_assumption)

lemma uminus_uminus_assume[simp]:
  "x \<in> assumption \<Longrightarrow> neg_assume (neg_assume x) = x"
  by (simp add: assumption_neg_assume)

lemma sup_assumption[simp]:
  "x \<in> assumption \<Longrightarrow> y \<in> assumption \<Longrightarrow> x \<squnion> y \<in> assumption"
  by (smt assert_iff_assume dual_dual dual_sup inf_assertion)

lemma comp_assumption[simp]:
  "x \<in> assumption \<Longrightarrow> y \<in> assumption \<Longrightarrow> x * y \<in> assumption"
  using assumption_sup_comp_eq sup_assumption by auto

lemma inf_assumption[simp]:
  "x \<in> assumption \<Longrightarrow> y \<in> assumption \<Longrightarrow> x \<sqinter> y \<in> assumption"
  by (smt assert_iff_assume dual_dual dual_inf sup_assertion)

lemma assumption_comp_idempotent[simp]:
  "x \<in> assumption \<Longrightarrow> x * x = x"
  using assumption_sup_comp_eq by fastforce

lemma assumption_comp_idempotent_dual[simp]:
  "x \<in> assumption \<Longrightarrow> (x ^ o) * (x ^ o) = x ^ o"
  by (metis assumption_comp_idempotent dual_comp)

lemma top_assumption[simp]:
  "top \<in> assumption"
  by (simp add: assumption_def)

lemma one_assumption[simp]:
  "1 \<in> assumption"
  by (simp add: assumption_def)

lemma assert_top:
  "neg_assert (neg_assert p) ^ o * bot = neg_assert p * top"
  by (smt bot_comp dual_comp dual_dual dual_top inf_comp inf_top_right mult.assoc mult.left_neutral neg_assert_def)

lemma assume_bot:
  "neg_assume (neg_assume p) ^ o * top = neg_assume p * bot"
  by (smt assert_top dual_bot dual_comp dual_dual neg_assume_assert)

definition "wpb x \<equiv> (x * bot) \<squnion> 1"

lemma wpt_iff_wpb:
  "wpb x = wpt (x ^ o) ^ o"
  using dual_comp dual_dual dual_inf dual_one dual_top wpt_def wpb_def by auto

lemma wpb_is_assumption[simp]:
  "wpb x \<in> assumption"
  using assert_iff_assume wpt_is_assertion wpt_iff_wpb by auto

lemma wpb_comp:
  "(wpb x) * x = x"
  by (smt dual_comp dual_dual dual_neg_top dual_sup wpt_comp wpt_iff_wpb)

lemma wpb_comp_2:
  "wpb (x * y) = wpb (x * (wpb y))"
  by (simp add: sup_comp mult_assoc wpb_def)

lemma wpb_assumption[simp]:
  "x \<in> assumption \<Longrightarrow> wpb x = x"
  by (simp add: assumption_prop wpb_def)

lemma wpb_choice:
  "wpb (x \<squnion> y) = wpb x \<squnion> wpb y"
  using sup_assoc sup_commute sup_comp wpb_def by auto

lemma wpb_dual_assumption:
  "x \<in> assumption \<Longrightarrow> wpb (x ^ o) = 1"
  by (smt assert_iff_assume dual_dual dual_one wpt_dual_assertion wpt_iff_wpb)

lemma wpb_mono:
  "x \<le> y \<Longrightarrow> wpb x \<le> wpb y"
  by (metis le_iff_sup wpb_choice)

lemma assumption_disjunctive:
  "x \<in> assumption \<Longrightarrow> x \<in> disjunctive"
  by (smt assert_iff_assume assertion_conjunctive dual_comp dual_conjunctive dual_dual)

lemma assumption_conjunctive:
  "x \<in> assumption \<Longrightarrow> x \<in> conjunctive"
  by (smt assert_iff_assume assertion_disjunctive dual_comp dual_disjunctive dual_dual)

lemma wpb_le_assumption:
  "x \<in> assumption \<Longrightarrow> x * y = y \<Longrightarrow> x \<le> wpb y"
  by (metis assumption_prop bot_least le_comp sup_commute sup_right_isotone mult_assoc wpb_def)

definition dual_omega :: "'a \<Rightarrow> 'a" ("(_ ^ \<mho>)" [81] 80)
  where "(x ^ \<mho>) \<equiv> (((x ^ o) ^ \<omega>) ^ o)"

lemma dual_omega_fix:
  "x^\<mho> = (x * (x^\<mho>)) \<squnion> 1"
  by (smt dual_comp dual_dual dual_omega_def dual_one dual_sup omega_fix)

lemma dual_omega_comp_fix:
  "x^\<mho> * y = (x * (x^\<mho>) * y) \<squnion> y"
  by (metis dual_omega_fix mult_1_left sup_comp)

lemma dual_omega_greatest:
  "z \<le> (x * z) \<squnion> y \<Longrightarrow> z \<le> (x^\<mho>) * y"
  by (smt dual_comp dual_dual dual_le dual_neg_top dual_omega_def dual_sup omega_least)

end

context post_mbt_algebra
begin

lemma post_antitone:
  assumes "x \<le> y"
    shows "post y \<le> post x"
proof -
  have "post y \<le> post x * y * top \<sqinter> post y"
    by (metis assms inf_top_left post_1 inf_mono le_comp_left_right order_refl)
  thus ?thesis
    using order_lesseq_imp post_2 by blast
qed

lemma post_assumption_below_one:
  "q \<in> assumption \<Longrightarrow> post q \<le> post 1"
  by (simp add: assumption_def post_antitone)

lemma post_assumption_above_one:
  "q \<in> assumption \<Longrightarrow> post 1 \<le> post (q ^ o)"
  by (metis dual_le dual_one post_antitone sup.commute sup_ge1 wpb_assumption wpb_def)

lemma post_assumption_below_dual:
  "q \<in> assumption \<Longrightarrow> post q \<le> post (q ^ o)"
  using order_trans post_assumption_above_one post_assumption_below_one by blast

lemma assumption_assertion_absorb:
  "q \<in> assumption \<Longrightarrow> q * (q ^ o) = q"
  by (smt CollectE assumption_def assumption_prop bot_comp mult.left_neutral mult_assoc sup_comp)

lemma post_dual_below_post_one:
  assumes "q \<in> assumption"
  shows "post (q ^ o) \<le> post 1 * q"
proof -
  have "post (q ^ o) \<le> post 1 * q * (q ^ o) * top \<sqinter> post (q ^ o)"
    by (metis assms assumption_assertion_absorb gt_one_comp inf_le1 inf_top_left mult_assoc order_refl post_1 sup_uminus_assume top_unique)
  thus ?thesis
    using order_lesseq_imp post_2 by blast
qed

lemma post_below_post_one:
  "q \<in> assumption \<Longrightarrow> post q \<le> post 1 * q"
  using order.trans post_assumption_below_dual post_dual_below_post_one by blast

end

context complete_mbt_algebra
begin

lemma Inf_assumption[simp]:
  "X \<subseteq> assumption \<Longrightarrow> Inf X \<in> assumption"
  by (metis Sup_assertion assert_iff_assume assumption_iff_assertion_subseteq dual_Inf dual_dual)

definition "continuous x \<equiv> (\<forall>Y . directed Y \<longrightarrow> x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y))"

definition "Continuous \<equiv> { x . continuous x }"

lemma continuous_Continuous:
  "continuous x \<longleftrightarrow> x \<in> Continuous"
  by (simp add: Continuous_def)

text \<open>Theorem 53.1\<close>

lemma one_continuous:
  "1 \<in> Continuous"
  by (simp add: Continuous_def continuous_def image_def)

lemma continuous_dist_ascending_chain:
  assumes "x \<in> Continuous"
      and "ascending_chain f"
    shows "x * (SUP n::nat . f n) = (SUP n::nat . x * f n)"
proof -
  have "directed (range f)"
    by (simp add: assms(2) ascending_chain_directed)
  hence "x * (SUP n::nat . f n) = (SUP y\<in>range f . x * y)"
    using assms(1) continuous_Continuous continuous_def by auto
  thus ?thesis
    by (simp add: range_composition)
qed

text \<open>Theorem 53.1\<close>

lemma assertion_continuous:
  assumes "x \<in> assertion"
    shows "x \<in> Continuous"
proof -
  have 1: "x = (x * top) \<sqinter> 1"
    using assms assertion_prop by auto
  have "\<forall>Y . directed Y \<longrightarrow> x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y" (* assumption not used *)
    have "x * (SUP y\<in>Y . y) = (x * top) \<sqinter> (SUP y\<in>Y . y)"
      using 1 by (smt inf_comp mult.assoc mult.left_neutral top_comp)
    also have "... = (SUP y\<in>Y . (x * top) \<sqinter> y)"
      by (simp add: inf_Sup)
    finally show "x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
      using 1 by (smt inf_comp mult.left_neutral mult.assoc top_comp SUP_cong)
  qed
  thus ?thesis
    by (simp add: continuous_def Continuous_def)
qed

text \<open>Theorem 53.1\<close>

lemma assumption_continuous:
  assumes "x \<in> assumption"
    shows "x \<in> Continuous"
proof -
  have 1: "x = (x * bot) \<squnion> 1"
    by (simp add: assms assumption_prop)
  have "\<forall>Y . directed Y \<longrightarrow> x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume 2: "directed Y"
    have "x * (SUP y\<in>Y . y) = (x * bot) \<squnion> (SUP y\<in>Y . y)"
      using 1 by (smt sup_comp mult.assoc mult.left_neutral bot_comp)
    also have "... = (SUP y\<in>Y . (x * bot) \<squnion> y)"
      using 2 by (smt (verit, ccfv_threshold) sup_SUP SUP_cong directed_def)
    finally show "x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
      using 1 by (metis sup_comp mult.left_neutral mult.assoc bot_comp SUP_cong)
  qed
  thus ?thesis
    by (simp add: continuous_def Continuous_def)
qed

text \<open>Theorem 53.1\<close>

lemma mult_continuous:
  assumes "x \<in> Continuous"
      and "y \<in> Continuous"
    shows "x * y \<in> Continuous"
proof -
  have "\<forall>Y. directed Y \<longrightarrow> x * y * (SUP y\<in>Y . y) = (SUP z\<in>Y . x * y * z)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "x * y * (SUP w\<in>Y . w) = (SUP z\<in>Y . x * (y * z))"
      by (metis assms continuous_Continuous continuous_def directed_left_mult image_ident image_image mult_assoc)
    thus "x * y * (SUP y\<in>Y . y) = (SUP z\<in>Y . x * y * z)"
      using mult_assoc by auto
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text \<open>Theorem 53.1\<close>

lemma sup_continuous:
  "x \<in> Continuous \<Longrightarrow> y \<in> Continuous \<Longrightarrow> x \<squnion> y \<in> Continuous"
  by (smt SUP_cong SUP_sup_distrib continuous_Continuous continuous_def sup_comp)

text \<open>Theorem 53.1\<close>

lemma inf_continuous:
  assumes "x \<in> Continuous"
      and "y \<in> Continuous"
    shows "x \<sqinter> y \<in> Continuous"
proof -
  have "\<forall>Y. directed Y \<longrightarrow> (x \<sqinter> y) * (SUP y\<in>Y . y) = (SUP z\<in>Y . (x \<sqinter> y) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume 1: "directed Y"
    have 2: "(SUP w\<in>Y . SUP z\<in>Y . (x * w) \<sqinter> (y * z)) \<le> (SUP z\<in>Y . (x * z) \<sqinter> (y * z))"
    proof (intro SUP_least)
      fix w z
      assume "w \<in> Y" and "z \<in> Y"
      from this obtain v where 3: "v\<in>Y \<and> w \<le> v \<and> z \<le> v"
        using 1 by (meson directed_def)
      hence "x * w \<sqinter> (y * z) \<le> (x * v) \<sqinter> (y * v)"
        by (meson inf.sup_mono le_comp)
      thus "x * w \<sqinter> (y * z) \<le> (SUP z\<in>Y . (x * z) \<sqinter> (y * z))"
        using 3 by (meson SUP_upper2)
    qed
    have "(SUP z\<in>Y . (x * z) \<sqinter> (y * z)) \<le> (SUP w\<in>Y . SUP z\<in>Y . (x * w) \<sqinter> (y * z))"
      apply (rule SUP_least)
      by (meson SUP_upper SUP_upper2)
    hence "(SUP w\<in>Y . SUP z\<in>Y . (x * w) \<sqinter> (y * z)) = (SUP z\<in>Y . (x \<sqinter> y) * z)"
      using 2 order.antisym inf_comp by auto
    thus "(x \<sqinter> y) * (SUP y\<in>Y . y) = (SUP z\<in>Y . (x \<sqinter> y) * z)"
      using 1 by (metis assms inf_comp continuous_Continuous continuous_def SUP_inf_distrib2)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text \<open>Theorem 53.1\<close>

lemma dual_star_continuous:
  assumes "x \<in> Continuous"
    shows "x ^ \<otimes> \<in> Continuous"
proof -
  have "\<forall>Y. directed Y \<longrightarrow> (x ^ \<otimes>) * (SUP y\<in>Y . y) = (SUP z\<in>Y . (x ^ \<otimes>) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "directed ((*) (x ^ \<otimes>) ` Y)"
      by (simp add: directed_left_mult)
    hence "x * (SUP y\<in>Y . (x ^ \<otimes>) * y) = (SUP y\<in>Y . x * ((x ^ \<otimes>) * y))"
      by (metis assms continuous_Continuous continuous_def image_ident image_image)
    also have "... = (SUP y\<in>Y . x * (x ^ \<otimes>) * y)"
      using mult_assoc by auto
    also have "... \<le> (SUP y\<in>Y . (x ^ \<otimes>) * y)"
      apply (rule SUP_least)
      by (simp add: SUP_upper2 dual_star_comp_fix)
    finally have "x * (SUP y\<in>Y . (x ^ \<otimes>) * y) \<squnion> (SUP y\<in>Y . y) \<le> (SUP y\<in>Y . (x ^ \<otimes>) * y)"
      apply (rule sup_least)
      by (metis SUP_mono' dual_star_comp_fix sup.cobounded1 sup_commute)
    thus "(x ^ \<otimes>) * (SUP y\<in>Y . y) = (SUP z\<in>Y . (x ^ \<otimes>) * z)"
      by (meson SUP_least SUP_upper order.antisym dual_star_least le_comp)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text \<open>Theorem 53.1\<close>

lemma omega_continuous:
  assumes "x \<in> Continuous"
    shows "x ^ \<omega> \<in> Continuous"
proof -
  have "\<forall>Y. directed Y \<longrightarrow> (x ^ \<omega>) * (SUP y\<in>Y . y) = (SUP z\<in>Y . (x ^ \<omega>) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume 1: "directed Y"
    hence "directed ((*) (x ^ \<omega>) ` Y)"
      using directed_left_mult by auto
    hence "x * (SUP y\<in>Y . (x ^ \<omega>) * y) = (SUP y\<in>Y . x * ((x ^ \<omega>) * y))"
      by (metis assms continuous_Continuous continuous_def image_ident image_image)
    hence 2: "x * (SUP y\<in>Y . (x ^ \<omega>) * y) = (SUP y\<in>Y . x * (x ^ \<omega>) * y)"
      by (simp add: mult_assoc)
    have "(SUP y\<in>Y . x * (x ^ \<omega>) * y) \<sqinter> (SUP y\<in>Y . y) = (SUP w\<in>Y . SUP z\<in>Y . (x * (x ^ \<omega>) * w) \<sqinter> z)"
      using SUP_inf_distrib2 by blast
    hence "x * (SUP y\<in>Y . (x ^ \<omega>) * y) \<sqinter> (SUP y\<in>Y . y) = (SUP w\<in>Y . SUP z\<in>Y . (x * (x ^ \<omega>) * w) \<sqinter> z)"
      using 2 by auto
    also have "... \<le> (SUP y\<in>Y . (x ^ \<omega>) * y)"
    proof (intro SUP_least)
      fix w z
      assume "w \<in> Y" and "z \<in> Y"
      from this obtain v where 3: "v\<in>Y \<and> w \<le> v \<and> z \<le> v"
        using 1 by (meson directed_def)
      hence "x * x ^ \<omega> * w \<sqinter> z \<le> x ^ \<omega> * v"
        using inf.sup_mono le_comp omega_comp_fix by auto
      thus "x * x ^ \<omega> * w \<sqinter> z \<le> (SUP y\<in>Y . (x ^ \<omega>) * y)"
        using 3 by (meson SUP_upper2)
    qed
    finally show "(x ^ \<omega>) * (SUP y\<in>Y . y) = (SUP z\<in>Y . (x ^ \<omega>) * z)"
      by (meson SUP_least SUP_upper order.antisym omega_least le_comp)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

definition "co_continuous x \<equiv> (\<forall>Y . co_directed Y \<longrightarrow> x * (INF y\<in>Y . y) = (INF y\<in>Y . x * y))"

definition "Co_continuous \<equiv> { x . co_continuous x }"

lemma directed_dual:
  "directed X \<longleftrightarrow> co_directed (dual ` X)"
  by (simp add: directed_def co_directed_def dual_le[THEN sym])

lemma dual_dual_image:
  "dual ` dual ` X = X"
  by (simp add: image_comp)

lemma continuous_dual:
  "continuous x \<longleftrightarrow> co_continuous (x ^ o)"
proof (unfold continuous_def co_continuous_def, rule iffI)
  assume 1: "\<forall>Y. directed Y \<longrightarrow> x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
  show "\<forall>Y. co_directed Y \<longrightarrow> x ^ o * (INF y\<in>Y . y) = (INF y\<in>Y . x ^ o * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "co_directed Y"
    hence "x ^ o * (INF y\<in>Y . y) = (INF y\<in>(dual ` Y) . (x * y) ^ o)"
      using 1 by (metis dual_dual_image dual_SUP image_ident image_image dual_comp directed_dual)
    also have "... = (INF y\<in>(dual ` Y) . x ^ o * y ^ o)"
      by (meson dual_comp)
    also have "... = (INF y\<in>Y . x ^ o * y)"
      by (simp add: image_image)
    finally show "x ^ o * (INF y\<in>Y . y) = (INF y\<in>Y . x ^ o * y)"
      .
 qed
next
  assume 2: "\<forall>Y. co_directed Y \<longrightarrow> x ^ o * (INF y\<in>Y . y) = (INF y\<in>Y . x ^ o * y)"
  show "\<forall>Y. directed Y \<longrightarrow> x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "x * (SUP y\<in>Y . y) = (SUP y\<in>(dual ` Y) . (x ^ o * y) ^ o)"
      using 2 by (metis directed_dual dual_dual_image image_ident image_image dual_SUP dual_comp dual_dual)
    also have "... = (SUP y\<in>(dual ` Y) . x * y ^ o)"
      using dual_comp dual_dual by auto
    also have "... = (SUP y\<in>Y . x * y)"
      by (simp add: image_image)
    finally show "x * (SUP y\<in>Y . y) = (SUP y\<in>Y . x * y)"
      .
 qed
qed

lemma co_continuous_Co_continuous:
  "co_continuous x \<longleftrightarrow> x \<in> Co_continuous"
  by (simp add: Co_continuous_def)

text \<open>Theorem 53.1 and Theorem 53.2\<close>

lemma Continuous_dual:
  "x \<in> Continuous \<longleftrightarrow> x ^ o \<in> Co_continuous"
  by (simp add: Co_continuous_def Continuous_def continuous_dual)

text \<open>Theorem 53.2\<close>

lemma one_co_continuous:
  "1 \<in> Co_continuous"
  using Continuous_dual one_continuous by auto

lemma ascending_chain_dual:
  "ascending_chain f \<longleftrightarrow> descending_chain (dual o f)"
  using ascending_chain_def descending_chain_def dual_le by auto

lemma co_continuous_dist_descending_chain:
  assumes "x \<in> Co_continuous"
      and "descending_chain f"
    shows "x * (INF n::nat . f n) = (INF n::nat . x * f n)"
proof -
  have "x ^ o * (SUP n::nat . (dual o f) n) = (SUP n::nat . x ^ o * (dual o f) n)"
    by (smt assms Continuous_dual SUP_cong ascending_chain_dual continuous_dist_ascending_chain descending_chain_def dual_dual o_def)
  thus ?thesis
    by (smt INF_cong dual_SUP dual_comp dual_dual o_def)
qed

text \<open>Theorem 53.2\<close>

lemma assertion_co_continuous:
  "x \<in> assertion \<Longrightarrow> x \<in> Co_continuous"
  by (smt Continuous_dual assert_iff_assume assumption_continuous dual_dual)

text \<open>Theorem 53.2\<close>

lemma assumption_co_continuous:
  "x \<in> assumption \<Longrightarrow> x \<in> Co_continuous"
  by (smt Continuous_dual assert_iff_assume assertion_continuous dual_dual)

text \<open>Theorem 53.2\<close>

lemma mult_co_continuous:
  "x \<in> Co_continuous \<Longrightarrow> y \<in> Co_continuous \<Longrightarrow> x * y \<in> Co_continuous"
  by (smt Continuous_dual dual_comp dual_dual mult_continuous)

text \<open>Theorem 53.2\<close>

lemma sup_co_continuous:
  "x \<in> Co_continuous \<Longrightarrow> y \<in> Co_continuous \<Longrightarrow> x \<squnion> y \<in> Co_continuous"
  by (smt Continuous_dual dual_sup dual_dual inf_continuous)

text \<open>Theorem 53.2\<close>

lemma inf_co_continuous:
  "x \<in> Co_continuous \<Longrightarrow> y \<in> Co_continuous \<Longrightarrow> x \<sqinter> y \<in> Co_continuous"
  by (smt Continuous_dual dual_inf dual_dual sup_continuous)

text \<open>Theorem 53.2\<close>

lemma dual_omega_co_continuous:
  "x \<in> Co_continuous \<Longrightarrow> x ^ \<mho> \<in> Co_continuous"
  by (smt Continuous_dual dual_omega_def dual_dual omega_continuous)

text \<open>Theorem 53.2\<close>

lemma star_co_continuous:
  "x \<in> Co_continuous \<Longrightarrow> x ^ * \<in> Co_continuous"
  by (smt Continuous_dual dual_star_def dual_dual dual_star_continuous)

lemma dual_omega_iterate:
  assumes "y \<in> Co_continuous"
    shows "y ^ \<mho> * z = (INF n::nat . ((\<lambda>x . y * x \<squnion> z) ^ n) top)"
proof (rule order.antisym)
  show "y ^ \<mho> * z \<le> (INF n::nat . ((\<lambda>x . y * x \<squnion> z) ^ n) top)"
  proof (rule INF_greatest)
    fix n
    show "y ^ \<mho> * z \<le> ((\<lambda>x. y * x \<squnion> z) ^ n) top"
      apply (induct n)
      apply (metis power_zero_id id_def top_greatest)
      by (smt dual_omega_comp_fix le_comp mult_assoc order_refl sup_mono power_succ_unfold_ext)
  qed
next
  have 1: "descending_chain (\<lambda>n . ((\<lambda>x. y * x \<squnion> z) ^ n) top)"
  proof (unfold descending_chain_def, rule allI)
    fix n
    show "((\<lambda>x. y * x \<squnion> z) ^ Suc n) top \<le> ((\<lambda>x. y * x \<squnion> z) ^ n) top"
      apply (induct n)
      apply (metis power_zero_id id_def top_greatest)
      by (smt power_succ_unfold_ext sup_mono order_refl le_comp)
  qed
  have "(INF n. ((\<lambda>x. y * x \<squnion> z) ^ n) top) \<le> (INF n. ((\<lambda>x. y * x \<squnion> z) ^ Suc n) top)"
    apply (rule INF_greatest)
    apply (unfold power_succ_unfold_ext)
    by (smt power_succ_unfold_ext INF_lower UNIV_I)
  thus "(INF n. ((\<lambda>x. y * x \<squnion> z) ^ n) top) \<le> y ^ \<mho> * z"
    using 1 by (smt assms INF_cong co_continuous_dist_descending_chain power_succ_unfold_ext sup_INF sup_commute dual_omega_greatest)
qed

lemma dual_omega_iterate_one:
  "y \<in> Co_continuous \<Longrightarrow> y ^ \<mho> = (INF n::nat . ((\<lambda>x . y * x \<squnion> 1) ^ n) top)"
  by (metis dual_omega_iterate mult.right_neutral)

subclass ccpo
  apply unfold_locales
  apply (simp add: Sup_upper)
  using Sup_least by auto

end

class post_mbt_algebra_ext = post_mbt_algebra +
  assumes post_sub_fusion: "post 1 * neg_assume q \<le> post (neg_assume q ^ o)"
begin

lemma post_fusion:
  "post (neg_assume q ^ o) = post 1 * neg_assume q"
  using order.antisym neg_assumption post_dual_below_post_one post_sub_fusion by auto

lemma post_dual_post_one:
  "q \<in> assumption \<Longrightarrow> post 1 * q \<le> post (q ^ o)"
  by (metis assumption_neg_assume post_sub_fusion)

end

instance MonoTran :: (complete_boolean_algebra) post_mbt_algebra_ext
proof
  fix q :: "'a MonoTran"
  show "post 1 * neg_assume q \<le> post (neg_assume q ^ o)"
  proof (unfold neg_assume_def, transfer)
    fix f :: "'a \<Rightarrow> 'a"
    assume "mono f"
    have "\<forall>x. top \<le> -f bot \<squnion> x \<longrightarrow> \<not> f bot \<le> x \<longrightarrow> top \<le> bot"
      by (metis (no_types, lifting) double_compl inf.sup_bot_left inf_compl_bot sup.order_iff sup_bot_left sup_commute sup_inf_distrib1 top.extremum_uniqueI)
    hence "post_fun top \<circ> (dual_fun f \<circ> top) \<squnion> id \<le> post_fun (f bot)"
      by (simp add: dual_fun_def le_fun_def post_fun_def)
    thus "post_fun (id top) \<circ> (dual_fun f \<circ> top) \<squnion> id \<le> post_fun (dual_fun ((dual_fun f \<circ> top) \<squnion> id) top)"
      by simp
  qed
qed

class complete_mbt_algebra_ext = complete_mbt_algebra + post_mbt_algebra_ext

instance MonoTran :: (complete_boolean_algebra) complete_mbt_algebra_ext ..

end


(*  File:       Evaluation_Function.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Evaluation Function\<close>

theory Evaluation_Function
  imports "Social_Choice_Types/Profile"
          "Social_Choice_Types/Vectors"
begin

text
\<open>This is the evaluation function. From a set of currently eligible alternatives,
the evaluation function computes a numerical value that is then to be used for
further (s)election, e.g., by the elimination module.\<close>

subsection \<open>Definition\<close>

type_synonym 'a Evaluation_Function = "'a  \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow> nat"

subsection \<open>Property\<close>

(*
   An Evaluation function is Condorcet-rating iff the following holds:
   If a Condorcet Winner w exists, w and only w has the highest value.
*)
definition condorcet_rating :: "'a Evaluation_Function \<Rightarrow> bool" where
  "condorcet_rating f \<equiv>
    \<forall>A p w vs. condorcet_winner A p w \<longrightarrow>
      (\<forall>l \<in> A . l \<noteq> w \<longrightarrow> f l A p vs < f w A p vs)"

subsection \<open>Theorems\<close>

(*
   If e is Condorcet-rating, the following holds:
   If a Condorcet Winner w exists, w has the maximum evaluation value.
*)
theorem cond_winner_imp_max_eval_val:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w"
  shows "e w A p vs = Max {e a A p vs | a. a \<in> A}"
proof -
  (*
    lemma eq_max_iff: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow>
        m = Max A  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. a \<le> m)"
  *)
  let ?set = "{e a A p vs | a. a \<in> A}" and
      ?eMax = "Max {e a A p vs | a. a \<in> A}" and
      ?eW = "e w A p vs"
  (*finite A*)
  from f_prof have 0: "finite ?set"
    by simp
  (*2. non-empty A*)
  have 1: "?set \<noteq> {}"
    using condorcet_winner.simps winner
    by fastforce
  (*3. m \<in> A*)
  have 2: "?eW \<in> ?set"
    using CollectI condorcet_winner.simps winner
    by (metis (mono_tags, lifting))
  (*4. (\<forall>a \<in> A. a \<le> m)*)
  have 3: "\<forall> e \<in> ?set . e \<le> ?eW"
  proof (safe)
    fix a :: "'a"
    assume aInA: "a \<in> A"
    have "\<forall>n na. (n::nat) \<noteq> na \<or> n \<le> na"
      by simp
    with aInA show "e a A p vs \<le> e w A p vs"
      using condorcet_rating_def
            less_imp_le rating winner
      by (metis (no_types))
  qed
  (*Result*)
  from 2 3 have 4:
    "?eW \<in> ?set \<and> (\<forall>a \<in> ?set. a \<le> ?eW)"
    by blast
  from 0 1 4 Max_eq_iff
  show ?thesis
    by (metis (no_types, lifting))
qed

(*
   If e is Condorcet-rating, the following holds:
   If a Condorcet Winner w exists, a non-Condorcet
   winner has a value lower than the maximum
   evaluation value.
*)
theorem non_cond_winner_not_max_eval:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs" and
    winner: "condorcet_winner A p w" and
    linA: "l \<in> A" and
    loser: "w \<noteq> l"
  shows "e l A p vs < Max {e a A p vs | a. a \<in> A}"
proof -
  have "e l A p vs < e w A p vs"
    using condorcet_rating_def linA loser rating winner
    by metis
  also have "e w A p vs = Max {e a A p vs |a. a \<in> A}"
    using cond_winner_imp_max_eval_val f_prof rating winner
    by fastforce
  finally show ?thesis
    by simp
qed

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_37
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun z :: "'a list => 'a list => 'a list" where
  "z (nil2) y2 = y2"
| "z (cons2 z2 xs) y2 = cons2 z2 (z xs y2)"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x22) (Z) = False"
| "y (S x22) (S y22) = y x22 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem x2 (nil2) = False"
| "elem x2 (cons2 z2 xs) = x (y x2 z2) (elem x2 xs)"

lemma or_left_true: "x x2 True = True" by(case_tac "x2", auto)

theorem property0 :
  "((elem x2 z2) ==> (elem x2 (z y2 z2)))"
  apply(induction y2, auto)
  apply(case_tac "elem x2 z2", auto)
  apply(induction z2, auto)
  apply(simp add:or_left_true)
  done

end