section \<open> Normal Reactive Designs \<close>

theory utp_rdes_normal
  imports
    utp_rdes_triples
    "UTP1-KAT.utp_kleene"
begin

text \<open> These additional healthiness conditions are analogous to H3 \<close>

definition RD3 where
[upred_defs]: "RD3(P) = P ;; II\<^sub>R"

definition RD3c where
[upred_defs]: "RD3c(P) = P ;; II\<^sub>C"

lemma RD3_idem: "RD3(RD3(P)) = RD3(P)"
proof -
  have a: "II\<^sub>R ;; II\<^sub>R = II\<^sub>R"
    by (simp add: SRD_left_unit SRD_srdes_skip)
  show ?thesis
    by (simp add: RD3_def seqr_assoc a)
qed

lemma RD3_Idempotent [closure]: "Idempotent RD3"
  by (simp add: Idempotent_def RD3_idem)

lemma RD3_continuous: "RD3(\<Sqinter>A) = (\<Sqinter>P\<in>A. RD3(P))"
  by (simp add: RD3_def seq_Sup_distr)

lemma RD3_Continuous [closure]: "Continuous RD3"
  by (simp add: Continuous_def RD3_continuous)

lemma RD3_right_subsumes_RD2: "RD2(RD3(P)) = RD3(P)"
proof -
  have a:"II\<^sub>R ;; J = II\<^sub>R"
    by (rel_auto)
  show ?thesis
    by (metis (no_types, opaque_lifting) H2_def RD2_def RD3_def a seqr_assoc)
qed

lemma RD3c_idem: "RD3c(RD3c(P)) = RD3c(P)"
proof -
  have a: "II\<^sub>C ;; II\<^sub>C = II\<^sub>C"
    by simp
  show ?thesis
    by (simp add: RD3c_def seqr_assoc a)
qed

lemma RD3c_Idempotent [closure]: "Idempotent RD3c"
  by (simp add: Idempotent_def RD3c_idem)

lemma RD3c_continuous: "RD3c(\<Sqinter>A) = (\<Sqinter>P\<in>A. RD3c(P))"
  by (simp add: RD3c_def seq_Sup_distr)

lemma RD3c_Continuous [closure]: "Continuous RD3c"
  by (simp add: Continuous_def RD3c_continuous)

lemma RD3c_right_subsumes_RD2: "RD2 (RD3c P) = RD3c P"
proof -
  have a:"II\<^sub>C ;; J = II\<^sub>C"
    by (rel_auto)
  thus ?thesis
    by (simp add: a H2_def RD2_def RD3c_def seqr_assoc)
qed

lemma RD3_left_subsumes_RD2: "RD3(RD2(P)) = RD3(P)"
proof -
  have a:"J ;; II\<^sub>R = II\<^sub>R"
    by (rel_simp, safe, blast+)
  show ?thesis
    by (metis (no_types, opaque_lifting) H2_def RD2_def RD3_def a seqr_assoc)
qed

lemma RD3c_left_subsumes_RD2: "RD3c(RD2(P)) = RD3c(P)"
proof -
  have a:"J ;; II\<^sub>C = II\<^sub>C"
    by (rel_auto)
  show ?thesis
    by (simp add: H2_def RD2_def RD3c_def a seqr_assoc)
qed

lemma RD3_implies_RD2: "P is RD3 \<Longrightarrow> P is RD2"
  by (metis Healthy_def RD3_right_subsumes_RD2)

lemma RD3_intro_pre:
  assumes "P is SRD" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))" "$st\<acute> \<sharp> peri\<^sub>R(P)"
  shows "P is RD3"
proof -
  have "RD3(P) = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> (\<exists> $st\<acute> \<bullet> peri\<^sub>R P) \<diamondop> post\<^sub>R P)"
    by (simp add: RD3_def SRD_right_unit_tri_lemma assms)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P)"
    by (simp add: assms(3) ex_unrest)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> cmt\<^sub>R P)"
    by (simp add: wait'_cond_peri_post_cmt)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> cmt\<^sub>R P)"
    by (simp add: assms(2) rpred wp_rea_def R1_preR)
  finally show ?thesis
    by (metis Healthy_def SRD_as_reactive_design assms(1))
qed

lemma RHS_tri_design_RD3_intro:
  assumes
    "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q" "$ok\<acute> \<sharp> R" "$st\<acute> \<sharp> Q"  "$wait\<acute> \<sharp> R"
    "P is R1" "(\<not>\<^sub>r P) ;; true\<^sub>r = (\<not>\<^sub>r P)"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) is RD3"
  apply (simp add: Healthy_def RD3_def)
  apply (subst RHS_tri_design_right_unit_lemma)
  apply (simp_all add:assms ex_unrest rpred)
done

text \<open> RD3 reactive designs are those whose assumption can be written as a conjunction of a
  precondition on (undashed) program variables, and a negated statement about the trace. The latter
  allows us to state that certain events must not occur in the trace -- which are effectively safety
  properties. \<close>

lemma R1_right_unit_lemma:
  "\<lbrakk> out\<alpha> \<sharp> b; out\<alpha> \<sharp> e \<rbrakk> \<Longrightarrow> (\<not>\<^sub>r b \<or> $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>) ;; R1(true) = (\<not>\<^sub>r b\<or> $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>)"
  by (rel_auto, blast, metis (no_types, lifting) dual_order.trans)

lemma RHS_tri_design_RD3_intro_form:
  assumes
    "out\<alpha> \<sharp> b" "out\<alpha> \<sharp> e" "$ok\<acute> \<sharp> Q" "$st\<acute> \<sharp> Q" "$ok\<acute> \<sharp> R" "$wait\<acute> \<sharp> R"
  shows "\<^bold>R\<^sub>s((b \<and> \<not>\<^sub>r $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>) \<turnstile> Q \<diamondop> R) is RD3"
  apply (rule RHS_tri_design_RD3_intro)
        apply (simp_all add: assms unrest closure rpred)
  apply (subst R1_right_unit_lemma)
    apply (simp_all add: assms unrest)
  done

lemma RD1_RD3_commute: "RD1(RD3(P)) = RD3(RD1(P))"
  by (rel_auto, blast+)

lemma RD1_RD3c_commute: "RD1(RD3c(P)) = RD3c(RD1(P))"
  by (rel_auto)

definition NSRD :: "('s,'t::trace,'\<alpha>) hrel_rsp \<Rightarrow> ('s,'t,'\<alpha>) hrel_rsp"
where [upred_defs]: "NSRD = RD1 \<circ> RD3 \<circ> RHS"

definition NRD :: "('t::trace,'\<alpha>) hrel_rp \<Rightarrow> ('t,'\<alpha>) hrel_rp"
where [upred_defs]: "NRD = RD1 \<circ> RD3c \<circ> RH"

lemma NRD_is_RD [closure]: "P is NRD \<Longrightarrow> P is RD"
  by (simp add: Healthy_def NRD_def RD_def)
     (metis (no_types, lifting) R1_R3c_commute R1_seqr R1_skip_rea R2c_R1_seq R2c_R3c_commute R2c_skip_rea R3_skipr R3c_semir_form R3c_via_RD1_R3 RD1_R1_commute RD1_R2c_commute RD1_R3c_commute RD1_RD2_commute RD1_idem RD3c_def RD3c_right_subsumes_RD2 RH_def RP_def RP_idem skip_rea_RD1_skip)

lemma NRD_elim [RD_elim]:
  "\<lbrakk> P is NRD; Q(\<^bold>R(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))) \<rbrakk> \<Longrightarrow> Q(P)"
  by (simp add: RD_elim closure)

lemma NRD_idem: "NRD(NRD(P)) = NRD(P)"
  by (metis (no_types, opaque_lifting) Healthy_Idempotent Healthy_def Idempotent_def NRD_def R1_R3c_commute R1_skip_rea R2_R2c_def R2_idem R2_seqr_closure R2c_R3c_commute R2c_skip_rea R3c_Idempotent R3c_def R3c_seq_closure R3c_via_RD1_R3 RD1_RD3c_commute RD1_RH_commute RD1_idem RD3c_def RD3c_idem RD_healths(3) RH_def comp_assoc comp_eq_dest_lhs rdes_left_unital.Healthy_Unit rea_lift_R1 rea_lift_def)

lemma NRD_Idempotent [closure]: "Idempotent NRD"
  by (simp add: Idempotent_def NRD_idem)

lemma NRD_Continuous [closure]: "Continuous NRD"
  by (simp add: Continuous_comp NRD_def RD1_Continuous RD3c_Continuous RH_Continuous)

lemma NRD_form:
  "NRD(P) = \<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
proof -
  have "NRD(P) = RD3c(RD(P))"
    by (metis NRD_def RD1_RD3c_commute RD3c_left_subsumes_RD2 RD_alt_def comp_eq_dest_lhs)
  also have "... = RD3c(\<^bold>R(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: RD_as_reactive_tri_design)
  also have "... = \<^bold>R(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) ;; II\<^sub>C"
    by (simp add: RD3c_def)
  also have "... = \<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: RH_tri_design_right_unit_lemma unrest)
  finally show ?thesis .
qed

lemma NRD_healthy_form:
  assumes "P is NRD"
  shows "\<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))) = P"
  by (metis Healthy_def NRD_form assms)

lemma NRD_neg_pre_unit:
  assumes "P is NRD"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))"
