theory
  Consensus_Demo
imports
  Network
begin

datatype 'val msg
  = Propose 'val
  | Accept 'val

fun acceptor_step where
  \<open>acceptor_step state (Receive sender (Propose val)) =
     (case state of
        None   \<Rightarrow> (Some val, {Send sender (Accept val)}) |
        Some v \<Rightarrow> (Some v,   {Send sender (Accept v)}))\<close> |
  \<open>acceptor_step state _ = (state, {})\<close>

fun proposer_step where
  \<open>proposer_step None (Request val) = (None, {Send 0 (Propose val)})\<close> |
  \<open>proposer_step None (Receive _ (Accept val)) = (Some val, {})\<close> |
  \<open>proposer_step state _ = (state, {})\<close>

fun consensus_step where
  \<open>consensus_step proc =
     (if proc = 0 then acceptor_step else proposer_step)\<close>

(* Invariant 1: for any proposer p, if p's state is ``Some val'',
   then there exists a process that has sent a message
   ``Accept val'' to p. *)

definition inv1 where
  \<open>inv1 msgs states \<longleftrightarrow>
     (\<forall>proc val. proc \<noteq> 0 \<and> states proc = Some val \<longrightarrow>
                 (\<exists>sender. (sender, Send proc (Accept val)) \<in> msgs))\<close>

(* Invariant 2: if a message ``Accept val'' has been sent, then
   the acceptor is in the state ``Some val''. *)

definition inv2 where
  \<open>inv2 msgs states \<longleftrightarrow>
     (\<forall>sender recpt val. (sender, Send recpt (Accept val)) \<in> msgs \<longrightarrow>
                         states 0 = Some val)\<close>

lemma invariant_propose:
  assumes \<open>msgs' = msgs \<union> {(proc, Send 0 (Propose val))}\<close>
    and \<open>inv1 msgs states \<and> inv2 msgs states\<close>
  shows \<open>inv1 msgs' states \<and> inv2 msgs' states\<close>
proof -
  have \<open>\<forall>sender proc val.
      (sender, Send proc (Accept val)) \<in> msgs' \<longleftrightarrow>
      (sender, Send proc (Accept val)) \<in> msgs\<close>
    using assms(1) by blast
  then show ?thesis
    by (meson assms(2) inv1_def inv2_def)
qed

lemma invariant_decide:
  assumes \<open>states' = states (0 := Some val)\<close>
    and \<open>msgs' = msgs \<union> {(0, Send sender (Accept val))}\<close>
    and \<open>states 0 = None \<or> states 0 = Some val\<close>
    and \<open>inv1 msgs states \<and> inv2 msgs states\<close>
  shows \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
proof -
  {
    fix p v
    assume asm: \<open>p \<noteq> 0 \<and> states' p = Some v\<close>
    hence \<open>states p = Some v\<close>
      by (simp add: asm assms(1))
    hence \<open>\<exists>sender. (sender, Send p (Accept v)) \<in> msgs\<close>
      by (meson asm assms(4) inv1_def)
    hence \<open>\<exists>sender. (sender, Send p (Accept v)) \<in> msgs'\<close>
      using assms(2) by blast
  }
  moreover {
    fix p1 p2 v
    assume asm: \<open>(p1, Send p2 (Accept v)) \<in> msgs'\<close>
    have \<open>states' 0 = Some v\<close>
    proof (cases \<open>(p1, Send p2 (Accept v)) \<in> msgs\<close>)
      case True
      then show ?thesis
        by (metis assms(1) assms(3) assms(4) fun_upd_same inv2_def option.distinct(1))
    next
      case False
      then show ?thesis
        using asm assms(1) assms(2) by auto
    qed
  }
  ultimately show ?thesis
    by (simp add: inv1_def inv2_def)
qed

lemma invariant_learn:
  assumes \<open>states' = states (proc := Some val)\<close>
    and \<open>(sender, Send proc (Accept val)) \<in> msgs\<close>
    and \<open>inv1 msgs states \<and> inv2 msgs states\<close>
  shows \<open>inv1 msgs states' \<and> inv2 msgs states'\<close>
proof -
  {
    fix p v
    assume asm: \<open>p \<noteq> 0 \<and> states' p = Some v\<close>
    have \<open>\<exists>sender. (sender, Send p (Accept v)) \<in> msgs\<close>
    proof (cases \<open>p = proc\<close>)
      case True
      then show ?thesis
        using asm assms(1) assms(2) by auto
    next
      case False
      then show ?thesis
        by (metis asm assms(1) assms(3) fun_upd_apply inv1_def)
    qed
  }
  moreover {
    fix p1 p2 v
    assume \<open>(p1, Send p2 (Accept v)) \<in> msgs\<close>
    hence \<open>states' 0 = Some v\<close>
      by (metis assms fun_upd_apply inv2_def)
  }
  ultimately show ?thesis
    by (simp add: inv1_def inv2_def)
qed

lemma invariant_proposer:
  assumes \<open>proposer_step (states proc) event = (new_state, sent)\<close>
    and \<open>msgs' = msgs \<union> ((\<lambda>msg. (proc, msg)) ` sent)\<close>
    and \<open>states' = states (proc := new_state)\<close>
    and \<open>execute consensus_step (\<lambda>p. None) UNIV (events @ [(proc, event)]) msgs' states'\<close>
    and \<open>inv1 msgs states \<and> inv2 msgs states\<close>
  shows \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
proof (cases event)
  case (Receive sender msg)
  then show ?thesis
  proof (cases msg)
    case (Propose val)
    then show ?thesis
      using Receive assms by auto
  next
    case (Accept val) (* proposer receives Accept message: learn the decided value *)
    then show ?thesis
    proof (cases \<open>states proc\<close>)
      case None
      hence \<open>states' = states (proc := Some val) \<and> msgs' = msgs\<close>
        using Accept Receive assms(1) assms(2) assms(3) by auto
      then show ?thesis
        by (metis Accept Receive assms(4) assms(5) execute_receive invariant_learn)
    next
      case (Some v)
      then show ?thesis
        using assms by auto
    qed
  qed
next
  (* on a Request event, proposer sends a Propose message if its state
     is None, or ignores the event if already learnt a decision *)
  case (Request val)
  then show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
  proof (cases \<open>states proc\<close>)
    case None
    hence \<open>states' = states \<and> msgs' = msgs \<union> {(proc, Send 0 (Propose val))}\<close>
      using Request assms(1) assms(2) assms(3) by auto
    then show ?thesis
      by (simp add: assms(5) invariant_propose)
  next
    case (Some v)
    then show ?thesis using assms by auto
  qed
next
  case Timeout
  then show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
    using assms by auto
qed

lemma invariant_acceptor:
  assumes \<open>acceptor_step (states 0) event = (new_state, sent)\<close>
    and \<open>msgs' = msgs \<union> ((\<lambda>msg. (0, msg)) ` sent)\<close>
    and \<open>states' = states (0 := new_state)\<close>
    and \<open>execute consensus_step (\<lambda>p. None) UNIV (events @ [(0, event)]) msgs' states'\<close>
    and \<open>inv1 msgs states \<and> inv2 msgs states\<close>
  shows \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
proof (cases event)
  case (Receive sender msg)
  then show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
  proof (cases msg)
    case (Propose val)
    then show ?thesis
    proof (cases \<open>states 0\<close>)
      case None (* not decided yet: decide now *)
      hence \<open>states' = states (0 := Some val) \<and>
             msgs' = msgs \<union> {(0, Send sender (Accept val))}\<close>
        using Receive Propose assms(1) assms(2) assms(3) by auto
        (* for some reason sledgehammer couldn't find the line above *)
      then show ?thesis
        by (simp add: None assms(5) invariant_decide)
    next
      case (Some val') (* already decided previously *)
      hence \<open>states' = states \<and>
             msgs' = msgs \<union> {(0, Send sender (Accept val'))}\<close>
        using Receive Propose assms(1) assms(2) assms(3) by auto
        (* for some reason sledgehammer couldn't find the line above *)
      then show ?thesis
        by (metis Some assms(3) assms(5) fun_upd_same invariant_decide)
    qed
  next
    case (Accept val)
    then show ?thesis
      using Receive assms by auto
  qed
next
  case (Request val)
  then show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
    using assms by auto
next
  case Timeout
  then show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
    using assms by auto
qed

lemma invariants:
  assumes \<open>execute consensus_step (\<lambda>x. None) UNIV events msgs' states'\<close>
  shows \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
using assms proof(induction events arbitrary: msgs' states' rule: List.rev_induct)
  case Nil
  from this show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
    using execute_init inv1_def inv2_def by fastforce
next
  case (snoc x events)
  obtain proc event where \<open>x = (proc, event)\<close>
    by fastforce
  hence exec: \<open>execute consensus_step (\<lambda>p. None) UNIV
               (events @ [(proc, event)]) msgs' states'\<close>
    using snoc.prems by blast
  from this obtain msgs states sent new_state
    where step_rel1: \<open>execute consensus_step (\<lambda>x. None) UNIV events msgs states\<close>
      and step_rel2: \<open>consensus_step proc (states proc) event = (new_state, sent)\<close>
      and step_rel3: \<open>msgs' = msgs \<union> ((\<lambda>msg. (proc, msg)) ` sent)\<close>
      and step_rel4: \<open>states' = states (proc := new_state)\<close>
    by auto
  have inv_before: \<open>inv1 msgs states \<and> inv2 msgs states\<close>
    using snoc.IH step_rel1 by fastforce
  then show \<open>inv1 msgs' states' \<and> inv2 msgs' states'\<close>
  proof (cases \<open>proc = 0\<close>)
    case True
    then show ?thesis
      by (metis consensus_step.simps exec inv_before invariant_acceptor
          step_rel2 step_rel3 step_rel4)
  next
    case False
    then show ?thesis
      by (metis consensus_step.simps exec inv_before invariant_proposer
          step_rel2 step_rel3 step_rel4)
  qed
qed

theorem agreement:
  assumes \<open>execute consensus_step (\<lambda>x. None) UNIV events msgs states\<close>
    and \<open>states proc1 = Some val1\<close> and \<open>states proc2 = Some val2\<close>
  shows \<open>val1 = val2\<close>
proof -
  have \<open>states 0 = Some val1\<close>
    by (metis assms(1) assms(2) inv1_def inv2_def invariants)
  moreover have \<open>states 0 = Some val2\<close>
    by (metis assms(1) assms(3) inv1_def inv2_def invariants)
  ultimately show \<open>val1 = val2\<close>
    by simp
qed

end


theory Additional_Lemmas

imports Main
        infnorm
        Partition
        Lattice_int
        Digits_int

begin

text \<open>Lemma about length and concat.\<close>
lemma length_concat_map_5:
  "length (concat (map (\<lambda>i. [f1 i, f2 i, f3 i, f4 i, f5 i]) xs)) = length xs * 5"
by (induct xs, auto)

text \<open>Lemma about splitting the index of sums.\<close>
lemma sum_split_idx_prod:
  "(\<Sum>i=0..<k*l::nat. f i) = (\<Sum>i=0..<k. (\<Sum>j=0..<l. f (i*l+j)))"
proof -
  have set_rew: "{0..<k*l} = (\<lambda>(i,j). i*l+j) ` ({0..<k} \<times> {0..<l})"
  proof (safe, goal_cases)
    case (1 x)
    have "x = (\<lambda>(i,j). i*l+j) (x div l, x mod l)" by auto
    moreover have "(x div l, x mod l)\<in>{0..<k} \<times> {0..<l}" using 1 less_mult_imp_div_less
      by (metis le_less_trans lessThan_atLeast0 lessThan_iff mem_Sigma_iff
        mod_less_divisor mult_zero_right neq0_conv zero_le)
    ultimately show ?case by blast
  next
    case (2 x i j)
    then show ?case
    by (auto, metis less_nat_zero_code linorder_neqE_nat mod_lemma mult.commute nat_mod_lem)
  qed
  have inj: "inj_on (\<lambda>(i, y). i * l + y) ({0..<k} \<times> {0..<l})"
    unfolding inj_on_def by (auto)
      (metis add.commute add_right_imp_eq linorder_neqE_nat mod_mult_self2 mult.commute
        mult_cancel_right nat_mod_lem not_less_zero,
       metis add.commute le0 le_less_trans mod_mult_self2 mult.commute nat_mod_lem)
  have "(\<Sum> i\<in>{0..<k*l}. f i) = (\<Sum>(i,j)\<in>{0..<k}\<times>{0..<l}. f (i*l+j))"
    unfolding set_rew using inj
    by (subst sum.reindex[of "(\<lambda>(i, j). i * l + j)" "({0..<k} \<times> {0..<l})" f])
       (auto simp add: prod.case_distrib)
  also have "\<dots> = (\<Sum>i\<in>{0..<k}. (\<Sum>j\<in>{0..<l}. f (i*l+j)))"
    using sum.cartesian_product[of "(\<lambda>i j. f (i*l+j))" "{0..<l}" "{0..<k}", symmetric]
    by auto
  finally show ?thesis by auto
qed

text \<open>Helping lemma to split sums.\<close>

lemma lt_M:
  assumes "M > (\<Sum>i<(n::nat). \<bar>b i\<bar>::int)"
          "\<forall>i<n. \<bar>x i\<bar> \<le> 1"
  shows "\<bar>(\<Sum>i<n. x i * b i)\<bar> < M"
proof -
  have "\<bar>(\<Sum>i<(n::nat). x i * b i)::int\<bar> \<le> (\<Sum>i<n. \<bar>x i * b i\<bar>)" using sum_abs by auto
  moreover have "\<dots> = (\<Sum>i<n. \<bar>x i\<bar> * \<bar>b i\<bar>)" using abs_mult by metis
  moreover have "\<dots> \<le> (\<Sum>i<n. \<bar>b i\<bar>)" using assms
    by (smt (verit, best) lessThan_iff mult_cancel_right2 sum_mono zero_less_mult_iff)
  moreover have "\<dots> = (\<Sum>i<n. \<bar>b i\<bar>)" using sum_distrib_left by metis
  ultimately have "\<bar>(\<Sum>i<n. x i * b i)\<bar> \<le> (\<Sum>i<n. \<bar>b i\<bar>)" by linarith
  then show ?thesis using assms by auto
qed

lemma split_sum:
  "(\<Sum>i<(n::nat). x i * (a i + M * b i)::int) = (\<Sum>i<n. x i * a i) + M * (\<Sum>i<n. x i * b i)"
proof -
  have "(\<Sum>i<(n::nat). x i * (a i + M * b i)) = (\<Sum>i<n. x i * a i) + (\<Sum>i<n. M * x i * b i)"
    by (simp add: distrib_left mult.commute mult.left_commute)
  also have "\<dots> = (\<Sum>i<n. x i * a i) + M * (\<Sum>i<n. x i * b i)"
    using sum_distrib_left[symmetric, where r=M and f="(\<lambda>i. x i*b i)" and A = "{0..<n}"]
    by (metis (no_types, lifting) lessThan_atLeast0 mult.assoc sum.cong)
  finally show ?thesis by blast
qed

lemma split_eq_system:
  assumes "M > (\<Sum>i<n::nat. \<bar>a i\<bar>::int)"
          "\<forall>i<n. \<bar>x i\<bar> \<le> 1"
          "(\<Sum>i<n. x i * (a i + M * b i)) = 0"
  shows   "(\<Sum>i<n. x i * a i) = 0 \<and> (\<Sum>i<n. x i * b i) = 0"
using assms proof (safe, goal_cases)
  case 1
  then show ?case
  proof (cases "(\<Sum>i<n. x i * b i) = 0")
    case True
    then show ?thesis using assms(3) split_sum[of x a M b n] by auto
  next
    case False
    then have "\<bar>(\<Sum>i<n. x i * a i)\<bar> < M * \<bar>(\<Sum>i<n. x i * b i)\<bar>"
      using lt_M[OF assms(1) assms(2)] False
      by (smt (verit, best) mult_less_cancel_left2)
    moreover have "\<bar>(\<Sum>i<n. x i * a i)\<bar> = M * \<bar>(\<Sum>i<n. x i * b i)\<bar>"
      using assms(3) split_sum[of x a M b n] calculation by linarith
    ultimately have False by linarith
    then show ?thesis by auto
  qed
next
  case 2
  then show ?case
  proof (cases "(\<Sum>i<n. x i * b i) = 0")
    case True
    then show ?thesis using split_sum 2 using lt_M[OF assms(1) assms(2)]
       by auto
  next
    case False
    then have "\<bar>(\<Sum>i<n. x i * a i)\<bar> < M * \<bar>(\<Sum>i<n. x i * b i)\<bar>"
      using lt_M[OF assms(1) assms(2)] False
      by (smt (verit, best) mult_less_cancel_left2)
    moreover have "\<bar>(\<Sum>i<n. x i * a i)\<bar> = M * \<bar>(\<Sum>i<n. x i * b i)\<bar>"
      using split_sum[of x a M b n] assms calculation by linarith
    ultimately have False by linarith
    then show ?thesis by auto
  qed
qed

text \<open>Lemmas about splitting into 4 or 5 cases.\<close>
(*split into 4 mod classes*)
lemma lt_4_split: "(i::nat) < 4 \<longrightarrow> i = 0 \<or> i = 1 \<or> i = 2 \<or> i = 3"
by auto

lemma mod_exhaust_less_4_int: "(i::int) mod 4 = 0 \<or> i mod 4 = 1 \<or> i mod 4 = 2 \<or> i mod 4 = 3"
using MacLaurin.mod_exhaust_less_4 by auto

lemma mod_4_choices:
  assumes "i mod 4 = 0 \<longrightarrow> P i"
          "i mod 4 = 1 \<longrightarrow> P i"
          "i mod 4 = 2 \<longrightarrow> P i"
          "i mod 4 = 3 \<longrightarrow> P i"
  shows "P (i::nat)"
using assms mod_exhaust_less_4 by auto

lemma mod_4_if_split:
  assumes "i mod 4 = 0 \<longrightarrow> P = P0 i"
          "i mod 4 = 1 \<longrightarrow> P = P1 i"
          "i mod 4 = 2 \<longrightarrow> P = P2 i"
          "i mod 4 = 3 \<longrightarrow> P = P3 i"
  shows "P = (if i mod 4 = 0 then P0 i else
               (if i mod 4 = 1 then P1 i else
               (if i mod 4 = 2 then P2 i else P3 (i::nat))))" (is "?P i")
