(*  Title:      Continuations.thy
    Author:     Peter Gammie
*)

section \<open>Relating direct and continuation semantics\<close>
(*<*)
theory Continuations
imports
  PCF
begin

(*>*)
text\<open>

\label{sec:continuations}

This is a fairly literal version of
\<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close>, adapted to untyped PCF. A more
abstract account has been given by
\<^citet>\<open>"DBLP:journals/tcs/Filinski07"\<close> in terms of a monadic meta
language, which is difficult to model in Isabelle (but see
\<^citet>\<open>"Huffman:MonadTransformers:2012"\<close>).

We begin by giving PCF a continuation semantics following the modern
account of \<^citet>\<open>"wadler92:_essence_of_funct_progr"\<close>.  We use the
symmetric function space \<open>('o ValK, 'o) K \<rightarrow> ('o ValK, 'o) K\<close>
as our language includes call-by-name.

\<close>

type_synonym ('a, 'o) K = "('a \<rightarrow> 'o) \<rightarrow> 'o"

domain 'o ValK
  = ValKF (lazy appKF :: "('o ValK, 'o) K \<rightarrow> ('o ValK, 'o) K")
  | ValKTT | ValKFF
  | ValKN (lazy "nat")

type_synonym 'o ValKM = "('o ValK, 'o) K"
(*<*)

lemma ValK_case_ID [simp]:
  "ValK_case\<cdot>ValKF\<cdot>ValKTT\<cdot>ValKFF\<cdot>ValKN = ID"
  apply (rule cfun_eqI)
  apply (case_tac x)
  apply simp_all
  done

lemma below_monic_ValKF [iff]:
  "below_monic_cfun ValKF"
  by (rule below_monicI) simp

lemma below_monic_ValKN [iff]:
  "below_monic_cfun ValKN"
  by (rule below_monicI) simp

(*>*)
text\<open>

We use the standard continuation monad to ease the semantic
definition.

\<close>

definition unitK :: "'o ValK \<rightarrow> 'o ValKM" where
  "unitK \<equiv> \<Lambda> a. \<Lambda> c. c\<cdot>a"

definition bindK :: "'o ValKM \<rightarrow> ('o ValK \<rightarrow> 'o ValKM) \<rightarrow> 'o ValKM" where
  "bindK \<equiv> \<Lambda> m k. \<Lambda> c. m\<cdot>(\<Lambda> a. k\<cdot>a\<cdot>c)"

definition appKM :: "'o ValKM \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM" where
  "appKM \<equiv> \<Lambda> fK xK. bindK\<cdot>fK\<cdot>(\<Lambda> (ValKF\<cdot>f). f\<cdot>xK)"
(*<*)

lemma unitK_simps [simp]:
  "unitK\<cdot>v\<cdot>c = c\<cdot>v"
  unfolding unitK_def by simp

lemma bindK_strict:
  "bindK\<cdot>\<bottom> = \<bottom>"
  unfolding bindK_def by (simp add: eta_cfun)

lemma bindK_unitl:
  "bindK\<cdot>(unitK\<cdot>e)\<cdot>f = f\<cdot>e"
  unfolding bindK_def unitK_def by (simp add: eta_cfun)

lemma bindK_unitr:
  "bindK\<cdot>e\<cdot>unitK = e"
  unfolding bindK_def unitK_def by (simp add: eta_cfun)

lemma bindK_assoc:
  "bindK\<cdot>(bindK\<cdot>f\<cdot>g)\<cdot>h = bindK\<cdot>f\<cdot>(\<Lambda> v. bindK\<cdot>(g\<cdot>v)\<cdot>h)"
  unfolding bindK_def unitK_def by simp

lemmas bindK_simps[simp] = bindK_strict bindK_unitl bindK_unitr bindK_assoc

(*>*)
text\<open>The interpretations of the constants.\<close>

definition
  condK :: "'o ValKM \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM"
where
  "condK \<equiv> \<Lambda> iK tK eK. bindK\<cdot>iK\<cdot>(\<Lambda> i. case i of
                ValKF\<cdot>f \<Rightarrow> \<bottom> | ValKTT \<Rightarrow> tK | ValKFF \<Rightarrow> eK | ValKN\<cdot>n \<Rightarrow> \<bottom>)"

definition succK :: "'o ValKM \<rightarrow> 'o ValKM" where
  "succK \<equiv> \<Lambda> nK. bindK\<cdot>nK\<cdot>(\<Lambda> (ValKN\<cdot>n). unitK\<cdot>(ValKN\<cdot>(n + 1)))"

definition predK :: "'o ValKM \<rightarrow> 'o ValKM" where
  "predK \<equiv> \<Lambda> nK. bindK\<cdot>nK\<cdot>(\<Lambda> (ValKN\<cdot>n). case n of 0 \<Rightarrow> \<bottom> | Suc n \<Rightarrow> unitK\<cdot>(ValKN\<cdot>n))"

definition isZeroK :: "'o ValKM \<rightarrow> 'o ValKM" where
  "isZeroK \<equiv> \<Lambda> nK. bindK\<cdot>nK\<cdot>(\<Lambda> (ValKN\<cdot>n). unitK\<cdot>(if n = 0 then ValKTT else ValKFF))"

text \<open>

A continuation semantics for PCF. If we had defined our direct
semantics using a monad then the correspondence would be more
syntactically obvious.

\<close>

type_synonym 'o EnvK = "'o ValKM Env"

primrec
  evalK :: "expr \<Rightarrow> 'o EnvK \<rightarrow> 'o ValKM"
where
  "evalK (Var v) = (\<Lambda> \<rho>. \<rho>\<cdot>v)"
| "evalK (App f x) = (\<Lambda> \<rho>. appKM\<cdot>(evalK f\<cdot>\<rho>)\<cdot>(evalK x\<cdot>\<rho>))"
| "evalK (AbsN v e) = (\<Lambda> \<rho>. unitK\<cdot>(ValKF\<cdot>(\<Lambda> x. evalK e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))))"
| "evalK (AbsV v e) = (\<Lambda> \<rho>. unitK\<cdot>(ValKF\<cdot>(\<Lambda> x c. x\<cdot>(\<Lambda> x'. evalK e\<cdot>(env_ext\<cdot>v\<cdot>(unitK\<cdot>x')\<cdot>\<rho>)\<cdot>c))))"
| "evalK (Diverge) = (\<Lambda> \<rho>. \<bottom>)"
| "evalK (Fix v e) = (\<Lambda> \<rho>. \<mu> x. evalK e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))"
| "evalK (tt) = (\<Lambda> \<rho>. unitK\<cdot>ValKTT)"
| "evalK (ff) = (\<Lambda> \<rho>. unitK\<cdot>ValKFF)"
| "evalK (Cond i t e) = (\<Lambda> \<rho>. condK\<cdot>(evalK i\<cdot>\<rho>)\<cdot>(evalK t\<cdot>\<rho>)\<cdot>(evalK e\<cdot>\<rho>))"
| "evalK (Num n) = (\<Lambda> \<rho>. unitK\<cdot>(ValKN\<cdot>n))"
| "evalK (Succ e) = (\<Lambda> \<rho>. succK\<cdot>(evalK e\<cdot>\<rho>))"
| "evalK (Pred e) = (\<Lambda> \<rho>. predK\<cdot>(evalK e\<cdot>\<rho>))"
| "evalK (IsZero e) = (\<Lambda> \<rho>. isZeroK\<cdot>(evalK e\<cdot>\<rho>))"

text\<open>

To establish the chain completeness (admissibility) of our logical
relation, we need to show that @{term "unitK"} is an \emph{order
monic}, i.e., if @{term "unitK\<cdot>x \<sqsubseteq> unitK\<cdot>y"} then @{term "x \<sqsubseteq>
y"}. This is an order-theoretic version of injectivity.

In order to define a continuation that witnesses this, we need to be
able to distinguish converging and diverging computations. We
therefore require our observation domain to contain at least two
elements:

\<close>

locale at_least_two_elements =
  fixes some_non_bottom_element :: "'o::domain"
  assumes some_non_bottom_element: "some_non_bottom_element \<noteq> \<bottom>"

text\<open>

Following \<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close> and \<^citet>\<open>\<open>Remark
47\<close> in "DBLP:journals/tcs/Filinski07"\<close> we use the following continuation:

\<close>

lemma cont_below [simp, cont2cont]:
  "cont (\<lambda>x::'a::pcpo. if x \<sqsubseteq> d then \<bottom> else c)"
(*<*)
proof(rule contI2)
  show "monofun (\<lambda>x. if x \<sqsubseteq> d then \<bottom> else c)"
    apply (rule monofunI)
    apply clarsimp
    apply (cut_tac x=x and y=y and z=d in below_trans)
    apply auto
    done
next
  fix Y :: "nat \<Rightarrow> 'a::pcpo"
  assume Y: "chain Y"
  assume "chain (\<lambda>i. if Y i \<sqsubseteq> d then \<bottom> else c)"
  show "(if (\<Squnion> i. Y i) \<sqsubseteq> d then \<bottom> else c) \<sqsubseteq> (\<Squnion> i. if Y i \<sqsubseteq> d then \<bottom> else c)"
  proof(cases "\<forall>i. Y i \<sqsubseteq> d")
    case True hence "Lub Y \<sqsubseteq> d"
      using lub_below_iff[OF Y] by simp
    thus ?thesis by simp
  next
    case False
    let ?f = "\<lambda>i. if Y i \<sqsubseteq> d then \<bottom> else c"
    from False have LubY: "\<not> Lub Y \<sqsubseteq> d"
      using lub_below_iff[OF Y] by simp
    from False have F: "chain ?f"
      apply -
      apply (rule chainI)
      apply clarsimp
      apply (cut_tac i=i and j="Suc i" in chain_mono[OF Y])
      apply clarsimp
      apply (cut_tac x="Y i" and y="Y (Suc i)" and z=d in below_trans)
      apply simp_all
      done
    from False obtain i where Yi: "\<not> Y i \<sqsubseteq> d" by blast
    hence M: "max_in_chain i ?f"
      apply -
      apply (rule max_in_chainI)
      apply clarsimp
      apply (drule chain_mono[OF Y])
      apply (cut_tac x="Y i" and y="Y j" and z=d in below_trans)
      apply simp_all
      done
    from LubY Yi show ?thesis
      using iffD1[OF maxinch_is_thelub, OF F M] by simp
  qed
qed
(*>*)
text\<open>\<close>

lemma (in at_least_two_elements) below_monic_unitK [intro, simp]:
  "below_monic_cfun (unitK :: 'o ValK \<rightarrow> 'o ValKM)"
proof(rule below_monicI)
  fix v v' :: "'o ValK"
  assume vv': "unitK\<cdot>v \<sqsubseteq> unitK\<cdot>v'"
  let ?k = "\<Lambda> x. if x \<sqsubseteq> v' then \<bottom> else some_non_bottom_element"
  from vv' have "unitK\<cdot>v\<cdot>?k \<sqsubseteq> unitK\<cdot>v'\<cdot>?k" by (rule monofun_cfun_fun)
  hence "?k\<cdot>v \<sqsubseteq> ?k\<cdot>v'" by (simp add: unitK_def)
  with some_non_bottom_element show "v \<sqsubseteq> v'" by (auto split: if_split_asm)
qed

subsection\<open>Logical relation\<close>

text\<open>

We follow \<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close> by simultaneously
defining a pair of relations over values and functions. Both are
bottom-reflecting, in contrast to the situation for computational
adequacy in \S\ref{sec:compad}.  \<^citet>\<open>"DBLP:journals/tcs/Filinski07"\<close>
differs by assuming that values are always defined, and relates values
and monadic computations.

\<close>

type_synonym 'o lfr = "(ValD, 'o ValKM, ValD \<rightarrow> ValD, 'o ValKM \<rightarrow> 'o ValKM) lf_pair_rep"
type_synonym 'o lflf = "(ValD, 'o ValKM, ValD \<rightarrow> ValD, 'o ValKM \<rightarrow> 'o ValKM) lf_pair"

context at_least_two_elements
begin