proof -
  have "(\<not>\<^sub>r pre\<^sub>R(P)) = (\<not>\<^sub>r pre\<^sub>R(\<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))))"
    by (simp add: NRD_healthy_form assms)
  also have "... = R1 (R2c ((\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
    by (simp add: rea_pre_RH_design R1_negate_R1 R1_idem R1_rea_not' R2c_rea_not usubst rpred unrest closure)
  also have "... = (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true"
    by (simp add: R1_R2c_seqr_distribute closure assms)
  finally show ?thesis
    by (simp add: rea_not_def)
qed

lemma NRD_wait'_unrest_pre [unrest]:
  assumes "P is NRD"
  shows "$wait\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NRD_healthy_form assms)
  also have "... = (R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true)))"
    by (simp add: rea_pre_RH_design usubst unrest)
  also have "$wait\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma preR_NRD_RR [closure]: "P is NRD \<Longrightarrow> pre\<^sub>R(P) is RR"
  by (rule RR_intro, simp_all add: closure unrest)

lemma NRD_neg_pre_RC [closure]:
  assumes "P is NRD"
  shows "pre\<^sub>R(P) is RC"
  by (rule RC_intro, simp_all add: closure assms NRD_neg_pre_unit rpred)

lemma NRD_intro:
  assumes "P is RD" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))"
  shows "P is NRD"
proof -
  have "NRD(P) = \<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: NRD_form)
  also have "... = \<^bold>R(pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P)"
    by (simp add: assms rpred closure)
  also have "... = P"
    by (simp add: RD_reactive_tri_design assms(1))
  finally show ?thesis
    using Healthy_def by blast
qed

lemma NRD_intro':
  assumes "P is R2" "P is R3c" "P is RD1" "P is RD3c"
  shows "P is NRD"
  by (metis (no_types, opaque_lifting) Healthy_def NRD_def R1_R2c_is_R2 RH_def assms comp_apply)

lemma NRD_RC_intro:
  assumes "P is RD" "pre\<^sub>R(P) is RC"
  shows "P is NRD"
  by (metis Healthy_def NRD_form RD_reactive_tri_design assms(1) assms(2)
      rea_not_false  wp_rea_RC_false wp_rea_def)

lemma NRD_rdes_intro [closure]:
  assumes "P is RC" "Q is RR" "R is RR"
  shows "\<^bold>R(P \<turnstile> Q \<diamondop> R) is NRD"
  by (rule NRD_RC_intro, simp_all add: rdes closure assms unrest)

lemma NRD_composition_wp:
  assumes "P is NRD" "Q is RD"
  shows "P ;; Q =
         \<^bold>R ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)) \<diamondop> (post\<^sub>R P ;; post\<^sub>R Q))"
  by (simp add: RD_composition_wp assms NRD_is_RD wp_rea_def NRD_neg_pre_unit R1_negate_R1 R1_preR ex_unrest rpred)

lemma NSRD_is_SRD [closure]: "P is NSRD \<Longrightarrow> P is SRD"
  by (simp add: Healthy_def NSRD_def SRD_def, metis Healthy_def RD1_RD3_commute RD2_RHS_commute RD3_def RD3_right_subsumes_RD2 SRD_def SRD_idem SRD_seqr_closure SRD_srdes_skip)

lemma NSRD_elim [RD_elim]:
  "\<lbrakk> P is NSRD; Q(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))) \<rbrakk> \<Longrightarrow> Q(P)"
  by (simp add: RD_elim closure)

lemma NSRD_idem: "NSRD(NSRD(P)) = NSRD(P)"
  by (metis (no_types, opaque_lifting) Healthy_def NSRD_def RD1_RD2_commute RD1_RD3_commute RD1_RHS_commute RD1_idem RD2_RHS_commute RD2_idem RD3_def RD3_idem RD3_left_subsumes_RD2 RHS_idem SRD_def comp_apply fun.map_comp srdes_left_unital.Healthy_Sequence srdes_left_unital.Healthy_Unit)

lemma NSRD_Idempotent [closure]: "Idempotent NSRD"
  by (simp add: Idempotent_def NSRD_idem)

lemma NSRD_Continuous [closure]: "Continuous NSRD"
  by (simp add: Continuous_comp NSRD_def RD1_Continuous RD3_Continuous RHS_Continuous)

lemma NSRD_form:
  "NSRD(P) = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))"
proof -
  have "NSRD(P) = RD3(SRD(P))"
    by (metis (no_types, lifting) NSRD_def RD1_RD3_commute RD3_left_subsumes_RD2 SRD_def comp_def)
  also have "... = RD3(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: SRD_as_reactive_tri_design)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) ;; II\<^sub>R"
    by (simp add: RD3_def)
  also have "... = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))"
    by (simp add: RHS_tri_design_right_unit_lemma unrest)
  finally show ?thesis .
qed

lemma NSRD_healthy_form:
  assumes "P is NSRD"
  shows "\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))) = P"
  by (metis Healthy_def NSRD_form assms)

lemma NSRD_Sup_closure [closure]:
  assumes "A \<subseteq> \<lbrakk>NSRD\<rbrakk>\<^sub>H" "A \<noteq> {}"
  shows "\<Sqinter> A is NSRD"
proof -
  have "NSRD (\<Sqinter> A) = (\<Sqinter> (NSRD `A))"
    by (simp add: ContinuousD NSRD_Continuous assms(2))
  also have "... = (\<Sqinter> A)"
    by (simp only: Healthy_carrier_image assms)
  finally show ?thesis by (simp add: Healthy_def)
qed

lemma intChoice_NSRD_closed [closure]:
  assumes "P is NSRD" "Q is NSRD"
  shows "P \<sqinter> Q is NSRD"
  using NSRD_Sup_closure[of "{P, Q}"] by (simp add: assms)

lemma NRSD_SUP_closure [closure]:
  "\<lbrakk> \<And> i. i \<in> A \<Longrightarrow> P(i) is NSRD; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter>i\<in>A. P(i)) is NSRD"
  by (rule NSRD_Sup_closure, auto)

lemma NSRD_neg_pre_unit:
  assumes "P is NSRD"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))"
proof -
  have "(\<not>\<^sub>r pre\<^sub>R(P)) = (\<not>\<^sub>r pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = R1 (R2c ((\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
    by (simp add: rea_pre_RHS_design R1_negate_R1 R1_idem R1_rea_not' R2c_rea_not usubst rpred unrest closure)
  also have "... = (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true"
    by (simp add: R1_R2c_seqr_distribute closure assms)
  finally show ?thesis
    by (simp add: rea_not_def)
qed

lemma NSRD_neg_pre_left_zero:
  assumes "P is NSRD" "Q is R1" "Q is RD1"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; Q = (\<not>\<^sub>r pre\<^sub>R(P))"
  by (metis (no_types, opaque_lifting) NSRD_neg_pre_unit RD1_left_zero assms(1) assms(2) assms(3) seqr_assoc)

lemma NSRD_st'_unrest_peri [unrest]:
  assumes "P is NSRD"
  shows "$st\<acute> \<sharp> peri\<^sub>R(P)"
proof -
  have "peri\<^sub>R(P) = peri\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true \<Rightarrow>\<^sub>r (\<exists> $st\<acute> \<bullet> peri\<^sub>R P)))"
    by (simp add: rea_peri_RHS_design usubst unrest)
  also have "$st\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma NSRD_wait'_unrest_pre [unrest]:
  assumes "P is NSRD"
  shows "$wait\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = (R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true)))"
    by (simp add: rea_pre_RHS_design usubst unrest)
  also have "$wait\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma NSRD_st'_unrest_pre [unrest]:
  assumes "P is NSRD"
  shows "$st\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
    by (simp add: rea_pre_RHS_design usubst unrest)
  also have "$st\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma NSRD_peri_under_pre [rpred]:
  "P is NSRD \<Longrightarrow> (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P) = peri\<^sub>R P"
  by (simp add: SRD_peri_under_pre unrest closure)

lemma NSRD_post_under_pre [rpred]:
  "P is NSRD \<Longrightarrow> (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P) = post\<^sub>R P"
  by (simp add: SRD_post_under_pre unrest closure)

lemma NSRD_peri_seq_under_pre:
  assumes "P is NSRD" "Q is NSRD"
  shows "(pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q) = (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q)"
  by (metis NSRD_peri_under_pre assms(1) rea_impl_def utp_pred_laws.disj_assoc)

lemma NSRD_postR_seq_periR_impl:
  assumes "P is NSRD" "Q is NSRD"
  shows "(post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r (post\<^sub>R P ;; peri\<^sub>R Q)) = (post\<^sub>R P ;; peri\<^sub>R Q)"
  by (metis NSRD_is_SRD NSRD_peri_under_pre SRD_healths(2) assms postR_RR wpR_impl_post_spec)

lemma NSRD_postR_seq_postR_impl:
  assumes "P is NSRD" "Q is NSRD"
  shows "(post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R Q)) = (post\<^sub>R P ;; post\<^sub>R Q)"
  by (metis NSRD_is_SRD NSRD_post_under_pre SRD_healths(2) assms postR_RR wpR_impl_post_spec)

lemma NSRD_peri_under_assms:
  assumes "P is NSRD" "Q is NSRD"
  shows "(pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q) = (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q)"
  by (metis (no_types, lifting) NSRD_peri_seq_under_pre assms NSRD_postR_seq_periR_impl rea_impl_conj rea_impl_disj)

lemma NSRD_peri_under_assms':
  assumes "P is NSRD" "Q is NSRD"
  shows "(post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q) = (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q)"
  by (simp add: NSRD_postR_seq_periR_impl assms rea_impl_disj)

lemma NSRD_post_under_assms:
  assumes "P is NSRD" "Q is NSRD"
  shows "(pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r post\<^sub>R P ;; post\<^sub>R Q) = (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R Q))"
  by (metis NSRD_postR_seq_postR_impl assms(1) assms(2) rea_impl_conj)

lemma NSRD_alt_def: "NSRD(P) = RD3(SRD(P))"
  by (metis NSRD_def RD1_RD3_commute RD3_left_subsumes_RD2 SRD_def comp_eq_dest_lhs)

lemma preR_RR [closure]: "P is NSRD \<Longrightarrow> pre\<^sub>R(P) is RR"
  by (rule RR_intro, simp_all add: closure unrest)

lemma NSRD_neg_pre_RC [closure]:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P) is RC"
  by (rule RC_intro, simp_all add: closure assms NSRD_neg_pre_unit rpred)