using mod_exhaust_less_4  by (auto simp add: assms)

(*split into 5 mod classes*)

lemma lt_5_split: "(i::nat) < 5 \<longrightarrow> i = 0 \<or> i = 1 \<or> i = 2 \<or> i = 3 \<or> i = 4"
by auto

lemma mod_exhaust_less_5_int:
  "(i::int) mod 5 = 0 \<or> i mod 5 = 1 \<or> i mod 5 = 2 \<or> i mod 5 = 3 \<or> i mod 5 = 4"
using lt_5_split by linarith

lemma mod_exhaust_less_5:
  "(i::nat) mod 5 = 0 \<or> i mod 5 = 1 \<or> i mod 5 = 2 \<or> i mod 5 = 3 \<or> i mod 5 = 4"
using lt_5_split by linarith

lemma mod_5_choices:
  assumes "i mod 5 = 0 \<longrightarrow> P i"
          "i mod 5 = 1 \<longrightarrow> P i"
          "i mod 5 = 2 \<longrightarrow> P i"
          "i mod 5 = 3 \<longrightarrow> P i"
          "i mod 5 = 4 \<longrightarrow> P i"
  shows "P (i::nat)"
using assms mod_exhaust_less_5 by auto

lemma mod_5_if_split:
  assumes "i mod 5 = 0 \<longrightarrow> P = P0 i"
          "i mod 5 = 1 \<longrightarrow> P = P1 i"
          "i mod 5 = 2 \<longrightarrow> P = P2 i"
          "i mod 5 = 3 \<longrightarrow> P = P3 i"
          "i mod 5 = 4 \<longrightarrow> P = P4 i"
  shows "P = (if i mod 5 = 0 then P0 i else
               (if i mod 5 = 1 then P1 i else
               (if i mod 5 = 2 then P2 i else
               (if i mod 5 = 3 then P3 i else
                                    P4 (i::nat)))))" (is "?P i")
using mod_exhaust_less_5  by (auto simp add: assms)

(*number in set is lower limit plus difference*)

lemma split_lower_plus_diff:
  assumes "s \<in> {n..<m::nat}"
  obtains j where "s = n+j" and "j<m-n"
using assms
by (metis atLeastLessThan_iff diff_diff_left le_Suc_ex zero_less_diff)

end


section \<open>Examples\<close>
theory Examples
  imports Poincare_Bendixson
    "HOL-ODE-Numerics.ODE_Numerics"
    Affine_Arithmetic_Misc
begin

subsection \<open>Simple\<close>

context
begin

text \<open>coordinate functions\<close>
definition "cx x y = -y + x * (1 - x^2 - y^2)"
definition "cy x y = x + y * (1 - x^2 - y^2)"

lemmas c_defs = cx_def cy_def

text \<open>partial derivatives\<close>
definition C11::"real\<Rightarrow>real\<Rightarrow>real" where "C11 x y = 1 - 3 * x^2 - y^2"
definition C12::"real\<Rightarrow>real\<Rightarrow>real" where "C12 x y = -1 - 2 * x * y"
definition C21::"real\<Rightarrow>real\<Rightarrow>real" where "C21 x y = 1 - 2 * x * y"
definition C22::"real\<Rightarrow>real\<Rightarrow>real" where "C22 x y = 1 - x^2 - 3 * y^2"

lemmas C_partials = C11_def C12_def C21_def C22_def

text \<open>Jacobian as linear map\<close>
definition C :: "real \<Rightarrow> real \<Rightarrow> (real \<times> real) \<Rightarrow>\<^sub>L (real \<times> real)" where
  "C x y = blinfun_of_matrix
    ((\<lambda>_ _. 0)
      ((1,0) := (\<lambda>_. 0)((1, 0):=C11 x y, (0, 1):=C12 x y),
       (0, 1):= (\<lambda>_. 0)((1, 0):=C21 x y, (0, 1):=C22 x y)))"

lemma C_simp[simp]: "blinfun_apply (C x y) (dx, dy) =
  (dx * C11 x y + dy * C12 x y,
   dx * C21 x y + dy * C22 x y)"
  by (auto simp: C_def blinfun_of_matrix_apply Basis_prod_def)

lemma C_continuous[continuous_intros]:
  "continuous_on S (\<lambda>x. local.C (f x) (g x))"
  if "continuous_on S f" "continuous_on S g"
  unfolding C_def
  by (auto intro!: continuous_on_blinfun_of_matrix continuous_intros that
      simp: Basis_prod_def C_partials)

interpretation c: c1_on_open_R2 "\<lambda>(x::real, y::real). (cx x y, cy x y)::real*real"
  "\<lambda>(x, y). C x y" UNIV
  by unfold_locales
    (auto intro!: derivative_eq_intros ext continuous_intros simp: split_beta algebra_simps
      c_defs C_partials power2_eq_square)

definition "trapC = cball (0::real,0::real) 2 - ball (0::real,0::real) (1/2)"

lemma trapC_eq:
  shows "trapC = {p. (fst p)^2 + (snd p)^2 - 4 \<le> 0} \<inter> {p. 1/4 - ((fst p)^2 + (snd p)^2) \<le> 0}"
  unfolding trapC_def
  apply (auto simp add: dist_Pair_Pair)
  using real_sqrt_le_iff apply fastforce
    apply (smt four_x_squared one_le_power real_sqrt_ge_0_iff real_sqrt_pow2)
  using real_sqrt_le_mono apply fastforce
proof -
  fix a :: real and b :: real
  assume a1: "sqrt (a\<^sup>2 + b\<^sup>2) * 2 < 1"
  assume a2: "1 \<le> a\<^sup>2 * 4 + b\<^sup>2 * 4"
  have "\<forall>r. 1 \<le> sqrt r \<or> \<not> 1 \<le> r"
    by simp
  then show False
    using a2 a1 by (metis (no_types) Groups.mult_ac(2) distrib_left linorder_not_le real_sqrt_four real_sqrt_mult)
qed

lemma x_in_trapC:
  shows "(2,0) \<in> trapC"
  unfolding trapC_def
  by (auto simp add: dist_Pair_Pair)

lemma compact_trapC:
  shows "compact trapC"
  unfolding trapC_def
  using compact_cball compact_diff by blast

lemma nonempty_trapC:
  shows "trapC \<noteq> {}"
  using x_in_trapC by auto

lemma origin_fixpoint:
  assumes "(\<lambda>(x, y). (cx x y, cy x y)) (a,b) = 0"
  shows "a = (0::real)" "b = (0::real)"
  using assms unfolding cx_def cy_def zero_prod_def apply auto
  apply (sos "((((A<0 * R<1) + (([28859/65536*a + 5089/8192*b + ~1/2] * A=0) + (([~5089/8192*a + 17219/65536*b + ~1/2] * A=1) + (R<1 * ((R<11853/65536 * [~16384/11853*a^2 + ~11585/11853*b^2 + 302/1317*a*b + a + 1940/3951*b]^2) + ((R<73630271/776798208 * [a^2 + 64177444/73630271*b^2 + 44531712/73630271*a*b + ~131061126/73630271*b]^2) + ((R<70211653911/4825433440256 * [~77895776116/70211653911*b^2 + 5825642465/10030236273*a*b + b]^2) + ((R<48375415273/657341564387328 * [~36776393918/48375415273*b^2 + a*b]^2) + (R<18852430195/11096159253659648 * [b^2]^2)))))))))) & (((A<0 * (A<0 * R<1)) + (([b] * A=0) + (([~1*a] * A=1) + (R<1 * (R<1 * [b]^2)))))))")
proof -
  assume a1: "a * (1 - a\<^sup>2 - b\<^sup>2) = b"
  assume a2: "a + b * (1 - a\<^sup>2 - b\<^sup>2) = 0"
  have f3: "\<forall>r ra. - (ra::real) * r = ra * - r"
    by simp
  have "- b * (1 - a\<^sup>2 - b\<^sup>2) = a"
    using a2 by simp
  then have "\<exists>r ra. b * b - ra * (r * (ra * - r)) = 0"
    using f3 a1 by (metis (no_types) c.vec_simps(15) right_minus_eq)
  then have "\<exists>r. b * b - r * - r = 0"
    using f3 by (metis (no_types) c.vec_simps(14))
  then show "b = 0"
    by simp
qed

lemma origin_not_trapC:
  shows "0 \<notin> trapC"
  unfolding trapC_def zero_prod_def
  by auto

lemma regular_trapC:
  shows "0 \<notin> (\<lambda>(x, y). (cx x y, cy x y)) ` trapC"
  using origin_fixpoint origin_not_trapC
  by (smt UNIV_I UNIV_I UNIV_def case_prodE2 imageE c.flow_initial_time_if
      c.rev.flow_initial_time_if mem_Collect_eq zero_prod_def)

lemma positively_invariant_outer:
  shows "c.positively_invariant  {p. (\<lambda>p. (fst p)\<^sup>2 + (snd p)\<^sup>2 - 4) p \<le> 0}"
  apply (rule c.positively_invariant_le[of "\<lambda>p.-2*((fst p)^2+(snd p)^2)" _  "\<lambda>x p. 2 * fst x * fst p + 2 * snd x * snd p" ])
    apply (auto intro!: continuous_intros derivative_eq_intros)
  unfolding cx_def cy_def
  by (sos "(((A<0 * R<1) + (R<1 * ((R<6 * [a]^2) + (R<6 * [b]^2)))))")

lemma positively_invariant_inner:
  shows "c.positively_invariant  {p. (\<lambda>p. 1/4 - ((fst p)\<^sup>2 + (snd p)\<^sup>2)) p \<le> 0}"
  apply (rule c.positively_invariant_le[of "\<lambda>p.-2*((fst p)^2+(snd p)^2)" _ "\<lambda>x p. - 2 * fst x * fst p - 2 * snd x * snd p"])
    apply (auto intro!: continuous_intros derivative_eq_intros)
  unfolding cx_def cy_def
  by (sos "(((A<0 * R<1) + (R<1 * ((R<3/2 * [a]^2) + (R<3/2 * [b]^2)))))")

lemma positively_invariant_trapC:
  shows "c.positively_invariant trapC"
  unfolding trapC_eq
  apply (rule c.positively_invariant_conj)
  using positively_invariant_outer
   apply (metis (no_types, lifting) Collect_cong case_prodE case_prodI2 case_prod_conv)
  using positively_invariant_inner
  by (metis (no_types, lifting) Collect_cong case_prodE case_prodI2 case_prod_conv)

theorem c_has_periodic_orbit:
  obtains y where "c.periodic_orbit y" "c.flow0 y ` UNIV \<subseteq> trapC"
proof -
  from c.poincare_bendixson_applied[OF compact_trapC _ nonempty_trapC positively_invariant_trapC regular_trapC]
  show ?thesis using that by blast
qed

text \<open>Real-Arithmetic\<close>
schematic_goal c_fas:
  "[-(-(X!1) + (X!0) * (1 - (X!0)^2 - (X!1)^2)), -((X!0) + (X!1) * (1 - (X!0)^2 - (X!1)^2))] = interpret_floatariths ?fas X"
  by (reify_floatariths)

concrete_definition c_fas uses c_fas