abbreviation lr_eta_rep_N where
  "lr_eta_rep_N \<equiv> { (e, e') .
       (e = \<bottom> \<and> e' = \<bottom>)
     \<or> (e = ValTT \<and> e' = unitK\<cdot>ValKTT)
     \<or> (e = ValFF \<and> e' = unitK\<cdot>ValKFF)
     \<or> (\<exists>n. e = ValN\<cdot>n \<and> e' = unitK\<cdot>(ValKN\<cdot>n)) }"

abbreviation lr_eta_rep_F where
  "lr_eta_rep_F \<equiv> \<lambda>(rm, rp). { (e, e') .
       (e = \<bottom> \<and> e' = \<bottom>)
     \<or> (\<exists>f f'. e = ValF\<cdot>f \<and> e' = unitK\<cdot>(ValKF\<cdot>f') \<and> (f, f') \<in> unlr (snd rp)) }"

definition lr_eta_rep where
  "lr_eta_rep \<equiv> \<lambda>r. lr_eta_rep_N \<union> lr_eta_rep_F r"

definition lr_theta_rep where
  "lr_theta_rep \<equiv> \<lambda>(rm, rp). { (f, f') .
     (\<forall>(x, x') \<in> unlr (fst (undual rm)). (f\<cdot>x, f'\<cdot>x') \<in> unlr (fst rp)) }"

definition lr_rep :: "'o lfr" where
  "lr_rep \<equiv> \<lambda>r. (lr_eta_rep r, lr_theta_rep r)"

abbreviation lr :: "'o lflf" where
  "lr \<equiv> \<lambda>r. (mklr (fst (lr_rep r)), mklr (snd (lr_rep r)))"
(*<*)
text\<open>

Properties of the logical relation.

\<close>

lemma admS_eta_rep [intro, simp]:
  "fst (lr_rep r) \<in> admS"
  unfolding lr_rep_def lr_eta_rep_def
  apply simp
  apply rule
  apply (auto intro!: adm_disj simp: split_def)
   using adm_below_monic_exists[OF _ below_monic_pair[OF below_monic_ValN below_monic_cfcomp2[OF below_monic_unitK below_monic_ValKN]], where P="\<lambda>_. True"]
   apply (simp add: prod_eq_iff)
  using adm_below_monic_exists[OF _ below_monic_pair_split[OF below_monic_ValF below_monic_cfcomp2[OF below_monic_unitK below_monic_ValKF]], where P="\<lambda>x. x \<in> unlr (snd (snd r))"]
  apply (simp add: prod_eq_iff)
  done

lemma admS_theta_rep [intro, simp]:
  "snd (lr_rep r) \<in> admS"
proof
  show "\<bottom> \<in> snd (lr_rep r)"
    unfolding lr_rep_def lr_theta_rep_def
    by (cases r) simp
next
  show "adm (\<lambda>x. x \<in> snd (lr_rep r))"
    apply (rule admI)
    unfolding lr_rep_def lr_theta_rep_def
    apply (clarsimp simp: split_def)
    apply (rule admD)
      apply (rule adm_subst)
      apply force+
    done
qed

lemma mono_lr:
  shows "mono (lr :: 'o lflf)"
  apply (rule monoI)
  apply simp
  apply (simp add: lr_rep_def)
  apply (rule conjI)
   apply (force simp: lr_eta_rep_def split_def dual_less_eq_iff unlr_leq[symmetric])
  (* FIXME stuck with the projections on the product *)
  apply (auto simp: lr_theta_rep_def split_def dual_less_eq_iff unlr_leq[symmetric])
  apply (drule_tac x="(ae, bc)" in bspec)
   apply (case_tac a)
   apply (case_tac ab)
   apply (auto simp: unlr_leq[symmetric])
  done

(*>*)
end (* context at_least_two_elements *)

text\<open>

It takes some effort to set up the minimal invariant relating the two
pairs of domains. One might hope this would be easier using deflations
(which might compose) rather than ``copy'' functions (which certainly
don't).

We elide these as they are tedious.

\<close>
(*<*)

primrec
  ValD_copy_i :: "nat \<Rightarrow> ValD \<rightarrow> ValD"
where
  "ValD_copy_i 0 = \<bottom>"
| "ValD_copy_i (Suc n) = (\<Lambda> v. case v of ValF\<cdot>f \<Rightarrow> ValF\<cdot>(ValD_copy_i n oo f oo ValD_copy_i n) | ValTT \<Rightarrow> ValTT | ValFF \<Rightarrow> ValFF | ValN\<cdot>m \<Rightarrow> ValN\<cdot>m)"

abbreviation
  "ValD_copy_lub \<equiv> (\<Squnion>i. ValD_copy_i i)"

lemma ValD_copy_chain [intro, simp]:
  "chain ValD_copy_i"
proof(rule chainI)
  fix i show "ValD_copy_i i \<sqsubseteq> ValD_copy_i (Suc i)"
  proof(induct i)
    case (Suc i)
    { fix x
      have "ValD_copy_i (Suc i)\<cdot>x \<sqsubseteq> ValD_copy_i (Suc (Suc i))\<cdot>x"
      proof(cases x)
        case (ValF f) with Suc show ?thesis
          by (clarsimp simp: cfcomp1 cfun_below_iff monofun_cfun)
      qed simp_all }
    thus ?case by (simp add: cfun_below_iff)
  qed simp
qed

lemma ValD_copy_lub_ID:
  "ValD_copy_lub = ID"
proof -
  { fix x :: ValD
    fix i :: nat
    have "ValD_take i\<cdot>(ValD_copy_i i\<cdot>(ValD_take i\<cdot>x)) = ValD_take i\<cdot>x"
    proof (induct i arbitrary: x)
      case (Suc n) thus ?case
        by (cases x) (simp_all add: cfun_map_def)
    qed simp }
  hence "\<And>x :: ValD. (\<Squnion>i. ValD_take i\<cdot>(ValD_copy_i i\<cdot>(ValD_take i\<cdot>x))) = (\<Squnion>i. ValD_take i\<cdot>x)"
    by (blast intro: lub_eq)
  thus ?thesis by (simp add: lub_distribs ValD.lub_take cfun_eq_iff)
qed

text\<open>

Continuations: we need to ensure the observation type is always the
same.

\<close>

definition
  KM_map :: "('o ValK \<rightarrow> 'o ValK) \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM"
where
  "KM_map \<equiv> \<Lambda> f. cfun_map\<cdot>(cfun_map\<cdot>f\<cdot>ID)\<cdot>ID"

lemma KM_map_id [intro, simp]:
  "KM_map\<cdot>ID = ID"
  unfolding KM_map_def by (simp add: cfun_map_ID)

lemma KM_map_strict [intro, simp]:
  "KM_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
  unfolding KM_map_def by (simp add: cfun_map_def)

primrec
  ValK_copy_i :: "nat \<Rightarrow> 'o ValK \<rightarrow> 'o ValK"
where
  "ValK_copy_i 0 = \<bottom>"
| "ValK_copy_i (Suc n) = (\<Lambda> v. case v of ValKF\<cdot>f \<Rightarrow> ValKF\<cdot>(cfun_map\<cdot>(KM_map\<cdot>(ValK_copy_i n))\<cdot>(KM_map\<cdot>(ValK_copy_i n))\<cdot>f) | ValKTT \<Rightarrow> ValKTT | ValKFF \<Rightarrow> ValKFF | ValKN\<cdot>m \<Rightarrow> ValKN\<cdot>m)"

abbreviation
  "ValK_copy \<equiv> (\<Squnion>i. ValK_copy_i i)"

lemma ValK_copy_chain [intro, simp]:
  "chain (ValK_copy_i :: nat \<Rightarrow> 'o ValK \<rightarrow> 'o ValK)"
proof(rule chainI)
  fix i show "ValK_copy_i i \<sqsubseteq> (ValK_copy_i (Suc i) :: 'o ValK \<rightarrow> 'o ValK)"
  proof(induct i)
    case (Suc i)
    { fix x :: "'o ValK"
      have "ValK_copy_i (Suc i)\<cdot>x \<sqsubseteq> ValK_copy_i (Suc (Suc i))\<cdot>x"
      proof(cases x)
        case (ValKF f) with Suc show ?thesis by (clarsimp simp: monofun_cfun KM_map_def)
      qed simp_all }
    thus ?case by (simp add: cfun_below_iff)
  qed simp
qed

lemma ValK_copy_fix:
  "ValK_copy = (ID :: 'o ValK \<rightarrow> 'o ValK)"
proof -
  { fix x :: "'o ValK"
    fix i :: nat
    have "ValK_take i\<cdot>(ValK_copy_i i\<cdot>(ValK_take i\<cdot>x)) = ValK_take i\<cdot>x"
    proof (induct i arbitrary: x)
      case (Suc n) thus ?case
        by (cases x) (simp_all add: KM_map_def cfun_map_def)
    qed simp }
  hence "\<And>x :: 'o ValK. (\<Squnion>i. ValK_take i\<cdot>(ValK_copy_i i\<cdot>(ValK_take i\<cdot>x))) = (\<Squnion>i. ValK_take i\<cdot>x)"
    by (blast intro: lub_eq)
  thus ?thesis by (simp add: lub_distribs ValK.lub_take cfun_eq_iff)
qed

lemma ValK_strict [intro, simp]:
  "ValK_copy\<cdot>\<bottom> = \<bottom>"
  by (simp add: ValK_copy_fix)

text\<open>

We need to respect the purported domain structure, and positive and
negative occurrences.

\<close>

fixrec
  ValD_copy_rec :: "((ValD \<rightarrow> ValD) \<times> ((ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)))
                  \<rightarrow> ((ValD \<rightarrow> ValD) \<times> ((ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)))"
where
  "ValD_copy_rec\<cdot>r =
     (\<Lambda> v. case v of ValF\<cdot>f \<Rightarrow> ValF\<cdot>(snd r\<cdot>f) | ValTT \<Rightarrow> ValTT | ValFF \<Rightarrow> ValFF | ValN\<cdot>n \<Rightarrow> ValN\<cdot>n,
      \<Lambda> f. cfun_map\<cdot>(strictify\<cdot>(fst r))\<cdot>(strictify\<cdot>(fst r))\<cdot>f)"

abbreviation
  ValD_copy_eta :: "nat \<Rightarrow> ValD \<rightarrow> ValD"
where
  "ValD_copy_eta i \<equiv> fst (iterate i\<cdot>ValD_copy_rec\<cdot>\<bottom>)"

abbreviation
  ValD_copy_theta :: "nat \<Rightarrow> (ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)"
where
  "ValD_copy_theta i \<equiv> snd (iterate i\<cdot>ValD_copy_rec\<cdot>\<bottom>)"

lemma ValD_copy_eta_theta_strict [intro, simp]:
  "ValD_copy_eta n\<cdot>\<bottom> = \<bottom>"
  "ValD_copy_theta n\<cdot>\<bottom> = \<bottom>"
  by (induct n) (simp_all add: cfun_map_def)

lemma ValD_copy_fix_strict [simp]:
  "fst (fix\<cdot>ValD_copy_rec)\<cdot>\<bottom> = \<bottom>"
  "snd (fix\<cdot>ValD_copy_rec)\<cdot>\<bottom> = \<bottom>"
  by (subst fix_eq, simp add: cfun_map_def)+

lemma ValD_copy_rec_ValD_copy_lub:
  "fix\<cdot>ValD_copy_rec = (ValD_copy_lub, cfun_map\<cdot>ValD_copy_lub\<cdot>ValD_copy_lub)" (is "?lhs = ?rhs")
proof(rule below_antisym)
  show "?lhs \<sqsubseteq> ?rhs"
    apply (rule fix_least)
    apply (simp add: eta_cfun strictify_cancel ValD_copy_lub_ID cfun_map_def ID_def)
    done
next
  { fix i have "ValD_copy_i i \<sqsubseteq> fst (fix\<cdot>ValD_copy_rec)"
    proof(induct i)
      case (Suc i) thus ?case
        apply -
        apply (subst fix_eq)
        apply (subst fix_eq)
        apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def)
        apply (intro monofun_cfun_fun monofun_cfun_arg)
        apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 cfun_map_def cfun_below_iff)
        done
    qed simp }
  hence D: "ValD_copy_lub \<sqsubseteq> fst (fix\<cdot>ValD_copy_rec)" by (simp add: lub_below_iff)
  moreover
  from D
  have "cfun_map\<cdot>ValD_copy_lub\<cdot>ValD_copy_lub \<sqsubseteq> snd (fix\<cdot>ValD_copy_rec)"
    by (subst fix_eq) (simp add: eta_cfun strictify_cancel monofun_cfun)
  ultimately show "?rhs \<sqsubseteq> ?lhs" by (simp add: prod_belowI)
qed

lemma fix_ValD_copy_rec_ID:
  "fix\<cdot>ValD_copy_rec = (ID, ID)"
  using ValD_copy_rec_ValD_copy_lub ValD_copy_lub_ID cfun_map_ID
  by simp

fixrec
  ValK_copy_rec :: "(('o ValKM \<rightarrow> 'o ValKM) \<times> (('o ValKM \<rightarrow> 'o ValKM) \<rightarrow> ('o ValKM \<rightarrow> 'o ValKM)))
                  \<rightarrow> ('o ValKM \<rightarrow> 'o ValKM) \<times> (('o ValKM \<rightarrow> 'o ValKM) \<rightarrow> ('o ValKM \<rightarrow> 'o ValKM))"
where
  "ValK_copy_rec\<cdot>r =
     (\<Lambda> vm. KM_map\<cdot>(\<Lambda> v. case v of ValKF\<cdot>f \<Rightarrow> ValKF\<cdot>(snd r\<cdot>f) | ValKTT \<Rightarrow> ValKTT | ValKFF \<Rightarrow> ValKFF | ValKN\<cdot>a \<Rightarrow> ValKN\<cdot>a)\<cdot>vm,
      \<Lambda> f. cfun_map\<cdot>(strictify\<cdot>(fst r))\<cdot>(strictify\<cdot>(fst r))\<cdot>f)"

abbreviation
  ValK_copy_eta
where
  "ValK_copy_eta i \<equiv> fst (iterate i\<cdot>ValK_copy_rec\<cdot>\<bottom>)"

abbreviation
  ValK_copy_theta
where
  "ValK_copy_theta i \<equiv> snd (iterate i\<cdot>ValK_copy_rec\<cdot>\<bottom>)"

lemma ValK_copy_strict [intro, simp]:
  "ValK_copy_eta n\<cdot>\<bottom> = (\<bottom> :: 'o ValKM)"
  "ValK_copy_theta n\<cdot>\<bottom> = (\<bottom> :: 'o ValKM \<rightarrow> 'o ValKM)"
  by (induct n) (simp_all add: cfun_map_def)

lemma ValK_copy_fix_strict [simp]:
  "fst (fix\<cdot>ValK_copy_rec)\<cdot>\<bottom> = \<bottom>"
  "snd (fix\<cdot>ValK_copy_rec)\<cdot>\<bottom> = \<bottom>"
  by (subst fix_eq, simp add: cfun_map_def)+

lemma ValK_copy_rec_ValK_copy:
  "fix\<cdot>ValK_copy_rec
  = (KM_map\<cdot>(ValK_copy :: 'o ValK \<rightarrow> 'o ValK),
     cfun_map\<cdot>(KM_map\<cdot>ValK_copy)\<cdot>(KM_map\<cdot>ValK_copy))" (is "?lhs = ?rhs")
proof(rule below_antisym)
  show "?lhs \<sqsubseteq> ?rhs"
    apply (rule fix_least)
    apply (simp add: eta_cfun strictify_cancel cfun_map_def ID_def)
    apply (intro cfun_eqI)
    apply (simp add: KM_map_def cfun_map_def ValK_copy_fix eta_cfun)
    done
next
  { fix i
    have "KM_map\<cdot>(ValK_copy_i i :: 'o ValK \<rightarrow> 'o ValK) \<sqsubseteq> fst (fix\<cdot>ValK_copy_rec)"
     and "(ValK_copy_i i :: 'o ValK \<rightarrow> 'o ValK) \<sqsubseteq> ValK_case\<cdot>(\<Lambda> f. ValKF\<cdot>(snd (fix\<cdot>ValK_copy_rec)\<cdot>f))\<cdot>ValKTT\<cdot>ValKFF\<cdot>ValKN"
    proof(induct i)
      case 0
      { case 1 show ?case
          apply (subst fix_eq)
          apply (auto iff: cfun_below_iff intro!: monofun_cfun_arg simp: KM_map_def cfun_map_def eta_cfun)
          done }
      { case 2 show ?case by simp }
    next
      case (Suc i)
      { case 1 from Suc show ?case
          apply -
          apply (subst fix_eq)
          apply (subst fix_eq)
          apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def)
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def)
          apply (intro monofun_cfun_arg)
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def)
          apply (intro monofun_cfun_arg)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 cfun_map_def)
          apply (intro monofun_cfun)
          apply simp_all
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 cfun_map_def)
          apply (intro cfun_belowI)
          apply (subst fix_eq)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 KM_map_def cfun_map_def)
          apply (intro monofun_cfun)
          apply simp_all
          apply (subst fix_eq)
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 KM_map_def cfun_map_def)
          apply (intro monofun_cfun)
          apply simp_all
          apply (intro cfun_belowI)
          apply simp
          apply (intro monofun_cfun)
          apply simp_all
          apply (intro cfun_belowI)
          apply simp
          apply (intro monofun_cfun)
          apply simp_all
          done }
      { case 2 from Suc show ?case
          apply -
          apply (subst fix_eq)
          apply (subst fix_eq)
          apply (auto simp: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def cfun_below_iff intro!: monofun_cfun)
          done }
    qed }
  hence "(\<Squnion>i. KM_map\<cdot>(ValK_copy_i i :: 'o ValK \<rightarrow> 'o ValK)) \<sqsubseteq> fst (fix\<cdot>ValK_copy_rec)"
    by (simp add: lub_below_iff)
  hence D: "KM_map\<cdot>(ValK_copy :: 'o ValK \<rightarrow> 'o ValK) \<sqsubseteq> fst (fix\<cdot>ValK_copy_rec)"
    by (simp add: contlub_cfun_arg[symmetric])
  from D
  have E: "cfun_map\<cdot>(KM_map\<cdot>(ValK_copy :: 'o ValK \<rightarrow> 'o ValK))\<cdot>(KM_map\<cdot>ValK_copy) \<sqsubseteq> snd (fix\<cdot>ValK_copy_rec)"
    apply (subst fix_eq)
    apply (simp add: eta_cfun strictify_cancel KM_map_def)
    apply (intro monofun_cfun)
    apply simp_all
    done
  show "?rhs \<sqsubseteq> ?lhs" by (simp add: prod_belowI D E)