lemma NSRD_intro:
  assumes "P is SRD" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))" "$st\<acute> \<sharp> peri\<^sub>R(P)"
  shows "P is NSRD"
proof -
  have "NSRD(P) = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))"
    by (simp add: NSRD_form)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P)"
    by (simp add: assms ex_unrest rpred closure)
  also have "... = P"
    by (simp add: SRD_reactive_tri_design assms(1))
  finally show ?thesis
    using Healthy_def by blast
qed

lemma NSRD_intro':
  assumes "P is R2" "P is R3h" "P is RD1" "P is RD3"
  shows "P is NSRD"
  by (metis (no_types, opaque_lifting) Healthy_def NSRD_def R1_R2c_is_R2 RHS_def assms comp_apply)

lemma NSRD_RC_intro:
  assumes "P is SRD" "pre\<^sub>R(P) is RC" "$st\<acute> \<sharp> peri\<^sub>R(P)"
  shows "P is NSRD"
  by (metis Healthy_def NSRD_form SRD_reactive_tri_design assms(1) assms(2) assms(3)
      ex_unrest rea_not_false  wp_rea_RC_false wp_rea_def)

lemma NSRD_rdes_intro [closure]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) is NSRD"
  by (rule NSRD_RC_intro, simp_all add: rdes closure assms unrest)

lemma SRD_RD3_implies_NSRD:
  "\<lbrakk> P is SRD; P is RD3 \<rbrakk> \<Longrightarrow> P is NSRD"
  by (metis (no_types, lifting) Healthy_def NSRD_def RHS_idem SRD_healths(4) SRD_reactive_design comp_apply)