interpretation crev: ode_interpretation true_form UNIV c_fas
  "-(\<lambda>(x, y). (cx x y, cy x y)::real*real)"
  "d::2" for d
  by unfold_locales (auto simp: c_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      cx_def cy_def eval_nat_numeral
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

lemma crev: "t \<in> {1/8 .. 1/8} \<longrightarrow> (x, y) \<in> {(2, 0) .. (2, 0)} \<longrightarrow>
   t \<in> c.rev.existence_ivl0 (x, y) \<and> c.rev.flow0 (x, y) t \<in> {(5.15, -0.651)..(5.18, -0.647)}"
  by (tactic \<open>ode_bnds_tac @{thms c_fas_def} 30 20 7 12 [(0, 1, "0x000000")] (* "crev.out" *) "" @{context} 1\<close>)

theorem c_has_limit_cycle:
  obtains y where "c.limit_cycle y" "range (c.flow0 y) \<subseteq> trapC"
proof -
  define E where "E = {(5.15, -0.651)..(5.18, -0.647)::real*real}"
  from crev have "c.rev.flow0 (2, 0) (1/8) \<in> E"
    by (auto simp: E_def)
  moreover
  have "E \<inter> trapC = {}"
  proof -
    have "norm x > 2" if "x \<in> E" for x
      using that
      apply (auto simp: norm_prod_def less_eq_prod_def E_def)
      by (smt power2_less_eq_zero_iff real_less_rsqrt zero_compare_simps(9))
    moreover have "norm x \<le> 2" if "x \<in> trapC" for x
      using that
      by (auto simp: trapC_def dist_prod_def norm_prod_def)
    ultimately show ?thesis by force
  qed
  ultimately have "c.rev.flow0 (2, 0) (1 / 8) \<notin> trapC" by blast
  from c.poincare_bendixson_limit_cycle[OF compact_trapC subset_UNIV x_in_trapC positively_invariant_trapC regular_trapC this] that
  show ?thesis by blast
qed

end

subsection \<open>Glycolysis\<close>

text \<open>Strogatz, Example 7.3.2\<close>

context
begin

text \<open>coordinate functions\<close>
definition "gx x y = -x + 0.08 * y + x\<^sup>2 * y"
definition "gy x y = 0.6 - 0.08 * y - x\<^sup>2 * y"

lemmas g_defs = gx_def gy_def

text \<open>partial derivatives\<close>
definition A11::"real\<Rightarrow>real\<Rightarrow>real" where "A11 x y = -1 + 2 * x * y"
definition A12::"real\<Rightarrow>real\<Rightarrow>real" where "A12 x y = (0.08 + x\<^sup>2)"
definition A21::"real\<Rightarrow>real\<Rightarrow>real" where "A21 x y = -2*x*y"
definition A22::"real\<Rightarrow>real\<Rightarrow>real" where "A22 x y = -(0.08 + x\<^sup>2)"

lemmas A_partials = A11_def A12_def A21_def A22_def

text \<open>Jacobian as linear map\<close>
definition A :: "real \<Rightarrow> real \<Rightarrow> (real \<times> real) \<Rightarrow>\<^sub>L (real \<times> real)" where
  "A x y = blinfun_of_matrix
    ((\<lambda>_ _. 0)
      ((1,0) := (\<lambda>_. 0)((1, 0):=A11 x y, (0, 1):=A12 x y),
       (0, 1):= (\<lambda>_. 0)((1, 0):=A21 x y, (0, 1):=A22 x y)))"

lemma A_simp[simp]: "blinfun_apply (A x y) (dx, dy) =
  (dx * A11 x y + dy * A12 x y,
   dx * A21 x y + dy * A22 x y)"
  by (auto simp: A_def blinfun_of_matrix_apply Basis_prod_def)

lemma A_continuous[continuous_intros]:
  "continuous_on S (\<lambda>x. local.A (f x) (g x))"
  if "continuous_on S f" "continuous_on S g"
  unfolding A_def
  by (auto intro!: continuous_on_blinfun_of_matrix continuous_intros that
      simp: Basis_prod_def A_partials)

interpretation g: c1_on_open_R2 "\<lambda>(x::real, y::real). (gx x y, gy x y)::real*real"
  "\<lambda>(x, y). A x y" UNIV
  by unfold_locales
    (auto intro!: derivative_eq_intros ext continuous_intros simp: split_beta algebra_simps
      g_defs A_partials)

(*
  The outer invariant is the convex set formed by the axes, y \<le> 7.51, and x+y\<le>8.12
*)
definition "(pos_quad::(real \<times> real) set) =  {p . - snd p \<le> 0} \<inter> {p . - fst p \<le> 0}"

definition "(trapG1::(real \<times> real) set) = pos_quad \<inter> ({p. (snd p) - 751/100 \<le> 0} \<inter> {p. (fst p) + (snd p) - 812/100 \<le> 0})"

lemma positively_invariant_y:
  shows "g.positively_invariant {p . - snd p \<le> 0}"
  apply (rule g.positively_invariant_le[of "\<lambda>p. -(0.08 + (fst p)^2)" _ "\<lambda>x p. - snd p"])
    apply (auto intro!: continuous_intros derivative_eq_intros)
  unfolding gy_def
  by (sos "()")

lemma positively_invariant_pos_quad:
  shows "g.positively_invariant pos_quad"
  unfolding pos_quad_def
  apply (rule g.positively_invariant_le_domain[OF positively_invariant_y, of "\<lambda>p. fst p * snd p -1"])
    apply (auto intro!: continuous_intros derivative_eq_intros)
  unfolding gx_def
  by (sos "(((A<0 * R<1) + (((A<0 * R<1) * (R<11/14 * [1]^2)) + ((A<=0 * R<1) * (R<1/7 * [1]^2)))))")

lemma positively_invariant_y_upper:
  shows "g.positively_invariant {p. (snd p) - 751/100 \<le> 0}"
  apply (rule g.positively_invariant_barrier)
    apply (auto intro!: continuous_intros derivative_eq_intros)
  unfolding gy_def
  by (sos "((R<1 + ((R<1 * (R<18775/2 * [a]^2)) + ((A<=0 * R<1) * (R<1250 * [1]^2)))))")

lemma arith2:
  shows "(y::real) \<le> 751/100 \<and> x + (y::real) = 812/100 \<Longrightarrow> 3/5 - (x::real) < 0"
  by linarith

lemma positively_invariant_trapG1:
  shows "g.positively_invariant trapG1"
  unfolding trapG1_def
  apply (rule g.positively_invariant_conj[OF positively_invariant_pos_quad])
  apply (rule g.positively_invariant_barrier_domain[OF positively_invariant_y_upper])
  apply (auto intro!: continuous_intros derivative_eq_intros)
  unfolding gx_def gy_def by auto

(* Polynomial in invariant *)
definition "p1 (x::real) (y::real) = -(21/34) - (69*x)/38 + (19*x^2)/15 - (9*x^3)/28 - (6*x^4)/43 + ( 14*y)/29 + (31*x*y)/21 + (182*x^2*y)/47 - (35*x^3*y)/16 - ( 3*y^2)/17 - (2*x*y^2)/9 - (31*x^2*y^2)/20 +y^3/102 + (x*y^3)/59"

definition "p1d x xa = 38 * (fst xa * fst x) / 15 - 69 * fst xa / 38 -
          27 * (fst xa * (fst x)\<^sup>2) / 28 -
          24 * (fst xa * fst x ^ 3) / 43 +
          14 * snd xa / 29 +
          (651 * (fst x * snd xa) +
           651 * (fst xa * snd x)) /
          441 +
          (8554 * ((fst x)\<^sup>2 * snd xa) +
           17108 * (fst xa * (fst x * snd x))) /
          2209 -
          (560 * (fst x ^ 3 * snd xa) +
           1680 * (fst xa * ((fst x)\<^sup>2 * snd x))) /
          256 -
          6 * (snd xa * snd x) / 17 -
          (36 * (fst x * (snd xa * snd x)) +
           18 * (fst xa * (snd x)\<^sup>2)) /
          81 -
          (1240 * ((fst x)\<^sup>2 * (snd xa * snd x)) +
           1240 * (fst xa * (fst x * (snd x)\<^sup>2))) /
          400 +
          snd xa * (snd x)\<^sup>2 / 34 +
          (177 * (fst x * (snd xa * (snd x)\<^sup>2)) +
           fst xa * snd x ^ 3 * 59) /
          3481"

lemma p1_has_derivative:
  shows "((\<lambda>x. p1 (fst x) (snd x)) has_derivative p1d x) (at x)"
  unfolding p1_def p1d_def
  by (auto intro!: continuous_intros derivative_eq_intros)

(* p1 excludes equilibria for free *)
lemma p1_not_equil:
  shows " p1 x y \<le> 0 \<Longrightarrow> gx x y \<noteq> 0 \<or> gy x y \<noteq> 0"
  unfolding gx_def gy_def p1_def
  by (sos "()")

definition "trapG = trapG1 \<inter> {p. p1 (fst p) (snd p) \<le> 0}"

text \<open>Real-Arithmetic\<close>
definition "g_arith a b = (- (27 / 25) - a\<^sup>2 + 2 * a * b) * p1 a b - p1d (a, b) (gx a b, gy a b)"

schematic_goal g_arith_fas:
  "[g_arith (X!0) (X!1)] = interpret_floatariths ?fas X"
  unfolding g_arith_def p1_def p1d_def gx_def gy_def fst_conv snd_conv
  by (reify_floatariths)

concrete_definition g_arith_fas uses g_arith_fas

lemma list_interval2: "list_interval [a, b] [c, d] = {[x, y] | x y. x \<in> {a .. c} \<and> y \<in> {b .. d}}"
  apply (auto simp: list_interval_def)
  subgoal for x
    apply (cases x)
    apply auto
    subgoal for y zs
      apply (cases zs)
      by auto
    done
  done

lemma g_arith_nonneg: "g_arith a b \<ge> 0"
  if a: "0 \<le> a" "a \<le> 8.24" and b: "0 \<le> b" "b \<le> 7.51"
proof -
  have "prove_nonneg [(0, 1, ''0x000000'')] 1000000 30 (slp_of_fas [hd g_arith_fas]) [aforms_of_ivls [0, 0]
    [float_divr 30 824 100, float_divr 30 751 100]]"
    by eval\<comment> \<open>slow: 60s\<close>
  from prove_nonneg[OF this]
  have "0 \<le> interpret_floatarith (hd g_arith_fas) [a, b]"
    apply (auto simp: g_arith_fas)
    apply (subst (asm) Joints_aforms_of_ivls)
     apply (auto )
      apply (smt divide_nonneg_nonneg float_divr float_numeral rel_simps(27))
     apply (smt divide_nonneg_nonneg float_divr float_numeral rel_simps(27))
    apply (subst (asm) list_interval2)
    apply auto
    apply (drule spec[where x="[a, b]"])
    using a b
    apply auto
    subgoal by (rule order_trans[OF _ float_divr]) simp
    subgoal by (rule order_trans[OF _ float_divr]) simp
    done
  also have "\<dots> = g_arith a b"
    by (auto simp: g_arith_fas_def g_arith_def p1_def p1d_def gx_def gy_def)
  finally show ?thesis .
qed

lemma trap_arithmetic:
  "p1d (a, b) (gx a b, gy a b) \<le> (- (27 / 25) - a\<^sup>2 + 2 * a * b) * p1 a b" if "(a, b) \<in> trapG1"
proof -
  from that
  have b: "0 \<le> b" "b \<le> 7.51"
    and a: "0 \<le> a" "a \<le> 8.24"
    by (auto simp: trapG1_def pos_quad_def)
  from g_arith_nonneg[OF a b] show ?thesis
    by (simp add: g_arith_def)
qed

lemma positively_invariant_trapG:
  shows "g.positively_invariant trapG"
  unfolding trapG_def
  apply (rule g.positively_invariant_le_domain[OF positively_invariant_trapG1 _ p1_has_derivative,
        of "\<lambda>p. -1.08 - (fst p)^2 + 2 * fst p * snd p"])
  subgoal by (auto intro!: continuous_intros derivative_eq_intros simp add: pos_quad_def)
  apply auto
  by (rule trap_arithmetic)

lemma regular_trapG:
  shows "0 \<notin> (\<lambda>(x, y). (gx x y, gy x y)) ` trapG"
  unfolding trapG_def apply auto using p1_not_equil
  by force

lemma arith:
  "\<And>a b::real. 0 \<le> b \<Longrightarrow>
           0 \<le> a \<Longrightarrow>
           b * 100 \<le> 751 \<Longrightarrow>
           a * 25 + b * 25 \<le> 203 \<Longrightarrow> norm a + norm b \<le> 20"
  by auto

lemma trapG1_subset:
  shows "trapG1 \<subseteq> cball (0::real \<times> real) 20"
  unfolding trapG1_def pos_quad_def
  apply auto
  using arith norm_Pair_le
  by smt

lemma compact_subset_closed:
  assumes "compact S" "closed T"
  assumes "T \<subseteq> S"
  shows "compact T"
  using compact_Int_closed[OF assms(1-2)] assms(3)
  by (simp add: inf_absorb2)

lemma compact_trapG1:
  shows "compact trapG1"
  apply (auto intro!: compact_subset_closed[OF _ _ trapG1_subset])
  unfolding trapG1_def pos_quad_def
  by (auto intro!: closed_Collect_le continuous_intros)

lemma compact_trapG:
  shows "compact trapG"
  unfolding trapG_def
  by (auto intro!: compact_Int_closed compact_trapG1 closed_Collect_le continuous_intros simp add: p1_def)

lemma x_in_trapG:
  shows "(1,0) \<in> trapG"
  unfolding trapG_def trapG1_def pos_quad_def p1_def
  by (auto simp add: dist_Pair_Pair)

schematic_goal g_fas:
  "[- (- (X!0) + 8 / 100 * (X!1) + (X!0)^2 * (X!1)),-( 6 / 10 - 8 / 100 * (X!1) - (X!0)^2 * (X!1))] = interpret_floatariths ?fas X"
  by (reify_floatariths)

concrete_definition g_fas uses g_fas

interpretation grev: ode_interpretation true_form UNIV g_fas
  "-(\<lambda>(x, y). (gx x y, gy x y)::real*real)"
  "d::2" for d
  by unfold_locales (auto simp: g_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      gx_def gy_def eval_nat_numeral
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

lemma grev: "t \<in> {1/8 .. 1/8} \<longrightarrow> (x, y) \<in> {(1, 0) .. (1, 0)} \<longrightarrow>
   t \<in> g.rev.existence_ivl0 (x, y) \<and> g.rev.flow0 (x, y) t \<in>
    {(1.1, -0.09) .. (1.2, -0.08)}"
  by (tactic \<open>ode_bnds_tac @{thms g_fas_def} 30 20 7 12 [(0, 1, "0x000000")] (* "grev.out" *) "" @{context} 1\<close>)

theorem g_has_limit_cycle:
  obtains y where "g.limit_cycle y" "range (g.flow0 y) \<subseteq> trapG"
proof -
  define E::"(real*real) set" where "E = {(1.1, -0.09) .. (1.2, -0.08)}"
  from grev have "g.rev.flow0 (1, 0) (1/8) \<in> E"
    by (auto simp: E_def)
  moreover
  have "E \<inter> trapG = {}"
    by (auto simp: trapG_def E_def trapG1_def pos_quad_def)
  ultimately have "g.rev.flow0 (1, 0) (1 / 8) \<notin> trapG" by blast
  from g.poincare_bendixson_limit_cycle[OF compact_trapG subset_UNIV x_in_trapG positively_invariant_trapG regular_trapG this] that
  show ?thesis by blast
qed

end

end


(*section {* Sliceable distinct lists *}*)
text {* \label{sec:theory-sliceable-dlist}*}

(*<*)
theory Sliceable_dlist

imports
  Sliceable
  "~~/src/HOL/Library/Dlist"

begin
(*>*)

(*<*)
lemma take1_drop_nth: "i < length xs \<Longrightarrow> take 1 (drop i xs) = [xs!i]"
by (simp add: take_Suc_conv_app_nth)

lemma "(\<forall>i. xs!i = ys!i) \<and> length xs = length ys \<longleftrightarrow> xs = ys"
using list_eq_iff_nth_eq
by blast
(*>*)

text {* The following is the instantiation of the sliceable class for the dlist type. *}

instantiation dlist :: (type) sliceable
begin

definition
  "l\<dagger>i..f = Dlist (take (max 0 (f-i)) (drop i (list_of_dlist l)))"

definition
  "size l = length (list_of_dlist l)"

definition
  "empty_inter l k =
  ((set (list_of_dlist l)) \<inter> (set (list_of_dlist k)) = {})"

definition
  "disjoint l = distinct (list_of_dlist l)"

lemma list_of_dlist_slice :
  "list_of_dlist (l\<dagger>i..f) = take (max 0 (f-i)) (drop i (list_of_dlist l))"
unfolding slice_dlist_def
by simp

lemma Dlist_slice_inverse :
  "list_of_dlist (Dlist (take (max 0 (c-i)) (drop i (list_of_dlist x))))
  = (take (max 0 (c-i)) (drop i (list_of_dlist x)))"
by simp

lemma Dlist_empty_seq_inter: "c \<le> k \<Longrightarrow>
  (
  set (take c (list_of_dlist x)) \<inter>
  set (drop k (list_of_dlist x))
  ) = {}"
by (simp add: set_take_disj_set_drop_if_distinct)

lemma Dlist_forall_slice_eq1:
  "(\<forall>i f. (Dlist (take (max 0 (f-i)) (drop i (list_of_dlist l1))) =
  Dlist (take (max 0 (f-i)) (drop i (list_of_dlist l2))))) \<Longrightarrow>
  l1 = l2"