qed

lemma fix_ValK_copy_rec_ID:
  "fix\<cdot>ValK_copy_rec = (ID, ID)"
  by (simp add: ValK_copy_rec_ValK_copy ValK_copy_fix cfun_map_ID)

lemma (in at_least_two_elements) min_inv_lr:
  assumes "fst ea\<cdot>\<bottom> = \<bottom>"
  assumes "fst eb\<cdot>\<bottom> = \<bottom>"
  assumes "eRSP ea eb R S"
  shows "eRSP (ValD_copy_rec\<cdot>ea) (ValK_copy_rec\<cdot>eb) (dual ((lr :: 'o lflf) (dual S, undual R))) (lr (R, S))"
  using assms some_non_bottom_element
  apply (simp add: split_def)
  apply (auto simp: split_def lr_rep_def lr_eta_rep_def lr_theta_rep_def KM_map_def cfun_map_def unitK_def)
  apply (force simp: cfun_map_def strictify_cancel unitK_def) (* FIXME obvious but auto misses it *)
  done

(*>*)
sublocale at_least_two_elements < F: DomSolP lr ValD_copy_rec ValK_copy_rec
  apply standard
         apply (rule mono_lr)
        apply (rule fix_ValD_copy_rec_ID)
       apply (rule fix_ValK_copy_rec_ID)
      apply (simp_all add: cfun_map_def)[4]
  apply (erule (2) min_inv_lr)
  done

subsection\<open>A retraction between the two definitions\<close>

text\<open>

We can use the relation to establish a strong connection between the
direct and continuation semantics.  All results depend on the
observation type being rich enough.

\<close>

context at_least_two_elements
begin

abbreviation mrel ("\<eta>: _ \<mapsto> _" [50, 51] 50) where
  "\<eta>: x \<mapsto> x' \<equiv> (x, x') \<in> unlr (fst F.delta)"

abbreviation vrel ("\<theta>: _ \<mapsto> _" [50, 51] 50) where
  "\<theta>: y \<mapsto> y' \<equiv> (y, y') \<in> unlr (snd F.delta)"
(*<*)
lemma F_bottom_triv [intro, simp]:
  "\<eta>: \<bottom> \<mapsto> \<bottom>"
  "\<theta>: \<bottom> \<mapsto> \<bottom>"
  by simp_all

lemma etaI [intro, simp]:
  "\<eta>: ValTT \<mapsto> unitK\<cdot>ValKTT"
  "\<eta>: ValFF \<mapsto> unitK\<cdot>ValKFF"
  "\<eta>: ValN\<cdot>n \<mapsto> unitK\<cdot>(ValKN\<cdot>n)"
  by (subst F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)+

lemma eta_F:
  "\<theta>: f \<mapsto> f' \<Longrightarrow> \<eta>: ValF\<cdot>f \<mapsto> unitK\<cdot>(ValKF\<cdot>f')"
apply (subst F.delta_sol)
apply simp
apply (subst lr_rep_def)
apply (fastforce simp: lr_eta_rep_def split_def)
done

lemma theta_F:
  "(\<And>x x'. \<eta>: x \<mapsto> x' \<Longrightarrow> \<eta>: f\<cdot>x \<mapsto> f'\<cdot>x') \<Longrightarrow> \<theta>: f \<mapsto> f'"
apply (subst F.delta_sol)
apply simp
apply (subst lr_rep_def)
apply (simp add: lr_theta_rep_def split_def)
done