lemma NSRD_iff:
  "P is NSRD \<longleftrightarrow> ((P is SRD) \<and> (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1(true) = (\<not>\<^sub>r pre\<^sub>R(P)) \<and> ($st\<acute> \<sharp> peri\<^sub>R(P)))"
  by (meson NSRD_intro NSRD_is_SRD NSRD_neg_pre_unit NSRD_st'_unrest_peri)

lemma NSRD_is_RD3 [closure]:
  assumes "P is NSRD"
  shows "P is RD3"
  by (simp add: NSRD_is_SRD NSRD_neg_pre_unit NSRD_st'_unrest_peri RD3_intro_pre assms)

lemma NSRD_refine_elim:
  assumes
    "P \<sqsubseteq> Q" "P is NSRD" "Q is NSRD"
    "\<lbrakk> `pre\<^sub>R(P) \<Rightarrow> pre\<^sub>R(Q)`; `pre\<^sub>R(P) \<and> peri\<^sub>R(Q) \<Rightarrow> peri\<^sub>R(P)`; `pre\<^sub>R(P) \<and> post\<^sub>R(Q) \<Rightarrow> post\<^sub>R(P)` \<rbrakk> \<Longrightarrow> R"
  shows "R"
proof -
  have "\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) \<sqsubseteq> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> peri\<^sub>R(Q) \<diamondop> post\<^sub>R(Q))"
    by (simp add: NSRD_is_SRD SRD_reactive_tri_design assms(1) assms(2) assms(3))
  hence 1:"`pre\<^sub>R P \<Rightarrow> pre\<^sub>R Q`" and 2:"`pre\<^sub>R P \<and> peri\<^sub>R Q \<Rightarrow> peri\<^sub>R P`" and 3:"`pre\<^sub>R P \<and> post\<^sub>R Q \<Rightarrow> post\<^sub>R P`"
    by (simp_all add: RHS_tri_design_refine assms closure)
  with assms(4) show ?thesis
    by simp
qed

lemma NSRD_right_unit: "P is NSRD \<Longrightarrow> P ;; II\<^sub>R = P"
  by (metis Healthy_if NSRD_is_RD3 RD3_def)

lemma NSRD_composition_wp:
  assumes "P is NSRD" "Q is SRD"
  shows "P ;; Q =
         \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)) \<diamondop> (post\<^sub>R P ;; post\<^sub>R Q))"
  by (simp add: SRD_composition_wp assms NSRD_is_SRD wp_rea_def NSRD_neg_pre_unit NSRD_st'_unrest_peri R1_negate_R1 R1_preR ex_unrest rpred)

lemma preR_NSRD_seq_lemma:
  assumes "P is NSRD" "Q is SRD"
  shows "R1 (R2c (post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q))) = post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q)"
proof -
  have "post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q) = R1(R2c(post\<^sub>R P)) ;; R1(R2c(\<not>\<^sub>r pre\<^sub>R Q))"
    by (simp add: NSRD_is_SRD R1_R2c_post_RHS R1_rea_not R2c_preR R2c_rea_not assms(1) assms(2))
  also have "... = R1 (R2c (post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q)))"
    by (simp add: R1_seqr R2c_R1_seq calculation)
  finally show ?thesis ..
qed

lemma preR_NRD_seq [rdes]:
  assumes "P is NRD" "Q is RD"
  shows "pre\<^sub>R(P ;; Q) = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
  by (simp add: NRD_composition_wp assms rea_pre_RH_design usubst unrest wp_rea_def R2c_disj
      R1_disj R2c_and R2c_preR R1_R2c_commute[THEN sym] R1_extend_conj' R1_idem R2c_not closure
      R1_rea_not' R2c_rea_not preR_NSRD_seq_lemma Healthy_if)

lemma preR_NSRD_seq [rdes]:
  assumes "P is NSRD" "Q is SRD"
  shows "pre\<^sub>R(P ;; Q) = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
  by (simp add: NSRD_composition_wp assms rea_pre_RHS_design usubst unrest wp_rea_def R2c_disj
      R1_disj R2c_and R2c_preR R1_R2c_commute[THEN sym] R1_extend_conj' R1_idem R2c_not closure
      R1_rea_not' R2c_rea_not preR_NSRD_seq_lemma)

lemma periR_NSRD_seq [rdes]:
  assumes "P is NSRD" "Q is NSRD"
  shows "peri\<^sub>R(P ;; Q) = ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)))"
  by (simp add: NSRD_composition_wp assms closure rea_peri_RHS_design usubst unrest wp_rea_def
      R1_extend_conj' R1_disj R1_R2c_seqr_distribute R2c_disj R2c_and R2c_rea_impl R1_rea_impl'
      R2c_preR R2c_periR R1_rea_not' R2c_rea_not R1_peri_SRD)

lemma postR_NSRD_seq [rdes]:
  assumes "P is NSRD" "Q is NSRD"
  shows "post\<^sub>R(P ;; Q) = ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R Q))"
  by (simp add: NSRD_composition_wp assms closure rea_post_RHS_design usubst unrest wp_rea_def
      R1_extend_conj' R1_disj R1_R2c_seqr_distribute R2c_disj R2c_and R2c_rea_impl R1_rea_impl'
      R2c_preR R2c_periR R1_rea_not' R2c_rea_not)

lemma NRD_seqr_closure [closure]:
  assumes "P is NRD" "Q is NRD"
  shows "(P ;; Q) is NRD"
proof -
  have "(\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) ;; true\<^sub>r = (\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
    by (simp add: wp_rea_def rpred assms closure seqr_assoc NRD_neg_pre_unit)
  thus ?thesis
    by (rule_tac NRD_intro, simp_all add: seqr_or_distl NRD_neg_pre_unit assms closure rdes unrest)
qed

lemma NSRD_seqr_closure [closure]:
  assumes "P is NSRD" "Q is NSRD"
  shows "(P ;; Q) is NSRD"
proof -
  have "(\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) ;; true\<^sub>r = (\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
    by (simp add: wp_rea_def rpred assms closure seqr_assoc NSRD_neg_pre_unit)
  moreover have "$st\<acute> \<sharp> pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q"
    by (simp add: unrest assms wp_rea_def)
  ultimately show ?thesis
    by (rule_tac NSRD_intro, simp_all add: seqr_or_distl NSRD_neg_pre_unit assms closure rdes unrest)
qed

lemma RHS_tri_normal_design_composition:
  assumes
    "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q\<^sub>1" "$ok\<acute> \<sharp> Q\<^sub>2" "$ok \<sharp> R" "$ok \<sharp> S\<^sub>1" "$ok \<sharp> S\<^sub>2"
    "$wait \<sharp> R" "$wait\<acute> \<sharp> Q\<^sub>2" "$wait \<sharp> S\<^sub>1" "$wait \<sharp> S\<^sub>2"
    "P is R2c" "Q\<^sub>1 is R1" "Q\<^sub>1 is R2c" "Q\<^sub>2 is R1" "Q\<^sub>2 is R2c"
    "R is R2c" "S\<^sub>1 is R1" "S\<^sub>1 is R2c" "S\<^sub>2 is R1" "S\<^sub>2 is R2c"
    "R1 (\<not> P) ;; R1(true) = R1(\<not> P)" "$st\<acute> \<sharp> Q\<^sub>1"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2) ;; \<^bold>R\<^sub>s(R \<turnstile> S\<^sub>1 \<diamondop> S\<^sub>2)
         = \<^bold>R\<^sub>s((P \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> (Q\<^sub>1 \<or> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
proof -
  have "\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2) ;; \<^bold>R\<^sub>s(R \<turnstile> S\<^sub>1 \<diamondop> S\<^sub>2) =
        \<^bold>R\<^sub>s ((R1 (\<not> P) wp\<^sub>r false \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> ((\<exists> $st\<acute> \<bullet> Q\<^sub>1) \<sqinter> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
    by (simp_all add: RHS_tri_design_composition_wp rea_not_def assms unrest)
  also have "... = \<^bold>R\<^sub>s((P \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> (Q\<^sub>1 \<or> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
    by (simp add: assms wp_rea_def ex_unrest, rel_auto)
  finally show ?thesis .
qed

lemma RHS_tri_normal_design_composition' [rdes_def]:
  assumes "P is RC" "Q\<^sub>1 is RR" "$st\<acute> \<sharp> Q\<^sub>1" "Q\<^sub>2 is RR" "R is RR" "S\<^sub>1 is RR" "S\<^sub>2 is RR"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2) ;; \<^bold>R\<^sub>s(R \<turnstile> S\<^sub>1 \<diamondop> S\<^sub>2)
         = \<^bold>R\<^sub>s((P \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> (Q\<^sub>1 \<or> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
proof -
  have "R1 (\<not> P) ;; R1 true = R1(\<not> P)"
    using RC_implies_RC1[OF assms(1)]
    by (simp add: Healthy_def RC1_def rea_not_def)
       (metis R1_negate_R1 R1_seqr utp_pred_laws.double_compl)
  thus ?thesis
    by (simp add: RHS_tri_normal_design_composition assms closure unrest RR_implies_R2c)
qed

text \<open> If a normal reactive design has postcondition false, then it is a left zero for sequential
  composition. \<close>

lemma NSRD_seq_post_false:
  assumes "P is NSRD" "Q is SRD" "post\<^sub>R(P) = false"
  shows "P ;; Q = P"
  apply (simp add: NSRD_composition_wp assms wp rpred closure)
  using NSRD_is_SRD SRD_reactive_tri_design assms(1,3) apply fastforce
done

lemma NSRD_srd_skip [closure]: "II\<^sub>R is NSRD"
  by (rule NSRD_intro, simp_all add: rdes closure unrest)

lemma NSRD_Chaos [closure]: "Chaos is NSRD"
  by (rule NSRD_intro, simp_all add: closure rdes unrest)

lemma NSRD_Miracle [closure]: "Miracle is NSRD"
  by (rule NSRD_intro, simp_all add: closure rdes unrest)

text \<open> Post-composing a miracle filters out the non-terminating behaviours \<close>

lemma NSRD_right_Miracle_tri_lemma:
  assumes "P is NSRD"
  shows "P ;; Miracle = \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> false)"
  by (simp add: NSRD_composition_wp closure assms rdes wp rpred)

lemma Miracle_right_anhil_iff:
  assumes "P is NSRD"
  shows "P ;; Miracle = Miracle \<longleftrightarrow> pre\<^sub>R P = true\<^sub>r \<and> (\<exists> $st\<acute> \<bullet> peri\<^sub>R P) = false"
  by (simp add: SRD_right_Miracle_tri_lemma assms closure, simp add: rdes_def srdes_tri_eq_iff closure assms wp rpred, fastforce)

text \<open> The set of non-terminating behaviours is a subset \<close>

lemma NSRD_right_Miracle_refines:
  assumes "P is NSRD"
  shows "P \<sqsubseteq> P ;; Miracle"
proof -
  have "\<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P) \<sqsubseteq> \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> false)"
    by (rule srdes_tri_refine_intro, rel_auto+)
  thus ?thesis
    by (simp add: NSRD_elim NSRD_right_Miracle_tri_lemma assms)
qed

text \<open> @{term Chaos} is a right zero of @{term P} precisely when the conjunction of the precondition
  of @{term P} with the weakest precondition under which @{term "post\<^sub>R P"} yields @{term false}
  reduces to @{term false}. This is effectively a feasibility check for reactive designs. \<close>

lemma Chaos_right_anhil_iff:
  assumes "P is NSRD"
  shows "P ;; Chaos = Chaos \<longleftrightarrow> (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r false) = false"
  by (simp add: SRD_right_Chaos_tri_lemma assms closure, simp add: rdes_def srdes_tri_eq_iff closure assms wp)

lemma upower_Suc_NSRD_closed [closure]:
  "P is NSRD \<Longrightarrow> P \<^bold>^ Suc n is NSRD"
proof (induct n)
  case 0
  then show ?case
    by (simp)
next
  case (Suc n)
  then show ?case
    by (simp add: NSRD_seqr_closure upred_semiring.power_Suc)
qed

lemma NSRD_power_Suc [closure]:
  "P is NSRD \<Longrightarrow> P ;; P \<^bold>^ n is NSRD"
  by (metis upower_Suc_NSRD_closed upred_semiring.power_Suc)

lemma uplus_NSRD_closed [closure]: "P is NSRD \<Longrightarrow> P\<^sup>+ is NSRD"
  by (simp add: uplus_power_def closure)

lemma preR_power:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P ;; P\<^bold>^n) = (\<Squnion> i\<in>{0..n}. (post\<^sub>R(P) \<^bold>^ i) wp\<^sub>r (pre\<^sub>R(P)))"
proof (induct n)
  case 0
  then show ?case
    by (simp add: wp closure)
next
  case (Suc n) note hyp = this
  have "pre\<^sub>R (P \<^bold>^ (Suc n + 1)) = pre\<^sub>R (P ;; P \<^bold>^ (n+1))"
    by (simp add: upred_semiring.power_Suc)
  also have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ (Suc n)))"
    using NSRD_iff assms preR_NSRD_seq upower_Suc_NSRD_closed by fastforce
  also have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r (\<Squnion>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P))"
    by (simp add: hyp upred_semiring.power_Suc)
  also have "... = (pre\<^sub>R P \<and> (\<Squnion>i\<in>{0..n}. post\<^sub>R P wp\<^sub>r (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P)))"
    by (simp add: wp)
  also have "... = (pre\<^sub>R P \<and> (\<Squnion>i\<in>{0..n}. (post\<^sub>R P \<^bold>^ (i+1) wp\<^sub>r pre\<^sub>R P)))"
  proof -
    have "\<And> i. R1 (post\<^sub>R P \<^bold>^ i ;; (\<not>\<^sub>r pre\<^sub>R P)) = (post\<^sub>R P \<^bold>^ i ;; (\<not>\<^sub>r pre\<^sub>R P))"
      by (induct_tac i, simp_all add: closure Healthy_if assms)
    thus ?thesis
      by (simp add: wp_rea_def upred_semiring.power_Suc seqr_assoc rpred closure assms)
  qed
  also have "... = (post\<^sub>R P \<^bold>^ 0 wp\<^sub>r pre\<^sub>R P \<and> (\<Squnion>i\<in>{0..n}. (post\<^sub>R P \<^bold>^ (i+1) wp\<^sub>r pre\<^sub>R P)))"
    by (simp add: wp assms closure)
  also have "... = (post\<^sub>R P \<^bold>^ 0 wp\<^sub>r pre\<^sub>R P \<and> (\<Squnion>i\<in>{1..Suc n}. (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P)))"
  proof -
    have "(\<Squnion>i\<in>{0..n}. (post\<^sub>R P \<^bold>^ (i+1) wp\<^sub>r pre\<^sub>R P)) = (\<Squnion>i\<in>{1..Suc n}. (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P))"
      by (rule cong[of Inf], simp_all add: fun_eq_iff)
         (metis (no_types, lifting) image_Suc_atLeastAtMost image_cong image_image)
    thus ?thesis by simp
  qed
  also have "... = (\<Squnion>i\<in>insert 0 {1..Suc n}. (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P))"
    by (simp add: conj_upred_def)
  also have "... = (\<Squnion>i\<in>{0..Suc n}. post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P)"
    by (simp add: atLeast0_atMost_Suc_eq_insert_0)
  finally show ?case by (simp add: upred_semiring.power_Suc)
qed

lemma preR_power' [rdes]:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P ;; P\<^bold>^n) = (\<Squnion> i\<in>{0..n} \<bullet> (post\<^sub>R(P) \<^bold>^ i) wp\<^sub>r (pre\<^sub>R(P)))"
  by (simp add: preR_power assms USUP_as_Inf[THEN sym], simp add: USUP_as_Inf_image)

lemma preR_power_Suc [rdes]:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P\<^bold>^(Suc n)) = (\<Squnion> i\<in>{0..n} \<bullet> (post\<^sub>R(P) \<^bold>^ i) wp\<^sub>r (pre\<^sub>R(P)))"
  by (simp add: upred_semiring.power_Suc rdes assms)

declare upred_semiring.power_Suc [simp]

lemma periR_power:
  assumes "P is NSRD"
  shows "peri\<^sub>R(P ;; P\<^bold>^n) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter> i\<in>{0..n}. post\<^sub>R(P) \<^bold>^ i) ;; peri\<^sub>R(P))"
proof (induct n)
  case 0
  then show ?case
    by (simp add: NSRD_is_SRD NSRD_wait'_unrest_pre SRD_peri_under_pre assms)
next
  case (Suc n) note hyp = this
  have "peri\<^sub>R (P \<^bold>^ (Suc n + 1)) = peri\<^sub>R (P ;; P \<^bold>^ (n+1))"
    by (simp)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R (P ;; P \<^bold>^ n)))"
    by (simp add: closure assms rdes)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<or> post\<^sub>R P ;; (pre\<^sub>R (P \<^bold>^ (Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P)))"
    by (simp only: hyp)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; (pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P)))"
    by (simp add: rdes closure assms, rel_blast)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; ((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P)))"
  proof -
    have "(\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) is R1"
      by (simp add: R1_Continuous assms closure)
    hence 1:"((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P) is R1"
      by (simp add: closure assms)
    hence "(pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P) is R1"
      by (simp add: closure)
    hence "(post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; (pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))
          = (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r R1(post\<^sub>R P) ;; R1(pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
      by (simp add: Healthy_if R1_post_SRD assms closure)
    thus ?thesis
      by (simp only: wp_rea_impl_lemma, simp add: Healthy_if 1, simp add: R1_post_SRD assms closure)
  qed
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; ((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
    by (pred_auto)
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> ((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ (Suc i)) ;; peri\<^sub>R P))"
    by (simp add: seq_Sup_distl seqr_assoc[THEN sym])
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> ((\<Sqinter>i\<in>{1..Suc n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
  proof -
    have "(\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ Suc i) = (\<Sqinter>i\<in>{1..Suc n}. post\<^sub>R P \<^bold>^ i)"
      apply (rule cong[of Sup], auto)
      apply (metis atLeast0AtMost atMost_iff image_Suc_atLeastAtMost rev_image_eqI upred_semiring.power_Suc)
      using Suc_le_D apply fastforce
    done
    thus ?thesis by simp
  qed
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r ((\<Sqinter>i\<in>{0..Suc n}. post\<^sub>R P \<^bold>^ i)) ;; peri\<^sub>R P)"
    by (simp add: SUP_atLeastAtMost_first uinf_or seqr_or_distl seqr_or_distr)
  also
  have "... = (pre\<^sub>R(P\<^bold>^(Suc (Suc n))) \<Rightarrow>\<^sub>r ((\<Sqinter>i\<in>{0..Suc n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
    by (simp add: rdes closure assms)
  finally show ?case by (simp)
qed

lemma periR_power' [rdes]:
  assumes "P is NSRD"
  shows "peri\<^sub>R(P ;; P\<^bold>^n) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter> i\<in>{0..n} \<bullet> post\<^sub>R(P) \<^bold>^ i) ;; peri\<^sub>R(P))"
  by (simp add: periR_power assms UINF_as_Sup[THEN sym], simp add: UINF_as_Sup_image)

lemma periR_power_Suc [rdes]:
  assumes "P is NSRD"
  shows "peri\<^sub>R(P\<^bold>^(Suc n)) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter> i\<in>{0..n} \<bullet> post\<^sub>R(P) \<^bold>^ i) ;; peri\<^sub>R(P))"
  by (simp add: rdes assms)

lemma postR_power [rdes]:
  assumes "P is NSRD"
  shows "post\<^sub>R(P ;; P\<^bold>^n) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r post\<^sub>R(P) \<^bold>^ Suc n)"
proof (induct n)
  case 0
  then show ?case
    by (simp add: NSRD_is_SRD NSRD_wait'_unrest_pre SRD_post_under_pre assms)
next
  case (Suc n) note hyp = this
  have "post\<^sub>R (P \<^bold>^ (Suc n + 1)) = post\<^sub>R (P ;; P \<^bold>^ (n+1))"
    by (simp)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R (P ;; P \<^bold>^ n)))"
    by (simp add: closure assms rdes)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (post\<^sub>R P ;; (pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc n)))"
    by (simp only: hyp)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; (pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc n)))"
    by (simp add: rdes closure assms, pred_auto)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; post\<^sub>R P \<^bold>^ Suc n))"
    by (metis (no_types, lifting) Healthy_if NSRD_is_SRD NSRD_power_Suc R1_power assms hyp postR_SRD_R1 upred_semiring.power_Suc wp_rea_impl_lemma)
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc (Suc n))"
    by (pred_auto)
  also have "... = (pre\<^sub>R(P\<^bold>^(Suc (Suc n))) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc (Suc n))"
    by (simp add: rdes closure assms)
  finally show ?case by (simp)
qed

lemma postR_power_Suc [rdes]:
  assumes "P is NSRD"
  shows "post\<^sub>R(P\<^bold>^(Suc n)) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r post\<^sub>R(P) \<^bold>^ Suc n)"
  by (simp add: rdes assms)

lemma power_rdes_def [rdes_def]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^bold>^(Suc n)
        = \<^bold>R\<^sub>s((\<Squnion> i\<in>{0..n} \<bullet> (R \<^bold>^ i) wp\<^sub>r P) \<turnstile> ((\<Sqinter> i\<in>{0..n} \<bullet> R \<^bold>^ i) ;; Q) \<diamondop> (R \<^bold>^ Suc n))"
proof (induct n)
  case 0
  then show ?case
    by (simp add: wp assms closure)
next
  case (Suc n)

  have 1: "(P \<and> (\<Squnion> i \<in> {0..n} \<bullet> R wp\<^sub>r (R \<^bold>^ i wp\<^sub>r P))) = (\<Squnion> i \<in> {0..Suc n} \<bullet> R \<^bold>^ i wp\<^sub>r P)"
    (is "?lhs = ?rhs")
  proof -
    have "?lhs = (P \<and> (\<Squnion> i \<in> {0..n} \<bullet> (R \<^bold>^ Suc i wp\<^sub>r P)))"
      by (simp add: wp closure assms)
    also have "... = (P \<and> (\<Squnion> i \<in> {0..n}. (R \<^bold>^ Suc i wp\<^sub>r P)))"
      by (simp only: USUP_as_Inf_collect)
    also have "... = (P \<and> (\<Squnion> i \<in> {1..Suc n}. (R \<^bold>^ i wp\<^sub>r P)))"
      by (metis (no_types, lifting) INF_cong One_nat_def image_Suc_atLeastAtMost image_image)
    also have "... = (\<Squnion> i \<in> insert 0 {1..Suc n}. (R \<^bold>^ i wp\<^sub>r P))"
      by (simp add: wp assms closure conj_upred_def)
    also have "... = (\<Squnion> i \<in> {0..Suc n}. (R \<^bold>^ i wp\<^sub>r P))"
      by (simp add: atLeastAtMost_insertL)
    finally show ?thesis
      by (simp add: USUP_as_Inf_collect)
  qed

  have 2: "(Q \<or> R ;; (\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ i) ;; Q) = (\<Sqinter> i \<in> {0..Suc n} \<bullet> R \<^bold>^ i) ;; Q"
    (is "?lhs = ?rhs")
  proof -
    have "?lhs = (Q \<or> (\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ Suc i) ;; Q)"
      by (simp add: seqr_assoc[THEN sym] seq_UINF_distl)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {0..n}. R \<^bold>^ Suc i) ;; Q)"
      by (simp only: UINF_as_Sup_collect)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {1..Suc n}. R \<^bold>^ i) ;; Q)"
      by (metis One_nat_def image_Suc_atLeastAtMost image_image)
    also have "... = ((\<Sqinter> i \<in> insert 0 {1..Suc n}. R \<^bold>^ i) ;; Q)"
      by (simp add: disj_upred_def[THEN sym] seqr_or_distl)
    also have "... = ((\<Sqinter> i \<in> {0..Suc n}. R \<^bold>^ i) ;; Q)"
      by (simp add: atLeastAtMost_insertL)
    finally show ?thesis
      by (simp add: UINF_as_Sup_collect)
  qed

  have 3: "(\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ i) ;; Q is RR"
  proof -
    have "(\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ i) ;; Q = (\<Sqinter> i \<in> {0..n}. R \<^bold>^ i) ;; Q"
      by (simp add: UINF_as_Sup_collect)
    also have "... = (\<Sqinter> i \<in> insert 0 {1..n}. R \<^bold>^ i) ;; Q"
      by (simp add: atLeastAtMost_insertL)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {1..n}. R \<^bold>^ i) ;; Q)"
      by (metis (no_types, lifting) SUP_insert disj_upred_def seqr_left_unit seqr_or_distl upred_semiring.power_0)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {0..<n}. R \<^bold>^ Suc i) ;; Q)"
      by (metis One_nat_def atLeastLessThanSuc_atLeastAtMost image_Suc_atLeastLessThan image_image)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {0..<n} \<bullet> R \<^bold>^ Suc i) ;; Q)"
      by (simp add: UINF_as_Sup_collect)
    also have "... is RR"
      by (simp_all add: closure assms)
    finally show ?thesis .
  qed
  from 1 2 3 Suc show ?case
    by (simp add: Suc RHS_tri_normal_design_composition' closure assms wp)
qed

declare upred_semiring.power_Suc [simp del]

theorem uplus_rdes_def [rdes_def]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^sup>+ = \<^bold>R\<^sub>s(R\<^sup>\<star>\<^sup>r wp\<^sub>r P \<turnstile> (R\<^sup>\<star>\<^sup>r ;; Q) \<diamondop> R\<^sup>+)"
proof -
  have 1:"(\<Sqinter> i \<bullet> R \<^bold>^ i) ;; Q = R\<^sup>\<star>\<^sup>r ;; Q"
    by (metis (no_types) RA1 assms(2) rea_skip_unit(2) rrel_theory.Star_def ustar_alt_def)
  show ?thesis
    by (simp add: uplus_power_def seq_UINF_distr wp closure assms rdes_def)
       (metis "1" seq_UINF_distr')
qed

subsection \<open> UTP theory \<close>

lemma NSRD_false: "NSRD false = Miracle"
  by (metis Healthy_if NSRD_Miracle NSRD_alt_def NSRD_is_RD3 srdes_theory.healthy_top)

lemma NSRD_true: "NSRD true = Chaos"
  by (metis Healthy_if NSRD_Chaos NSRD_alt_def NSRD_is_RD3 srdes_theory.healthy_bottom)

interpretation nsrdes_theory: utp_theory_kleene NSRD II\<^sub>R
  rewrites "P \<in> carrier nsrdes_theory.thy_order \<longleftrightarrow> P is NSRD"
  and "carrier nsrdes_theory.thy_order \<rightarrow> carrier nsrdes_theory.thy_order \<equiv> \<lbrakk>NSRD\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>NSRD\<rbrakk>\<^sub>H"
  and "le nsrdes_theory.thy_order = (\<sqsubseteq>)"
  and "eq nsrdes_theory.thy_order = (=)"
  and nsrdes_top: "nsrdes_theory.utp_top = Miracle"
  and nsrdes_bottom: "nsrdes_theory.utp_bottom = Chaos"
proof -
  have "utp_theory_continuous NSRD"
    by (unfold_locales, simp_all add: NSRD_idem NSRD_Continuous)
  then interpret utp_theory_continuous NSRD
    by simp
  show t: "utp_top = Miracle" and b:"utp_bottom = Chaos"
    by (simp_all add: healthy_top healthy_bottom NSRD_false NSRD_true)
  show "utp_theory_kleene NSRD II\<^sub>R"
    by (unfold_locales, simp_all add: closure srdes_left_unital.Unit_Left NSRD_right_unit Miracle_left_zero t)
qed (simp_all)

abbreviation TestR ("test\<^sub>R") where
"test\<^sub>R P \<equiv> nsrdes_theory.utp_test P"

definition StarR :: "('s, 't::trace, '\<alpha>) hrel_rsp \<Rightarrow> ('s, 't, '\<alpha>) hrel_rsp" ("_\<^sup>\<star>\<^sup>R" [999] 999) where
"StarR \<equiv> nsrdes_theory.utp_star"

text \<open> We also show how to calculate the Kleene closure of a reactive design. \<close>

thm rdes_def

lemma StarR_rdes_def [rdes_def]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^sup>\<star>\<^sup>R = \<^bold>R\<^sub>s((R\<^sup>\<star>\<^sup>r wp\<^sub>r P) \<turnstile> (R\<^sup>\<star>\<^sup>r ;; Q) \<diamondop> R\<^sup>\<star>\<^sup>r)"
  by (simp add: StarR_def rrel_theory.Star_alt_def nsrdes_theory.Star_alt_def closure assms)
     (simp add: rrel_theory.Star_alt_def assms closure rdes_def unrest rpred disj_upred_def)

end


(* Author: Peter Lammich *)

section \<open>Single Threaded Arrays\<close>
theory DiffArray_ST
imports DiffArray_Base
begin

subsection \<open>Primitive Operations\<close>

typedef 'a starray = "UNIV :: 'a array set"
  morphisms Rep_starray STArray
  by blast
setup_lifting type_definition_starray

lift_definition starray_new :: "nat \<Rightarrow> 'a \<Rightarrow> 'a starray" is "array_new" .

lift_definition starray_tabulate :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a starray" is "array_tabulate" .

lift_definition starray_length :: "'a starray \<Rightarrow> nat" is array_length .

lift_definition starray_get :: "'a starray \<Rightarrow> nat \<Rightarrow> 'a" is array_get .

lift_definition starray_set :: "'a starray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a starray" is array_set .

lift_definition starray_of_list :: "'a list \<Rightarrow> 'a starray" is \<open>array_of_list\<close> .

lift_definition starray_grow :: "'a starray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a starray" is "array_grow" .

lift_definition starray_take :: "'a starray \<Rightarrow> nat \<Rightarrow> 'a starray" is array_take .

lift_definition starray_get_oo :: "'a \<Rightarrow> 'a starray \<Rightarrow> nat \<Rightarrow> 'a" is array_get_oo .

lift_definition starray_set_oo :: "(unit \<Rightarrow> 'a starray) \<Rightarrow> 'a starray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a starray" is array_set_oo .

lift_definition starray_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a starray \<Rightarrow> 'b starray" is array_map .

lift_definition starray_fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a starray \<Rightarrow> 'b \<Rightarrow> 'b" is array_fold .

lift_definition starray_foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a starray \<Rightarrow> 'b \<Rightarrow> 'b" is array_foldr .

definition "starray_\<alpha> = array_\<alpha> o Rep_starray"

subsubsection \<open>Refinement Lemmas\<close>

context
  notes [simp] = STArray_inverse array_eq_iff starray_\<alpha>_def
begin

  lemma starray_\<alpha>_inj: "starray_\<alpha> a = starray_\<alpha> b \<Longrightarrow> a=b" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_eq_iff: "a=b \<longleftrightarrow> starray_\<alpha> a = starray_\<alpha> b" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_new_refine[simp,array_refine]: "starray_\<alpha> (starray_new n a) = replicate n a" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_tabulate_refine[simp,array_refine]: "starray_\<alpha> (starray_tabulate n f) = tabulate n f" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_length_refine[simp,array_refine]: "starray_length a = length (starray_\<alpha> a)" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_get_refine[simp,array_refine]: "starray_get a i = starray_\<alpha> a ! i" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_set_refine[simp,array_refine]: "starray_\<alpha> (starray_set a i x) = (starray_\<alpha> a)[i := x]" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_of_list_refine[simp,array_refine]: "starray_\<alpha> (starray_of_list xs) = xs" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_grow_refine[simp,array_refine]:
    "starray_\<alpha> (starray_grow a n d) = take n (starray_\<alpha> a) @ replicate (n-length (starray_\<alpha> a)) d"
    unfolding starray_\<alpha>_def by transfer auto

  lemma starray_take_refine[simp,array_refine]: "starray_\<alpha> (starray_take a n) = take n (starray_\<alpha> a)"
    unfolding starray_\<alpha>_def by transfer auto

  lemma starray_get_oo_refine[simp,array_refine]: "starray_get_oo x a i = (if i<length (starray_\<alpha> a) then starray_\<alpha> a!i else x)" unfolding starray_\<alpha>_def by transfer auto

  lemma starray_set_oo_refine[simp,array_refine]: "starray_\<alpha> (starray_set_oo f a i x)
    = (if i<length (starray_\<alpha> a) then (starray_\<alpha> a)[i:=x] else starray_\<alpha> (f ()))"
    unfolding starray_\<alpha>_def by transfer auto

  lemma starray_map_refine[simp,array_refine]: "starray_\<alpha> (starray_map f a) = map f (starray_\<alpha> a)"
    unfolding starray_\<alpha>_def by transfer auto

  lemma starray_fold_refine[simp, array_refine]: "starray_fold f a s = fold f (starray_\<alpha> a) s"
    unfolding starray_\<alpha>_def by transfer auto

  lemma starray_foldr_refine[simp, array_refine]: "starray_foldr f a s = foldr f (starray_\<alpha> a) s"
    unfolding starray_\<alpha>_def by transfer auto

end

lifting_update starray.lifting
lifting_forget starray.lifting

subsection \<open>Code Generator Setup\<close>

subsubsection \<open>Code-Numeral Preparation\<close>

definition [code del]: "starray_new' == starray_new o nat_of_integer"
definition [code del]: "starray_tabulate' n f \<equiv> starray_tabulate (nat_of_integer n) (f o integer_of_nat)"

definition [code del]: "starray_length' == integer_of_nat o starray_length"
definition [code del]: "starray_get' a == starray_get a o nat_of_integer"
definition [code del]: "starray_set' a == starray_set a o nat_of_integer"
definition [code del]:
  "starray_get_oo' x a == starray_get_oo x a o nat_of_integer"
definition [code del]:
  "starray_set_oo' f a == starray_set_oo f a o nat_of_integer"

text \<open>Fallbacks\<close>

lemmas starray_get_oo'_fallback[code] = starray_get_oo'_def[unfolded starray_get_oo_def[abs_def]]
lemmas starray_set_oo'_fallback[code] = starray_set_oo'_def[unfolded starray_set_oo_def[abs_def]]

lemma starray_tabulate'_fallback[code]:
  "starray_tabulate' n f = starray_of_list (map (f o integer_of_nat) [0..<nat_of_integer n])"
  unfolding starray_tabulate'_def
  by (simp add: starray_eq_iff tabulate_def)

lemma starray_new'_fallback[code]: "starray_new' n x = starray_of_list (replicate (nat_of_integer n) x)"
  by (simp add: starray_new'_def starray_eq_iff)

(*
  Primitive operations, to be implemented for target:

    starray_of_list
    starray_tabulate' (dflt via of_list)
    starray_new' (dflt via of_list)

    starray_length'
    starray_get'
    starray_set'
    starray_get_oo' (dflt via array_get)

*)

code_printing code_module "STArray" \<rightharpoonup>
  (SML)
\<open>
structure STArray = struct

datatype 'a Cell = Invalid | Value of 'a array;

exception AccessedOldVersion;

type 'a starray = 'a Cell Unsynchronized.ref;

fun fromList l = Unsynchronized.ref (Value (Array.fromList l));
fun starray (size, v) = Unsynchronized.ref (Value (Array.array (size,v)));
fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
fun sub (Unsynchronized.ref Invalid, idx) = raise AccessedOldVersion |
    sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx);
fun update (aref,idx,v) =
  case aref of
    (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
    (Unsynchronized.ref (Value a)) => (
      aref := Invalid;
      Array.update (a,idx,v);
      Unsynchronized.ref (Value a)
    );

fun length (Unsynchronized.ref Invalid) = raise AccessedOldVersion |
    length (Unsynchronized.ref (Value a)) = Array.length a

structure IsabelleMapping = struct
type 'a ArrayType = 'a starray;

fun starray_new (n:IntInf.int) (a:'a) = starray (IntInf.toInt n, a);
fun starray_of_list (xs:'a list) = fromList xs;

fun starray_tabulate (n:IntInf.int) (f:IntInf.int -> 'a) = tabulate (IntInf.toInt n, f o IntInf.fromInt)

fun starray_length (a:'a ArrayType) = IntInf.fromInt (length a);

fun starray_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);

fun starray_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);

fun starray_get_oo (d:'a) (a:'a ArrayType) (i:IntInf.int) =
  sub (a,IntInf.toInt i) handle Subscript => d

fun starray_set_oo (d:(unit->'a ArrayType)) (a:'a ArrayType) (i:IntInf.int) (e:'a) =
  update (a, IntInf.toInt i, e) handle Subscript => d ()

end;

end;
\<close>

code_printing
  type_constructor starray \<rightharpoonup> (SML) "_/ STArray.IsabelleMapping.ArrayType"
| constant STArray \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_of'_list"
| constant starray_new' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_new"
| constant starray_tabulate' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_tabulate"
| constant starray_length' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_length"
| constant starray_get' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_get"
| constant starray_set' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_set"
| constant starray_of_list \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_of'_list"
| constant starray_get_oo' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_get'_oo"
| constant starray_set_oo' \<rightharpoonup> (SML) "STArray.IsabelleMapping.starray'_set'_oo"

subsection \<open>Tests\<close>
(* TODO: Add more systematic tests! *)

definition "test1 \<equiv>
  let a=starray_of_list [1,2,3,4,5,6];
      b=starray_tabulate 6 (Suc);
      a'=starray_set a 3 42;
      b'=starray_set b 3 42;
      c=starray_new 6 0
  in
    \<forall>i\<in>{0..<6}.
      starray_get a' i = (if i=3 then 42 else i+1)
    \<and> starray_get b' i = (if i=3 then 42 else i+1)
    \<and> starray_get c i = (0::nat)
          "

lemma enum_rangeE:
  assumes "i\<in>{l..<h}"
  assumes "P l"
  assumes "i\<in>{Suc l..<h} \<Longrightarrow> P i"
  shows "P i"
  using assms
  by (metis atLeastLessThan_iff less_eq_Suc_le nat_less_le)

lemma "test1"
  unfolding test1_def Let_def
  apply (intro ballI conjI)
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  done

ML_val \<open>
  if not @{code test1} then error "ERROR" else ()
\<close>

export_code test1 checking OCaml? Haskell? SML

hide_const test1
hide_fact test1_def

experiment
begin

fun allTrue :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
"allTrue a 0 = a" |
"allTrue a (Suc i) = (allTrue a i)[i := True]"

lemma length_allTrue: "n \<le> length a  \<Longrightarrow> length(allTrue a n) = length a"
by(induction n) (auto)

lemma "n \<le> length a \<Longrightarrow> \<forall>i < n. (allTrue a n) ! i"
by(induction n) (auto simp: nth_list_update length_allTrue)

fun allTrue' :: "bool array \<Rightarrow> nat \<Rightarrow> bool array" where
"allTrue' a 0 = a" |
"allTrue' a (Suc i) = array_set (allTrue' a i) i True"

lemma "array_\<alpha> (allTrue' xs i) = allTrue (array_\<alpha> xs) i"
  apply (induction xs i rule: allTrue'.induct)
  apply auto
  done

end

end


theory Term4
imports "../NewAlpha" "../Abs" "../Perm" "../Rsp" "../Lift" "Quotient_List" "../../Attic/Prove"
begin

atom_decl name

section {*** lam with indirect list recursion ***}

datatype rtrm4 =
  rVr4 "name"
| rAp4 "rtrm4" "rtrm4 list"
| rLm4 "name" "rtrm4"  --"bind (name) in (trm)"

(* there cannot be a clause for lists, as *)
(* permutations are  already defined in Nominal (also functions, options, and so on) *)
ML {*
  val dtinfo = Datatype.the_info @{theory} "Term4.rtrm4";
  val {descr, sorts, ...} = dtinfo;
*}
setup {* snd o (define_raw_perms descr sorts @{thm rtrm4.induct} 1) *}
lemmas perm = permute_rtrm4_permute_rtrm4_list.simps(1-3)
lemma perm_fix:
  fixes ts::"rtrm4 list"
  shows "permute_rtrm4_list p ts = p \<bullet> ts"
  by (induct ts) simp_all
lemmas perm_fixed = perm[simplified perm_fix]

ML {* val bl = [[[BEmy 0], [BEmy 0, BEmy 1], [BSet ([(NONE, 0)], [1])]], [[], [BEmy 0, BEmy 1]]] *}

local_setup {* fn ctxt => let val (_, _, _, ctxt') = define_raw_fvs descr sorts [] bl ctxt in ctxt' end *}
lemmas fv = fv_rtrm4.simps (*fv_rtrm4_list.simps*)

lemma fv_fix: "fv_rtrm4_list = Union o (set o (map fv_rtrm4))"
  by (rule ext) (induct_tac x, simp_all)
lemmas fv_fixed = fv[simplified fv_fix]

(* TODO: check remove 2 *)
local_setup {* snd o (prove_eqvt [@{typ rtrm4},@{typ "rtrm4 list"}] @{thm rtrm4.induct} @{thms perm_fixed fv_rtrm4.simps fv_rtrm4_list.simps} [@{term fv_rtrm4}, @{term fv_rtrm4_list}]) *}
thm eqvts(1-2)

local_setup {* snd o define_raw_alpha dtinfo [] bl [@{term fv_rtrm4}, @{term fv_rtrm4_list}] *}
local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha4_inj}, []), (build_rel_inj @{thms alpha_rtrm4_alpha_rtrm4_list.intros} @{thms rtrm4.distinct rtrm4.inject list.distinct list.inject} @{thms alpha_rtrm4.cases alpha_rtrm4_list.cases} ctxt)) ctxt)) *}
lemmas alpha_inj = alpha4_inj(1-3)

lemma alpha_fix: "alpha_rtrm4_list = list_all2 alpha_rtrm4"
  apply (rule ext)+
  apply (induct_tac x xa rule: list_induct2')
  apply (simp_all add: alpha_rtrm4_alpha_rtrm4_list.intros)
  apply clarify apply (erule alpha_rtrm4_list.cases) apply(simp_all)
  apply clarify apply (erule alpha_rtrm4_list.cases) apply(simp_all)
  apply rule
  apply (erule alpha_rtrm4_list.cases)
  apply simp_all
  apply (rule alpha_rtrm4_alpha_rtrm4_list.intros)
  apply simp_all
  done

lemmas alpha_inj_fixed = alpha_inj[simplified alpha_fix (*fv_fix*)]

notation
    alpha_rtrm4 ("_ \<approx>4 _" [100, 100] 100)
and alpha_rtrm4_list ("_ \<approx>4l _" [100, 100] 100)

declare perm_fixed[eqvt]
equivariance alpha_rtrm4
lemmas alpha4_eqvt = eqvts(1-2)
lemmas alpha4_eqvt_fixed = alpha4_eqvt(2)[simplified alpha_fix (*fv_fix*)]

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha4_reflp}, []),
  build_alpha_refl [((0, @{term alpha_rtrm4}), 0), ((0, @{term alpha_rtrm4_list}), 0)] [@{term alpha_rtrm4}, @{term alpha_rtrm4_list}] @{thm rtrm4.induct} @{thms alpha4_inj} ctxt) ctxt)) *}
