theory Horn_Inference
  imports Main
begin

datatype 'a horn = horn "'a list" 'a (infix "\<rightarrow>\<^sub>h" 55)

locale horn =
  fixes \<H> :: "'a horn set"
begin

inductive_set saturate :: "'a set" where
  infer: "as \<rightarrow>\<^sub>h a \<in> \<H> \<Longrightarrow> (\<And>x. x \<in> set as \<Longrightarrow> x \<in> saturate) \<Longrightarrow> a \<in> saturate"

definition infer0 where
  "infer0 = {a. [] \<rightarrow>\<^sub>h a \<in> \<H>}"

definition infer1 where
  "infer1 x B = {a |as a. as \<rightarrow>\<^sub>h a \<in> \<H> \<and> x \<in> set as \<and> set as \<subseteq> B \<union> {x}}"

inductive step :: "'a set \<times> 'a set \<Rightarrow> 'a set \<times> 'a set \<Rightarrow> bool" (infix "\<turnstile>" 50) where
  delete: "x \<in> B \<Longrightarrow> (insert x G, B) \<turnstile> (G, B)"
| propagate: "(insert x G, B) \<turnstile> (G \<union> infer1 x B, insert x B)"
| refl: "(G, B) \<turnstile> (G, B)"
| trans: "(G, B) \<turnstile> (G', B') \<Longrightarrow> (G', B') \<turnstile> (G'', B'') \<Longrightarrow> (G, B) \<turnstile> (G'', B'')"

lemma step_mono:
  "(G, B) \<turnstile> (G', B') \<Longrightarrow> (H \<union> G, B) \<turnstile> (H \<union> G', B')"
  by (induction "(G, B)" "(G', B')" arbitrary: G B G' B' rule: step.induct)
    (auto intro: step.intros simp: Un_assoc[symmetric])

fun invariant where
  "invariant (G, B) \<longleftrightarrow> G \<subseteq> saturate \<and> B \<subseteq> saturate \<and> (\<forall>a as. as \<rightarrow>\<^sub>h a \<in> \<H> \<and> set as \<subseteq> B \<longrightarrow> a \<in> G \<union> B)"

lemma inv_start:
  shows "invariant (infer0, {})"
  by (auto simp: infer0_def invariant.simps intro: infer)

lemma inv_step:
  assumes "invariant (G, B)" "(G, B) \<turnstile> (G', B')"
  shows "invariant (G', B')"
  using assms(2,1)
proof (induction "(G, B)" "(G', B')" arbitrary: G B G' B' rule: step.induct)
  case (propagate x G B)
  let ?G' = "G \<union> local.infer1 x B" and ?B' = "insert x B"
  have "?G' \<subseteq> saturate" "?B' \<subseteq> saturate"
    using assms(1) propagate by (auto 0 3 simp: infer1_def intro: saturate.infer)
  moreover have "as \<rightarrow>\<^sub>h a \<in> \<H> \<Longrightarrow> set as \<subseteq> ?B' \<Longrightarrow> a \<in> ?G' \<union> ?B'" for a as
    using assms(1) propagate by (fastforce simp: infer1_def)
  ultimately show ?case by auto
qed auto

lemma inv_end:
  assumes "invariant ({}, B)"
  shows "B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) then show ?case using assms by auto
next
  case (rl x) then show ?case using assms
    by (induct x rule: saturate.induct) fastforce
qed

lemma step_sound:
  "(infer0, {}) \<turnstile> ({}, B) \<Longrightarrow> B = saturate"
  by (metis inv_start inv_step inv_end)

end

lemma horn_infer0_union:
  "horn.infer0 (\<H>\<^sub>1 \<union> \<H>\<^sub>2) = horn.infer0 \<H>\<^sub>1 \<union> horn.infer0 \<H>\<^sub>2"
  by (auto simp: horn.infer0_def)

lemma horn_infer1_union:
  "horn.infer1 (\<H>\<^sub>1 \<union> \<H>\<^sub>2) x B = horn.infer1 \<H>\<^sub>1 x B \<union> horn.infer1 \<H>\<^sub>2 x B"
  by (auto simp: horn.infer1_def)

end


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

header {* Relating direct and continuation semantics *}
(*<*)
theory Continuations
imports
  PCF
begin

(*>*)
text{*

\label{sec:continuations}

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

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

*}

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{*

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

*}

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{* The interpretations of the constants. *}

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 {*

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

*}

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{*

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:

*}

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