lemma eta_induct[case_names bottom N F, consumes 1]:
  "\<lbrakk> \<eta>: x \<mapsto> x';
     \<lbrakk> x = \<bottom>; x' = \<bottom> \<rbrakk> \<Longrightarrow> P x x';
     \<And>n. \<lbrakk> x = ValTT; x' = unitK\<cdot>ValKTT \<rbrakk> \<Longrightarrow> P x x';
     \<And>n. \<lbrakk> x = ValFF; x' = unitK\<cdot>ValKFF \<rbrakk> \<Longrightarrow> P x x';
     \<And>n. \<lbrakk> x = ValN\<cdot>n; x' = unitK\<cdot>(ValKN\<cdot>n) \<rbrakk> \<Longrightarrow> P x x';
     \<And>f f'. \<lbrakk> x = ValF\<cdot>f; x' = unitK\<cdot>(ValKF\<cdot>f'); \<theta>: f \<mapsto> f' \<rbrakk> \<Longrightarrow> P x x'
   \<rbrakk> \<Longrightarrow> P x x'"
  apply (cases x)
      apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
     defer
     apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
    apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
   apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
  apply simp
  apply (subst (asm) F.delta_sol)
  apply simp
  apply (subst (asm) lr_rep_def)
  apply (subst (asm) lr_eta_rep_def)
  apply clarsimp
  done

lemma theta_induct[case_names F, consumes 1]:
  "\<lbrakk> \<theta>: f \<mapsto> f';
     (\<And>x x'. \<eta>: x \<mapsto> x' \<Longrightarrow> \<eta>: f\<cdot>x \<mapsto> f'\<cdot>x') \<Longrightarrow> P f f'
   \<rbrakk> \<Longrightarrow> P f f'"
  apply (subst (asm) F.delta_sol)
  apply simp
  apply (subst (asm) lr_rep_def)
  apply (subst (asm) lr_theta_rep_def)
  apply fastforce
  done

(*>*)
text\<open>

Theorem 1 from \<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close>.

\<close>

lemma AbsV_aux:
  assumes "\<eta>: ValF\<cdot>f \<mapsto> unitK\<cdot>(ValKF\<cdot>f')"
  shows "\<eta>: ValF\<cdot>(strictify\<cdot>f) \<mapsto> unitK\<cdot>(ValKF\<cdot>(\<Lambda> x c. x\<cdot>(\<Lambda> x'. f'\<cdot>(unitK\<cdot>x')\<cdot>c)))"
(*<*)
  apply (rule eta_F)
  apply (rule theta_F)
  using assms
  apply (rule eta_induct) (* FIXME special rule would help *)
  apply simp_all
  apply (drule injD[OF below_monic_inj[OF below_monic_unitK]])
  apply clarsimp
  apply (erule theta_induct)
  apply (erule eta_induct)
  apply (simp_all add: eta_cfun eta_F)
  done

(*>*)
text\<open>\<close>

theorem Theorem1:
  assumes "\<forall>v. \<eta>: \<rho>\<cdot>v \<mapsto> \<rho>'\<cdot>v"
  shows "\<eta>: evalD e\<cdot>\<rho> \<mapsto> evalK e\<cdot>\<rho>'"
(*<*)
using assms
proof(induct e arbitrary: \<rho> \<rho>')
  case App show ?case
    apply simp
    apply (simp add: appKM_def bindK_def)
    using App.hyps(1)[OF App(3)]
    apply (rule eta_induct)
      apply simp_all
    apply (simp add: eta_cfun)
    apply (erule theta_induct)
    using App.hyps(2)[OF App(3)]
    apply simp
    done
next
  case AbsN show ?case
    apply simp
    apply (rule eta_F)
    apply (rule theta_F)
    apply simp
    apply (rule AbsN.hyps)
    using AbsN(2)
    unfolding env_ext_def
    apply simp
    done
next
  case (AbsV v e \<rho> \<rho>')
  have "\<eta>: ValF\<cdot>(\<Lambda> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>)) \<mapsto> unitK\<cdot>(ValKF\<cdot>(\<Lambda> x. evalK e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>')))"
    apply (rule eta_F)
    apply (rule theta_F)
    apply simp
    apply (rule AbsV.hyps)
    using AbsV(2)
    unfolding env_ext_def
    apply simp
    done
  thus ?case by (fastforce dest: AbsV_aux)
next
  case Fix thus ?case
    apply simp
    apply (rule parallel_fix_ind)
    apply (simp_all add: env_ext_def)
    done
next
  case Cond thus ?case
    apply (simp add: cond_def condK_def eta_cfun)
    using Cond(1)[OF Cond(4)]
    apply (rule eta_induct)
    apply simp_all
    done
next
  case Succ thus ?case
    apply (simp add: succ_def succK_def eta_cfun)
    using Succ(1)[OF Succ(2)]
    apply (rule eta_induct)
    apply simp_all
    done
next
  case Pred thus ?case
    apply (simp add: pred_def predK_def eta_cfun)
    using Pred(1)[OF Pred(2)]
    apply (rule eta_induct)
    apply (simp_all split: nat.split)
    done
next
  case IsZero thus ?case
    apply (simp add: isZero_def isZeroK_def eta_cfun)
    using IsZero(1)[OF IsZero(2)]
    apply (rule eta_induct)
    apply (simp_all split: nat.split)
    done
qed simp_all
(*>*)

end

text\<open>

The retraction between the two value and monadic value spaces.

Note we need to work with an observation type that can represent the
``explicit values'', i.e. @{typ "'o ValK"}.

\<close>

locale value_retraction =
  fixes VtoO :: "'o ValK \<rightarrow> 'o"
  fixes OtoV :: "'o \<rightarrow> 'o ValK"
  assumes OV: "OtoV oo VtoO = ID"

sublocale value_retraction < at_least_two_elements "VtoO\<cdot>(ValKN\<cdot>0)"
using OV by - (standard, simp add: injection_defined cfcomp1 cfun_eq_iff)

context value_retraction
begin

fun
  DtoKM_i :: "nat \<Rightarrow> ValD \<rightarrow> 'o ValKM"
and
  KMtoD_i :: "nat \<Rightarrow> 'o ValKM \<rightarrow> ValD"
where
  "DtoKM_i 0 = \<bottom>"
| "DtoKM_i (Suc n) = (\<Lambda> v. case v of
     ValF\<cdot>f \<Rightarrow> unitK\<cdot>(ValKF\<cdot>(cfun_map\<cdot>(KMtoD_i n)\<cdot>(DtoKM_i n)\<cdot>f))
   | ValTT \<Rightarrow> unitK\<cdot>ValKTT
   | ValFF \<Rightarrow> unitK\<cdot>ValKFF
   | ValN\<cdot>m \<Rightarrow> unitK\<cdot>(ValKN\<cdot>m))"

| "KMtoD_i 0 = \<bottom>"
| "KMtoD_i (Suc n) = (\<Lambda> v. case OtoV\<cdot>(v\<cdot>VtoO) of
     ValKF\<cdot>f \<Rightarrow> ValF\<cdot>(cfun_map\<cdot>(DtoKM_i n)\<cdot>(KMtoD_i n)\<cdot>f)
   | ValKTT \<Rightarrow> ValTT
   | ValKFF \<Rightarrow> ValFF
   | ValKN\<cdot>m \<Rightarrow> ValN\<cdot>m)"

abbreviation "DtoKM \<equiv> (\<Squnion>i. DtoKM_i i)"
abbreviation "KMtoD \<equiv> (\<Squnion>i. KMtoD_i i)"
(*<*)

lemma DtoKM_KMtoD_chain [intro, simp]:
  "chain DtoKM_i"
  "chain KMtoD_i"
proof -
  let ?C = "\<lambda>i. (DtoKM_i i, KMtoD_i i)"
  have "chain ?C"
  proof(rule chainI)
    fix i show "?C i \<sqsubseteq> ?C (Suc i)"
    proof(induct i)
      case (Suc i) show ?case
      proof(rule monofun_pair)
        show "DtoKM_i (Suc i) \<sqsubseteq> DtoKM_i (Suc (Suc i))"
        proof(rule cfun_belowI)
          fix x from Suc show "DtoKM_i (Suc i)\<cdot>x \<sqsubseteq> DtoKM_i (Suc (Suc i))\<cdot>x"
            by (cases x) (auto intro!: monofun_cfun simp: cfun_map_def cfun_below_iff)
        qed
        show "KMtoD_i (Suc i) \<sqsubseteq> KMtoD_i (Suc (Suc i))"
        proof(rule cfun_belowI)
          fix x from Suc show "KMtoD_i (Suc i)\<cdot>x \<sqsubseteq> KMtoD_i (Suc (Suc i))\<cdot>x"
            apply (simp add: eta_cfun)
            apply (intro monofun_cfun_fun monofun_cfun_arg)
            apply (intro cfun_belowI)
            apply (auto intro: monofun_cfun)
            done
        qed
      qed
    qed simp
  qed
  then show "chain DtoKM_i" "chain KMtoD_i"
    by (auto dest: ch2ch_fst ch2ch_snd)
qed
(*>*)

text\<open>

Lemma 1 from \<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close>.

\<close>

lemma Lemma1:
  "\<eta>: x \<mapsto> DtoKM\<cdot>x"
  "\<eta>: x \<mapsto> x' \<Longrightarrow> x = KMtoD\<cdot>x'"
(*<*)
proof -
  have K: "\<eta>: ValD_copy_i i\<cdot>x \<mapsto> DtoKM_i i\<cdot>x"
   and L: "\<eta>: x \<mapsto> x' \<Longrightarrow> ValD_copy_i i\<cdot>x = KMtoD_i i\<cdot>x'" for x x' i
  proof(induct i arbitrary: x x')
    case (Suc i)
    { case 1 show ?case
        apply (cases x)
          apply simp_all
        apply (rule eta_F)
        apply (rule theta_F)
        using Suc
        apply simp
        done }
    { case 2 thus ?case
        apply (induct rule: eta_induct)
          using OV
          apply (simp_all add: cfun_eq_iff retraction_strict)
        apply (clarsimp simp: cfun_eq_iff)
        apply (erule theta_induct)
        using Suc
        apply simp
        done }
  qed simp_all
  let ?C1 = "\<lambda>i. (ValD_copy_i i, DtoKM_i i)"
  let ?P1 = "\<lambda>f. \<eta>: (fst f)\<cdot>x \<mapsto> (snd f)\<cdot>x"
  have "adm ?P1" by (rule adm_subst) simp_all
  with K
  have "?P1 (\<Squnion>i. ValD_copy_i i, \<Squnion>i. DtoKM_i i)"
    using admD[where P="?P1" and Y="?C1"] lub_prod[where S="?C1"] by simp
  moreover
  { fix x :: ValD
    fix x' :: "'o ValKM"
    let ?C2 = "\<lambda>i. (ValD_copy_i i, KMtoD_i i)"
    let ?P2 = "\<lambda>f. (fst f)\<cdot>x = (snd f)\<cdot>x'"
    have "adm (\<lambda>f. ?P2 f)" by simp
    with L have "\<eta>: x \<mapsto> x' \<Longrightarrow> ?P2 (\<Squnion>i. ValD_copy_i i, \<Squnion>i. KMtoD_i i)"
      using admD[where P="?P2" and Y="?C2"] lub_prod[where S="?C2"]
      by simp }
  ultimately show
    "\<eta>: x \<mapsto> DtoKM\<cdot>x"
    "\<eta>: x \<mapsto> x' \<Longrightarrow> x = KMtoD\<cdot>x'"
      by (simp_all add: ValD_copy_lub_ID)
qed

(*>*)
text\<open>

Theorem 2 from \<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close>.

\<close>

theorem Theorem2: "evalD e\<cdot>\<rho> = KMtoD\<cdot>(evalK e\<cdot>(DtoKM oo \<rho>))"
using Lemma1(2)[OF Theorem1] Lemma1(1) by (simp add: cfcomp1)

end

text\<open>

\<^citet>\<open>\<open>Remark~48\<close> in "DBLP:journals/tcs/Filinski07"\<close> observes that there
will not be a retraction between direct and continuation semantics for
languages with richer notions of effects.

It should be routine to extend the above approach to the higher-order
backtracking language of \<^citet>\<open>"DBLP:conf/icfp/WandV04"\<close>.

I wonder if it is possible to construct continuation semantics from
direct semantics as proposed by
\<^citet>\<open>"DBLP:journals/jacm/SethiT80"\<close>. Roughly we might hope to lift a
retraction between two value domains to a retraction at higher types
by synthesising a suitable logical relation.

\<close>
(*<*)

end
(*>*)


(* Author: Andreas Lochbihler, ETH Zurich
   Author: Joshua Schneider, ETH Zurich *)

section \<open>Preliminaries\<close>

theory Preliminaries imports
  Main
begin

alias Grp = BNF_Def.Grp
alias vimage2p = BNF_Def.vimage2p

lemma Domainp_conversep: "Domainp R\<inverse>\<inverse> = Rangep R"
  by auto

lemma Grp_apply: "Grp A f x y \<longleftrightarrow> y = f x \<and> x \<in> A"
  by (simp add: Grp_def)

lemma conversep_Grp_id: "(Grp A id)\<inverse>\<inverse> = Grp A id"
  by (auto simp add: fun_eq_iff Grp_apply)

lemma eq_onp_compp_Grp: "eq_onp P OO Grp A f = Grp (Collect P \<inter> A) f"
  by (auto simp add: fun_eq_iff eq_onp_def elim: GrpE intro: GrpI)

consts relcompp_witness :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b"

specification (relcompp_witness)
  relcompp_witness1: "(A OO B) (fst xy) (snd xy) \<Longrightarrow> A (fst xy) (relcompp_witness A B xy)"
  relcompp_witness2: "(A OO B) (fst xy) (snd xy) \<Longrightarrow> B (relcompp_witness A B xy) (snd xy)"
  apply(fold all_conj_distrib)
  apply(rule choice allI)+
  apply(auto)
  done

lemmas relcompp_witness[of _ _ "(x, y)" for x y, simplified] = relcompp_witness1 relcompp_witness2

hide_fact (open) relcompp_witness1 relcompp_witness2

lemma relcompp_witness_eq [simp]: "relcompp_witness (=) (=) (x, x) = x"
  using relcompp_witness(1)[of "(=)" "(=)" x x] by (simp add: eq_OO)

lemma Quotient_equiv_abs1: "\<lbrakk> Quotient R Abs Rep T; R x y \<rbrakk> \<Longrightarrow> T x (Abs y)"
  unfolding Quotient_alt_def2 by blast

lemma Quotient_equiv_abs2: "\<lbrakk> Quotient R Abs Rep T; R x y \<rbrakk> \<Longrightarrow> T y (Abs x)"
  unfolding Quotient_alt_def2 by blast

lemma Quotient_rep_equiv1: "\<lbrakk> Quotient R Abs Rep T; T a b \<rbrakk> \<Longrightarrow> R a (Rep b)"
  unfolding Quotient_alt_def3 by blast

lemma Quotient_rep_equiv2: "\<lbrakk> Quotient R Abs Rep T; T a b \<rbrakk> \<Longrightarrow> R (Rep b) a"
  unfolding Quotient_alt_def3 by blast

end


(*
  File:     Dirichlet_Theorem.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Dirichlet's Theorem on primes in arithmetic progressions\<close>
theory Dirichlet_Theorem
imports
  Dirichlet_L_Functions
  Bertrands_Postulate.Bertrand
  Landau_Symbols.Landau_More
begin

text \<open>
  We can now turn to the proof of the main result: Dirichlet's theorem about the infinitude
  of primes in arithmetic progressions.

  There are previous proofs of this by John Harrison in HOL Light~\cite{harrison-dirichlet} and
  by Mario Carneiro in Metamath~\cite{carneiro16}. Both of them strive to prove Dirichlet's
  theorem with a minimum amount of auxiliary results and definitions, whereas our goal was to
  get a short and simple proof of Dirichlet's theorem built upon a large library of Analytic
  Number Theory.

  At this point, we already have the key part -- the non-vanishing of $L(1,\chi)$
  -- and the proof was relatively simple and straightforward due to the large amount of Complex
  Analysis and Analytic Number Theory we have available. The remainder will be a bit more concrete,
  but still reasonably concise.

  First, we need to re-frame some of the results from the AFP entry about Bertrand's postulate a
  little bit.
\<close>

subsection \<open>Auxiliary results\<close>

text \<open>
  The AFP entry for Bertrand's postulate already provides a slightly stronger version of
  this for integer values of $x$, but we can easily extend this to real numbers to obtain
  a slightly nicer presentation.
\<close>
lemma sum_upto_mangoldt_le:
  assumes "x \<ge> 0"
  shows   "sum_upto mangoldt x \<le> 3 / 2 * x"
proof -
  have "sum_upto mangoldt x = psi (nat \<lfloor>x\<rfloor>)"
    by (simp add: sum_upto_altdef psi_def atLeastSucAtMost_greaterThanAtMost)
  also have "\<dots> \<le> 551 / 256 * ln 2 * real (nat \<lfloor>x\<rfloor>)"
    by (rule psi_ubound_log)
  also have "\<dots> \<le> 3 / 2 * real (nat \<lfloor>x\<rfloor>)"
    using Bertrand.ln_2_le by (intro mult_right_mono) auto
  also have "\<dots> \<le> 3 / 2 * x" using assms by linarith
  finally show ?thesis .
qed

text \<open>
  We can also, similarly, use the results from the Bertrand's postulate entry to show
  that the sum of $\ln p / p$ over all primes grows logarithmically.
\<close>
lemma Mertens_bigo:
  "(\<lambda>x. (\<Sum>p | prime p \<and> real p \<le> x. ln p / p) - ln x) \<in> O(\<lambda>_. 1)"
proof (intro bigoI[of _ 8] eventually_mono[OF eventually_gt_at_top[of 1]], goal_cases)
  case (1 x)
  have "\<bar>(\<Sum>p | prime p \<and> p \<le> nat \<lfloor>x\<rfloor>. ln p / p) - ln x\<bar> =
          \<bar>(\<Sum>p | prime p \<and> p \<le> nat \<lfloor>x\<rfloor>. ln p / p) - ln (nat \<lfloor>x\<rfloor>) - (ln x - ln (nat \<lfloor>x\<rfloor>))\<bar>"
    by simp
  also have "\<dots> \<le> \<bar>(\<Sum>p | prime p \<and> p \<le> nat \<lfloor>x\<rfloor>. ln p / p) - ln (nat \<lfloor>x\<rfloor>)\<bar> + \<bar>ln x - ln (nat \<lfloor>x\<rfloor>)\<bar>"
    by (rule abs_triangle_ineq4)
  also have "\<bar>(\<Sum>p | prime p \<and> p \<le> nat \<lfloor>x\<rfloor>. ln p / p) - ln (nat \<lfloor>x\<rfloor>)\<bar> \<le> 7"
    using 1 by (intro Mertens) auto
  also have "\<bar>ln x - ln (nat \<lfloor>x\<rfloor>)\<bar> = ln x - ln (nat \<lfloor>x\<rfloor>)"
    using 1 by (intro abs_of_nonneg) auto
  also from 1 have "\<dots> \<le> (x - nat \<lfloor>x\<rfloor>) / nat \<lfloor>x\<rfloor>" by (intro ln_diff_le) auto
  also have "\<dots> \<le> (x - nat \<lfloor>x\<rfloor>) / 1" using 1 by (intro divide_left_mono) auto
  also have "\<dots> = x - nat \<lfloor>x\<rfloor>" by simp
  also have "\<dots> \<le> 1" using 1 by linarith
  also have "(\<Sum>p | prime p \<and> p \<le> nat \<lfloor>x\<rfloor>. ln p / p) = (\<Sum>p | prime p \<and> real p \<le> x. ln p / p)"
    using 1 by (intro sum.cong refl) (auto simp: le_nat_iff le_floor_iff)
  finally show ?case by simp
qed

subsection \<open>The contribution of the non-principal characters\<close>

text \<open>
  The estimates in the next two sections are partially inspired by John Harrison's
  proof of Dirichlet's Theorem~\cite{harrison-dirichlet}.

  We first estimate the growth of the partial sums of
    \[-L'(1, \chi)/L(1, \chi) = \sum_{k=1}^\infty \chi(k) \frac{\Lambda(k)}{k}\]
  for a non-principal character $\chi$ and show that they are, in fact, bounded, which is
  ultimately a consequence of the non-vanishing of $L(1, \chi)$ for non-principal $\chi$.
\<close>

context dcharacter
begin

context
  includes no_vec_lambda_notation dcharacter_syntax
  fixes L
  assumes nonprincipal: "\<chi> \<noteq> \<chi>\<^sub>0"
  defines "L \<equiv> Dirichlet_L n \<chi> 1"
begin

lemma Dirichlet_L_nonprincipal_mangoldt_bound_aux_strong:
  assumes x: "x > 0"
  shows   "norm (L * sum_upto (\<lambda>k. \<chi> k * mangoldt k / k) x - sum_upto (\<lambda>k. \<chi> k * ln k / k) x)
             \<le> 9 / 2 * real (totient n)"
proof -
  define B where "B = 3 * real (totient n)"
  have "sum_upto (\<lambda>k. \<chi> k * ln k / k) x = sum_upto (\<lambda>k. \<chi> k * (\<Sum>d | d dvd k. mangoldt d) / k) x"
    by (intro sum_upto_cong) (simp_all add: mangoldt_sum)
  also have "\<dots> = sum_upto (\<lambda>k. \<Sum>d | d dvd k. \<chi> k * mangoldt d / k) x"
    by (simp add: sum_distrib_left sum_distrib_right sum_divide_distrib)
  also have "\<dots> = sum_upto (\<lambda>k. sum_upto (\<lambda>d. \<chi> (d * k) * mangoldt k / (d * k)) (x / real k)) x"
    by (rule sum_upto_sum_divisors)
  also have "\<dots> = sum_upto (\<lambda>k. \<chi> k * mangoldt k / k * sum_upto (\<lambda>d. \<chi> d / d) (x / real k)) x"
    by (simp add: sum_upto_def sum_distrib_left mult_ac)
  also have "L * sum_upto (\<lambda>k. \<chi> k * mangoldt k / k) x - \<dots> =
              sum_upto (\<lambda>k. (L - sum_upto (\<lambda>d. \<chi> d / d) (x / real k)) * (\<chi> k * mangoldt k / k)) x"
    unfolding ring_distribs by (simp add: sum_upto_def sum_subtractf sum_distrib_left mult_ac)
  also have "norm \<dots> \<le> sum_upto (\<lambda>k. B / x * mangoldt k) x" unfolding sum_upto_def
  proof (rule sum_norm_le, goal_cases)
    case (1 k)
    have "norm ((L - sum_upto (\<lambda>d. \<chi> d / of_nat d) (x / k)) * \<chi> k * (mangoldt k / of_nat k)) \<le>
            (B * real k / x) * 1 * (mangoldt k / real k)" unfolding norm_mult norm_divide
    proof (intro mult_mono divide_left_mono)
      show "norm (L - sum_upto (\<lambda>d. \<chi> d / d) (x / k)) \<le> B * real k / x"
        using Dirichlet_L_minus_partial_sum_bound[OF nonprincipal, of 1 "x / k"] 1 x
        by (simp add: powr_minus B_def L_def divide_simps norm_minus_commute)
    qed (insert 1, auto intro!: divide_nonneg_pos mangoldt_nonneg norm_le_1 simp: B_def)
    also have "\<dots> =  B / x * mangoldt k" using 1 by simp
    finally show ?case by (simp add: sum_upto_def mult_ac)
  qed
  also have "\<dots> = B / x * sum_upto mangoldt x"
    unfolding sum_upto_def sum_distrib_left by simp
  also have "\<dots> \<le> B / x * (3 / 2 * x)" using x
    by (intro mult_left_mono sum_upto_mangoldt_le) (auto simp: B_def)
  also have "\<dots> = 9 / 2 * real (totient n)" using x by (simp add: B_def)
  finally show ?thesis by (simp add: B_def)
qed

lemma Dirichlet_L_nonprincipal_mangoldt_aux_bound:
  "(\<lambda>x. L * sum_upto (\<lambda>k. \<chi> k * mangoldt k / k) x - sum_upto (\<lambda>k. \<chi> k * ln k / k) x) \<in> O(\<lambda>_. 1)"
  by (intro bigoI[of _ "9 / 2 * real (totient n)"] eventually_mono[OF eventually_gt_at_top[of 0]])
     (use Dirichlet_L_nonprincipal_mangoldt_bound_aux_strong in simp_all)

lemma nonprincipal_mangoldt_bound:
  "(\<lambda>x. sum_upto (\<lambda>k. \<chi> k * mangoldt k / k) x) \<in> O(\<lambda>_. 1)" (is "?lhs \<in> _")
proof -
  have [simp]: "L \<noteq> 0"
    using nonprincipal unfolding L_def by (intro Dirichlet_L_Re_ge_1_nonzero_nonprincipal) auto
  have "fds_converges (fds_deriv (fds \<chi>)) 1" using conv_abscissa_le_0[OF nonprincipal]
    by (intro fds_converges_deriv) (auto intro: le_less_trans)
  hence "summable (\<lambda>n. -(\<chi> n * ln n / n))"
    by (auto simp: fds_converges_def fds_deriv_def scaleR_conv_of_real fds_nth_fds' algebra_simps)
  hence "summable (\<lambda>n. \<chi> n * ln n / n)" by (simp only: summable_minus_iff)
  from summable_imp_convergent_sum_upto [OF this] obtain c where
    "(sum_upto (\<lambda>n. \<chi> n * ln n / n) \<longlongrightarrow> c) at_top" by blast
  hence *: "sum_upto (\<lambda>k. \<chi> k * ln k / k) \<in> O(\<lambda>_. 1)" unfolding sum_upto_def
    by (intro bigoI_tendsto[of _ _ c]) auto
  from sum_in_bigo[OF Dirichlet_L_nonprincipal_mangoldt_aux_bound *]
    have "(\<lambda>x. L * sum_upto (\<lambda>k. \<chi> k * mangoldt k / k) x) \<in> O(\<lambda>_. 1)" by (simp add: L_def)
  thus ?thesis by simp
qed

end
end

subsection \<open>The contribution of the principal character\<close>

text \<open>
  Next, we turn to the analogous partial sum for the principal character and show that
  it grows logarithmically and therefore is the dominant contribution.
\<close>

context residues_nat
begin
context
  includes no_vec_lambda_notation dcharacter_syntax
begin

lemma principal_dchar_sum_bound:
  "(\<lambda>x. (\<Sum>p | prime p \<and> real p \<le> x. \<chi>\<^sub>0 p * (ln p / p)) - ln x) \<in> O(\<lambda>_. 1)"
proof -
  have fin [simp]: "finite {p. prime p \<and> real p \<le> x \<and> Q p}" for Q x
    by (rule finite_subset[of _ "{..nat \<lfloor>x\<rfloor>}"]) (auto simp: le_nat_iff le_floor_iff)
  from fin[of _ "\<lambda>_. True"] have [simp]: "finite {p. prime p \<and> real p \<le> x}" for x
    by (simp del: fin)
  define P :: complex where "P = (\<Sum>p | prime p \<and> p dvd n. of_real (ln p / p))"

  have "(\<lambda>x. (\<Sum>p | prime p \<and> real p \<le> x. \<chi>\<^sub>0 p * (ln p / p)) - ln x) \<in>
          \<Theta>(\<lambda>x. of_real ((\<Sum>p | prime p \<and> real p \<le> x. ln p / p) - ln x) - P)" (is "_ \<in> \<Theta>(?f)")
  proof (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "real n"]], goal_cases)
    case (1 x)
    have *: "{p. prime p \<and> real p \<le> x} =
               {p. prime p \<and> real p \<le> x \<and> p dvd n} \<union> {p. prime p \<and> real p \<le> x \<and> \<not>p dvd n}"
      (is "_ = ?A \<union> ?B") by auto
    have "(\<Sum>p | prime p \<and> real p \<le> x. of_real (ln p / p)) =
            (\<Sum>p\<in>?A. of_real (ln p / p)) + (\<Sum>p\<in>?B. complex_of_real (ln p / p))"
      by (subst *, subst sum.union_disjoint) auto
    also from 1 have "?A = {p. prime p \<and> p dvd n}" using n by (auto dest: dvd_imp_le)
    also have "(\<Sum>p\<in>\<dots>. of_real (ln p / p)) = P" by (simp add: P_def)
    also have "(\<Sum>p\<in>?B. of_real (ln p / p)) =
                 (\<Sum>p | prime p \<and> real p \<le> x. \<chi>\<^sub>0 p * (ln p / p))"
      by (intro sum.mono_neutral_cong_left)
         (auto simp: principal_dchar_def prime_gt_0_nat coprime_absorb_left prime_imp_coprime)
    finally show ?case using 1 by (simp add: Ln_of_real)
  qed
  also have "?f \<in> O(\<lambda>_. of_real 1)"
    by (rule sum_in_bigo, subst landau_o.big.of_real_iff, rule Mertens_bigo) auto
  finally show ?thesis by simp
qed

lemma principal_dchar_sum_bound':
  "(\<lambda>x. sum_upto (\<lambda>k. \<chi>\<^sub>0 k * mangoldt k / k) x - Ln x) \<in> O(\<lambda>_. 1)"
proof -
  have "(\<lambda>x. sum_upto (\<lambda>k. \<chi>\<^sub>0 k * mangoldt k / k) x -
               (\<Sum>p | prime p \<and> real p \<le> x. \<chi>\<^sub>0 p * (ln p / p))) \<in> O(\<lambda>_. 1)"
  proof (intro bigoI[of _ 3] eventually_mono[OF eventually_gt_at_top[of 0]], goal_cases)
    case (1 x)
    have "norm (complex_of_real (\<Sum>k | real k \<le> x \<and> coprime k n. mangoldt k / k) -
                of_real (\<Sum>p | prime p \<and> p \<in> {k. real k \<le> x \<and> coprime k n}. ln p / p)) \<le> 3"
      unfolding of_real_diff [symmetric] norm_of_real
      by (rule Mertens_mangoldt_versus_ln[where n = "nat \<lfloor>x\<rfloor>"])
         (insert n, auto simp: Suc_le_eq le_nat_iff le_floor_iff intro!: Nat.gr0I)
    also have "complex_of_real (\<Sum>k | real k \<le> x \<and> coprime k n. mangoldt k / k) =
                 sum_upto (\<lambda>k. \<chi>\<^sub>0 k * mangoldt k / k) x"
      unfolding sum_upto_def of_real_sum using n
      by (intro sum.mono_neutral_cong_left) (auto simp: principal_dchar_def intro!: Nat.gr0I)
    also have "complex_of_real (\<Sum>p | prime p \<and> p \<in> {k. real k \<le> x \<and> coprime k n}. ln p / p) =
                 (\<Sum>p | prime p \<and> real p \<le> x. \<chi>\<^sub>0 p * (ln p / p))"
      unfolding of_real_sum
      by (intro sum.mono_neutral_cong_left)
         (auto simp: principal_dchar_def le_nat_iff le_floor_iff prime_gt_0_nat
               intro!: finite_subset[of _ "{..nat \<lfloor>x\<rfloor>}"])
    finally show ?case by simp
  qed
  from sum_in_bigo(1)[OF principal_dchar_sum_bound this] show ?thesis
    by simp
qed

subsection \<open>The main result\<close>

text \<open>
  We can now show the main result by extracting the primes we want using the orthogonality
  relation on characters, separating the principal part of the sum from the non-principal ones
  and then applying the above estimates.
\<close>
lemma Dirichlet_strong:
  assumes "coprime h n"
  shows   "(\<lambda>x. (\<Sum>p | prime p \<and> [p = h] (mod n) \<and> real p \<le> x. ln p / p) - ln x / totient n)
             \<in> O(\<lambda>_. 1)" (is "(\<lambda>x. sum _ (?A x) - _) \<in> _")
proof -
  from assms obtain h' where h': "[h * h' = Suc 0] (mod n)"
    by (subst (asm) coprime_iff_invertible_nat) blast
  let ?A' = "\<lambda>x. {p. p > 0 \<and> real p \<le> x \<and> [p = h] (mod n)}"
  let ?B = "dcharacters n - {\<chi>\<^sub>0}"
  have [simp]: "\<chi>\<^sub>0 \<in> dcharacters n"
    by (auto simp: dcharacters_def principal.dcharacter_axioms)

  have "(\<lambda>x. of_nat (totient n) * (\<Sum>p\<in>?A' x. mangoldt p / p) - ln x) \<in>
             \<Theta>(\<lambda>x. sum_upto (\<lambda>k. \<chi>\<^sub>0 k * mangoldt k / k) x - ln x +
                  (\<Sum>\<chi>\<in>?B. \<chi> h' * sum_upto (\<lambda>k. \<chi> k * mangoldt k / k) x))"
    (is "_ \<in> \<Theta>(?f)")
  proof (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of 0]], goal_cases)
    case (1 x)
    have "of_nat (totient n) * (\<Sum>p\<in>?A' x. of_real (mangoldt p / p) :: complex) =
            (\<Sum>p\<in>?A' x. of_nat (totient n) * of_real (mangoldt p / p))"
      by (subst sum_distrib_left) simp_all
    also have "\<dots> = sum_upto (\<lambda>k. \<Sum>\<chi>\<in>dcharacters n. \<chi> (h' * k) * (mangoldt k / k)) x"
      unfolding sum_upto_def
    proof (intro sum.mono_neutral_cong_left ballI, goal_cases)
      case (3 p)
      have "[h' * p \<noteq> 1] (mod n)"
      proof
        assume "[h' * p = 1] (mod n)"
        hence "[h * (h' * p) = h * 1] (mod n)" by (rule cong_scalar_left)
        hence "[h = h * h' * p] (mod n)" by (simp add: mult_ac cong_sym)
        also have "[h * h' * p = 1 * p] (mod n)"
          using h' by (intro cong_scalar_right) auto
        finally have "[p = h] (mod n)" by (simp add: cong_sym)
        with 3 show False by auto
      qed
      thus ?case
        by (auto simp: sum_dcharacters sum_divide_distrib [symmetric] sum_distrib_right [symmetric])
    next
      case (4 p)
      hence "[p * h' = h * h'] (mod n)" by (intro cong_scalar_right) auto
      also have "[h * h' = 1] (mod n)" using h' by simp
      finally have "[h' * p = 1] (mod n)" by (simp add: mult_ac)
      thus ?case using h' 4
        by (auto simp: sum_dcharacters sum_divide_distrib [symmetric] sum_distrib_right [symmetric])
    qed auto
    also have "\<dots> = (\<Sum>\<chi>\<in>dcharacters n. sum_upto (\<lambda>k. \<chi> (h' * k) * (mangoldt k / k)) x)"
      unfolding sum_upto_def by (rule sum.swap)
    also have "\<dots> = (\<Sum>\<chi>\<in>dcharacters n. \<chi> h' * sum_upto (\<lambda>k. \<chi> k * (mangoldt k / k)) x)"
      unfolding sum_upto_def
      by (intro sum.cong refl) (auto simp: dcharacters_def dcharacter.mult sum_distrib_left mult_ac)
    also have "\<dots> = \<chi>\<^sub>0 h' * sum_upto (\<lambda>k. \<chi>\<^sub>0 k * (mangoldt k / k)) x +
                    (\<Sum>\<chi>\<in>?B. \<chi> h' * sum_upto (\<lambda>k. \<chi> k * (mangoldt k / k)) x)"
      by (subst sum.remove [symmetric]) (auto simp: sum_distrib_left)
    also have "coprime h' n"
      using h' by (subst coprime_iff_invertible_nat, subst (asm) mult.commute) auto
    hence "\<chi>\<^sub>0 h' = 1"
      by (simp add: principal_dchar_def)
    finally show ?case using n 1 by (simp add: Ln_of_real)
  qed
  also have "?f \<in> O(\<lambda>_. complex_of_real 1)"
  proof (rule sum_in_bigo[OF _ big_sum_in_bigo], goal_cases)
    case 1
    from principal_dchar_sum_bound' show ?case by simp
  next
    case (2 \<chi>)
    then interpret dcharacter n G \<chi> by (simp_all add: G_def dcharacters_def)
    from 2 have "\<chi> \<noteq> \<chi>\<^sub>0" by auto
    thus ?case unfolding of_real_1
      by (intro landau_o.big.mult_in_1 nonprincipal_mangoldt_bound) auto
  qed
  finally have *: "(\<lambda>x. real (totient n) * (\<Sum>p\<in>?A' x. mangoldt p / p) - ln x) \<in> O(\<lambda>_. 1)"
    by (subst (asm) landau_o.big.of_real_iff)

  have "(\<lambda>x. real (totient n) * ((\<Sum>p\<in>?A x. ln p / p) - (\<Sum>p\<in>?A' x. mangoldt p / p))) \<in> O(\<lambda>_. 1)"
  proof (intro landau_o.big.mult_in_1)
    show "(\<lambda>x. (\<Sum>p\<in>?A x. ln p / p) - (\<Sum>p\<in>?A' x. mangoldt p / p)) \<in> O(\<lambda>_. 1)"
      unfolding landau_o.big.of_real_iff
    proof (intro bigoI[of _ 3] eventually_mono[OF eventually_gt_at_top[of 0]], goal_cases)
      case (1 x)
      have "\<bar>(\<Sum>p\<in>?A' x. mangoldt p / p) - (\<Sum>p | prime p \<and> p \<in> ?A' x. ln p / p)\<bar> \<le> 3"
        by (rule Mertens_mangoldt_versus_ln[where n = "nat \<lfloor>x\<rfloor>"])
           (auto simp: le_nat_iff le_floor_iff)
      also have "{p. prime p \<and> p \<in> ?A' x} = ?A x" by (auto simp: prime_gt_0_nat)
      finally show ?case by (simp add: abs_minus_commute)
    qed
  qed auto
  from sum_in_bigo(1)[OF * this]
    have "(\<lambda>x. totient n * (\<Sum>p\<in>?A x. ln p / p) - ln x) \<in> O(\<lambda>_. 1)"
    by (simp add: field_simps)
  also have "(\<lambda>x. totient n * (\<Sum>p\<in>?A x. ln p / p) - ln x) =
               (\<lambda>x. totient n * ((\<Sum>p\<in>?A x. ln p / p) - ln x / totient n))"
    using n by (intro ext) (auto simp: field_simps)
  also have "\<dots> \<in> O(\<lambda>_. 1) \<longleftrightarrow> ?thesis" using n
    by (intro landau_o.big.cmult_in_iff) auto
  finally show ?thesis .
qed

text \<open>
  It is now obvious that the set of primes we are interested in is, in fact, infinite.
\<close>
theorem Dirichlet:
  assumes "coprime h n"
  shows   "infinite {p. prime p \<and> [p = h] (mod n)}"
proof
  assume "finite {p. prime p \<and> [p = h] (mod n)}"
  then obtain K where K: "{p. prime p \<and> [p = h] (mod n)} \<subseteq> {..<K}"
    by (auto simp: finite_nat_iff_bounded)
  have "eventually (\<lambda>x. (\<Sum>p | prime p \<and> [p = h] (mod n) \<and> real p \<le> x. ln p / p) =
                        (\<Sum>p | prime p \<and> [p = h] (mod n). ln p / p)) at_top"
    using eventually_ge_at_top[of "real K"] by eventually_elim (intro sum.cong, use K in auto)
  hence "(\<lambda>x. (\<Sum>p | prime p \<and> [p = h] (mod n) \<and> real p \<le> x. ln p / p)) \<in>
            \<Theta>(\<lambda>_. (\<Sum>p | prime p \<and> [p = h] (mod n). ln p / p))" by (intro bigthetaI_cong) auto
  also have "(\<lambda>_. (\<Sum>p | prime p \<and> [p = h] (mod n). ln p / p)) \<in> O(\<lambda>_. 1)" by simp
  finally have "(\<lambda>x. (\<Sum>p | prime p \<and> [p = h] (mod n) \<and> real p \<le> x. ln p / p)) \<in> O(\<lambda>_. 1)" .
  from sum_in_bigo(2)[OF this Dirichlet_strong[OF assms]] and n show False by simp
qed

text \<open>
  In the future, one could extend this result to more precise estimates of the distribution
  of primes in arithmetic progressions in a similar way to the Prime Number Theorem.
\<close>

end
end
end


section \<open>Executable Type Checker\<close>

theory Wasm_Checker imports Wasm_Checker_Types begin

fun convert_cond :: "t \<Rightarrow> t \<Rightarrow> sx option \<Rightarrow> bool" where
  "convert_cond t1 t2 sx = ((t1 \<noteq> t2) \<and> (sx = None) = ((is_float_t t1 \<and> is_float_t t2)
                                                        \<or> (is_int_t t1 \<and> is_int_t t2 \<and> (t_length t1 < t_length t2))))"