thm alpha4_reflp

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha4_equivp}, []),
  (build_equivps [@{term alpha_rtrm4}, @{term alpha_rtrm4_list}] @{thms alpha4_reflp} @{thm alpha_rtrm4_alpha_rtrm4_list.induct} @{thms rtrm4.inject list.inject} @{thms alpha4_inj} @{thms rtrm4.distinct list.distinct} @{thms alpha_rtrm4_list.cases alpha_rtrm4.cases} @{thms alpha4_eqvt} ctxt)) ctxt)) *}
lemmas alpha4_equivp_fixed = alpha4_equivp[simplified alpha_fix fv_fix]

quotient_type
  trm4 = rtrm4 / alpha_rtrm4
  by (simp_all add: alpha4_equivp)

local_setup {*
(fn ctxt => ctxt
 |> snd o (Quotient_Def.quotient_lift_const [] ("Vr4", @{term rVr4}))
 |> snd o (Quotient_Def.quotient_lift_const [@{typ "trm4"}] ("Ap4", @{term rAp4}))
 |> snd o (Quotient_Def.quotient_lift_const [] ("Lm4", @{term rLm4}))
 |> snd o (Quotient_Def.quotient_lift_const [] ("fv_trm4", @{term fv_rtrm4})))
*}
print_theorems