by (metis (mono_tags, hide_lams) Dlist_list_of_dlist
  Sliceable_dlist.list_of_dlist_slice drop_0 drop_take max_0L take_equalityI)

lemma Dlist_forall_slice_eq:
  "l1 = l2 \<longleftrightarrow>
  (\<forall>i f. (Dlist (take (max 0 (f-i)) (drop i (list_of_dlist l1))) =
  Dlist (take (max 0 (f-i)) (drop i (list_of_dlist l2)))))"
using Dlist_forall_slice_eq1 by blast

lemma distinct_list_take_1_uniqueness:
  "distinct l \<Longrightarrow> i\<noteq>j \<Longrightarrow> i < length l \<Longrightarrow> j < length l \<Longrightarrow>
    take 1 (drop i l) \<noteq> take 1 (drop j l)"
by (simp add: hd_drop_conv_nth nth_eq_iff_index_eq take_Suc)

lemmas list_of_dlist_simps = slice_left_def slice_right_def slice_dlist_def
  size_dlist_def disjoint_dlist_def empty_inter_dlist_def Dlist_slice_inverse

instance proof
  fix l::"'a dlist"
  show "l\<dagger>0..(#l) = l" by (simp add: dlist_eqI list_of_dlist_slice size_dlist_def)
  fix l::"'a dlist"
  show "disjoint l" by (simp add: disjoint_dlist_def)
  next
  fix l::"'a dlist" and c::nat and k
  assume "c \<le> k"
  thus "empty_inter (l\<dagger>0..c) (l\<dagger>k..(#l))"
  by (simp add: size_dlist_def empty_inter_dlist_def
    set_take_disj_set_drop_if_distinct list_of_dlist_slice )
  next
  fix l::"'a dlist" and i and j and a and b
  show "size (l\<dagger>i..j) = max 0 (min j (#l) - i)"
  proof (cases "j \<le> #l")
    case True
    assume "j \<le> #l"
    thus ?thesis
      by (metis (no_types, hide_lams) list_of_dlist_simps(7) size_dlist_def
        drop_take length_drop length_take list_of_dlist_simps(3) max_0L
        min.commute)
    next
    case False
    assume "\<not> (j \<le> #l)"
    hence "j > #l" by simp
    thus ?thesis
      by (metis (no_types, lifting) list_of_dlist_simps(3)
        list_of_dlist_simps(7) size_dlist_def length_drop length_take max_0L
        min.commute min_diff)
  qed
  next
  fix l::"'a dlist" and i and j and a and b
  show "(l\<dagger>i..j)\<dagger>a..b = l\<dagger>(i + a)..(min j (i + b))"
    proof -
      have f1: "\<forall>n. max (0::nat) n = n"
        by (meson max_0L)
      hence "take b (take (max 0 (j - i)) (drop i (list_of_dlist l))) = drop i (take (i + b) (take j (list_of_dlist l)))"
        by (metis (no_types) diff_add_inverse drop_take)
      hence "take (max 0 (b - a)) (drop a (list_of_dlist (l\<dagger>i..j))) = drop a (drop i (take (min (i + b) j) (list_of_dlist l)))"
        using f1 by (metis Sliceable_dlist.list_of_dlist_slice drop_take take_take)
      thus ?thesis
        using f1 by (metis (no_types) add.commute drop_drop drop_take list_of_dlist_simps(3) min.commute)
    qed
  next
  fix l::"'a dlist" and i and j
  assume "disjoint l" "i\<noteq>j" "i < (#l)" "j < (#l)"
  hence "take 1 (drop i (list_of_dlist l)) \<noteq>
    take 1 (drop j (list_of_dlist l))"
    using distinct_list_take_1_uniqueness size_dlist_def by auto
  hence "take (Suc i - i) (drop i (list_of_dlist l)) \<noteq>
    take (Suc j - j) (drop j (list_of_dlist l))"
    by simp
  hence "take (max 0 (Suc i - i)) (drop i (list_of_dlist l)) \<noteq>
    take (max 0 (Suc j - j)) (drop j (list_of_dlist l))"
    by simp
  thus "l\<dagger>i..Suc i \<noteq> l\<dagger>j..Suc j"
  by (metis list_of_dlist_slice)
  next
  fix l1::"'a dlist" and l2::"'a dlist"
  show "(#l1) = (#l2) \<and> (\<forall>i j. l1\<dagger>i..j = l2\<dagger>i..j) \<longleftrightarrow> (l1 = l2)"
    using Dlist_forall_slice_eq
    by (metis Sliceable_dlist.list_of_dlist_slice)
qed

end

(*subsection {* Properties of sliceable distinct lists *}*)

text {* In the following we present lemmas, corollaries and theorems about sliceable distinct lists.*}

abbreviation dlist_nth :: "'a dlist \<Rightarrow> nat \<Rightarrow> 'a"
where
"dlist_nth l i \<equiv> (list_of_dlist (sliceable_nth l i))!0"

theorem set_slice :
  "set (list_of_dlist l) =
    set (list_of_dlist (l\<dagger>..i)) \<union> set (list_of_dlist (l\<dagger>i..))"
unfolding slice_dlist_def slice_right_def slice_left_def size_dlist_def
apply (simp add: list_of_dlist_inject)
by (metis append_take_drop_id set_append)

theorem take_slice_right: "take n (list_of_dlist l) = list_of_dlist (l\<dagger>..n)"
unfolding slice_right_def slice_dlist_def
by (metis Dlist_slice_inverse drop_0 max_0L minus_nat.diff_0)