fun same_lab_h :: "nat list \<Rightarrow> (t list) list \<Rightarrow> t list \<Rightarrow> (t list) option" where
  "same_lab_h [] _ ts = Some ts"
| "same_lab_h (i#is) lab_c ts = (if i \<ge> length lab_c
                                 then None
                                 else (if lab_c!i = ts
                                       then same_lab_h is lab_c (lab_c!i)
                                       else None))"

fun same_lab :: "nat list \<Rightarrow> (t list) list \<Rightarrow> (t list) option" where
  "same_lab [] lab_c = None"
| "same_lab (i#is) lab_c = (if i \<ge> length lab_c
                            then None
                            else same_lab_h is lab_c (lab_c!i))"

lemma same_lab_h_conv_list_all:
  assumes "same_lab_h ils ls ts' = Some ts"
  shows "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils \<and> ts' = ts"
  using assms
proof(induction ils)
  case (Cons a ils)
  thus ?case
    apply (simp,safe)
       apply (metis not_less option.distinct(1))+
    done
qed simp

lemma same_lab_conv_list_all:
  assumes "same_lab ils ls = Some ts"
  shows "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils"
  using assms
proof (induction rule: same_lab.induct)
case (2 i "is" lab_c)
  thus ?case
    using same_lab_h_conv_list_all
    by (metis (mono_tags, lifting) list_all_simps(1) not_less option.distinct(1) same_lab.simps(2))