lemma fv_rtrm4_rsp:
  "xa \<approx>4 ya \<Longrightarrow> fv_rtrm4 xa = fv_rtrm4 ya"
  "x \<approx>4l y \<Longrightarrow> fv_rtrm4_list x = fv_rtrm4_list y"
  apply (induct rule: alpha_rtrm4_alpha_rtrm4_list.inducts)
  apply (simp_all add: alpha_gen)
done

local_setup {* snd o prove_const_rsp [] @{binding fv_rtrm4_rsp'} [@{term fv_rtrm4}]
  (fn _ => asm_full_simp_tac (@{simpset} addsimps @{thms fv_rtrm4_rsp}) 1) *}
print_theorems

local_setup {* snd o prove_const_rsp [] @{binding rVr4_rsp} [@{term rVr4}]
  (fn _ => constr_rsp_tac @{thms alpha4_inj} @{thms fv_rtrm4_rsp alpha4_equivp} 1) *}
local_setup {* snd o prove_const_rsp [] @{binding rLm4_rsp} [@{term rLm4}]
  (fn _ => constr_rsp_tac @{thms alpha4_inj} @{thms fv_rtrm4_rsp alpha4_equivp} 1) *}

lemma [quot_respect]:
  "(alpha_rtrm4 ===> list_all2 alpha_rtrm4 ===> alpha_rtrm4) rAp4 rAp4"
  by (simp add: alpha_inj_fixed)

local_setup {* snd o prove_const_rsp [] @{binding permute_rtrm4_rsp}
  [@{term "permute :: perm \<Rightarrow> rtrm4 \<Rightarrow> rtrm4"}]
  (fn _ => asm_simp_tac (HOL_ss addsimps @{thms alpha4_eqvt}) 1) *}

setup {* define_lifted_perms [@{typ trm4}] ["Term4.trm4"] [("permute_trm4", @{term "permute :: perm \<Rightarrow> rtrm4 \<Rightarrow> rtrm4"})] @{thms permute_rtrm4_permute_rtrm4_list_zero permute_rtrm4_permute_rtrm4_list_plus} *}
print_theorems

(* Instead of permute for trm4_list we may need the following 2 lemmas: *)
lemma [quot_preserve]: "(id ---> map rep_trm4 ---> map abs_trm4) permute = permute"
  apply (simp add: expand_fun_eq)
  apply clarify
  apply (rename_tac "pi" x)
  apply (induct_tac x)
  apply simp
  apply simp
  apply (simp add: meta_eq_to_obj_eq[OF permute_trm4_def,simplified expand_fun_eq,simplified])
  done

lemma [quot_respect]: "(op = ===> list_all2 alpha_rtrm4 ===> list_all2 alpha_rtrm4) permute permute"
  apply simp
  apply (rule allI)+
  apply (induct_tac xa y rule: list_induct2')
  apply simp_all
  apply clarify
  apply (erule alpha4_eqvt)
  done

ML {*
  map (lift_thm [@{typ trm4}] @{context}) @{thms perm_fixed}
*}

ML {* lift_thm [@{typ trm4}] @{context} @{thm rtrm4.induct} *}

ML {*
  map (lift_thm [@{typ trm4}] @{context}) @{thms fv_rtrm4.simps[simplified fv_fix] fv_rtrm4_list.simps[simplified fv_fix]}
*}

ML {*
val liftd =
  map (Local_Defs.unfold @{context} @{thms id_simps}) (
    map (Local_Defs.fold @{context} @{thms alphas}) (
      map (lift_thm [@{typ trm4}] @{context}) @{thms alpha_inj_fixed[unfolded alphas]}
    )
  )
*}

ML {*
  map (lift_thm [@{typ trm4}] @{context})
  (flat (map (distinct_rel @{context} @{thms alpha_rtrm4.cases alpha_rtrm4_list.cases}) [(@{thms rtrm4.distinct},@{term "alpha_rtrm4"})]))
*}

thm eqvts(6-7)
ML {*
  map (lift_thm [@{typ trm4}] @{context}) @{thms eqvts(6-7)[simplified fv_fix]}
*}

end


(*  Title:      Containers/Collection_Eq.thy
    Author:     Andreas Lochbihler, KIT
                René Thiemann, UIBK *)
theory Collection_Eq imports
  Containers_Auxiliary
  Containers_Generator
begin

section {* A type class for optional equality testing *}

class ceq =
  fixes ceq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) option"
  assumes ceq: "ceq = Some eq \<Longrightarrow> eq = op ="
begin

lemma ID_ceq: "ID ceq = Some eq \<Longrightarrow> eq = op ="
unfolding ID_def id_apply by(rule ceq)

abbreviation ceq' :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "ceq' \<equiv> the (ID ceq)"

end

syntax "_CEQ" :: "type => logic"  ("(1CEQ/(1'(_')))")

parse_translation {*
let
  fun ceq_tr [ty] =
     (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "ceq"} $
       (Syntax.const @{type_syntax option} $
         (Syntax.const @{type_syntax fun} $ ty $
           (Syntax.const @{type_syntax fun} $ ty $ Syntax.const @{type_syntax bool}))))
    | ceq_tr ts = raise TERM ("ceq_tr", ts);
in [(@{syntax_const "_CEQ"}, K ceq_tr)] end
*}