theorem slice_right_cons: "distinct (x # xs) \<Longrightarrow>
  (Dlist (x # xs))\<dagger>..(Suc n) = Dlist (x # (list_of_dlist ((Dlist xs)\<dagger>..n)))"
unfolding slice_right_def slice_dlist_def
by (simp add: distinct_remdups_id)

theorem slice_append:
  "\<forall>n. Dlist ((list_of_dlist (l\<dagger>..n)) @ (list_of_dlist (l\<dagger>n..))) = l"
unfolding size_dlist_def slice_left_def slice_right_def
by (simp add: list_of_dlist_inverse list_of_dlist_slice )

theorem slice_append_mid:
"\<forall>i s e. s \<le> i \<and> i \<le> e \<longrightarrow>
  ((list_of_dlist (l\<dagger>s..i)) @ (list_of_dlist (l\<dagger>i..e))) =
    list_of_dlist (l\<dagger>s..e)"
unfolding size_dlist_def slice_left_def slice_right_def list_of_dlist_slice
by (smt Nat.diff_add_assoc2 drop_drop le_add_diff_inverse
  le_add_diff_inverse2 max_0L take_add)

theorem slice_append_3:
"\<forall>i j. i \<le> j \<longrightarrow>
  ((list_of_dlist (l\<dagger>..i)) @
    (list_of_dlist (l\<dagger>i..j)) @ (list_of_dlist (l\<dagger>j..))) = list_of_dlist l"
unfolding size_dlist_def slice_left_def slice_right_def list_of_dlist_slice
by (metis append_assoc append_take_drop_id drop_0 le_add_diff_inverse
  length_drop max.cobounded2 max_0L minus_nat.diff_0 take_add take_all)

theorem distinct_slice_lte_inter_empty[simp]:
  "i \<le> j \<Longrightarrow> set (list_of_dlist (l\<dagger>..i)) \<inter> set (list_of_dlist (l\<dagger>j..)) = {}"
unfolding size_dlist_def slice_left_def slice_right_def
by (simp add: Dlist_empty_seq_inter list_of_dlist_slice )

corollary distinct_slice_inter_empty [simp]:
  "set (list_of_dlist (l\<dagger>..i)) \<inter> set (list_of_dlist (l\<dagger>i..)) = {}"
by simp

corollary distinct_slice_lt_inter_empty [simp]:
  "i < j \<Longrightarrow> set (list_of_dlist (l\<dagger>..i)) \<inter> set (list_of_dlist (l\<dagger>j..)) = {}"
by simp

corollary distinct_slice_diff1:
  "set (list_of_dlist (l\<dagger>..i)) - set (list_of_dlist (l\<dagger>i..)) =
    set (list_of_dlist (l\<dagger>..i))"
by (simp add: Diff_triv)

corollary distinct_slice_diff2:
  "set (list_of_dlist (l\<dagger>i..)) - set (list_of_dlist (l\<dagger>..i)) =
    set (list_of_dlist (l\<dagger>i..))"
using distinct_slice_diff1 by fastforce

(*
lemma Dlist_slice_inverse[simp]:
  "list_of_dlist (Dlist ((list_of_dlist l)\<dagger>i..f)) = (list_of_dlist l)\<dagger>i..f"
by (simp add: Dlist_inverse distinct_dlist distinct_slice)
*)

theorem distinct_in_set_slice1_not_in_slice2:
  "i \<le> j \<Longrightarrow>
  x \<in> set (list_of_dlist (l\<dagger>..i)) \<and> x \<in> set (list_of_dlist (l\<dagger>j..)) \<Longrightarrow>
  False"
using distinct_slice_lte_inter_empty by fastforce

corollary distinct_in_set_slice1_implies_not_in_slice2:
  "i \<le> j \<Longrightarrow> x \<in> set (list_of_dlist (l\<dagger>..i)) \<Longrightarrow>
  x \<in> set (list_of_dlist (l\<dagger>j..)) \<Longrightarrow> False"
by (meson distinct_in_set_slice1_not_in_slice2)

lemma exists_sublist_or_not_sublist [simp]: "\<exists>i. l\<dagger>..i \<in> T \<or> l\<dagger>i.. \<notin> T"
unfolding slice_right_def slice_left_def
by auto

lemma forall_slice_left_implies_exists [simp]:
  "\<forall> i . l\<dagger>i.. \<in> S \<Longrightarrow> \<exists> i . l\<dagger>(Suc i).. \<in> S"
unfolding slice_right_def slice_left_def
by (simp add: slice_dlist_def)

lemma forall_slice_right_implies_exists [simp]:
  "\<forall> i . l\<dagger>..i \<in> S \<Longrightarrow> \<exists> i . l\<dagger>..(i-1) \<in> S"
unfolding slice_right_def slice_left_def
by auto

(*lemma take_Suc_Cons [simp]: "take (Suc n) (xDlist_inverse # xs) = x # take n xs"*)

lemma take_Suc_Cons_hd_tl: "length l > 0 \<Longrightarrow>
  take (Suc n) l = hd l # (take n (tl l))"
apply (induct l)
by auto

corollary take_Suc_Cons_hd_tl_singleton:
  "length l > 0 \<Longrightarrow> take (Suc 0) l = [hd l]"
apply (induct l)
by auto

lemma take_drop_suc: "i < length l \<Longrightarrow> length l > 0 \<Longrightarrow>
  take (max 0 ((Suc i) - i)) (drop i l) = [l!i]"
by (metis (no_types, lifting) Suc_diff_Suc Suc_eq_plus1_left add.commute
  append_eq_append_conv cancel_comm_monoid_add_class.diff_cancel
  hd_drop_conv_nth lessI max_0L numeral_1_eq_Suc_0 numeral_One take_add
  take_hd_drop)

lemma slice_right_take:"l\<dagger>..i = Dlist (take i (list_of_dlist l))"
unfolding slice_right_def slice_dlist_def
by auto

lemma slice_left_drop: "l\<dagger>i.. = Dlist (drop i (list_of_dlist l))"
unfolding slice_left_def slice_dlist_def size_dlist_def
by auto

lemma take_one_singleton_hd: "l \<noteq> [] \<Longrightarrow> take (Suc 0) l = [hd l]"
apply (induct l, simp)
by auto

lemma take_one_singleton_nth: "l \<noteq> [] \<Longrightarrow> take (Suc 0) l = [l!0]"
apply (induct l, simp)
by auto

lemma take_one_drop_n_append_singleton_nth:
  "ys \<noteq> [] \<Longrightarrow> take 1 (drop (length xs) (xs @ ys)) =
  [(xs @ ys)!(length xs)]"
by (induct xs, auto simp add: take_one_singleton_nth)

lemma append_length_nth_hd: "ys \<noteq> [] \<Longrightarrow> [(xs @ ys)!(length xs)] = [hd ys]"
by (induct ys, auto)

lemma take_one_drop_n_singleton_nth: "l \<noteq> [] \<Longrightarrow> n < length l \<Longrightarrow>
  take 1 (drop n l) = [l!n]"
proof-
  assume 0: "l \<noteq> []"
  assume 1: "n < length l"
  obtain xs where "xs = take n l" by simp
  obtain ys where "ys = drop n l" by simp
  have "take 1 (drop n l) = take 1 (drop (length xs) (xs @ ys))" using 0 1
    by (simp add: `ys = drop n l`)
  also have "... = [(xs @ ys)!(length xs)]" using 0 1
    by (metis `ys = drop n l` drop_eq_Nil not_le
      take_one_drop_n_append_singleton_nth)
  also have "... = [l!(length xs)]"
    by (simp add: `xs = take n l` `ys = drop n l`)
  finally show ?thesis using 0 1
    by (simp add: hd_drop_conv_nth take_one_singleton_hd)
qed

lemma slice_singleton: "(list_of_dlist l) \<noteq> [] \<Longrightarrow> i < (#l) \<Longrightarrow>
  list_of_dlist (l\<dagger>i..(Suc i)) = [(list_of_dlist l)!i]"
by (metis list_of_dlist_slice length_greater_0_conv size_dlist_def
  take_drop_suc)

lemma slice_right_zero_eq_empty: "list_of_dlist (l\<dagger>..0) = []"
by (simp add: slice_right_def slice_dlist_def)

lemma slice_left_size_eq_empty: "list_of_dlist (l\<dagger>(#l)..) = []"
by (simp add: slice_left_def slice_dlist_def )

lemma slice_right_singleton_eq_element: "list_of_dlist l \<noteq> [] \<Longrightarrow>
  list_of_dlist (l\<dagger>..1) = [(list_of_dlist l)!0]"
by (metis One_nat_def take_one_singleton_nth take_slice_right)

lemma slice_left_singleton_eq_element: "list_of_dlist l \<noteq> [] \<Longrightarrow>
  list_of_dlist (l\<dagger>((#l)-1)..) = [(list_of_dlist l)!((#l)-1)]"
by (metis (no_types, lifting) Cons_nth_drop_Suc list_of_dlist_slice
  Suc_diff_Suc Suc_leI diff_Suc_eq_diff_pred diff_less drop_0 drop_all
  drop_take length_greater_0_conv max_0L minus_nat.diff_0 size_dlist_def
  slice_left_def slice_none zero_less_one)

lemma dlist_empty_slice[simp]: "i \<le> j \<Longrightarrow> (l\<dagger>j..i) = Dlist []"
by (simp add: slice_dlist_def)

lemma dlist_append_extreme_left:
  "i\<le>j \<Longrightarrow> list_of_dlist (l\<dagger>..j) =
  (list_of_dlist (l\<dagger>..i)) @ (list_of_dlist (l\<dagger>i..j))"
by (metis list_of_dlist_slice le_add_diff_inverse max_0L take_add
  take_slice_right)

lemma dlist_append_extreme_right:
  "i\<le>j \<Longrightarrow> list_of_dlist (l\<dagger>i..) =
  (list_of_dlist (l\<dagger>i..j)) @ (list_of_dlist (l\<dagger>j..))"
unfolding list_of_dlist_slice slice_left_def slice_right_def
by (metis append_take_drop_id drop_drop le_add_diff_inverse2 length_drop
  max.cobounded2 max_0L size_dlist_def take_all)

lemma dlist_disjoint[simp]: "disjoint (l::'a dlist)"
by (simp add: disjoint_dlist_def)

lemma dlist_member_suc_nth1:
  "x \<in> set (list_of_dlist(l\<dagger>i..(Suc i))) \<Longrightarrow> x = (list_of_dlist l)!i"
proof-
  assume 0: "x \<in> set (list_of_dlist (l\<dagger>i..(Suc i)))"
  obtain rl where 1:"rl = list_of_dlist l" by blast
  hence "x \<in> set (take (max 0 (Suc i - i)) (drop i rl))"
    using 0 by (metis list_of_dlist_slice )
  hence "x \<in> set (take 1 (drop i rl))" by simp
  hence "x = rl!i"
    by (metis drop_Nil drop_all empty_iff list.inject list.set(1)
      list.set_cases not_less take_Nil take_one_drop_n_singleton_nth)
  thus ?thesis using 1 by simp
qed

lemma dlist_member_suc_nth2:
  "i < (#l) \<Longrightarrow> x = (list_of_dlist l)!i \<Longrightarrow>
  x \<in> set (list_of_dlist (l\<dagger>i..(Suc i)))"
unfolding size_dlist_def slice_dlist_def
by (metis Dlist_slice_inverse drop_Nil drop_eq_Nil leD length_greater_0_conv
  list.set_intros(1) take_drop_suc)

lemma dlist_member_suc_nth: "i < (#l) \<Longrightarrow>
  (x = (list_of_dlist l)!i) \<longleftrightarrow> (x \<in> set (list_of_dlist (l\<dagger>i..(Suc i))))"
using dlist_member_suc_nth1 dlist_member_suc_nth2
by fastforce

corollary not_dlist_member_empty[simp]:
  "\<not> Dlist.member (Dlist.empty) v"
  "\<not> (Dlist.member (Dlist []) v)"
by (simp add: Dlist.member_def Dlist.empty_def List.member_def)+

lemma dlist_empty_slice_none: "(Dlist.empty\<dagger>i..j) = Dlist.empty"
by (simp add: Dlist.empty_def slice_dlist_def)

corollary dlist_empty_slice_right_none: "(Dlist.empty\<dagger>..j) = Dlist.empty"
by (simp add: dlist_empty_slice_none slice_right_def)

corollary dlist_empty_slice_left_none: "(Dlist.empty\<dagger>i..) = Dlist.empty"
by (simp add: dlist_empty_slice_none slice_left_def)

lemma dlist_member_slice_empty_none:
  "\<not> (Dlist.member (Dlist.empty\<dagger>i..j) v)"
by (auto simp add: slice_dlist_def)

corollary dlist_member_slice_right_empty_none[simp]:
  "\<not> (Dlist.member (Dlist.empty\<dagger>..j) v)"
by (simp add: slice_right_def dlist_empty_slice_none)

corollary dlist_member_slice_left_empty_none[simp]:
  "\<not> (Dlist.member (Dlist.empty\<dagger>i..) v)"
by (simp add: slice_left_def dlist_empty_slice_none)

lemma dlist_member_slice_member_dlist:
  "\<exists> i j. Dlist.member (dl\<dagger>i..j) v \<Longrightarrow> Dlist.member dl v"
unfolding Dlist.member_def List.member_def slice_dlist_def
using in_set_dropD in_set_takeD by fastforce

corollary dlist_member_slice_right_member_dlist:
  "\<exists>j. Dlist.member (dl\<dagger>..j) v \<Longrightarrow> Dlist.member dl v"
by (metis dlist_member_slice_member_dlist slice_right_def)

corollary dlist_member_slice_left_member_dlist:
  "\<exists>i. Dlist.member (dl\<dagger>i..) v \<Longrightarrow> Dlist.member dl v"
by (metis dlist_member_slice_member_dlist slice_left_def)

lemma sliceable_nth_member1:
  "sliceable_nth dl i = Dlist [v] \<Longrightarrow> Dlist.member dl v"
by (metis Dlist.member_def distinct_remdups_id distinct_singleton
  dlist_member_slice_member_dlist in_set_member list.set_intros(1) list_of_dlist_Dlist)

corollary sliceable_nth_member:
  "\<exists>i. sliceable_nth dl i = Dlist [v] \<Longrightarrow> Dlist.member dl v"
by (auto simp add: sliceable_nth_member1)

lemma sliceable_nth_member_iff:
  "(\<exists>i. sliceable_nth dl i = Dlist [v]) \<longleftrightarrow> Dlist.member dl v"
apply (rule iffI, simp add: sliceable_nth_member)
by (metis Dlist.member_def empty_iff empty_set in_set_conv_nth in_set_member
  list_of_dlist_slice size_dlist_def slice_dlist_def slice_singleton)

(*<*)
end
(*>*)


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

header {* Logical relations for definability in PCF *}
(*<*)

theory PCF
imports
  Basis
  Logical_Relations
begin

(*>*)
text{*

\label{sec:directsem}

Using this machinery we can demonstrate some classical results about
PCF \citep{Plotkin77}. We diverge from the traditional treatment by
considering PCF as an untyped language and including both call-by-name
(CBN) and call-by-value (CBV) abstractions following
\citet{DBLP:conf/icalp/Reynolds74}. We also adopt some of the
presentation of \citet[Chapter~11]{Winskel:1993}, in particular by
making the fixed point operator a binding construct.

We model the syntax of PCF as a HOL datatype, where variables have
names drawn from the naturals:

*}

type_synonym var = nat

datatype expr =
    Var var
  | App expr expr
  | AbsN var expr (* non-strict fns *)
  | AbsV var expr (* strict fns *)
  | Diverge ("\<Omega>")
  | Fix var expr
  | tt
  | ff
  | Cond expr expr expr
  | Num nat
  | Succ expr
  | Pred expr
  | IsZero expr

subsection{* Direct denotational semantics *}

text{*

\label{sec:densem}

We give this language a direct denotational semantics by interpreting
it into a domain of values.

*}

domain ValD =
   ValF (lazy appF :: "ValD \<rightarrow> ValD")
 | ValTT | ValFF
 | ValN (lazy "nat")

text{*

The \textbf{lazy} keyword means that the @{term "ValF"} constructor is
lifted, i.e. @{term "ValF\<cdot>\<bottom> \<noteq> \<bottom>"}, which further means that @{term
"ValF\<cdot>(\<Lambda> x. \<bottom>) \<noteq> \<bottom>"}.

The naturals are discretely ordered.

*}
(*<*)

lemma ValD_case_ID [simp]:
  "ValD_case\<cdot>ValF\<cdot>ValTT\<cdot>ValFF\<cdot>ValN = ID"
  apply (rule cfun_eqI)
  apply (case_tac x)
  apply simp_all
  done

lemma below_monic_ValF [iff]:
  "below_monic_cfun ValF"
  by (rule below_monicI) simp

lemma below_monic_ValN [iff]:
  "below_monic_cfun ValN"
  by (rule below_monicI) simp

(*>*)
text{*

The minimal invariant for @{typ "ValD"} is straightforward; the
function @{term "cfun_map\<cdot>f\<cdot>g\<cdot>h"} denotes @{term "g oo h oo f"}.

*}

fixrec
  ValD_copy_rec :: "(ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)"
where
  "ValD_copy_rec\<cdot>r\<cdot>(ValF\<cdot>f) = ValF\<cdot>(cfun_map\<cdot>r\<cdot>r\<cdot>f)"
| "ValD_copy_rec\<cdot>r\<cdot>(ValTT) = ValTT"
| "ValD_copy_rec\<cdot>r\<cdot>(ValFF) = ValFF"
| "ValD_copy_rec\<cdot>r\<cdot>(ValN\<cdot>n) = ValN\<cdot>n"
(*<*)

lemma ValD_copy_rec_strict [simp]:
  "ValD_copy_rec\<cdot>r\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

abbreviation
  "ValD_copy \<equiv> fix\<cdot>ValD_copy_rec"

lemma ValD_copy_strict [simp]:
  "ValD_copy\<cdot>\<bottom> = \<bottom>"
  by (subst fix_eq) simp

lemma ValD_copy_ID [simp]:
  "ValD_copy = ID"
proof -
  { fix x :: ValD
    fix i :: nat
    have "ValD_take i\<cdot>(ValD_copy\<cdot>(ValD_take i\<cdot>x)) = ValD_take i\<cdot>x"
    proof (induct i arbitrary: x)
      case (Suc n) thus ?case
        by (cases x) (subst fix_eq, simp add: cfun_map_def)+
    qed simp }
  hence "\<And>x :: ValD. (\<Squnion>i. ValD_take i\<cdot>(ValD_copy\<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{*

We interpret the PCF constants in the obvious ways. ``Ill-typed'' uses
of these combinators are mapped to @{term "\<bottom>"}.

*}

definition cond :: "ValD \<rightarrow> ValD \<rightarrow> ValD \<rightarrow> ValD" where
  "cond \<equiv> \<Lambda> i t e. case i of ValF\<cdot>f \<Rightarrow> \<bottom> | ValTT \<Rightarrow> t | ValFF \<Rightarrow> e | ValN\<cdot>n \<Rightarrow> \<bottom>"

definition succ :: "ValD \<rightarrow> ValD" where
  "succ \<equiv> \<Lambda> (ValN\<cdot>n). ValN\<cdot>(n + 1)"

definition pred :: "ValD \<rightarrow> ValD" where
  "pred \<equiv> \<Lambda> (ValN\<cdot>n). case n of 0 \<Rightarrow> \<bottom> | Suc n \<Rightarrow> ValN\<cdot>n"

definition isZero :: "ValD \<rightarrow> ValD" where
  "isZero \<equiv> \<Lambda> (ValN\<cdot>n). if n = 0 then ValTT else ValFF"

text{*

We model environments simply as continuous functions from variable
names to values.

*}

type_synonym Var = "var"
type_synonym 'a Env = "Var \<rightarrow> 'a"

definition env_empty :: "'a Env" where
  "env_empty \<equiv> \<bottom>"

definition env_ext :: "Var \<rightarrow> 'a \<rightarrow> 'a Env \<rightarrow> 'a Env" where
  "env_ext \<equiv> \<Lambda> v x \<rho> v'. if v = v' then x else \<rho>\<cdot>v'"
(*<*)

lemma env_ext_same: "env_ext\<cdot>v\<cdot>x\<cdot>\<rho>\<cdot>v = x"
  by (simp add: env_ext_def)

lemma env_ext_neq: "v \<noteq> v' \<Longrightarrow> env_ext\<cdot>v\<cdot>x\<cdot>\<rho>\<cdot>v' = \<rho>\<cdot>v'"
  by (simp add: env_ext_def)

lemmas env_ext_simps[simp] = env_ext_same env_ext_neq

(*>*)
text{*

The semantics is given by a function defined by primitive recursion
over the syntax.

*}

type_synonym EnvD = "ValD Env"

primrec
  evalD :: "expr \<Rightarrow> EnvD \<rightarrow> ValD"
where
  "evalD (Var v) = (\<Lambda> \<rho>. \<rho>\<cdot>v)"
| "evalD (App f x) = (\<Lambda> \<rho>. appF\<cdot>(evalD f\<cdot>\<rho>)\<cdot>(evalD x\<cdot>\<rho>))"
| "evalD (AbsN v e) = (\<Lambda> \<rho>. ValF\<cdot>(\<Lambda> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>)))"
| "evalD (AbsV v e) = (\<Lambda> \<rho>. ValF\<cdot>(strictify\<cdot>(\<Lambda> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))))"
| "evalD (Diverge) = (\<Lambda> \<rho>. \<bottom>)"
| "evalD (Fix v e) = (\<Lambda> \<rho>. \<mu> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))"
| "evalD (tt) = (\<Lambda> \<rho>. ValTT)"
| "evalD (ff) = (\<Lambda> \<rho>. ValFF)"
| "evalD (Cond i t e) = (\<Lambda> \<rho>. cond\<cdot>(evalD i\<cdot>\<rho>)\<cdot>(evalD t\<cdot>\<rho>)\<cdot>(evalD e\<cdot>\<rho>))"
| "evalD (Num n) = (\<Lambda> \<rho>. ValN\<cdot>n)"
| "evalD (Succ e) = (\<Lambda> \<rho>. succ\<cdot>(evalD e\<cdot>\<rho>))"
| "evalD (Pred e) = (\<Lambda> \<rho>. pred\<cdot>(evalD e\<cdot>\<rho>))"
| "evalD (IsZero e) = (\<Lambda> \<rho>. isZero\<cdot>(evalD e\<cdot>\<rho>))"

abbreviation eval' :: "expr \<Rightarrow> ValD Env \<Rightarrow> ValD" ("\<lbrakk>_\<rbrakk>_" [0,1000] 60) where
  "eval' M \<rho> \<equiv> evalD M\<cdot>\<rho>"

subsection{* The Y Combinator *}

text{*

We can shown the Y combinator is the least fixed point operator Using
just the minimal invariant.  In other words, @{term "fix"} is
definable in untyped PCF minus the @{term "Fix"} construct.

This is Example~3.6 from \citet{PittsAM:relpod}. He attributes the
proof to Plotkin.

These two functions are @{text "\<Delta> \<equiv> \<lambda>f x. f (x x)"} and @{text "Y \<equiv>
\<lambda>f. (\<Delta> f) (\<Delta> f)"}.

Note the numbers here are names, not de Bruijn indices.

*}

definition Y_delta :: expr where
  "Y_delta \<equiv> AbsN 0 (AbsN 1 (App (Var 0) (App (Var 1) (Var 1))))"

definition Ycomb :: expr where
  "Ycomb \<equiv> AbsN 0 (App (App Y_delta (Var 0)) (App Y_delta (Var 0)))"

definition fixD :: "ValD \<rightarrow> ValD" where
  "fixD \<equiv> \<Lambda> (ValF\<cdot>f). fix\<cdot>f"

lemma Y: "\<lbrakk>Ycomb\<rbrakk>\<rho> = ValF\<cdot>fixD"
(*<*)
proof(rule below_antisym)
  show "ValF\<cdot>fixD \<sqsubseteq> \<lbrakk>Ycomb\<rbrakk>\<rho>"
    unfolding fixD_def Ycomb_def
    apply (clarsimp simp: cfun_below_iff eta_cfun)
    apply (case_tac x)
     apply simp_all
    apply (rule fix_least)
    by (subst Y_delta_def, simp)
next
  { fix f \<rho>
    let ?P = "\<lambda>x. x \<sqsubseteq> ID \<and> appF\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)) \<sqsubseteq> fixD\<cdot>(ValF\<cdot>f)"
    have "?P ValD_copy"
      apply (rule fix_ind)
        apply simp
       apply simp
      apply clarsimp
      apply (rule conjI)
       apply (rule cfun_belowI)
       apply (case_tac xa)
        apply simp_all
       apply (drule cfun_map_below_ID)
       apply (simp add: cfun_below_iff)
      apply (simp add: fixD_def eta_cfun)
      apply (subst Y_delta_def)
      apply (subst fix_eq)
      apply simp
      apply (rule cfun_below_ID, assumption)
      apply (rule monofun_cfun_arg)
      apply (subgoal_tac "appF\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))
                        \<sqsubseteq> appF\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f))")
       apply (erule (1) below_trans)
      apply (simp add: monofun_cfun_arg cfun_below_iff)
      done }
  thus "\<lbrakk>Ycomb\<rbrakk>\<rho> \<sqsubseteq> ValF\<cdot>fixD"
    unfolding Ycomb_def fixD_def
    apply (clarsimp simp: cfun_below_iff)
    apply (case_tac x)
    apply (subst Y_delta_def, simp)
    apply simp
    apply (subst Y_delta_def, simp)+
    done
qed

(* FIXME could also try to show uniformity, cf Gunter, Plotkin "3 Inadequate Models". *)

(*>*)

subsection{* Logical relations for definability *}

text{*

\label{sec:pcfdefinability}

An element of @{typ "ValD"} is definable if there is an expression
that denotes it.

*}

definition definable :: "ValD \<Rightarrow> bool" where
  "definable d \<equiv> \<exists>M. \<lbrakk>M\<rbrakk>env_empty = d"

text{*

A classical result about PCF is that while the denotational semantics
is \emph{adequate}, as we show in \S\ref{sec:opsem}, it is not
\emph{fully abstract}, i.e. it contains undefinable values (junk).

One way of showing this is to reason operationally; see, for instance,
\citet[\S4]{Plotkin77} and \citet[\S6.1]{Gunter:1992}.

Another is to use \emph{logical relations}, following
\citet{Plotkin:1973}, and also
\citet{Mitchell:1996,Sieber:1992,DBLP:conf/mfps/Stoughton93}.

For this purpose we define a logical relation to be a set of vectors
over @{typ "ValD"} that is closed under continuous functions of type
@{typ "ValD \<rightarrow> ValD"}. This is complicated by the @{term "ValF"} tag
and having strict function abstraction.

*}

definition
  logical_relation :: "('i::type \<Rightarrow> ValD) set \<Rightarrow> bool"
where
  "logical_relation R \<equiv>
     (\<forall>fs \<in> R. \<forall>xs \<in> R. (\<lambda>j. appF\<cdot>(fs j)\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>fs \<in> R. \<forall>xs \<in> R. (\<lambda>j. strictify\<cdot>(appF\<cdot>(fs j))\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>fs. (\<forall>xs \<in> R. (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> R) \<longrightarrow> (\<lambda>j. ValF\<cdot>(fs j)) \<in> R)
   \<and> (\<forall>fs. (\<forall>xs \<in> R. (\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> R) \<longrightarrow> (\<lambda>j. ValF\<cdot>(strictify\<cdot>(fs j))) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. fixD\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>cs \<in> R. \<forall>ts \<in> R. \<forall>es \<in> R. (\<lambda>j. cond\<cdot>(cs j)\<cdot>(ts j)\<cdot>(es j)) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. succ\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. pred\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. isZero\<cdot>(xs j)) \<in> R)"
(*<*)

lemma logical_relationI:
  "\<lbrakk> \<And>fs xs. \<lbrakk> fs \<in> R; xs \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>j. appF\<cdot>(fs j)\<cdot>(xs j)) \<in> R;
     \<And>fs xs. \<lbrakk> fs \<in> R; xs \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>j. strictify\<cdot>(appF\<cdot>(fs j))\<cdot>(xs j)) \<in> R;
     \<And>fs. (\<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> R) \<Longrightarrow> (\<lambda>j. ValF\<cdot>(fs j)) \<in> R;
     \<And>fs. (\<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> R) \<Longrightarrow> (\<lambda>j. ValF\<cdot>(strictify\<cdot>(fs j))) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. fixD\<cdot>(xs j)) \<in> R;
     \<And>cs ts es. \<lbrakk> cs \<in> R; ts \<in> R; es \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>j. cond\<cdot>(cs j)\<cdot>(ts j)\<cdot>(es j)) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. succ\<cdot>(xs j)) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. pred\<cdot>(xs j)) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. isZero\<cdot>(xs j)) \<in> R \<rbrakk> \<Longrightarrow> logical_relation R"
  unfolding logical_relation_def by (simp add: cfcomp1)

lemma lr_l2r:
  "\<lbrakk> fs \<in> R; xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. appF\<cdot>(fs j)\<cdot>(xs j)) \<in> R"
  "\<lbrakk> fs \<in> R; xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. strictify\<cdot>(appF\<cdot>(fs j))\<cdot>(xs j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. fixD\<cdot>(xs j)) \<in> R"
  "\<lbrakk> cs \<in> R; ts \<in> R; es \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. cond\<cdot>(cs j)\<cdot>(ts j)\<cdot>(es j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. succ\<cdot>(xs j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. pred\<cdot>(xs j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. isZero\<cdot>(xs j)) \<in> R"
  unfolding logical_relation_def by blast+

lemma lr_r2l:
  "\<lbrakk> logical_relation R; \<forall>xs \<in> R. (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(fs i)) \<in> R"
  unfolding logical_relation_def by (simp add: cfcomp1)

lemma lr_r2l_strict:
  "\<lbrakk> logical_relation R; \<forall>xs \<in> R. (\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(strictify\<cdot>(fs i))) \<in> R"
  unfolding logical_relation_def by (simp add: cfcomp1)

(*>*)
text{*

In the context of PCF these relations also need to respect the
constants.

*}

definition
  PCF_consts_rel :: "('i::type \<Rightarrow> ValD) set \<Rightarrow> bool"
where
  "PCF_consts_rel R \<equiv>
       \<bottom> \<in> R
     \<and> (\<lambda>i. ValTT) \<in> R
     \<and> (\<lambda>i. ValFF) \<in> R
     \<and> (\<forall>n. (\<lambda>i. ValN\<cdot>n) \<in> R)"
(*<*)

lemma PCF_consts_rel_simps [simp, elim]:
  "PCF_consts_rel R \<Longrightarrow> \<bottom> \<in> R"
  "PCF_consts_rel R \<Longrightarrow> (\<lambda>i. ValTT) \<in> R"
  "PCF_consts_rel R \<Longrightarrow> (\<lambda>i. ValFF) \<in> R"
  "PCF_consts_rel R \<Longrightarrow> (\<lambda>i. ValN\<cdot>n) \<in> R"
unfolding PCF_consts_rel_def by simp_all

lemma PCF_consts_relI:
  "\<lbrakk> \<bottom> \<in> R;
     (\<lambda>i. ValTT) \<in> R;
     (\<lambda>i. ValFF) \<in> R;
     \<And>n. (\<lambda>i. ValN\<cdot>n) \<in> R \<rbrakk> \<Longrightarrow> PCF_consts_rel R"
unfolding PCF_consts_rel_def by blast

(*>*)
text{**}

abbreviation
  "PCF_lr R \<equiv> adm (\<lambda>x. x \<in> R) \<and> logical_relation R \<and> PCF_consts_rel R"

text{*

The fundamental property of logical relations states that all PCF
expressions satisfy all PCF logical relations. This result is
essentially due to \citet{Plotkin:1973}.  The proof is by a
straightforward induction on the expression @{term "M"}.

*}

lemma lr_fundamental:
  assumes lr: "PCF_lr R"
  assumes \<rho>: "\<forall>v. (\<lambda>i. \<rho> i\<cdot>v) \<in> R"
  shows "(\<lambda>i. \<lbrakk>M\<rbrakk>(\<rho> i)) \<in> R"
(*<*)
using \<rho>
proof(induct M arbitrary: \<rho>)
  case (Var v \<rho>) thus ?case by simp
next
  case (App e1 e2 \<rho>)
  with lr lr_l2r(1)[where fs="\<lambda>j. \<lbrakk>e1\<rbrakk>(\<rho> j)" and xs="\<lambda>j. \<lbrakk>e2\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (AbsN v e)
  with lr show ?case
    apply clarsimp
    apply (erule lr_r2l[where fs="\<lambda>i. \<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i))" and R=R, simplified])
    apply clarsimp
    apply (cut_tac \<rho>="\<lambda>j. env_ext\<cdot>v\<cdot>(xs j)\<cdot>(\<rho> j)" in AbsN.hyps)
     apply (simp add: env_ext_def)
     using AbsN(2)
     apply clarsimp
     apply (case_tac "v=va")
      apply (simp add: eta_cfun)
     apply simp
    apply simp
    done
next
  case (AbsV v e)
  with lr show ?case
    apply clarsimp
    apply (rule lr_r2l_strict[where fs="\<lambda>i. \<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i))", simplified])
     apply simp
    apply clarsimp
    apply (cut_tac fs="\<lambda>i. ValF\<cdot>(\<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i)))" and xs=xs and R=R in lr_l2r(2))
     apply simp_all
    apply (erule lr_r2l[where fs="\<lambda>i. \<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i))" and R=R, simplified])
    apply clarsimp
    apply (cut_tac \<rho>="\<lambda>j. env_ext\<cdot>v\<cdot>(xsa j)\<cdot>(\<rho> j)" in AbsV.hyps)
     apply (simp add: env_ext_def)
     using AbsV(2)
     apply clarsimp
     apply (case_tac "v=va")
      apply (simp add: eta_cfun)
     apply simp
    apply simp
    done
next
  case (Fix v e \<rho>) show ?case
    apply simp
    apply (subst fix_argument_promote_fun)
    apply (rule fix_ind[where F="\<Lambda> f. (\<lambda>x. (\<Lambda> xa. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>xa\<cdot>(\<rho> x)))\<cdot>(f x))"])
      apply (simp add: lr)
     apply (simp add: lr inst_fun_pcpo[symmetric])
    apply simp
    apply (cut_tac \<rho>="\<lambda>i. env_ext\<cdot>v\<cdot>(x i)\<cdot>(\<rho> i)" in Fix.hyps)
     unfolding env_ext_def
     using Fix(2)
     apply clarsimp
     apply (case_tac "v=va")
      apply (simp add: eta_cfun)
     apply simp
    apply (simp add: cont_fun)
    done
next
  case (Cond i t e \<rho>)
  with lr lr_l2r(4)[where cs="\<lambda>j. \<lbrakk>i\<rbrakk>(\<rho> j)" and ts="\<lambda>j. \<lbrakk>t\<rbrakk>(\<rho> j)" and es="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (Succ e \<rho>)
  with lr lr_l2r(5)[where xs="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (Pred e \<rho>)
  with lr lr_l2r(6)[where xs="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (IsZero e \<rho>)
  with lr lr_l2r(7)[where xs="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp

(* FIXME weirdness *)
next
  case Diverge with lr show ?case
    apply simp
    apply (simp add: inst_fun_pcpo[symmetric])
    done
qed (insert lr, simp_all)
(*>*)

text{*

We can use this result to show that there is no PCF term that maps the
vector @{term "args \<in> R"} to @{term "result \<notin> R"} for some logical
relation @{term "R"}. If we further show that there is a function
@{term "f"} in @{term "ValD"} such that @{term "f args = result"} then
we can conclude that @{term "f"} is not definable.

*}

abbreviation
  appFLv :: "ValD \<Rightarrow> ('i::type \<Rightarrow> ValD) list \<Rightarrow> ('i \<Rightarrow> ValD)"
where
  "appFLv f args \<equiv> (\<lambda>i. foldl (\<lambda>f x. appF\<cdot>f\<cdot>(x i)) f args)"

lemma lr_appFLv:
  assumes lr: "logical_relation R"
  assumes f: "(\<lambda>i::'i::type. f) \<in> R"
  assumes args: "set args \<subseteq> R"
  shows "appFLv f args \<in> R"
(*<*)
using args
proof(induct args rule: rev_induct)
  case Nil with f show ?case by simp
next
  case (snoc x xs) thus ?case
    apply simp
    using lr_l2r(1)[OF _ _ lr, where fs="\<lambda>i. (foldl (\<lambda>f x. appF\<cdot>f\<cdot>(x i)) f xs)" and xs=x]
    apply simp
    done
qed

(*>*)
text{**}

corollary not_definable:
  fixes R :: "('i::type \<Rightarrow> ValD) set"
  fixes args :: "('i \<Rightarrow> ValD) list"
  fixes result :: "'i \<Rightarrow> ValD"
  assumes lr: "PCF_lr R"
  assumes args: "set args \<subseteq> R"
  assumes result: "result \<notin> R"
  shows "\<not>(\<exists>(f::ValD). definable f \<and> appFLv f args = result)"
(*<*)
proof
  assume "\<exists>f. definable f \<and> appFLv f args = result"
  then obtain f
    where df: "definable f"
      and f: "appFLv f args = result" by blast
  from df obtain M
    where Mf: "\<lbrakk>M\<rbrakk>env_empty = f"
    unfolding definable_def by blast
  with lr lr_fundamental[OF lr, where M=M and \<rho>="\<lambda>i. env_empty"]
       f args lr_appFLv[where f=f and R=R and args=args]
  have "result \<in> R" unfolding env_empty_def by (simp add: inst_fun_pcpo[symmetric])
  with result show False ..
qed
(*>*)

subsection{* Parallel OR is not definable *}

text {*

\label{sec:por}

We show that parallel-or is not @{text "\<lambda>"}-definable following
\citet{Sieber:1992} and \citet{DBLP:conf/mfps/Stoughton93}.

Parallel-or is similar to lazy-or except that if the first argument is
@{term "\<bottom>"} and the second one is @{term "ValTT"}, we get @{term
"ValTT"} (and not @{term "\<bottom>"}). It is continuous and hence included in
the @{typ "ValD"} domain.

*}

definition por :: "ValD \<Rightarrow> ValD \<Rightarrow> ValD" ("_ por _" [31,30] 30) where
  "x por y \<equiv>
     if x = ValTT then ValTT
       else if y = ValTT then ValTT
              else if (x = ValFF \<and> y = ValFF) then ValFF else \<bottom>"

text{* The defining properties of parallel-or. *}

lemma POR_simps [simp]:
  "(ValTT por y) = ValTT"
  "(x por ValTT) = ValTT"
  "(ValFF por ValFF) = ValFF"
  "(ValFF por \<bottom>) = \<bottom>"
  "(ValFF por ValN\<cdot>n) = \<bottom>"
  "(ValFF por ValF\<cdot>f) = \<bottom>"
  "(\<bottom> por ValFF) = \<bottom>"
  "(ValN\<cdot>n por ValFF) = \<bottom>"
  "(ValF\<cdot>f por ValFF) = \<bottom>"
  "(\<bottom> por \<bottom>) = \<bottom>"
  "(\<bottom> por ValN\<cdot>n) = \<bottom>"
  "(\<bottom> por ValF\<cdot>f) = \<bottom>"
  "(ValN\<cdot>n por \<bottom>) = \<bottom>"
  "(ValF\<cdot>f por \<bottom>) = \<bottom>"
  "(ValN\<cdot>m por ValN\<cdot>n) = \<bottom>"
  "(ValN\<cdot>n por ValF\<cdot>f) = \<bottom>"
  "(ValF\<cdot>f por ValN\<cdot>n) = \<bottom>"
  "(ValF\<cdot>f por ValF\<cdot>g) = \<bottom>"
  unfolding por_def by simp_all
(*<*)

text{*

We show that parallel-or is a continuous function.

*}

lemma POR_sym: "(x por y) = (y por x)"
  unfolding por_def by simp

lemma ValTT_below_iff [simp]: "ValTT \<sqsubseteq> x \<longleftrightarrow> x = ValTT"
  by (cases x) simp_all

lemma ValFF_below_iff [simp]: "ValFF \<sqsubseteq> x \<longleftrightarrow> x = ValFF"
  by (cases x) simp_all

lemma monofun_por: "monofun (\<lambda>x. x por y)"
  unfolding por_def
  by (rule monofunI) auto

lemma mic2mic: "max_in_chain i Y \<Longrightarrow> max_in_chain i (\<lambda>i. f (Y i))"
  unfolding max_in_chain_def by simp

lemma cont_por1: "cont (\<lambda>x. x por y)"
  apply (rule contI2[OF monofun_por])
  apply (case_tac "Lub Y")
   apply simp_all
   apply (cases y)
   apply simp_all
   apply (cases y)
   apply simp_all

   apply (frule compact_imp_max_in_chain)
    apply simp
   apply clarsimp
   apply (frule mic2mic[where f="\<lambda>x. x por y"])
   apply (subst iffD1[OF maxinch_is_thelub])
   apply simp_all
   apply (simp_all add: maxinch_is_thelub)

   apply (frule compact_imp_max_in_chain)
    apply simp
   apply clarsimp
   apply (frule mic2mic[where f="\<lambda>x. x por y"])
   apply (subst iffD1[OF maxinch_is_thelub])
   apply simp_all
   apply (simp_all add: maxinch_is_thelub)

   apply (cases y)
   apply simp_all
   done

lemma cont_por[cont2cont, simp]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x por g x)"
proof -
  have A: "\<And>f y. cont f \<Longrightarrow> cont (\<lambda>x. f x por y)"
    by (rule cont_apply) (simp_all add: cont_por1)
  from A[OF f] A[OF g] show ?thesis
    apply -
    apply (subst (asm) POR_sym) back
    apply (rule cont_apply[OF f])
    apply (simp_all add: cont_por1)
    done
qed

(*>*)
text{*

We need three-element vectors.

*}

datatype Three = One | Two | Three

text{*

The standard logical relation @{term "R"} that demonstrates POR is not
definable is:
\[
  (x, y, z) \in R\ \mbox{iff}\ x = y = z \lor (x = \bot \lor y = \bot)
\]
That POR satisfies this relation can be seen from its truth table (see
below).

Note we restrict the @{text "x = y = z"} clause to non-function
values. Adding functions breaks the ``logical relations'' property.

*}

definition
  POR_base_lf_rep :: "(Three \<Rightarrow> ValD) lf_rep"
where
  "POR_base_lf_rep \<equiv> \<lambda>(mR, pR).
     { (\<lambda>i. ValTT) } \<union> { (\<lambda>i. ValFF) } (* x = y = z for bools *)
   \<union> (\<Union>n. { (\<lambda>i. ValN\<cdot>n) }) (* x = y = z for numerals *)
   \<union> { f . f One = \<bottom> } (* x = \<bottom> *)
   \<union> { f . f Two = \<bottom> } (* y = \<bottom> *)"

text{*

We close this relation with respect to continuous functions. This
functor yields an admissible relation for all @{term "r"} and is
monotonic.

*}

definition
  fn_lf_rep :: "('i::type \<Rightarrow> ValD) lf_rep"
where
  "fn_lf_rep \<equiv> \<lambda>(mR, pR). { \<lambda>i. ValF\<cdot>(fs i) |fs. \<forall>xs \<in> unlr (undual mR). (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr pR }"
(*<*)

lemma adm_POR_base_lf_rep:
  "adm (\<lambda>x. x \<in> POR_base_lf_rep r)"
unfolding POR_base_lf_rep_def
using adm_below_monic_exists[OF _ below_monic_fun_K[where f="ValN"], where P="\<lambda>_. True", simplified]
by (auto intro!: adm_disj simp: cont_fun)

lemma mono_POR_base_lf_rep:
  "mono POR_base_lf_rep"
unfolding POR_base_lf_rep_def by (blast intro!: monoI)

lemma adm_fn:
  "adm (\<lambda>x. x \<in> fn_lf_rep r)"
unfolding fn_lf_rep_def
using adm_below_monic_exists[OF _ below_monic_fun_K[where f="ValF"], where P="\<lambda>_. True", simplified]
apply (clarsimp simp: split_def)
apply (rule adm_below_monic_exists)
apply (auto simp: cont_fun)

(* FIXME lemma *)
apply (rule below_monicI)
apply (rule fun_belowI)
apply (subst (asm) fun_below_iff)
apply auto
done

(*
  by (fastforce simp: split_def intro: adm_below_monic_exists)
*)

lemma mono_fn_lf_rep:
  "mono fn_lf_rep"
  by (rule monoI) (fastforce simp: fn_lf_rep_def unlr_leq[symmetric] undual_leq[symmetric])

(*>*)
text{**}

definition POR_lf_rep :: "(Three \<Rightarrow> ValD) lf_rep" where
  "POR_lf_rep R \<equiv> POR_base_lf_rep R \<union> fn_lf_rep R"

abbreviation "POR_lf \<equiv> \<lambda>r. mklr (POR_lf_rep r)"
(*<*)

lemma admS_POR_lf [intro, simp]:
  "POR_lf_rep r \<in> admS"
proof
  show "\<bottom> \<in> POR_lf_rep r"
    unfolding POR_lf_rep_def POR_base_lf_rep_def
    by simp
next
  show "adm (\<lambda>x. x \<in> POR_lf_rep r)"
    unfolding POR_lf_rep_def
    using adm_POR_base_lf_rep[of r] adm_fn[of r] by simp
qed

lemma mono_POR_lf:
  "mono POR_lf"
  apply (rule monoI)
  apply simp
  unfolding POR_lf_rep_def
  using mono_fn_lf_rep mono_POR_base_lf_rep
  apply (blast dest: monoD)
  done

(*>*)
text{*

Again it yields an admissible relation and is monotonic.

We need to show the functor respects the minimal invariant.

*}

lemma min_inv_POR_lf:
  assumes "eRSV e R' S'"
  shows "eRSV (ValD_copy_rec\<cdot>e) (dual (POR_lf (dual S', undual R'))) (POR_lf (R', S'))"
(*<*)
  apply clarsimp
  apply (simp add: POR_lf_rep_def)
  apply (elim disjE)
   apply (rule disjI1)
   apply (auto simp: POR_base_lf_rep_def eta_cfun cfcomp1 cfun_eq_iff)[1]
  apply (rule disjI2)
  using assms
  apply (clarsimp simp: fn_lf_rep_def eta_cfun)
  apply (simp add: cfcomp1 cfun_map_def)
  apply (rule_tac x="\<lambda>i. \<Lambda> xa. e\<cdot>(fs i\<cdot>(e\<cdot>xa))" in exI)
  apply force
  done

interpretation POR!: DomSolV ValD_copy_rec POR_lf
  apply default
    apply (rule ValD_copy_ID)
   apply (rule mono_POR_lf)
  apply (erule min_inv_POR_lf)
  done

lemma PORI [intro, simp]:
  "(\<lambda>i. ValTT) \<in> unlr POR.delta"
  "(\<lambda>i. ValFF) \<in> unlr POR.delta"
  "(\<lambda>i. ValN\<cdot>n) \<in> unlr POR.delta"
  "f One = \<bottom> \<Longrightarrow> f \<in> unlr POR.delta"
  "f Two = \<bottom> \<Longrightarrow> f \<in> unlr POR.delta"
  "\<lbrakk> \<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr POR.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(fs i)) \<in> unlr POR.delta"
  by (subst POR.delta_sol, simp, subst POR_lf_rep_def,
      fastforce simp: POR_base_lf_rep_def fn_lf_rep_def eta_cfun cfcomp1)+

lemma POR_fun_constI:
  "\<lbrakk> \<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. f\<cdot>(xs j)) \<in> unlr POR.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>f) \<in> unlr POR.delta"
  using PORI(6)[where fs="\<lambda>_. f"] by simp

lemma PORE:
  "\<lbrakk> a \<in> unlr POR.delta;
     (a = (\<lambda>i. ValTT) \<Longrightarrow> P);
     (a = (\<lambda>i. ValFF) \<Longrightarrow> P);
     (\<And>n. a = (\<lambda>i. ValN\<cdot>n) \<Longrightarrow> P);
     (a One = \<bottom> \<Longrightarrow> P);
     (a Two = \<bottom> \<Longrightarrow> P);
     (\<And>fs. \<lbrakk> a = (\<lambda>i. ValF\<cdot>(fs i)); \<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr POR.delta \<rbrakk> \<Longrightarrow> P)
   \<rbrakk> \<Longrightarrow> P"
  apply (subst (asm) POR.delta_sol)
  apply simp
  apply (subst (asm) POR_lf_rep_def)
  apply (fastforce simp: POR_base_lf_rep_def fn_lf_rep_def eta_cfun)
  done

lemma POR_strict_appI:
  assumes "xs \<in> unlr POR.delta"
  assumes "\<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. fs j\<cdot>(xs j)) \<in> unlr POR.delta"
  shows "(\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> unlr POR.delta"
using assms
apply -
apply (erule PORE)
apply simp_all
done

lemma logical_relation_POR:
  "logical_relation (unlr POR.delta)"
  apply (rule logical_relationI)

  (* Strict application *)
  prefer 2
  apply (cut_tac fs="\<lambda>i. appF\<cdot>(fs i)" and xs=xs in POR_strict_appI)
   apply simp_all
  apply (auto elim: PORE)[1]

  (* FIXME fixD *)
  prefer 2
  apply (erule PORE)
  apply (simp_all add: fixD_def)
  apply (subst fix_argument_promote_fun)
  apply (rule_tac F="\<Lambda> f. (\<lambda>x. fs x\<cdot>(f x))" in fix_ind)
  apply (simp_all split: nat.split add: cont_fun)

  apply (auto elim: PORE simp: cond_def isZero_def pred_def succ_def eta_cfun split: nat.split)
  done

lemma PCF_consts_rel_POR:
  "PCF_consts_rel (unlr POR.delta)"
  by (rule PCF_consts_relI) simp_all

(*>*)
text{*

We can show that the solution satisfies the expectations of the
fundamental theorem @{thm [source] "lr_fundamental"}.

*}

lemma PCF_lr_POR_delta: "PCF_lr (unlr POR.delta)"
(*<*)
  using logical_relation_POR PCF_consts_rel_POR by fastforce
(*>*)
text{*

This is the truth-table for POR rendered as a vector: we seek a
function that simultaneously maps the two argument vectors to the
result.

*}

definition POR_arg1_rel where
  "POR_arg1_rel \<equiv> \<lambda>i. case i of One \<Rightarrow> ValTT | Two \<Rightarrow> \<bottom> | Three \<Rightarrow> ValFF"

definition POR_arg2_rel where
  "POR_arg2_rel \<equiv> \<lambda>i. case i of One \<Rightarrow> \<bottom> | Two \<Rightarrow> ValTT | Three \<Rightarrow> ValFF"

definition POR_result_rel where
  "POR_result_rel \<equiv> \<lambda>i. case i of One \<Rightarrow> ValTT | Two \<Rightarrow> ValTT | Three \<Rightarrow> ValFF"

lemma lr_POR_arg1_rel: "POR_arg1_rel \<in> unlr POR.delta"
  unfolding POR_arg1_rel_def by auto

lemma lr_POR_arg2_rel: "POR_arg2_rel \<in> unlr POR.delta"
  unfolding POR_arg2_rel_def by auto

lemma lr_POR_result_rel: "POR_result_rel \<notin> unlr POR.delta"
(*<*)
  unfolding POR_result_rel_def
  apply clarify
  apply (erule PORE)
  apply (auto iff: fun_eq_iff split: Three.splits)
  done

(*>*)
text{*

Parallel-or satisfies these tests:

*}

theorem POR_sat:
  "appFLv (ValF\<cdot>(\<Lambda> x. ValF\<cdot>(\<Lambda> y. x por y))) [POR_arg1_rel, POR_arg2_rel] = POR_result_rel"
  unfolding POR_arg1_rel_def POR_arg2_rel_def POR_result_rel_def
  by (simp add: fun_eq_iff split: Three.splits)

text{*

... but is not PCF-definable:

*}

theorem POR_is_not_definable:
  shows "\<not>(\<exists>f. definable f \<and> appFLv f [POR_arg1_rel, POR_arg2_rel] = POR_result_rel)"
  apply (rule not_definable[where R="unlr POR.delta"])
    using lr_POR_arg1_rel lr_POR_arg2_rel lr_POR_result_rel PCF_lr_POR_delta
    apply simp_all
  done

subsection{* Plotkin's existential quantifier *}

text{*

We can also show that the existential quantifier of
\citet[\S5]{Plotkin77} is not PCF-definable using logical relations.

Our definition is quite loose; if the argument function @{term "f"}
maps any value to @{term "ValTT"} then @{term "plotkin_exists"} yields
@{term "ValTT"}. It may be more plausible to test @{term "f"} on
numerals only.

*}

definition plotkin_exists :: "ValD \<Rightarrow> ValD" where
  "plotkin_exists f \<equiv>
     if (appF\<cdot>f\<cdot>\<bottom> = ValFF)
       then ValFF
       else if (\<exists>n. appF\<cdot>f\<cdot>n = ValTT) then ValTT else \<bottom>"
(*<*)

lemma plotkin_exists_simps [simp]:
  "plotkin_exists \<bottom> = \<bottom>"
  "plotkin_exists (ValF\<cdot>\<bottom>) = \<bottom>"
  "plotkin_exists (ValF\<cdot>(\<Lambda> _. ValFF)) = ValFF"
  unfolding plotkin_exists_def by simp_all

lemma monofun_pe:
  "monofun plotkin_exists"
proof(rule monofunI)
  fix f g assume fg: "(f::ValD) \<sqsubseteq> g"
  let ?goal = "plotkin_exists f \<sqsubseteq> plotkin_exists g"
  {
    assume fbot: "appF\<cdot>f\<cdot>\<bottom> = ValFF"
    with fg have "appF\<cdot>g\<cdot>\<bottom> = ValFF"
      using monofun_cfun[where f="appF\<cdot>f" and g="appF\<cdot>g" and x="\<bottom>"]
      by (simp add: monofun_cfun_arg)
    with fbot have ?goal by (simp add: plotkin_exists_def)
  }
  moreover
  {
    assume efn: "\<exists>n. appF\<cdot>f\<cdot>n = ValTT"
    then obtain n where fn: "appF\<cdot>f\<cdot>n = ValTT" by blast
    hence fbot: "appF\<cdot>f\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>f" and x="\<bottom>" and y="n"] by fastforce
    from fg have "appF\<cdot>f\<cdot>n \<sqsubseteq> appF\<cdot>g\<cdot>n"
      using monofun_cfun_arg[OF fg, where f=appF]
      by (simp only: cfun_below_iff)
    with fn have gn: "appF\<cdot>g\<cdot>n = ValTT"
      using ValD.nchotomy[where y="appF\<cdot>g\<cdot>\<bottom>"] by simp
    hence gbot: "appF\<cdot>g\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>g" and x="\<bottom>" and y="n"] by fastforce
    from fn gn fbot gbot have ?goal apply (unfold plotkin_exists_def) by fastforce
  }
  moreover
  {
    assume fbot: "appF\<cdot>f\<cdot>\<bottom> \<noteq> ValFF" and efn: "\<not>(\<exists>n. appF\<cdot>f\<cdot>n = ValTT)"
    hence ?goal by (simp add: plotkin_exists_def)
  }
  ultimately show ?goal unfolding plotkin_exists_def by blast
qed

(*>*)
text{*

We can show this function is continuous.

*}

lemma cont_pe [cont2cont, simp]: "cont plotkin_exists"
(*<*)
proof (rule contI2[OF monofun_pe])
  fix Y assume Y: "chain (Y :: nat \<Rightarrow> ValD)"
  let ?goal = "plotkin_exists (\<Squnion> i. Y i) \<sqsubseteq> (\<Squnion> i. plotkin_exists (Y i))"
  have peY: "chain (\<lambda>i. plotkin_exists (Y i))"
    by (rule chainI, simp add: monofunE[OF monofun_pe] chainE[OF Y])
  {
    assume "\<exists>i. appF\<cdot>(Y i)\<cdot>\<bottom> = ValFF"
    then obtain i where Yi: "appF\<cdot>(Y i)\<cdot>\<bottom> = ValFF" by blast
    have "Y i \<sqsubseteq> (\<Squnion> i. Y i)"
      using is_ub_thelub[OF Y, where x=i] by simp
    hence "appF\<cdot>(Y i)\<cdot>\<bottom> \<sqsubseteq> appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom>" by (fastforce intro: monofun_cfun)
    with Yi have "ValFF \<sqsubseteq> appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom>" by simp
    hence "appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom> = ValFF" using ValD.nchotomy[where y="appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom>"] by simp
    moreover
    from Yi have "plotkin_exists (Y i) = ValFF" by (simp add: plotkin_exists_def)
    hence "ValFF \<sqsubseteq> (\<Squnion> i. plotkin_exists (Y i))" using is_ub_thelub[OF peY, where x=i] by simp
    hence "ValFF = (\<Squnion> i. plotkin_exists (Y i))" using ValD.nchotomy[where y="\<Squnion> i. plotkin_exists (Y i)"] by simp
    ultimately have ?goal by (simp add: plotkin_exists_def)
  }
  moreover
  {
    assume "\<exists>i j. appF\<cdot>(Y i)\<cdot>j = ValTT"
    then obtain i j where Yij: "appF\<cdot>(Y i)\<cdot>j = ValTT" by blast
    from Yij have Yib: "appF\<cdot>(Y i)\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>(Y i)" and x="\<bottom>" and y=j] by clarsimp
    moreover
    from Yij have "appF\<cdot>(Y i)\<cdot>j \<sqsubseteq> appF\<cdot>(\<Squnion> i. Y i)\<cdot>j"
      using is_ub_thelub[OF Y, where x=i] by (fastforce intro: monofun_cfun)
    with Yij have Yjlub: "appF\<cdot>(\<Squnion> i. Y i)\<cdot>j = ValTT"
      using ValD.nchotomy[where y="appF\<cdot>(\<Squnion> i. Y i)\<cdot>j"] by simp
    moreover
    from Yjlub have "appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>(\<Squnion> i. Y i)" and x="\<bottom>" and y=j] by auto
    moreover
    from Yib Yij have "plotkin_exists (Y i) = ValTT" by (auto simp add: plotkin_exists_def)
    hence "ValTT \<sqsubseteq> (\<Squnion> i. plotkin_exists (Y i))" using is_ub_thelub[OF peY, where x=i] by simp
    hence "ValTT = (\<Squnion> i. plotkin_exists (Y i))" using ValD.nchotomy[where y="\<Squnion> i. plotkin_exists (Y i)"] by simp
    ultimately have ?goal by (simp add: plotkin_exists_def)
  }
  moreover
  {
    assume nFF: "\<not>(\<exists>i. appF\<cdot>(Y i)\<cdot>\<bottom> = ValFF)" and nTT: "\<not>(\<exists>i j. appF\<cdot>(Y i)\<cdot>j = ValTT)"
    with Y have ?goal
      unfolding plotkin_exists_def
      apply (simp add: contlub_cfun_arg contlub_cfun_fun)
      using compact_below_lub_iff[OF ValD.compacts(2)]
            compact_below_lub_iff[OF ValD.compacts(3)]
      apply auto
      done
  }
  ultimately show ?goal by blast
qed

lemma cont_pe2[cont2cont, simp]: "cont f \<Longrightarrow> cont (\<lambda>x. plotkin_exists (f x))"
  by (rule cont_apply) simp_all

(*>*)
text{*

Again we construct argument and result test vectors such that @{term
"plotkin_exists"} satisfies these tests but no PCF-definable term
does.

*}

definition PE_arg_rel where
  "PE_arg_rel \<equiv> \<lambda>i. ValF\<cdot>(case i of
        0 \<Rightarrow> (\<Lambda> _. ValFF)
      | Suc n \<Rightarrow> (\<Lambda> (ValN\<cdot>x). if x = Suc n then ValTT else \<bottom>))"

definition PE_result_rel where
  "PE_result_rel \<equiv> \<lambda>i. case i of 0 \<Rightarrow> ValFF | Suc n \<Rightarrow> ValTT"

text{*

Note that unlike the POR case the argument relation does not
characterise PE: we don't treat functions that return @{term "ValTT"}s
and @{term "ValFF"}s.

The Plotkin existential satisfies these tests:

*}

theorem pe_sat:
  "appFLv (ValF\<cdot>(\<Lambda> x. plotkin_exists x)) [PE_arg_rel] = PE_result_rel"
  unfolding PE_arg_rel_def PE_result_rel_def
  by (clarsimp simp: fun_eq_iff split: nat.splits)

text{*

As for POR, the difference between the two vectors is that the
argument can diverge but not the result.

*}

definition PE_base_lf_rep :: "(nat \<Rightarrow> ValD) lf_rep" where
  "PE_base_lf_rep \<equiv> \<lambda>(mR, pR).
     { \<bottom> }
   \<union> { (\<lambda>i. ValTT) } \<union> { (\<lambda>i. ValFF) } (* x = y = z for bools *)
   \<union> (\<Union>n. { (\<lambda>i. ValN\<cdot>n) }) (* x = y = z for numerals *)
   \<union> { f . f 1 = \<bottom> \<or> f 2 = \<bottom> } (* Vectors that diverge on one or two. *)"
(*<*)

lemma adm_PE_base_lf_rep:
  "adm (\<lambda>x. x \<in> PE_base_lf_rep r)"
unfolding PE_base_lf_rep_def
using adm_below_monic_exists[OF _ below_monic_fun_K[where f=ValN], where P="\<lambda>_. True"]
by (auto intro!: adm_disj simp: cont_fun)

lemma mono_PE_base_lf_rep:
  "mono PE_base_lf_rep"
unfolding PE_base_lf_rep_def
by (blast intro!: monoI)

(*>*)
text{*

Again we close this under the function space, and show that it is
admissible, monotonic and respects the minimal invariant.

*}

definition PE_lf_rep :: "(nat \<Rightarrow> ValD) lf_rep" where
  "PE_lf_rep R \<equiv> PE_base_lf_rep R \<union> fn_lf_rep R"

abbreviation "PE_lf \<equiv> \<lambda>r. mklr (PE_lf_rep r)"
(*<*)

lemma admS_PE_lf [intro, simp]:
  "PE_lf_rep r \<in> admS"
proof
  show "\<bottom> \<in> PE_lf_rep r"
    unfolding PE_lf_rep_def PE_base_lf_rep_def
    by simp
next
  show "adm (\<lambda>x. x \<in> PE_lf_rep r)"
    unfolding PE_lf_rep_def
    using adm_PE_base_lf_rep[of r] adm_fn[of r] by simp
qed

lemma mono_PE_lf:
  "mono PE_lf"
  apply (rule monoI)
  apply simp
  unfolding PE_lf_rep_def
  using mono_fn_lf_rep mono_PE_base_lf_rep
  apply (blast dest: monoD)
  done

lemma min_inv_PE_lf:
  assumes "eRSV e R' S'"
  shows "eRSV (ValD_copy_rec\<cdot>e) (dual (PE_lf (dual S', undual R'))) (PE_lf (R', S'))"
  apply clarsimp
  apply (simp add: PE_lf_rep_def)
  apply (elim disjE)
   apply (rule disjI1)
   apply (auto simp: PE_base_lf_rep_def eta_cfun cfcomp1 cfun_eq_iff)[1]
  apply (rule disjI2)
  using assms
  apply (clarsimp simp: fn_lf_rep_def eta_cfun)
  apply (simp add: cfcomp1 cfun_map_def)
  apply (rule_tac x="\<lambda>x. \<Lambda> xa. e\<cdot>(fs x\<cdot>(e\<cdot>xa))" in exI)
  apply force
  done

interpretation PE!: DomSolV ValD_copy_rec PE_lf
  apply default
    apply (rule ValD_copy_ID)
   apply (rule mono_PE_lf)
  apply (erule min_inv_PE_lf)
  done

lemma PEI [intro, simp]:
  "\<bottom> \<in> unlr PE.delta"
  "(\<lambda>i. ValTT) \<in> unlr PE.delta"
  "(\<lambda>i. ValFF) \<in> unlr PE.delta"
  "(\<lambda>i. ValN\<cdot>n) \<in> unlr PE.delta"
  "f 1 = \<bottom> \<Longrightarrow> f \<in> unlr PE.delta"
  "f 2 = \<bottom> \<Longrightarrow> f \<in> unlr PE.delta"
  "\<lbrakk> \<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr PE.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(fs i)) \<in> unlr PE.delta"
  by (subst PE.delta_sol, simp, subst PE_lf_rep_def,
      fastforce simp: PE_base_lf_rep_def fn_lf_rep_def eta_cfun cfcomp1)+

lemma PE_fun_constI:
  "\<lbrakk> \<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. f\<cdot>(xs j)) \<in> unlr PE.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>f) \<in> unlr PE.delta"
  using PEI(7)[where fs="\<lambda>_. f"] by simp

lemma PEE:
  "\<lbrakk> a \<in> unlr PE.delta;
     (a = \<bottom> \<Longrightarrow> P);
     (a = (\<lambda>i. ValTT) \<Longrightarrow> P);
     (a = (\<lambda>i. ValFF) \<Longrightarrow> P);
     (\<And>n. a = (\<lambda>i. ValN\<cdot>n) \<Longrightarrow> P);
     (a 1 = \<bottom> \<Longrightarrow> P);
     (a 2 = \<bottom> \<Longrightarrow> P);
     (\<And>fs. \<lbrakk> a = (\<lambda>j. ValF\<cdot>(fs j)); \<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr PE.delta \<rbrakk> \<Longrightarrow> P)
   \<rbrakk> \<Longrightarrow> P"
  apply (subst (asm) PE.delta_sol)
  apply simp
  apply (subst (asm) PE_lf_rep_def)
  apply (fastforce simp: PE_base_lf_rep_def fn_lf_rep_def eta_cfun)
  done

lemma PEE_strict_appI:
  assumes "xs \<in> unlr PE.delta"
  assumes "\<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. fs j\<cdot>(xs j)) \<in> unlr PE.delta"
  shows "(\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> unlr PE.delta"
  using assms
  apply -
  apply (erule PEE)
  apply simp_all
  done

lemma logical_relation_PE:
  "logical_relation (unlr PE.delta)"
apply (rule logical_relationI)

  (* Strict application *)
  prefer 2
  apply (cut_tac fs="\<lambda>i. appF\<cdot>(fs i)" and xs=xs in PEE_strict_appI)
   apply simp_all
  apply (auto elim: PEE)[1]

  (* FIXME fixD *)
  prefer 2
  apply (erule PEE)
  apply (simp_all add: fixD_def)
  apply (subst fix_argument_promote_fun)
  apply (rule_tac F="\<Lambda> f. (\<lambda>x. fs x\<cdot>(f x))" in fix_ind)
  apply (simp_all split: nat.split add: cont_fun)

  apply (auto elim: PEE simp: cond_def isZero_def pred_def succ_def eta_cfun split: nat.split)
  done

lemma PCF_consts_rel_PE:
  "PCF_consts_rel (unlr PE.delta)"
  by (rule PCF_consts_relI) simp_all
(*>*)
text{*

The solution satisfies the expectations of the fundamental theorem:

*}

lemma PCF_lr_PE_delta: "PCF_lr (unlr PE.delta)"
(*<*)
  using logical_relation_PE PCF_consts_rel_PE by fastforce
(*>*)

lemma lr_PE_arg_rel: "PE_arg_rel \<in> unlr PE.delta"
(*<*)
  unfolding PE_arg_rel_def
  apply (rule PEI(7))
  apply (erule PEE)
   apply simp_all
  apply (case_tac n)
   apply simp
  apply (case_tac nat)
   apply simp_all
  done
(*>*)

lemma lr_PE_result_rel: "PE_result_rel \<notin> unlr PE.delta"
(*<*)
unfolding PE_result_rel_def
apply clarify
apply (erule PEE)
apply (auto iff: fun_eq_iff split: nat.splits)
done
(*>*)

theorem PE_is_not_definable: "\<not>(\<exists>f. definable f \<and> appFLv f [PE_arg_rel] = PE_result_rel)"
(*<*)
apply (rule not_definable[where R="unlr PE.delta"])
  using lr_PE_arg_rel lr_PE_result_rel PCF_lr_PE_delta
  apply simp_all
done
(*>*)

subsection{* Concluding remarks *}

text{*

These techniques could be used to show that Haskell's @{text "seq"}
operation is not PCF-definable. (It is definable for each base
``type'' separately, and requires some care on function values.) If we
added an (unlifted) product type then it should be provable that
parallel evaluation is required to support @{text "seq"} on these
objects (given @{text "seq"} on all other objects). (See
\citet[\S5.4]{DBLP:conf/hopl/HudakHJW07} and sundry posts to the
internet by Lennart Augustsson.) This may be difficult to do plausibly
without adding a type system.

*}

(*<*)

end
(*>*)