qed simp

lemma list_all_conv_same_lab_h:
  assumes "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils"
  shows "same_lab_h ils ls ts = Some ts"
  using assms
  by (induction ils, simp_all)

lemma list_all_conv_same_lab:
  assumes "list_all (\<lambda>i. i < length ls \<and>ls!i = ts) (is@[i])"
  shows "same_lab (is@[i]) ls = Some ts"
  using assms
proof (induction "(is@[i])")
  case (Cons a x)
  thus ?case
    using list_all_conv_same_lab_h[OF Cons(3)]
    by (metis option.distinct(1) same_lab.simps(2) same_lab_h.simps(2))
qed auto

fun b_e_type_checker :: "t_context \<Rightarrow>  b_e list \<Rightarrow> tf \<Rightarrow> bool"
and check :: "t_context \<Rightarrow> b_e list \<Rightarrow> checker_type \<Rightarrow> checker_type"
and check_single :: "t_context \<Rightarrow>  b_e \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "b_e_type_checker \<C> es (tn _> tm) = c_types_agree (check \<C> es (Type tn)) tm"
| "check \<C> es ts = (case es of
                     [] \<Rightarrow> ts
                   | (e#es) \<Rightarrow> (case ts of
                                  Bot \<Rightarrow> Bot
                                | _ \<Rightarrow> check \<C> es (check_single \<C> e ts)))"
(*
foldl (\<lambda> ts e. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) es

primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
foldl_Nil:  "foldl f a [] = a" |
foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
*)
  (* num ops *)
| "check_single \<C> (C v) ts = type_update ts [] (Type [typeof v])"
| "check_single \<C> (Unop_i t _) ts = (if is_int_t t
                                       then type_update ts [TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Unop_f t _) ts = (if is_float_t t
                                       then type_update ts [TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Binop_i t _) ts = (if is_int_t t
                                       then type_update ts [TSome t, TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Binop_f t _) ts = (if is_float_t t
                                       then type_update ts [TSome t, TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Testop t _) ts = (if is_int_t t
                                       then type_update ts [TSome t] (Type [T_i32])
                                       else Bot)"
| "check_single \<C> (Relop_i t _) ts = (if is_int_t t
                                       then type_update ts [TSome t, TSome t] (Type [T_i32])
                                       else Bot)"
| "check_single \<C> (Relop_f t _) ts =  (if is_float_t t
                                       then type_update ts [TSome t, TSome t] (Type [T_i32])
                                       else Bot)"
  (* convert *)
| "check_single \<C> (Cvtop t1 Convert t2 sx) ts = (if (convert_cond t1 t2 sx)
                                                   then type_update ts [TSome t2] (Type [t1])
                                                   else Bot)"
  (* reinterpret *)