text{*

Following \citet{DBLP:conf/icalp/Reynolds74} and \citet[Remark
47]{DBLP:journals/tcs/Filinski07} we use the following continuation:

*}

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{**}

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: split_if_asm)
qed

subsection{* Logical relation *}

text{*

We follow \citet{DBLP:conf/icalp/Reynolds74} 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{DBLP:journals/tcs/Filinski07}
differs by assuming that values are always defined, and relates values
and monadic computations.

*}

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{*

Properties of the logical relation.

*}

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 undual_leq[symmetric] unlr_leq[symmetric])
  (* FIXME stuck with the projections on the product *)
  apply (auto simp: lr_theta_rep_def split_def undual_leq[symmetric] 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{*

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.

*}
(*<*)

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

lemma ValD_copy_strict [intro, simp]:
  "ValD_copy\<cdot>\<bottom> = \<bottom>"
  using ValD_copy_lub_ID by simp

text{*

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

*}

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{*

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

*}

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 ValD_copy_rec ValK_copy_rec lr
  apply default
         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{* A retraction between the two definitions *}

text{*

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.

*}

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{*

Theorem 1 from \citet{DBLP:conf/icalp/Reynolds74}.

*}

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{**}

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{*

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"}.

*}

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 - (default, 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{*

Lemma 1 from \citet{DBLP:conf/icalp/Reynolds74}.

*}

lemma Lemma1:
  "\<eta>: x \<mapsto> DtoKM\<cdot>x"
  "\<eta>: x \<mapsto> x' \<Longrightarrow> x = KMtoD\<cdot>x'"
(*<*)
proof -
  { fix x x' i
    have "\<eta>: ValD_copy_i i\<cdot>x \<mapsto> DtoKM_i i\<cdot>x"
     and "\<eta>: x \<mapsto> x' \<Longrightarrow> ValD_copy_i i\<cdot>x = KMtoD_i i\<cdot>x'"
    proof(induct i arbitrary: x x')
      case 0
      { case 1 thus ?case by simp }
      { case 2 thus ?case by simp }
    next
      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 }
  note K = this
  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(1)
  have "?P1 (\<Squnion>i. ValD_copy_i i, \<Squnion>i. DtoKM_i i)"
    using admD[where P="?P1" and Y="?C1"]
    using lub_prod[where S="?C1"]
    apply simp
    done
  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 K(2) 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'"
    apply (simp_all add: ValD_copy_lub_ID)
    done
qed

(*>*)
text{*

Theorem 2 from \citet{DBLP:conf/icalp/Reynolds74}.

*}

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{*

\citet[Remark~48]{DBLP:journals/tcs/Filinski07} 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{DBLP:conf/icfp/WandV04}.

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

*}
(*<*)

end
(*>*)


(*  File:       Blacks_Rule.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>Black's Rule\<close>

theory Blacks_Rule
  imports Pairwise_Majority_Rule
          Borda_Rule
          Borda_Scoring_Rule
begin

text
\<open>This is Black's voting rule. It is composed of a function that determines
the Condorcet winner, i.e., the Pairwise Majority rule, and the Borda rule.
Whenever there exists no Condorcet winner, it elects the choice made by the
Borda rule, otherwise the Condorcet winner is elected.\<close>

subsection \<open>Definition\<close>

fun blacks_rule :: "'a Electoral_Module" where
  "blacks_rule A p vs = (pairwise_majority_rule \<triangleright> borda_rule) A p vs"

fun blacks_rule_scoring :: "'a Electoral_Module" where
  "blacks_rule_scoring A p vs = (pairwise_majority_rule \<triangleright> borda_Scoring_Rule) A p vs"

lemma pairwise_majority_rule_homogeneity:
  shows "homogeneity pairwise_majority_rule"
  unfolding pairwise_majority_rule.simps condorcet.simps
  using elector_homogeneity condorcet_homogeneity
  by blast

lemma blacks_rule_hom:
  shows "homogeneity blacks_rule_scoring" unfolding blacks_rule_scoring.simps
  using seq_hom pairwise_majority_rule_homogeneity borda_hom by blast

end


theory Degeneralization
imports
  Acceptance
  Sequence_Zip
begin

  type_synonym 'a degen = "'a \<times> nat"

  definition degen :: "'a pred gen \<Rightarrow> 'a degen pred" where
    "degen cs \<equiv> \<lambda> (a, k). k \<ge> length cs \<or> (cs ! k) a"

  lemma degen_simps[iff]: "degen cs (a, k) \<longleftrightarrow> k \<ge> length cs \<or> (cs ! k) a" unfolding degen_def by simp

  definition count :: "'a pred gen \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
    "count cs a k \<equiv>
      if k < length cs
      then if (cs ! k) a then Suc k mod length cs else k
      else if cs = [] then k else 0"

  lemma count_empty[simp]: "count [] a k = k" unfolding count_def by simp
  lemma count_nonempty[simp]: "cs \<noteq> [] \<Longrightarrow> count cs a k < length cs" unfolding count_def by simp
  lemma count_constant_1:
    assumes "k < length cs"
    assumes "\<And> a. a \<in> set w \<Longrightarrow> \<not> (cs ! k) a"
    shows "fold (count cs) w k = k"
    using assms unfolding count_def by (induct w) (auto)
  lemma count_constant_2:
    assumes "k < length cs"
    assumes "\<And> a. a \<in> set (w || k # scan (count cs) w k) \<Longrightarrow> \<not> degen cs a"
    shows "fold (count cs) w k = k"
    using assms unfolding count_def by (induct w) (auto)
  lemma count_step:
    assumes "k < length cs"
    assumes "(cs ! k) a"
    shows "count cs a k = Suc k mod length cs"
    using assms unfolding count_def by simp

  lemma degen_skip_condition:
    assumes "k < length cs"
    assumes "infs (degen cs) (w ||| k ## sscan (count cs) w k)"
    obtains u a v
    where "w = u @- a ## v" "fold (count cs) u k = k" "(cs ! k) a"
  proof -
    have 1: "Collect (degen cs) \<inter> sset (w ||| k ## sscan (count cs) w k) \<noteq> {}"
      using infs_any assms(2) by auto
    obtain ys x zs where 2:
      "w ||| k ## sscan (count cs) w k = ys @- x ## zs"
      "Collect (degen cs) \<inter> set ys = {}"
      "x \<in> Collect (degen cs)"
      using split_stream_first 1 by this
    define u where "u \<equiv> stake (length ys) w"
    define a where "a \<equiv> w !! length ys"
    define v where "v \<equiv> sdrop (Suc (length ys)) w"
    have "ys = stake (length ys) (w ||| k ## sscan (count cs) w k)" using shift_eq 2(1) by auto
    also have "\<dots> = stake (length ys) w || stake (length ys) (k ## sscan (count cs) w k)" by simp
    also have "\<dots> = take (length ys) u || take (length ys) (k # scan (count cs) u k)"
      unfolding u_def
      using append_eq_conv_conj length_stake length_zip stream.sel
      using sscan_stake stake.simps(2) stake_Suc stake_szip take_stake
      by metis
    also have "\<dots> = take (length ys) (u || k # scan (count cs) u k)" using take_zip by rule
    also have "\<dots> = u || k # scan (count cs) u k" unfolding u_def by simp
    finally have 3: "ys = u || k # scan (count cs) u k" by this
    have "x = (w ||| k ## sscan (count cs) w k) !! length ys" unfolding 2(1) by simp
    also have "\<dots> = (w !! length ys, (k ## sscan (count cs) w k) !! length ys)" by simp
    also have "\<dots> = (a, fold (count cs) u k)" unfolding u_def a_def by simp
    finally have 4: "x = (a, fold (count cs) u k)" by this
    have 5: "fold (count cs) u k = k" using count_constant_2 assms(1) 2(2) unfolding 3 by blast
    show ?thesis
    proof
      show "w = u @- a ## v" unfolding u_def a_def v_def using id_stake_snth_sdrop by this
      show "fold (count cs) u k = k" using 5 by this
      show "(cs ! k) a" using assms(1) 2(3) unfolding 4 5 by simp
    qed
  qed
  lemma degen_skip_arbitrary:
    assumes "k < length cs" "l < length cs"
    assumes "infs (degen cs) (w ||| k ## sscan (count cs) w k)"
    obtains u v
    where "w = u @- v" "fold (count cs) u k = l"
  using assms
  proof (induct "nat ((int l - int k) mod length cs)" arbitrary: l thesis)
    case (0)
    have 1: "length cs > 0" using assms(1) by auto
    have 2: "(int l - int k) mod length cs = 0" using 0(1) 1 by (auto intro: antisym)
    have 3: "int l mod length cs = int k mod length cs" using mod_eq_dvd_iff 2 by force
    have 4: "k = l" using 0(3, 4) 3 by simp
    show ?case
    proof (rule 0(2))
      show "w = [] @- w" by simp
      show "fold (count cs) [] k = l" using 4 by simp
    qed
  next
    case (Suc n)
    have 1: "length cs > 0" using assms(1) by auto
    define l' where "l' = nat ((int l - 1) mod length cs)"
    obtain u v where 2: "w = u @- v" "fold (count cs) u k = l'"
    proof (rule Suc(1))
      have 2: "Suc n < length cs" using nat_less_iff Suc(2) 1 by simp
      have "n = nat (int n)" by simp
      also have "int n = (int (Suc n) - 1) mod length cs" using 2 by simp
      also have "\<dots> = (int l - int k - 1) mod length cs" using Suc(2) by (simp add: mod_simps)
      also have "\<dots> = (int l - 1 - int k) mod length cs" by (simp add: algebra_simps)
      also have "\<dots> = (int l' - int k) mod length cs" using l'_def 1 by (simp add: mod_simps)
      finally show "n = nat ((int l' - int k) mod length cs)" by this
      show "k < length cs" using Suc(4) by this
      show "l' < length cs" using nat_less_iff l'_def 1 by simp
      show "infs (degen cs) (w ||| k ## sscan (count cs) w k)" using Suc(6) by this
    qed
    have 3: "l' < length cs" using nat_less_iff l'_def 1 by simp
    have 4: "v ||| l' ## sscan (count cs) v l' = sdrop (length u) (w ||| k ## sscan (count cs) w k)"
      using 2 eq_scons eq_shift
      by (metis sdrop.simps(2) sdrop_simps sdrop_szip sscan_scons_snth sscan_sdrop stream.sel(2))
    have 5: "infs (degen cs) (v ||| l' ## sscan (count cs) v l')" using Suc(6) unfolding 4 by blast
    obtain vu a vv where 6: "v = vu @- a ## vv" "fold (count cs) vu l' = l'" "(cs ! l') a"
      using degen_skip_condition 3 5 by this
    have "l = nat (int l)" by simp
    also have "int l = int l mod length cs" using Suc(5) by simp
    also have "\<dots> = int (Suc l') mod length cs" using l'_def 1 by (simp add: mod_simps)
    finally have 7: "l = Suc l' mod length cs" using nat_mod_as_int by metis
    show ?case
    proof (rule Suc(3))
      show "w = (u @ vu @ [a]) @- vv" unfolding 2(1) 6(1) by simp
      show "fold (count cs) (u @ vu @ [a]) k = l" using 2(2) 3 6(2, 3) 7 count_step by simp
    qed
  qed
  lemma degen_skip_arbitrary_condition:
    assumes "l < length cs"
    assumes "infs (degen cs) (w ||| k ## sscan (count cs) w k)"
    obtains u a v
    where "w = u @- a ## v" "fold (count cs) u k = l" "(cs ! l) a"
  proof -
    have 0: "cs \<noteq> []" using assms(1) by auto
    have 1: "count cs (shd w) k < length cs" using 0 by simp
    have 2: "infs (degen cs) (stl w ||| count cs (shd w) k ## sscan (count cs) (stl w) (count cs (shd w) k))"
      using assms(2) by (metis alw.cases sscan.code stream.sel(2) szip.simps(2))
    obtain u v where 3: "stl w = u @- v" "fold (count cs) u (count cs (shd w) k) = l"
      using degen_skip_arbitrary 1 assms(1) 2 by this
    have 4: "v ||| l ## sscan (count cs) v l =
      sdrop (length u) (stl w ||| count cs (shd w) k ## sscan (count cs) (stl w) (count cs (shd w) k))"
      using 3 eq_scons eq_shift
      by (metis sdrop.simps(2) sdrop_simps sdrop_szip sscan_scons_snth sscan_sdrop stream.sel(2))
    have 5: "infs (degen cs) (v ||| l ## sscan (count cs) v l)" using 2 unfolding 4 by blast
    obtain vu a vv where 6: "v = vu @- a ## vv" "fold (count cs) vu l = l" "(cs ! l) a"
      using degen_skip_condition assms(1) 5 by this
    show ?thesis
    proof
      show "w = (shd w # u @ vu) @- a ## vv" using 3(1) 6(1) by (simp add: eq_scons)
      show "fold (count cs) (shd w # u @ vu) k = l" using 3(2) 6(2) by simp
      show "(cs ! l) a" using 6(3) by this
    qed
  qed
  lemma gen_degen_step:
    assumes "gen infs cs w"
    obtains u a v
    where "w = u @- a ## v" "degen cs (a, fold (count cs) u k)"
  proof (cases "k < length cs")
    case True
    have 1: "infs (cs ! k) w" using assms True by auto
    have 2: "{a. (cs ! k) a} \<inter> sset w \<noteq> {}" using infs_any 1 by auto
    obtain u a v where 3: "w = u @- a ## v" "{a. (cs ! k) a} \<inter> set u = {}" "a \<in> {a. (cs ! k) a}"
      using split_stream_first 2 by this
    have 4: "fold (count cs) u k = k" using count_constant_1 True 3(2) by auto
    show ?thesis using 3(1, 3) 4 that by simp
  next
    case False
    show ?thesis
    proof
      show "w = [] @- shd w ## stl w" by simp
      show "degen cs (shd w, fold (count cs) [] k)" using False by simp
    qed
  qed

  lemma degen_infs[iff]: "infs (degen cs) (w ||| k ## sscan (count cs) w k) \<longleftrightarrow> gen infs cs w"
  proof
    show "gen infs cs w" if "infs (degen cs) (w ||| k ## sscan (count cs) w k)"
    proof
      fix c
      assume 1: "c \<in> set cs"
      obtain l where 2: "c = cs ! l" "l < length cs" using in_set_conv_nth 1 by metis
      show "infs c w"
      using that unfolding 2(1)
      proof (coinduction arbitrary: w k rule: infs_set_coinduct)
        case (infs_set w k)
        obtain u a v where 3: "w = u @- a ## v" "(cs ! l) a"
          using degen_skip_arbitrary_condition 2(2) infs_set by this
        let ?k = "fold (count cs) u k"
        let ?l = "fold (count cs) (u @ [a]) k"
        have 4: "a ## v ||| ?k ## sscan (count cs) (a ## v) ?k =
          sdrop (length u) (w ||| k ## sscan (count cs) w k)"
          using 3(1) eq_shift scons_eq
          by (metis sdrop_simps(1) sdrop_stl sdrop_szip sscan_scons_snth sscan_sdrop stream.sel(2))
        have 5: "infs (degen cs) (a ## v ||| ?k ## sscan (count cs) (a ## v) ?k)"
          using infs_set unfolding 4 by blast
        show ?case
        proof (intro exI conjI bexI)
          show "w = (u @ [a]) @- v" "(cs ! l) a" "a \<in> set (u @ [a])" "v = v" using 3 by auto
          show "infs (degen cs) (v ||| ?l ## sscan (count cs) v ?l)" using 5 by simp
        qed
      qed
    qed
    show "infs (degen cs) (w ||| k ## sscan (count cs) w k)" if "gen infs cs w"
    using that
    proof (coinduction arbitrary: w k rule: infs_set_coinduct)
      case (infs_set w k)
      obtain u a v where 1: "w = u @- a ## v" "degen cs (a, fold (count cs) u k)"
        using gen_degen_step infs_set by this
      let ?u = "u @ [a] || k # scan (count cs) u k"
      let ?l = "fold (count cs) (u @ [a]) k"
      show ?case
      proof (intro exI conjI bexI)
        have "w ||| k ## sscan (count cs) w k =
          (u @ [a]) @- v ||| k ## scan (count cs) u k @- ?l ## sscan (count cs) v ?l"
          unfolding 1(1) by simp
        also have "\<dots> = ?u @- (v ||| ?l ## sscan (count cs) v ?l)"
          by (metis length_Cons length_append_singleton scan_length shift.simps(2) szip_shift)
        finally show "w ||| k ## sscan (count cs) w k = ?u @- (v ||| ?l ## sscan (count cs) v ?l)" by this
        show "degen cs (a, fold (count cs) u k)" using 1(2) by this
        have "(a, fold (count cs) u k) = (last (u @ [a]), last (k # scan (count cs) u k))"
          unfolding scan_last by simp
        also have "\<dots> = last ?u" by (simp add: zip_eq_Nil_iff)
        also have "\<dots> \<in> set ?u" by (fastforce intro: last_in_set simp: zip_eq_Nil_iff)
        finally show "(a, fold (count cs) u k) \<in> set ?u" by this
        show "v ||| ?l ## sscan (count cs) v ?l = v ||| ?l ## sscan (count cs) v ?l" by rule
        show "gen infs cs v" using infs_set unfolding 1(1) by auto
      qed
    qed
  qed

end