typed_print_translation {*
let
  fun ceq_tr' ctxt
    (Type (@{type_name option}, [Type (@{type_name fun}, [T, _])])) ts =
    Term.list_comb (Syntax.const @{syntax_const "_CEQ"} $ Syntax_Phases.term_of_typ ctxt T, ts)
  | ceq_tr' _ _ _ = raise Match;
in [(@{const_syntax ceq}, ceq_tr')]
end
*}

definition is_ceq :: "'a :: ceq itself \<Rightarrow> bool"
where "is_ceq _ \<longleftrightarrow> ID CEQ('a) \<noteq> None"

subsection {* Generator for the @{class ceq}-class *}

text {*
This generator registers itself at the derive-manager for the class @{class ceq}.
To be more precise, one can choose whether one wants to take @{term "op ="} as function
for @{term ceq} by passing "eq" as parameter,
whether equality should not be supported by passing "no" as parameter,
or whether an own definition for equality should be derived by not passing
any parameters. The last possibility only works for datatypes.

\begin{itemize}
\item \texttt{instantiation type :: (type,\ldots,type) (eq) ceq}
\item \texttt{instantiation type :: (type,\ldots,type) (no) ceq}
\item \texttt{instantiation datatype :: (ceq,\ldots,ceq) ceq}
\end{itemize}

If the parameter "no" is not used, then the corresponding
@{term is_ceq}-theorem is also automatically generated and attributed with
\texttt{[simp, code-post]}.
*}

text {*
This generator can be used for arbitrary types, not just datatypes.
*}

ML_file "ceq_generator.ML"

setup {*
  Ceq_Generator.setup
*}

subsection {* Type class instances for HOL types *}

derive (eq) ceq unit

lemma is_ceq_fun [simp]: "\<not> is_ceq TYPE('a \<Rightarrow> 'b)"
  by(simp add: is_ceq_def ceq_fun_def ID_None)

definition set_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where [code del]: "set_eq = op ="

lemma set_eq_code:
  shows [code]: "set_eq A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
  and [code_unfold]: "op = = set_eq"
unfolding set_eq_def by blast+

instantiation set :: (ceq) ceq begin
definition "CEQ('a set) = (case ID CEQ('a) of None \<Rightarrow> None | Some _ \<Rightarrow> Some set_eq)"
instance by(intro_classes)(simp add: ceq_set_def set_eq_def split: option.splits)
end

lemma is_ceq_set [simp, code_post]: "is_ceq TYPE('a set) \<longleftrightarrow> is_ceq TYPE('a :: ceq)"
by(simp add: is_ceq_def ceq_set_def ID_None ID_Some split: option.split)

lemma ID_ceq_set_not_None_iff [simp]: "ID CEQ('a set) \<noteq> None \<longleftrightarrow> ID CEQ('a :: ceq) \<noteq> None"
by(simp add: ceq_set_def ID_def split: option.splits)

text {* Instantiation for @{typ "'a Predicate.pred"} *}

context fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" begin

definition member_pred :: "'a Predicate.pred \<Rightarrow> 'a \<Rightarrow> bool"
where "member_pred P x \<longleftrightarrow> (\<exists>y. eq x y \<and> Predicate.eval P y)"

definition member_seq :: "'a Predicate.seq \<Rightarrow> 'a \<Rightarrow> bool"
where "member_seq xp = member_pred (Predicate.pred_of_seq xp)"

lemma member_seq_code [code]:
  "member_seq seq.Empty x \<longleftrightarrow> False"
  "member_seq (seq.Insert y P) x \<longleftrightarrow> eq x y \<or> member_pred P x"
  "member_seq (seq.Join Q xq) x \<longleftrightarrow> member_pred Q x \<or> member_seq xq x"
by(auto simp add: member_seq_def member_pred_def)

lemma member_pred_code [code]:
  "member_pred (Predicate.Seq f) = member_seq (f ())"
by(simp add: member_seq_def Seq_def)

definition leq_pred :: "'a Predicate.pred \<Rightarrow> 'a Predicate.pred \<Rightarrow> bool"
where "leq_pred P Q \<longleftrightarrow> (\<forall>x. Predicate.eval P x \<longrightarrow> (\<exists>y. eq x y \<and> Predicate.eval Q y))"

definition leq_seq :: "'a Predicate.seq \<Rightarrow> 'a Predicate.pred \<Rightarrow> bool"
where "leq_seq xp Q \<longleftrightarrow> leq_pred (Predicate.pred_of_seq xp) Q"

lemma leq_seq_code [code]:
  "leq_seq seq.Empty Q \<longleftrightarrow> True"
  "leq_seq (seq.Insert x P) Q \<longleftrightarrow> member_pred Q x \<and> leq_pred P Q"
  "leq_seq (seq.Join P xp) Q \<longleftrightarrow> leq_pred P Q \<and> leq_seq xp Q"
by(auto simp add: leq_seq_def leq_pred_def member_pred_def)

lemma leq_pred_code [code]:
  "leq_pred (Predicate.Seq f) Q \<longleftrightarrow> leq_seq (f ()) Q"
by(simp add: leq_seq_def Seq_def)

definition predicate_eq :: "'a Predicate.pred \<Rightarrow> 'a Predicate.pred \<Rightarrow> bool"
where "predicate_eq P Q \<longleftrightarrow> leq_pred P Q \<and> leq_pred Q P"

context assumes eq: "eq = op =" begin

lemma member_pred_eq: "member_pred = Predicate.eval"
unfolding fun_eq_iff member_pred_def by(simp add: eq)

lemma member_seq_eq: "member_seq = Predicate.member"
by(simp add: member_seq_def fun_eq_iff eval_member member_pred_eq)

lemma leq_pred_eq: "leq_pred = op \<le>"
unfolding fun_eq_iff leq_pred_def by(auto simp add: eq less_eq_pred_def)

lemma predicate_eq_eq: "predicate_eq = op ="
unfolding predicate_eq_def fun_eq_iff by(auto simp add: leq_pred_eq)

end
end

instantiation Predicate.pred :: (ceq) ceq begin
definition "CEQ('a Predicate.pred) = map_option predicate_eq (ID CEQ('a))"
instance by(intro_classes)(auto simp add: ceq_pred_def predicate_eq_eq dest: ID_ceq)
end

end