| "check_single \<C> (Cvtop t1 Reinterpret t2 sx) ts = (if ((t1 \<noteq> t2) \<and> t_length t1 = t_length t2 \<and> sx = None)
                                                         then type_update ts [TSome t2] (Type [t1])
                                                         else Bot)"
  (* unreachable, nop, drop, select *)
| "check_single \<C> (Unreachable) ts = type_update ts [] (TopType [])"
| "check_single \<C> (Nop) ts = ts"
| "check_single \<C> (Drop) ts = type_update ts [TAny] (Type [])"
| "check_single \<C> (Select) ts = type_update_select ts"
  (* block *)
| "check_single \<C> (Block (tn _> tm) es) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es (tn _> tm))
                                                then type_update ts (to_ct_list tn) (Type tm)
                                                else Bot)"
  (* loop *)
| "check_single \<C> (Loop (tn _> tm) es) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tn] @ (label \<C>))\<rparr>) es (tn _> tm))
                                                then type_update ts (to_ct_list tn) (Type tm)
                                                else Bot)"
  (* if *)
| "check_single \<C> (If (tn _> tm) es1 es2) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es1 (tn _> tm)
                                                    \<and> b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es2 (tn _> tm))
                                                then type_update ts (to_ct_list (tn@[T_i32])) (Type tm)
                                                else Bot)"
  (* br *)
| "check_single \<C> (Br i) ts = (if i < length (label \<C>)
                                 then type_update ts (to_ct_list ((label \<C>)!i)) (TopType [])
                                 else Bot)"
  (* br_if *)
| "check_single \<C> (Br_if i) ts = (if i < length (label \<C>)
                                    then type_update ts (to_ct_list ((label \<C>)!i @ [T_i32])) (Type ((label \<C>)!i))
                                    else Bot)"
  (* br_table *)
| "check_single \<C> (Br_table is i) ts = (case (same_lab (is@[i]) (label \<C>)) of
                                        None \<Rightarrow> Bot
                                      | Some tls \<Rightarrow> type_update ts (to_ct_list (tls @ [T_i32])) (TopType []))"
  (* return *)
| "check_single \<C> (Return) ts = (case (return \<C>) of
                                   None \<Rightarrow> Bot
                                 | Some tls \<Rightarrow> type_update ts (to_ct_list tls) (TopType []))"
  (* call *)
| "check_single \<C> (Call i) ts = (if i < length (func_t \<C>)
                                    then (case ((func_t \<C>)!i) of
                                            (tn _> tm) \<Rightarrow> type_update ts (to_ct_list tn) (Type tm))
                                    else Bot)"
  (* call_indirect *)
| "check_single \<C> (Call_indirect i) ts = (if (table \<C>) \<noteq> None \<and> i < length (types_t \<C>)
                                            then (case ((types_t \<C>)!i) of
                                                    (tn _> tm) \<Rightarrow> type_update ts (to_ct_list (tn@[T_i32])) (Type tm))
                                            else Bot)"
  (* get_local *)
| "check_single \<C> (Get_local i) ts = (if i < length (local \<C>)
                                        then type_update ts [] (Type [(local \<C>)!i])
                                        else Bot)"
  (* set_local *)
| "check_single \<C> (Set_local i) ts = (if i < length (local \<C>)
                                        then type_update ts [TSome ((local \<C>)!i)] (Type [])
                                        else Bot)"
  (* tee_local *)
| "check_single \<C> (Tee_local i) ts = (if i < length (local \<C>)
                                 then type_update ts [TSome ((local \<C>)!i)] (Type [(local \<C>)!i])
                                 else Bot)"
  (* get_global *)
| "check_single \<C> (Get_global i) ts = (if i < length (global \<C>)
                                         then type_update ts [] (Type [tg_t ((global \<C>)!i)])
                                         else Bot)"
  (* set_global *)
| "check_single \<C> (Set_global i) ts = (if i < length (global \<C>) \<and> is_mut (global \<C> ! i)
                                         then type_update ts [TSome (tg_t ((global \<C>)!i))] (Type [])
                                         else Bot)"
  (* load *)
| "check_single \<C> (Load t tp_sx a off) ts = (if (memory \<C>) \<noteq> None \<and> load_store_t_bounds a (option_projl tp_sx) t
                                 then type_update ts [TSome T_i32] (Type [t])
                                 else Bot)"
  (* store *)
| "check_single \<C> (Store t tp a off) ts = (if (memory \<C>) \<noteq> None \<and> load_store_t_bounds a tp t
                                             then type_update ts [TSome T_i32,TSome t] (Type [])
                                             else Bot)"
  (* current_memory *)
| "check_single \<C> Current_memory ts = (if (memory \<C>) \<noteq> None
                                         then type_update ts [] (Type [T_i32])
                                         else Bot)"
  (* grow_memory *)
| "check_single \<C> Grow_memory ts = (if (memory \<C>) \<noteq> None
                                      then type_update ts [TSome T_i32] (Type [T_i32])
                                      else Bot)"

end


header {* The abstract semantics is computable *}

theory AbsCFComp
imports AbsCF Computability FixTransform CPSUtils MapSets
begin

default_sort type

text {*
The point of the abstract semantics is that it is computable. To show this, we exploit the special structure of @{text \<aF>} and @{text \<aC>}: Each call adds some elements to the result set and joins this with the results from a number of recursive calls. So we separate these two actions into separate functions. These take as arguments the direct sum of @{text \<afstate>} and @{text \<acstate>}, i.e.\ we treat the two mutually recursive functions now as one.

@{text abs_g} gives the local result for the given argument.
*}

fixrec abs_g :: "('c::contour \<afstate> + 'c \<acstate>) discr \<rightarrow> 'c \<aans>"
  where "abs_g\<cdot>x = (case undiscr x of
              (Inl (PC (Lambda lab vs c, \<beta>), as, ve, b)) \<Rightarrow> {}
            | (Inl (PP (Plus c),[_,_,cnts],ve,b)) \<Rightarrow>
                     let b' = \<anb> b c;
                         \<beta>  = [c \<mapsto> b]
                     in {((c, \<beta>), cont) | cont . cont \<in> cnts}
            | (Inl (PP (prim.If ct cf),[_, cntts, cntfs],ve,b)) \<Rightarrow>
                  ((   let b' = \<anb> b ct;
                            \<beta> = [ct \<mapsto> b]
                        in {((ct, \<beta>), cnt) | cnt . cnt \<in> cntts}
                   )\<union>(
                       let b' = \<anb> b cf;
                            \<beta> = [cf \<mapsto> b]
                        in {((cf, \<beta>), cnt) | cnt . cnt \<in> cntfs}
                   ))
            | (Inl (AStop,[_],_,_)) \<Rightarrow> {}
            | (Inl _) \<Rightarrow> \<bottom>
            | (Inr (App lab f vs,\<beta>,ve,b)) \<Rightarrow>
                 let fs = \<aA> f \<beta> ve;
                     as = map (\<lambda>v. \<aA> v \<beta> ve) vs;
                     b' = \<anb> b lab
                  in {((lab, \<beta>),f') | f' . f'\<in> fs}
            | (Inr (Let lab ls c',\<beta>,ve,b)) \<Rightarrow> {}
        )"

text {*
@{text abs_R} gives the set of arguments passed to the recursive calls.
*}

fixrec abs_R :: "('c::contour \<afstate> + 'c \<acstate>) discr \<rightarrow> ('c::contour \<afstate> + 'c \<acstate>) discr set"
  where "abs_R\<cdot>x = (case undiscr x of
              (Inl (PC (Lambda lab vs c, \<beta>), as, ve, b)) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,a). {(v,b) := a}.) (zip vs as)))
                     in {Discr (Inr (c,\<beta>',ve',b))}
                else \<bottom>)
            | (Inl (PP (Plus c),[_,_,cnts],ve,b)) \<Rightarrow>
                     let b' = \<anb> b c;
                         \<beta>  = [c \<mapsto> b]
                     in (\<Union>cnt\<in>cnts. {Discr (Inl (cnt,[{}],ve,b'))})
            | (Inl (PP (prim.If ct cf),[_, cntts, cntfs],ve,b)) \<Rightarrow>
                  ((   let b' = \<anb> b ct;
                            \<beta> = [ct \<mapsto> b]
                        in (\<Union>cnt\<in>cntts . {Discr (Inl (cnt,[],ve,b'))})
                   )\<union>(
                       let b' = \<anb> b cf;
                            \<beta> = [cf \<mapsto> b]
                        in (\<Union>cnt\<in>cntfs . {Discr (Inl (cnt,[],ve,b'))})
                   ))
            | (Inl (AStop,[_],_,_)) \<Rightarrow> {}
            | (Inl _) \<Rightarrow> \<bottom>
            | (Inr (App lab f vs,\<beta>,ve,b)) \<Rightarrow>
                 let fs = \<aA> f \<beta> ve;
                     as = map (\<lambda>v. \<aA> v \<beta> ve) vs;
                     b' = \<anb> b lab
                  in (\<Union>f' \<in> fs. {Discr (Inl (f',as,ve,b'))})
            | (Inr (Let lab ls c',\<beta>,ve,b)) \<Rightarrow>
                 let b' = \<anb> b lab;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                     ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,l). {(v,b') := (\<aA> (L l) \<beta>' ve)}.) ls))
                 in {Discr (Inr (c',\<beta>',ve',b'))}
        )"

text {*
The initial argument vector, as created by @{text \<aPR>}.
*}

definition initial_r :: "prog \<Rightarrow> ('c::contour \<afstate> + 'c \<acstate>) discr"
  where "initial_r prog = Discr (Inl
     (the_elem (\<aA> (L prog) empty {}.), [{AStop}], {}., \<abinit>))"

subsection {* Towards finiteness *}

text {*
We need to show that the set of possible arguments for a given program @{text p} is finite. Therefore, we define the set of possible procedures, of possible arguments to @{text \<aF>}, or possible arguments to @{text \<aC>} and of possible arguments.
*}

definition proc_poss :: "prog \<Rightarrow> 'c::contour proc set"
  where "proc_poss p = PC ` (lambdas p \<times> maps_over (labels p) UNIV) \<union> PP ` prims p \<union> {AStop}"

definition fstate_poss :: "prog \<Rightarrow> 'c::contour a_fstate set"
  where "fstate_poss p = (proc_poss p \<times> NList (Pow (proc_poss p)) (call_list_lengths p) \<times> smaps_over (vars p \<times> UNIV) (proc_poss p) \<times> UNIV)"

definition cstate_poss :: "prog \<Rightarrow> 'c::contour a_cstate set"
  where "cstate_poss p = (calls p \<times> maps_over (labels p) UNIV \<times> smaps_over (vars p \<times> UNIV) (proc_poss p) \<times> UNIV)"

definition arg_poss :: "prog \<Rightarrow> ('c::contour a_fstate + 'c a_cstate) discr set"
  where "arg_poss p = Discr ` (fstate_poss p <+> cstate_poss p)"

text {*
Using the auxiliary results from @{theory CPSUtils}, we see that the argument space as defined here is finite.
*}

lemma finite_arg_space: "finite (arg_poss p)"
  unfolding arg_poss_def and cstate_poss_def and fstate_poss_def and proc_poss_def
  by (auto intro!: finite_cartesian_product finite_imageI maps_over_finite smaps_over_finite finite_UNIV finite_Nlist)

text {*
But is it closed? I.e.\ if we pass a member of @{text arg_poss} to @{text abs_R}, are the generated recursive call arguments also in @{text arg_poss}? This is shown in @{text arg_space_complete}, after proving an auxiliary result about the possible outcome of a call to @{text \<aA>} and an admissibility lemma.
*}

lemma evalV_possible:
  assumes f: "f \<in> \<aA> d \<beta> ve"
  and d: "d \<in> vals p"
  and ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
  and \<beta>: "\<beta> \<in> maps_over (labels p) UNIV"
shows "f \<in> proc_poss p"
proof (cases "(d,\<beta>,ve)" rule: evalV_a.cases)
case (1 cl \<beta>' ve')
  thus ?thesis using f by auto next
case (2 prim \<beta>' ve')
  thus ?thesis using d f
    by (auto dest: vals1 simp add:proc_poss_def)
next
case (3 l var \<beta>' ve')
  thus ?thesis using f d smaps_over_im[OF _ ve]
  by (auto split:option.split_asm dest: vals2)
next
case (4 l \<beta> ve)
  thus ?thesis using f d \<beta>
  by (auto dest!: vals3 simp add:proc_poss_def)
qed

lemma adm_subset: "cont (\<lambda>x. f x) \<Longrightarrow>  adm (\<lambda>x. f x \<subseteq> S)"
by (subst sqsubset_is_subset[THEN sym], intro adm_lemmas cont2cont)

lemma arg_space_complete:
  "state \<in> arg_poss p \<Longrightarrow> abs_R\<cdot>state \<subseteq> arg_poss p"
proof(induct rule: abs_R.induct[case_names Admissibility Bot Step])
case Admissibility show ?case
   by (intro adm_lemmas adm_subset cont2cont)
next
case Bot show ?case by simp next
case (Step abs_R)
  note state = Step(2)
  show ?case
  proof (cases state)
  case (Discr state') show ?thesis
   proof (cases state')
     case (Inl fstate) show ?thesis
     using Inl Discr state
     proof (cases fstate rule: a_fstate_case, auto)
     txt {* Case Lambda *}
     fix l vs c \<beta> as ve b
     assume "Discr (Inl (PC (Lambda l vs c, \<beta>), as, ve, b)) \<in> arg_poss p"
       hence lam: "Lambda l vs c \<in> lambdas p"
       and  beta: "\<beta> \<in> maps_over (labels p) UNIV "
       and  ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       and  as: "as \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding arg_poss_def fstate_poss_def proc_poss_def by auto

     from lam have "c \<in> calls p"
       by (rule lambdas1)

     moreover
     from lam have "l \<in> labels p"
       by (rule lambdas2)
     with beta have "\<beta>(l \<mapsto> b) \<in> maps_over (labels p) UNIV"
       by (rule maps_over_upd, auto)

     moreover
     from lam have vs: "set vs \<subseteq> vars p" by (rule lambdas3)
     from as have "\<forall> x \<in> set as. x \<in> Pow (proc_poss p)"
        unfolding NList_def nList_def by auto
     with vs have "ve \<union>. \<Union>.map (\<lambda>(v, y). { (v, b) := y}.) (zip vs as)
       \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)" (is "?ve' \<in> _")
       by (auto intro!: smaps_over_un[OF ve] smaps_over_Union smaps_over_singleton)
          (auto simp add:set_zip)

     ultimately
     have "(c, \<beta>(l \<mapsto> b), ?ve', b) \<in> cstate_poss p" (is "?cstate \<in> _")
       unfolding cstate_poss_def by simp
     thus "Discr (Inr ?cstate) \<in> arg_poss p"
       unfolding arg_poss_def by auto
     next

     txt {* Case Plus *}
     fix ve b l v1 v2 cnts cnt
     assume "Discr (Inl (PP (prim.Plus l), [v1, v2, cnts], ve, b)) \<in> arg_poss p"
         and "cnt \<in> cnts"
     hence "cnt \<in> proc_poss p"
         and "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       unfolding arg_poss_def fstate_poss_def NList_def nList_def
       by auto
     moreover
     have "[{}] \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding call_list_lengths_def NList_def nList_def by auto
     ultimately
     have "(cnt, [{}], ve, \<anb> b l) \<in> fstate_poss p"
       unfolding fstate_poss_def by auto
     thus "Discr (Inl (cnt, [{}], ve, \<anb> b l)) \<in> arg_poss p"
       unfolding arg_poss_def by auto
     next

     txt {* Case If (true case) *}
     fix ve b l1 l2 v cntst cntsf cnt
     assume "Discr (Inl (PP (prim.If l1 l2), [v, cntst, cntsf], ve, b)) \<in> arg_poss p"
         and "cnt \<in> cntst"
     hence "cnt \<in> proc_poss p"
         and "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       unfolding arg_poss_def fstate_poss_def NList_def nList_def
       by auto
     moreover
     have "[] \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding call_list_lengths_def NList_def nList_def by auto
     ultimately
     have "(cnt, [], ve, \<anb> b l1) \<in> fstate_poss p"
       unfolding fstate_poss_def by auto
     thus "Discr (Inl (cnt, [], ve, \<anb> b l1)) \<in> arg_poss p"
       unfolding arg_poss_def by auto
     next

     txt {* Case If (false case) *}
     fix ve b l1 l2 v cntst cntsf cnt
     assume "Discr (Inl (PP (prim.If l1 l2), [v, cntst, cntsf], ve, b)) \<in> arg_poss p"
         and "cnt \<in> cntsf"
     hence "cnt \<in> proc_poss p"
         and "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       unfolding arg_poss_def fstate_poss_def NList_def nList_def
       by auto
     moreover
     have "[] \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding call_list_lengths_def NList_def nList_def by auto
     ultimately
     have "(cnt, [], ve, \<anb> b l2) \<in> fstate_poss p"
       unfolding fstate_poss_def by auto
     thus "Discr (Inl (cnt, [], ve, \<anb> b l2)) \<in> arg_poss p"
       unfolding arg_poss_def by auto
    qed
  next
  case (Inr cstate)
  show ?thesis proof(cases cstate rule: prod_cases4)
   case (fields c \<beta> ve b)
   show ?thesis using Discr Inr fields state proof(cases c, auto simp add:HOL.Let_def simp del:evalV_a.simps)

     txt {* Case App *}
     fix l d ds f
     assume arg: "Discr (Inr (App l d ds, \<beta>, ve, b)) \<in> arg_poss p"
       and f: "f \<in> \<aA> d \<beta> ve"
     hence c: "App l d ds \<in> calls p"
       and d: "d \<in> vals p"
       and ds: "set ds \<subseteq> vals p"
       and beta: "\<beta> \<in> maps_over (labels p) UNIV"
       and ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
     by (auto simp add: arg_poss_def cstate_poss_def call_list_lengths_def dest: app1 app2)

     have len: "length ds \<in> call_list_lengths p"
       by (auto intro: rev_image_eqI[OF c] simp add: call_list_lengths_def)

     have "f \<in> proc_poss p"
       using f d ve beta by (rule evalV_possible)
     moreover
     have "map (\<lambda>v. \<aA> v \<beta> ve) ds \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       using ds len
       unfolding NList_def by (auto simp add:nList_def intro!: evalV_possible[OF _ _ ve beta])
     ultimately
     have "(f, map (\<lambda>v. \<aA> v \<beta> ve) ds, ve, \<anb> b l) \<in> fstate_poss p" (is "?fstate \<in> _")
       using ve
       unfolding fstate_poss_def by simp
     thus "Discr (Inl ?fstate) \<in> arg_poss p"
       unfolding arg_poss_def by auto

   next
     txt {* Case Let *}
     fix l binds c'
     assume arg: "Discr (Inr (Let l binds c', \<beta>, ve, b)) \<in> arg_poss p"
     hence l: "l \<in> labels p"
       and c': "c' \<in> calls p"
       and vars: "fst ` set binds \<subseteq> vars p"
       and ls: "snd ` set binds \<subseteq> lambdas p"
       and beta: "\<beta> \<in> maps_over (labels p) UNIV"
       and ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
     by (auto simp add: arg_poss_def cstate_poss_def call_list_lengths_def
              dest:let1 let2 let3 let4)

     have beta': "\<beta>(l \<mapsto> \<anb> b l) \<in> maps_over (labels p) UNIV" (is "?\<beta>' \<in> _")
       by (auto intro: maps_over_upd[OF beta l])

     moreover
     have "ve \<union>. \<Union>.map (\<lambda>(v, lam). { (v, \<anb> b l) := \<aA> (L lam) (\<beta>(l \<mapsto> \<anb> b l)) ve }.)
                binds
       \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)" (is "?ve' \<in> _")
       using vars ls beta'
       by (auto intro!: smaps_over_un[OF ve] smaps_over_Union)
          (auto intro!:smaps_over_singleton simp add: proc_poss_def)

     ultimately
     have "(c', ?\<beta>', ?ve', \<anb> b l) \<in> cstate_poss p" (is "?cstate \<in> _")
     using c' unfolding cstate_poss_def by simp
     thus "Discr (Inr ?cstate) \<in> arg_poss p"
       unfolding arg_poss_def by auto
   qed
 qed
qed
qed
qed

text {*
This result is now lifted to the powerset of @{text abs_R}.
*}

lemma arg_space_complete_ps: "states \<subseteq> arg_poss p \<Longrightarrow> (\<^ps>abs_R)\<cdot>states \<subseteq> arg_poss p"
using arg_space_complete unfolding powerset_lift_def by auto

text {*
We are not so much interested in the finiteness of the set of possible arguments but rather of the the set of occurring arguments, when we start with the initial argument. But as this is of course a subset of the set of possible arguments, this is not hard to show.
*}

lemma UN_iterate_less:
  assumes start: "x \<in> S"
  and step: "\<And>y. y\<subseteq>S \<Longrightarrow> (f\<cdot>y) \<subseteq> S"
  shows "(\<Union>i. iterate i\<cdot>f\<cdot>{x}) \<subseteq> S"
proof- {
  fix i
  have "iterate i\<cdot>f\<cdot>{x} \<subseteq> S"
  proof(induct i)
    case 0 show ?case using `x \<in> S` by simp next
    case (Suc i) thus ?case using step[of "iterate i\<cdot>f\<cdot>{x}"] by simp
  qed
  } thus ?thesis by auto
qed

lemma args_finite: "finite (\<Union>i. iterate i\<cdot>(\<^ps>abs_R)\<cdot>{initial_r p})" (is "finite ?S")
proof (rule finite_subset[OF _finite_arg_space])
  have [simp]:"p \<in> lambdas p" by (cases p, simp)
  show "?S \<subseteq> arg_poss p"
  unfolding initial_r_def
  by  (rule UN_iterate_less[OF _ arg_space_complete_ps])
      (auto simp add:arg_poss_def fstate_poss_def proc_poss_def call_list_lengths_def NList_def nList_def
         intro!: imageI)
qed

subsection {* A decomposition *}

text {*
The functions @{text abs_g} and @{text abs_R} are derived from @{text \<aF>} and @{text \<aC>}. This connection has yet to expressed explicitly.
*}

lemma Un_commute_helper:"(a \<union> b) \<union> (c \<union> d) = (a \<union> c) \<union> (b \<union> d)"
by auto

lemma a_evalF_decomp:
  "\<aF> = fst (sum_to_tup\<cdot>(fix\<cdot>(\<Lambda> f x. (\<Union>y\<in>abs_R\<cdot>x. f\<cdot>y) \<union> abs_g\<cdot>x)))"
apply (subst a_evalF_def)
apply (subst fix_transform_pair_sum)
apply (rule arg_cong [of _ _ "\<lambda>x. fst (sum_to_tup\<cdot>(fix\<cdot>x))"])
apply (simp)
apply (simp only: discr_app undiscr_Discr)
apply (rule cfun_eqI, rule cfun_eqI, simp)
apply (case_tac xa, rename_tac a, case_tac a, simp)
apply (case_tac aa rule:a_fstate_case, simp_all add: Un_commute_helper)
apply (case_tac b rule:prod_cases4)
apply (case_tac aa)
apply (simp_all add:HOL.Let_def)
done

subsection {* The iterative equation *}

text {*
Because of the special form of @{text \<aF>} (and thus @{text \<aPR>}) derived in the previous lemma, we can apply our generic results from @{theory Computability} and express the abstract semantics as the image of a finite set under a computable function.
*}

lemma a_evalF_iterative:
  "\<aF>\<cdot>(Discr x) = \<^ps>abs_g\<cdot>(\<Union>i. iterate i\<cdot>(\<^ps>abs_R)\<cdot>{Discr (Inl x)})"
by (simp del:abs_R.simps abs_g.simps add: theorem12 Un_commute a_evalF_decomp)

lemma a_evalCPS_interative:
"\<aPR> prog = \<^ps>abs_g\<cdot>(\<Union>i. iterate i\<cdot>(\<^ps>abs_R)\<cdot>{initial_r prog})"
unfolding evalCPS_a_def and initial_r_def
by(subst a_evalF_iterative, simp del:abs_R.simps abs_g.simps evalV_a.simps)

end


(*  Title:      Doc/Logics_ZF/If.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

First-Order Logic: the 'if' example.
*)

theory If imports "~~/src/FOL/FOL" begin

definition "if" :: "[o,o,o]=>o" where
  "if(P,Q,R) == P&Q | ~P&R"

lemma ifI:
    "[| P ==> Q; ~P ==> R |] ==> if(P,Q,R)"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (simp add: if_def)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply blast
done

lemma ifE:
   "[| if(P,Q,R);  [| P; Q |] ==> S; [| ~P; R |] ==> S |] ==> S"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (simp add: if_def)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply blast
done

lemma if_commute: "if(P, if(Q,A,B), if(Q,C,D)) <-> if(Q, if(P,A,C), if(P,B,D))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule iffI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule ifE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule ifE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule ifI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule ifI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
oops

text{*Trying again from the beginning in order to use @{text blast}*}
declare ifI [intro!]
declare ifE [elim!]

lemma if_commute: "if(P, if(Q,A,B), if(Q,C,D)) <-> if(Q, if(P,A,C), if(P,B,D))"
by blast

lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,A,B))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
by blast

text{*Trying again from the beginning in order to prove from the definitions*}
lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,A,B))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (simp add: if_def)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply blast
done

text{*An invalid formula.  High-level rules permit a simpler diagnosis*}
lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,B,A))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply auto
  --{* @{subgoals[display,indent=0,margin=65]} *}
(*The next step will fail unless subgoals remain*)
apply (tactic all_tac)
oops

text{*Trying again from the beginning in order to prove from the definitions*}
lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,B,A))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (simp add: if_def)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (auto)
  --{* @{subgoals[display,indent=0,margin=65]} *}
(*The next step will fail unless subgoals remain*)
apply (tactic all_tac)
oops

end