section {* Designs *}

theory utp_designs
imports
  "../utp/utp"
begin

text {* In UTP, in order to explicitly record the termination of a program,
a subset of alphabetized relations is introduced. These relations are called
designs and their alphabet should contain the special boolean observational variable ok.
It is used to record the start and termination of a program. *}

subsection {* Definitions *}

text {* In the following, the definitions of designs alphabets, designs and
healthiness (well-formedness) conditions are given. The healthiness conditions of
designs are defined by $H1$, $H2$, $H3$ and $H4$.*}

alphabet des_vars =
  ok :: bool

text {*
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
*}

interpretation des_vars: lens_interp "\<lambda>r. (ok\<^sub>v r, more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation des_vars_rel:
  lens_interp "\<lambda>(r, r'). (ok\<^sub>v r, ok\<^sub>v r', more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

lemma ok_ord [usubst]:
  "$ok \<prec>\<^sub>v $ok\<acute>"
  by (simp add: var_name_ord_def)

type_synonym '\<alpha> des  = "'\<alpha> des_vars_scheme"
type_synonym ('\<alpha>, '\<beta>) rel_des = "('\<alpha> des, '\<beta> des) rel"
type_synonym '\<alpha> hrel_des = "('\<alpha> des) hrel"

translations
  (type) "'\<alpha> des" <= (type) "'\<alpha> des_vars_scheme"
  (type) "'\<alpha> des" <= (type) "'\<alpha> des_vars_ext"
  (type) "('\<alpha>, '\<beta>) rel_des" <= (type) "('\<alpha> des, '\<beta> des) rel"

notation des_vars_child_lens ("\<Sigma>\<^sub>D")

lemma ok_des_bij_lens: "bij_lens (ok +\<^sub>L \<Sigma>\<^sub>D)"
  by (unfold_locales, simp_all add: ok_def des_vars_child_lens_def lens_plus_def prod.case_eq_if)

text {* Define the lens functor for designs *}

definition lmap_des_vars :: "('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> ('\<alpha> des_vars_scheme \<Longrightarrow> '\<beta> des_vars_scheme)" ("lmap\<^sub>D")
  where "lmap_des_vars f = \<lparr> lens_get = \<lambda> v. extend (truncate v) (get\<^bsub>f\<^esub> (more v))
                           , lens_put = \<lambda> s v. extend (truncate v) (put\<^bsub>f\<^esub> (more s) (more v)) \<rparr>"

lemma lmap_des_vars: "vwb_lens f \<Longrightarrow> vwb_lens (lmap_des_vars f)"
  by (unfold_locales, simp_all add: lmap_des_vars_def extend_def truncate_def)

lemma lmap_id: "lmap\<^sub>D 1\<^sub>L = 1\<^sub>L"
  by (simp add: lmap_des_vars_def id_lens_def extend_def truncate_def fun_eq_iff)

lemma lmap_comp: "lmap\<^sub>D (f ;\<^sub>L g) = lmap\<^sub>D f ;\<^sub>L lmap\<^sub>D g"
  by (simp add: lmap_des_vars_def id_lens_def lens_comp_def extend_def truncate_def fun_eq_iff)

text {* The following notations define liftings from non-design predicates into design
  predicates using alphabet extensions. *}

abbreviation lift_desr ("\<lceil>_\<rceil>\<^sub>D")
where "\<lceil>P\<rceil>\<^sub>D \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>D \<times>\<^sub>L \<Sigma>\<^sub>D)"

abbreviation lift_pre_desr ("\<lceil>_\<rceil>\<^sub>D\<^sub><")
where "\<lceil>p\<rceil>\<^sub>D\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>D"

abbreviation lift_post_desr ("\<lceil>_\<rceil>\<^sub>D\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>D\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>D"

abbreviation drop_desr ("\<lfloor>_\<rfloor>\<^sub>D")
where "\<lfloor>P\<rfloor>\<^sub>D \<equiv> P \<restriction>\<^sub>p (\<Sigma>\<^sub>D \<times>\<^sub>L \<Sigma>\<^sub>D)"

definition design::"('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" (infixl "\<turnstile>" 60)
where "P \<turnstile> Q = ($ok \<and> P \<Rightarrow> $ok\<acute> \<and> Q)"

text {* An rdesign is a design that uses the Isabelle type system to prevent reference to ok in the
        assumption and commitment. *}

definition rdesign::"('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" (infixl "\<turnstile>\<^sub>r" 60)
where "(P \<turnstile>\<^sub>r Q) = \<lceil>P\<rceil>\<^sub>D \<turnstile> \<lceil>Q\<rceil>\<^sub>D"

text {* An ndesign is a normal design, i.e. where the assumption is a condition *}

definition ndesign::"'\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" (infixl "\<turnstile>\<^sub>n" 60)
where "(p \<turnstile>\<^sub>n Q) = (\<lceil>p\<rceil>\<^sub>< \<turnstile>\<^sub>r Q)"

definition skip_d :: "'\<alpha> hrel_des" ("II\<^sub>D")
where "II\<^sub>D \<equiv> (true \<turnstile>\<^sub>r II)"

definition assigns_d :: "'\<alpha> usubst \<Rightarrow> '\<alpha> hrel_des" ("\<langle>_\<rangle>\<^sub>D")
where "assigns_d \<sigma> = (true \<turnstile>\<^sub>r assigns_r \<sigma>)"

syntax
  "_assignmentd" :: "svid_list \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr ":=\<^sub>D" 55)

translations
  "_assignmentd xs vs" => "CONST assigns_d (_mk_usubst (CONST id) xs vs)"
  "x :=\<^sub>D v" <= "CONST assigns_d (CONST subst_upd (CONST id) (CONST svar x) v)"
  "x :=\<^sub>D v" <= "CONST assigns_d (CONST subst_upd (CONST id) x v)"
  "x,y :=\<^sub>D u,v" <= "CONST assigns_d (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"

definition J :: "'\<alpha> hrel_des"
where "J = (($ok \<Rightarrow> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D)"

definition "H1 (P)  \<equiv>  $ok \<Rightarrow> P"

definition "H2 (P)  \<equiv>  P ;; J"

definition "H3 (P)  \<equiv>  P ;; II\<^sub>D"

definition "H4 (P)  \<equiv> ((P;;true) \<Rightarrow> P)"

syntax
  "_ok_f"  :: "logic \<Rightarrow> logic" ("_\<^sup>f" [1000] 1000)
  "_ok_t"  :: "logic \<Rightarrow> logic" ("_\<^sup>t" [1000] 1000)
  "_top_d" :: "logic" ("\<top>\<^sub>D")
  "_bot_d" :: "logic" ("\<bottom>\<^sub>D")

translations
  "P\<^sup>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ovar CONST ok) false) P"
  "P\<^sup>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ovar CONST ok) true) P"
  "\<top>\<^sub>D" => "CONST not_upred (CONST utp_expr.var (CONST ivar CONST ok))"
  "\<bottom>\<^sub>D" => "true"

definition pre_design :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel" ("pre\<^sub>D'(_')") where
"pre\<^sub>D(P) = \<lfloor>\<not> P\<lbrakk>true,false/$ok,$ok\<acute>\<rbrakk>\<rfloor>\<^sub>D"

definition post_design :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel" ("post\<^sub>D'(_')") where
"post\<^sub>D(P) = \<lfloor>P\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>\<rfloor>\<^sub>D"

definition wp_design :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> '\<beta> cond \<Rightarrow> '\<alpha> cond" (infix "wp\<^sub>D" 60) where
"Q wp\<^sub>D r = (\<lfloor>pre\<^sub>D(Q) ;; true :: ('\<alpha>, '\<beta>) rel\<rfloor>\<^sub>< \<and> (post\<^sub>D(Q) wp r))"

declare design_def [upred_defs]
declare rdesign_def [upred_defs]
declare ndesign_def [upred_defs]
declare skip_d_def [upred_defs]
declare J_def [upred_defs]
declare pre_design_def [upred_defs]
declare post_design_def [upred_defs]
declare wp_design_def [upred_defs]
declare assigns_d_def [upred_defs]

declare H1_def [upred_defs]
declare H2_def [upred_defs]
declare H3_def [upred_defs]
declare H4_def [upred_defs]

lemma drop_desr_inv [simp]: "\<lfloor>\<lceil>P\<rceil>\<^sub>D\<rfloor>\<^sub>D = P"
  by (simp add: arestr_aext prod_mwb_lens)

lemma lift_desr_inv:
  fixes P :: "('\<alpha>, '\<beta>) rel_des"
  assumes "$ok \<sharp> P" "$ok\<acute> \<sharp> P"
  shows "\<lceil>\<lfloor>P\<rfloor>\<^sub>D\<rceil>\<^sub>D = P"
proof -
  have "bij_lens (\<Sigma>\<^sub>D \<times>\<^sub>L \<Sigma>\<^sub>D +\<^sub>L (in_var ok +\<^sub>L out_var ok) :: (_, '\<alpha> des_vars_scheme \<times> '\<beta> des_vars_scheme) lens)"
    (is "bij_lens (?P)")
  proof -
    have "?P \<approx>\<^sub>L (ok +\<^sub>L \<Sigma>\<^sub>D) \<times>\<^sub>L (ok +\<^sub>L \<Sigma>\<^sub>D)" (is "?P \<approx>\<^sub>L ?Q")
      apply (simp add: in_var_def out_var_def prod_as_plus)
      apply (simp add: prod_as_plus[THEN sym])
      apply (meson lens_equiv_sym lens_equiv_trans lens_indep_prod lens_plus_comm lens_plus_prod_exchange des_vars_indeps(1))
    done
    moreover have "bij_lens ?Q"
      by (simp add: ok_des_bij_lens prod_bij_lens)
    ultimately show ?thesis
      by (metis bij_lens_equiv lens_equiv_sym)
  qed

  with assms show ?thesis
    apply (rule_tac aext_arestr[of _ "in_var ok +\<^sub>L out_var ok"])
    apply (simp add: prod_mwb_lens)
    apply (simp)
    apply (metis alpha_in_var lens_indep_prod lens_indep_sym des_vars_indeps(1) out_var_def prod_as_plus)
    using unrest_var_comp apply blast
  done
qed

subsection {* Design laws *}

lemma unrest_out_des_lift [unrest]: "out\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> \<lceil>p\<rceil>\<^sub>D"
  by (pred_simp, auto simp add: out\<alpha>_def des_vars_child_lens_def)

lemma lift_dist_seq [simp]:
  "\<lceil>P ;; Q\<rceil>\<^sub>D = (\<lceil>P\<rceil>\<^sub>D ;; \<lceil>Q\<rceil>\<^sub>D)"
  by (rel_auto)

lemma lift_des_skip_dr_unit_unrest: "$ok\<acute> \<sharp> P \<Longrightarrow> (P ;; \<lceil>II\<rceil>\<^sub>D) = P"
  by (rel_auto)

lemma true_is_design:
  "(false \<turnstile> true) = true"
  by (rel_auto)

lemma true_is_rdesign:
  "(false \<turnstile>\<^sub>r true) = true"
  by (rel_auto)

lemma design_false_pre:
  "(false \<turnstile> P) = true"
  by (rel_auto)

lemma rdesign_false_pre:
  "(false \<turnstile>\<^sub>r P) = true"
  by (rel_auto)

lemma ndesign_false_pre:
  "(false \<turnstile>\<^sub>n P) = true"
  by (rel_auto)

theorem design_refinement:
  assumes
    "$ok \<sharp> P1" "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2" "$ok\<acute> \<sharp> P2"
    "$ok \<sharp> Q1" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2" "$ok\<acute> \<sharp> Q2"
  shows "(P1 \<turnstile> Q1 \<sqsubseteq> P2 \<turnstile> Q2) \<longleftrightarrow> (`P1 \<Rightarrow> P2` \<and> `P1 \<and> Q2 \<Rightarrow> Q1`)"
proof -
  have "(P1 \<turnstile> Q1) \<sqsubseteq> (P2 \<turnstile> Q2) \<longleftrightarrow> `($ok \<and> P2 \<Rightarrow> $ok\<acute> \<and> Q2) \<Rightarrow> ($ok \<and> P1 \<Rightarrow> $ok\<acute> \<and> Q1)`"
    by (pred_auto)
  also with assms have "... = `(P2 \<Rightarrow> $ok\<acute> \<and> Q2) \<Rightarrow> (P1 \<Rightarrow> $ok\<acute> \<and> Q1)`"
    by (subst subst_bool_split[of "in_var ok"], simp_all, subst_tac)
  also with assms have "... = `(\<not> P2 \<Rightarrow> \<not> P1) \<and> ((P2 \<Rightarrow> Q2) \<Rightarrow> P1 \<Rightarrow> Q1)`"
    by (subst subst_bool_split[of "out_var ok"], simp_all, subst_tac)
  also have "... \<longleftrightarrow> `(P1 \<Rightarrow> P2)` \<and> `P1 \<and> Q2 \<Rightarrow> Q1`"
    by (pred_auto)
  finally show ?thesis .
qed

theorem rdesign_refinement:
  "(P1 \<turnstile>\<^sub>r Q1 \<sqsubseteq> P2 \<turnstile>\<^sub>r Q2) \<longleftrightarrow> (`P1 \<Rightarrow> P2` \<and> `P1 \<and> Q2 \<Rightarrow> Q1`)"
  by (rel_auto)

lemma design_refine_intro:
  assumes "`P1 \<Rightarrow> P2`" "`P1 \<and> Q2 \<Rightarrow> Q1`"
  shows "P1 \<turnstile> Q1 \<sqsubseteq> P2 \<turnstile> Q2"
  using assms unfolding upred_defs
  by (pred_auto)

lemma design_refine_intro':
  assumes "P\<^sub>2 \<sqsubseteq> P\<^sub>1" "Q\<^sub>1 \<sqsubseteq> (P\<^sub>1 \<and> Q\<^sub>2)"
  shows "P\<^sub>1 \<turnstile> Q\<^sub>1 \<sqsubseteq> P\<^sub>2 \<turnstile> Q\<^sub>2"
  using assms design_refine_intro[of P\<^sub>1 P\<^sub>2 Q\<^sub>2 Q\<^sub>1] by (simp add: refBy_order)

lemma rdesign_refine_intro:
  assumes "`P1 \<Rightarrow> P2`" "`P1 \<and> Q2 \<Rightarrow> Q1`"
  shows "P1 \<turnstile>\<^sub>r Q1 \<sqsubseteq> P2 \<turnstile>\<^sub>r Q2"
  using assms unfolding upred_defs
  by (pred_auto)

lemma ndesign_refine_intro:
  assumes "`p1 \<Rightarrow> p2`" "`\<lceil>p1\<rceil>\<^sub>< \<and> Q2 \<Rightarrow> Q1`"
  shows "p1 \<turnstile>\<^sub>n Q1 \<sqsubseteq> p2 \<turnstile>\<^sub>n Q2"
  using assms unfolding upred_defs
  by (pred_auto)

lemma design_subst [usubst]:
  "\<lbrakk> $ok \<sharp> \<sigma>; $ok\<acute> \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (P \<turnstile> Q) = (\<sigma> \<dagger> P) \<turnstile> (\<sigma> \<dagger> Q)"
  by (simp add: design_def usubst)

theorem design_ok_false [usubst]: "(P \<turnstile> Q)\<lbrakk>false/$ok\<rbrakk> = true"
  by (simp add: design_def usubst)

theorem design_npre:
  "(P \<turnstile> Q)\<^sup>f = (\<not> $ok \<or> \<not> P\<^sup>f)"
  by (rel_auto)

theorem design_pre:
  "\<not> (P \<turnstile> Q)\<^sup>f = ($ok \<and> P\<^sup>f)"
  by (simp add: design_def, subst_tac)
     (metis (no_types, hide_lams) not_conj_deMorgans true_not_false(2) utp_pred.compl_top_eq
            utp_pred.sup.idem utp_pred.sup_compl_top)

theorem design_post:
  "(P \<turnstile> Q)\<^sup>t = (($ok \<and> P\<^sup>t) \<Rightarrow> Q\<^sup>t)"
  by (rel_auto)

theorem rdesign_pre [simp]: "pre\<^sub>D(P \<turnstile>\<^sub>r Q) = P"
  by (pred_auto)

theorem rdesign_post [simp]: "post\<^sub>D(P \<turnstile>\<^sub>r Q) = (P \<Rightarrow> Q)"
  by (pred_auto)

theorem design_true_left_zero: "(true ;; (P \<turnstile> Q)) = true"
proof -
  have "(true ;; (P \<turnstile> Q)) = (\<^bold>\<exists> ok\<^sub>0 \<bullet> true\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<rbrakk>)"
    by (subst seqr_middle[of ok], simp_all)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>false/$ok\<rbrakk>) \<or> (true\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: disj_comm false_alt_def true_alt_def)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; true\<^sub>h) \<or> (true ;; ((P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>)))"
    by (subst_tac, rel_auto)
  also have "... = true"
    by (subst_tac, simp add: precond_right_unit unrest)
  finally show ?thesis .
qed

theorem design_top_left_zero: "(\<top>\<^sub>D ;; (P \<turnstile> Q)) = \<top>\<^sub>D"
  by (rel_auto)

theorem design_choice:
  "(P\<^sub>1 \<turnstile> P\<^sub>2) \<sqinter> (Q\<^sub>1 \<turnstile> Q\<^sub>2) = ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> (P\<^sub>2 \<or> Q\<^sub>2))"
  by (rel_auto)

theorem design_inf:
  "(P\<^sub>1 \<turnstile> P\<^sub>2) \<squnion> (Q\<^sub>1 \<turnstile> Q\<^sub>2) = ((P\<^sub>1 \<or> Q\<^sub>1) \<turnstile> ((P\<^sub>1 \<Rightarrow> P\<^sub>2) \<and> (Q\<^sub>1 \<Rightarrow> Q\<^sub>2)))"
  by (rel_auto)

theorem rdesign_choice:
  "(P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2) \<sqinter> (Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2) = ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile>\<^sub>r (P\<^sub>2 \<or> Q\<^sub>2))"
  by (rel_auto)

theorem design_condr:
  "((P\<^sub>1 \<turnstile> P\<^sub>2) \<triangleleft> b \<triangleright> (Q\<^sub>1 \<turnstile> Q\<^sub>2)) = ((P\<^sub>1 \<triangleleft> b \<triangleright> Q\<^sub>1) \<turnstile> (P\<^sub>2 \<triangleleft> b \<triangleright> Q\<^sub>2))"
  by (rel_auto)

lemma design_top:
  "(P \<turnstile> Q) \<sqsubseteq> \<top>\<^sub>D"
  by (rel_auto)

lemma design_bottom:
  "\<bottom>\<^sub>D \<sqsubseteq> (P \<turnstile> Q)"
  by simp

lemma design_USUP:
  assumes "A \<noteq> {}"
  shows "(\<Sqinter> i \<in> A \<bullet> P(i) \<turnstile> Q(i)) = (\<Squnion> i \<in> A \<bullet> P(i)) \<turnstile> (\<Sqinter> i \<in> A \<bullet> Q(i))"
  using assms by (rel_auto)

lemma design_UINF:
  "(\<Squnion> i \<in> A \<bullet> P(i) \<turnstile> Q(i)) = (\<Sqinter> i \<in> A \<bullet> P(i)) \<turnstile> (\<Squnion> i \<in> A \<bullet> P(i) \<Rightarrow> Q(i))"
  by (rel_auto)

theorem design_composition_subst:
  assumes
    "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2"
  shows "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) =
         (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (\<not> P2))) \<turnstile> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; Q2\<lbrakk>true/$ok\<rbrakk>))"
proof -
  have "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = (\<^bold>\<exists> ok\<^sub>0 \<bullet> ((P1 \<turnstile> Q1)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<acute>\<rbrakk> ;; (P2 \<turnstile> Q2)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<rbrakk>))"
    by (rule seqr_middle, simp)
  also have " ...
        = (((P1 \<turnstile> Q1)\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (P2 \<turnstile> Q2)\<lbrakk>false/$ok\<rbrakk>)
            \<or> ((P1 \<turnstile> Q1)\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (P2 \<turnstile> Q2)\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: true_alt_def false_alt_def, pred_auto)
  also from assms
  have "... = ((($ok \<and> P1 \<Rightarrow> Q1\<lbrakk>true/$ok\<acute>\<rbrakk>) ;; (P2 \<Rightarrow> $ok\<acute> \<and> Q2\<lbrakk>true/$ok\<rbrakk>)) \<or> ((\<not> ($ok \<and> P1)) ;; true))"
    by (simp add: design_def usubst unrest, pred_auto)
  also have "... = ((\<not>$ok ;; true\<^sub>h) \<or> ((\<not>P1) ;; true) \<or> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (\<not>P2)) \<or> ($ok\<acute> \<and> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; Q2\<lbrakk>true/$ok\<rbrakk>)))"
    by (rel_auto)
  also have "... = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (\<not> P2))) \<turnstile> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; Q2\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: precond_right_unit design_def unrest, rel_auto)
  finally show ?thesis .
qed

lemma design_export_ok:
  "P \<turnstile> Q = (P \<turnstile> ($ok \<and> Q))"
  by (rel_auto)

lemma design_export_ok':
  "P \<turnstile> Q = (P \<turnstile> ($ok\<acute> \<and> Q))"
  by (rel_auto)

lemma design_export_pre: "P \<turnstile> (P \<and> Q) = P \<turnstile> Q"
  by (rel_auto)

lemma design_ok_pre_conj: "($ok \<and> P) \<turnstile> Q = P \<turnstile> Q"
  by (rel_auto)

theorem design_composition:
  assumes
    "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2"
  shows "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile> (Q1 ;; Q2))"
  using assms by (simp add: design_composition_subst usubst)

lemma runrest_ident_var:
  assumes "x \<sharp>\<sharp> P"
  shows "($x \<and> P) = (P \<and> $x\<acute>)"
proof -
  have "P = ($x\<acute> =\<^sub>u $x \<and> P)"
    by (metis RID_def assms unrest_relation_def utp_pred.inf.cobounded2 utp_pred.inf_absorb2)
  moreover have "($x\<acute> =\<^sub>u $x \<and> ($x \<and> P)) = ($x\<acute> =\<^sub>u $x \<and> (P \<and> $x\<acute>))"
    by (rel_auto)
  ultimately show ?thesis
    by (metis utp_pred.inf.assoc utp_pred.inf_left_commute)
qed

theorem design_composition_runrest:
  assumes
    "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2" "ok \<sharp>\<sharp> Q1" "ok \<sharp>\<sharp> Q2"
  shows "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1\<^sup>t ;; (\<not> P2))) \<turnstile> (Q1 ;; Q2))"
proof -
  have "($ok \<and> $ok\<acute> \<and> (Q1\<^sup>t ;; Q2\<lbrakk>true/$ok\<rbrakk>)) = ($ok \<and> $ok\<acute> \<and> (Q1 ;; Q2))"
  proof -
    have "($ok \<and> $ok\<acute> \<and> (Q1 ;; Q2)) = (($ok \<and> Q1) ;; (Q2 \<and> $ok\<acute>))"
      by (metis (no_types, lifting) conj_comm seqr_post_var_out seqr_pre_var_out)
    also have "... = ((Q1 \<and> $ok\<acute>) ;; ($ok \<and> Q2))"
      by (simp add: assms(3) assms(4) runrest_ident_var)
    also have "... = (Q1\<^sup>t ;; Q2\<lbrakk>true/$ok\<rbrakk>)"
      by (metis ok_vwb_lens seqr_pre_transfer seqr_right_one_point true_alt_def uovar_convr upred_eq_true utp_pred.inf.left_idem utp_urel_laws.unrest_ouvar vwb_lens_mwb)
    finally show ?thesis
      by (metis utp_pred.inf.left_commute utp_pred.inf_left_idem)
  qed
  moreover have "(\<not> (\<not> P1 ;; true) \<and> \<not> (Q1\<^sup>t ;; (\<not> P2))) \<turnstile> (Q1\<^sup>t ;; Q2\<lbrakk>true/$ok\<rbrakk>) =
                 (\<not> (\<not> P1 ;; true) \<and> \<not> (Q1\<^sup>t ;; (\<not> P2))) \<turnstile> ($ok \<and> $ok\<acute> \<and> (Q1\<^sup>t ;; Q2\<lbrakk>true/$ok\<rbrakk>))"
    by (metis design_export_ok design_export_ok')
  ultimately show ?thesis using assms
    by (simp add: design_composition_subst usubst, metis design_export_ok design_export_ok')
qed

theorem rdesign_composition:
  "((P1 \<turnstile>\<^sub>r Q1) ;; (P2 \<turnstile>\<^sub>r Q2)) = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile>\<^sub>r (Q1 ;; Q2))"
  by (simp add: rdesign_def design_composition unrest alpha)

lemma skip_d_alt_def: "II\<^sub>D = true \<turnstile> II"
  by (rel_auto)

theorem design_skip_idem [simp]:
  "(II\<^sub>D ;; II\<^sub>D) = II\<^sub>D"
  by (rel_auto)

theorem design_composition_cond:
  assumes
    "out\<alpha> \<sharp> p1" "$ok \<sharp> P2" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2"
  shows "((p1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = ((p1 \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile> (Q1 ;; Q2))"
  using assms
  by (simp add: design_composition unrest precond_right_unit)

theorem rdesign_composition_cond:
  assumes "out\<alpha> \<sharp> p1"
  shows "((p1 \<turnstile>\<^sub>r Q1) ;; (P2 \<turnstile>\<^sub>r Q2)) = ((p1 \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile>\<^sub>r (Q1 ;; Q2))"
  using assms
  by (simp add: rdesign_def design_composition_cond unrest alpha)

theorem design_composition_wp:
  assumes
    "ok \<sharp> p1" "ok \<sharp> p2"
    "$ok \<sharp> Q1" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2" "$ok\<acute> \<sharp> Q2"
  shows "((\<lceil>p1\<rceil>\<^sub>< \<turnstile> Q1) ;; (\<lceil>p2\<rceil>\<^sub>< \<turnstile> Q2)) = ((\<lceil>p1 \<and> Q1 wp p2\<rceil>\<^sub><) \<turnstile> (Q1 ;; Q2))"
  using assms by (rel_blast)

theorem rdesign_composition_wp:
  "((\<lceil>p1\<rceil>\<^sub>< \<turnstile>\<^sub>r Q1) ;; (\<lceil>p2\<rceil>\<^sub>< \<turnstile>\<^sub>r Q2)) = ((\<lceil>p1 \<and> Q1 wp p2\<rceil>\<^sub><) \<turnstile>\<^sub>r (Q1 ;; Q2))"
  by (rel_blast)

theorem ndesign_composition_wp:
  "((p1 \<turnstile>\<^sub>n Q1) ;; (p2 \<turnstile>\<^sub>n Q2)) = ((p1 \<and> Q1 wp p2) \<turnstile>\<^sub>n (Q1 ;; Q2))"
  by (rel_blast)

theorem rdesign_wp [wp]:
  "(\<lceil>p\<rceil>\<^sub>< \<turnstile>\<^sub>r Q) wp\<^sub>D r = (p \<and> Q wp r)"
  by (rel_auto)

theorem ndesign_wp [wp]:
  "(p \<turnstile>\<^sub>n Q) wp\<^sub>D r = (p \<and> Q wp r)"
  by (simp add: ndesign_def rdesign_wp)

theorem wpd_seq_r:
  fixes Q1 Q2 :: "'\<alpha> hrel"
  shows "(\<lceil>p1\<rceil>\<^sub>< \<turnstile>\<^sub>r Q1 ;; \<lceil>p2\<rceil>\<^sub>< \<turnstile>\<^sub>r Q2) wp\<^sub>D r = (\<lceil>p1\<rceil>\<^sub>< \<turnstile>\<^sub>r Q1) wp\<^sub>D ((\<lceil>p2\<rceil>\<^sub>< \<turnstile>\<^sub>r Q2) wp\<^sub>D r)"
  apply (simp add: wp)
  apply (subst rdesign_composition_wp)
  apply (simp only: wp)
  apply (rel_auto)
done

theorem wpnd_seq_r [wp]:
  fixes Q1 Q2 :: "'\<alpha> hrel"
  shows "(p1 \<turnstile>\<^sub>n Q1 ;; p2 \<turnstile>\<^sub>n Q2) wp\<^sub>D r = (p1 \<turnstile>\<^sub>n Q1) wp\<^sub>D ((p2 \<turnstile>\<^sub>n Q2) wp\<^sub>D r)"
  by (simp add: ndesign_def wpd_seq_r)

lemma design_subst_ok:
  "(P\<lbrakk>true/$ok\<rbrakk> \<turnstile> Q\<lbrakk>true/$ok\<rbrakk>) = (P \<turnstile> Q)"
  by (rel_auto)

lemma design_subst_ok_ok':
  "(P\<lbrakk>true/$ok\<rbrakk> \<turnstile> Q\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>) = (P \<turnstile> Q)"
proof -
  have "(P \<turnstile> Q) = (($ok \<and> P) \<turnstile> ($ok \<and> $ok\<acute> \<and> Q))"
    by (pred_auto)
  also have "... = (($ok \<and> P\<lbrakk>true/$ok\<rbrakk>) \<turnstile> ($ok \<and> ($ok\<acute> \<and> Q\<lbrakk>true/$ok\<acute>\<rbrakk>)\<lbrakk>true/$ok\<rbrakk>))"
    by (metis conj_eq_out_var_subst conj_pos_var_subst upred_eq_true utp_pred.inf_commute ok_vwb_lens)
  also have "... = (($ok \<and> P\<lbrakk>true/$ok\<rbrakk>) \<turnstile> ($ok \<and> $ok\<acute> \<and> Q\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>))"
    by (simp add: usubst)
  also have "... = (P\<lbrakk>true/$ok\<rbrakk> \<turnstile> Q\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>)"
    by (pred_auto)
  finally show ?thesis ..
qed

lemma design_subst_ok':
  "(P \<turnstile> Q\<lbrakk>true/$ok\<acute>\<rbrakk>) = (P \<turnstile> Q)"
proof -
  have "(P \<turnstile> Q) = (P \<turnstile> ($ok\<acute> \<and> Q))"
    by (pred_auto)
  also have "... = (P \<turnstile> ($ok\<acute> \<and> Q\<lbrakk>true/$ok\<acute>\<rbrakk>))"
    by (metis conj_eq_out_var_subst upred_eq_true utp_pred.inf_commute ok_vwb_lens)
  also have "... = (P \<turnstile> Q\<lbrakk>true/$ok\<acute>\<rbrakk>)"
    by (pred_auto)
  finally show ?thesis ..
qed

theorem design_left_unit_hom:
  fixes P Q :: "'\<alpha> hrel_des"
  shows "(II\<^sub>D ;; P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
proof -
  have "(II\<^sub>D ;; P \<turnstile>\<^sub>r Q) = (true \<turnstile>\<^sub>r II ;; P \<turnstile>\<^sub>r Q)"
    by (simp add: skip_d_def)
  also have "... = (true \<and> \<not> (II ;; (\<not> P))) \<turnstile>\<^sub>r (II ;; Q)"
  proof -
    have "out\<alpha> \<sharp> true"
      by unrest_tac
    thus ?thesis
      using rdesign_composition_cond by blast
  qed
  also have "... = (\<not> (\<not> P)) \<turnstile>\<^sub>r Q"
    by simp
  finally show ?thesis by simp
qed

theorem design_left_unit [simp]:
  "(II\<^sub>D ;; P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
  by (rel_auto)

theorem design_right_semi_unit:
  "(P \<turnstile>\<^sub>r Q ;; II\<^sub>D) = ((\<not> (\<not> P) ;; true) \<turnstile>\<^sub>r Q)"
  by (simp add: skip_d_def rdesign_composition)

theorem design_right_cond_unit [simp]:
  assumes "out\<alpha> \<sharp> p"
  shows "(p \<turnstile>\<^sub>r Q ;; II\<^sub>D) = (p \<turnstile>\<^sub>r Q)"
  using assms
  by (simp add: skip_d_def rdesign_composition_cond)

lemma lift_des_skip_dr_unit [simp]:
  "(\<lceil>P\<rceil>\<^sub>D ;; \<lceil>II\<rceil>\<^sub>D) = \<lceil>P\<rceil>\<^sub>D"
  "(\<lceil>II\<rceil>\<^sub>D ;; \<lceil>P\<rceil>\<^sub>D) = \<lceil>P\<rceil>\<^sub>D"
  by (rel_auto)+

lemma assigns_d_id [simp]: "\<langle>id\<rangle>\<^sub>D = II\<^sub>D"
  by (rel_auto)

lemma assign_d_left_comp:
  "(\<langle>f\<rangle>\<^sub>D ;; (P \<turnstile>\<^sub>r Q)) = (\<lceil>f\<rceil>\<^sub>s \<dagger> P \<turnstile>\<^sub>r \<lceil>f\<rceil>\<^sub>s \<dagger> Q)"
  by (simp add: assigns_d_def rdesign_composition assigns_r_comp subst_not)

lemma assign_d_right_comp:
  "((P \<turnstile>\<^sub>r Q) ;; \<langle>f\<rangle>\<^sub>D) = ((\<not> ((\<not> P) ;; true)) \<turnstile>\<^sub>r (Q ;; \<langle>f\<rangle>\<^sub>a))"
  by (simp add: assigns_d_def rdesign_composition)

lemma assigns_d_comp:
  "(\<langle>f\<rangle>\<^sub>D ;; \<langle>g\<rangle>\<^sub>D) = \<langle>g \<circ> f\<rangle>\<^sub>D"
  by (simp add: assigns_d_def rdesign_composition assigns_comp)

subsection {* Design preconditions *}

lemma design_pre_choice [simp]:
  "pre\<^sub>D(P \<sqinter> Q) = (pre\<^sub>D(P) \<and> pre\<^sub>D(Q))"
  by (rel_auto)

lemma design_post_choice [simp]:
  "post\<^sub>D(P \<sqinter> Q) = (post\<^sub>D(P) \<or> post\<^sub>D(Q))"
  by (rel_auto)

lemma design_pre_condr [simp]:
  "pre\<^sub>D(P \<triangleleft> \<lceil>b\<rceil>\<^sub>D \<triangleright> Q) = (pre\<^sub>D(P) \<triangleleft> b \<triangleright> pre\<^sub>D(Q))"
  by (rel_auto)

lemma design_post_condr [simp]:
  "post\<^sub>D(P \<triangleleft> \<lceil>b\<rceil>\<^sub>D \<triangleright> Q) = (post\<^sub>D(P) \<triangleleft> b \<triangleright> post\<^sub>D(Q))"
  by (rel_auto)

subsection {* H1: No observation is allowed before initiation *}

lemma H1_idem:
  "H1 (H1 P) = H1(P)"
  by (pred_auto)

lemma H1_monotone:
  "P \<sqsubseteq> Q \<Longrightarrow> H1(P) \<sqsubseteq> H1(Q)"
  by (pred_auto)

lemma H1_Continuous: "Continuous H1"
  by (rel_auto)

lemma H1_below_top:
  "H1(P) \<sqsubseteq> \<top>\<^sub>D"
  by (pred_auto)

lemma H1_design_skip:
  "H1(II) = II\<^sub>D"
  by (rel_auto)

lemma H1_cond: "H1(P \<triangleleft> b \<triangleright> Q) = H1(P) \<triangleleft> b \<triangleright> H1(Q)"
  by (rel_auto)

lemma H1_conj: "H1(P \<and> Q) = (H1(P) \<and> H1(Q))"
  by (rel_auto)

lemma H1_disj: "H1(P \<or> Q) = (H1(P) \<or> H1(Q))"
  by (rel_auto)

lemma design_export_H1: "(P \<turnstile> Q) = (P \<turnstile> H1(Q))"
  by (rel_auto)

text {* The H1 algebraic laws are valid only when $\alpha(R)$ is homogeneous. This should maybe be
        generalised. *}

theorem H1_algebraic_intro:
  assumes
    "(true\<^sub>h ;; R) = true\<^sub>h"
    "(II\<^sub>D ;; R) = R"
  shows "R is H1"
proof -
  have "R = (II\<^sub>D ;; R)" by (simp add: assms(2))
  also have "... = (H1(II) ;; R)"
    by (simp add: H1_design_skip)
  also have "... = (($ok \<Rightarrow> II) ;; R)"
    by (simp add: H1_def)
  also have "... = (((\<not> $ok) ;; R) \<or> R)"
    by (simp add: impl_alt_def seqr_or_distl)
  also have "... = ((((\<not> $ok) ;; true\<^sub>h) ;; R) \<or> R)"
    by (simp add: precond_right_unit unrest)
  also have "... = (((\<not> $ok) ;; true\<^sub>h) \<or> R)"
    by (metis assms(1) seqr_assoc)
  also have "... = ($ok \<Rightarrow> R)"
    by (simp add: impl_alt_def precond_right_unit unrest)
  finally show ?thesis by (metis H1_def Healthy_def')
qed

lemma nok_not_false:
  "(\<not> $ok) \<noteq> false"
  by (pred_auto)

theorem H1_left_zero:
  assumes "P is H1"
  shows "(true ;; P) = true"
proof -
  from assms have "(true ;; P) = (true ;; ($ok \<Rightarrow> P))"
    by (simp add: H1_def Healthy_def')
  (* The next step ensures we get the right alphabet for true by copying it *)
  also from assms have "... = (true ;; (\<not> $ok \<or> P))" (is "_ = (?true ;; _)")
    by (simp add: impl_alt_def)
  also from assms have "... = ((?true ;; (\<not> $ok)) \<or> (?true ;; P))"
    using seqr_or_distr by blast
  also from assms have "... = (true \<or> (true ;; P))"
    by (simp add: nok_not_false precond_left_zero unrest)
  finally show ?thesis
    by (simp add: upred_defs urel_defs)
qed

theorem H1_left_unit:
  fixes P :: "'\<alpha> hrel_des"
  assumes "P is H1"
  shows "(II\<^sub>D ;; P) = P"
proof -
  have "(II\<^sub>D ;; P) = (($ok \<Rightarrow> II) ;; P)"
    by (metis H1_def H1_design_skip)
  also have "... = (((\<not> $ok) ;; P) \<or> P)"
    by (simp add: impl_alt_def seqr_or_distl)
  also from assms have "... = ((((\<not> $ok) ;; true\<^sub>h) ;; P) \<or> P)"
    by (simp add: precond_right_unit unrest)
  also have "... = (((\<not> $ok) ;; (true\<^sub>h ;; P)) \<or> P)"
    by (simp add: seqr_assoc)
  also from assms have "... = ($ok \<Rightarrow> P)"
    by (simp add: H1_left_zero impl_alt_def precond_right_unit unrest)
  finally show ?thesis using assms
    by (simp add: H1_def Healthy_def')
qed

theorem H1_algebraic:
  "P is H1 \<longleftrightarrow> (true\<^sub>h ;; P) = true\<^sub>h \<and> (II\<^sub>D ;; P) = P"
  using H1_algebraic_intro H1_left_unit H1_left_zero by blast

theorem H1_nok_left_zero:
  fixes P :: "'\<alpha> hrel_des"
  assumes "P is H1"
  shows "((\<not> $ok) ;; P) = (\<not> $ok)"
proof -
  have "((\<not> $ok) ;; P) = (((\<not> $ok) ;; true\<^sub>h) ;; P)"
    by (simp add: precond_right_unit unrest)
  also have "... = ((\<not> $ok) ;; true\<^sub>h)"
    by (metis H1_left_zero assms seqr_assoc)
  also have "... = (\<not> $ok)"
    by (simp add: precond_right_unit unrest)
  finally show ?thesis .
qed

lemma H1_design:
  "H1(P \<turnstile> Q) = (P \<turnstile> Q)"
  by (rel_auto)

lemma H1_rdesign:
  "H1(P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
  by (rel_auto)

lemma H1_choice_closed:
  "\<lbrakk> P is H1; Q is H1 \<rbrakk> \<Longrightarrow> P \<sqinter> Q is H1"
  by (simp add: H1_def Healthy_def' disj_upred_def impl_alt_def semilattice_sup_class.sup_left_commute)

lemma H1_inf_closed:
  "\<lbrakk> P is H1; Q is H1 \<rbrakk> \<Longrightarrow> P \<squnion> Q is H1"
  by (rel_blast)

lemma H1_USUP:
  assumes "A \<noteq> {}"
  shows "H1(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> H1(P(i)))"
  using assms by (rel_auto)

lemma H1_Sup:
  assumes "A \<noteq> {}" "\<forall> P \<in> A. P is H1"
  shows "(\<Sqinter> A) is H1"
proof -
  from assms(2) have "H1 ` A = A"
    by (auto simp add: Healthy_def rev_image_eqI)
  with H1_USUP[of A id, OF assms(1)] show ?thesis
    using assms
    by (simp add: USUP_as_Sup_image Healthy_def)
qed

lemma H1_UINF:
  shows "H1(\<Squnion> i \<in> A \<bullet> P(i)) = (\<Squnion> i \<in> A \<bullet> H1(P(i)))"
  by (rel_auto)

lemma H1_Inf:
  assumes "\<forall> P \<in> A. P is H1"
  shows "(\<Squnion> A) is H1"
proof -
  from assms have "H1 ` A = A"
    by (auto simp add: Healthy_def rev_image_eqI)
  with H1_UINF[of A id] show ?thesis
    using assms
    by (simp add: UINF_as_Inf_image Healthy_def)
qed

subsection {* H2: A specification cannot require non-termination *}

lemma J_split:
  shows "(P ;; J) = (P\<^sup>f \<or> (P\<^sup>t \<and> $ok\<acute>))"
proof -
  have "(P ;; J) = (P ;; (($ok \<Rightarrow> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D))"
    by (simp add: H2_def J_def design_def)
  also have "... = (P ;; (($ok \<Rightarrow> $ok \<and> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D))"
    by (rel_auto)
  also have "... = ((P ;; (\<not> $ok \<and> \<lceil>II\<rceil>\<^sub>D)) \<or> (P ;; ($ok \<and> (\<lceil>II\<rceil>\<^sub>D \<and> $ok\<acute>))))"
    by (rel_auto)
  also have "... = (P\<^sup>f \<or> (P\<^sup>t \<and> $ok\<acute>))"
  proof -
    have "(P ;; (\<not> $ok \<and> \<lceil>II\<rceil>\<^sub>D)) = P\<^sup>f"
    proof -
      have "(P ;; (\<not> $ok \<and> \<lceil>II\<rceil>\<^sub>D)) = ((P \<and> \<not> $ok\<acute>) ;; \<lceil>II\<rceil>\<^sub>D)"
        by (rel_auto)
      also have "... = (\<exists> $ok\<acute> \<bullet> P \<and> $ok\<acute> =\<^sub>u false)"
        by (rel_auto)
      also have "... = P\<^sup>f"
        by (metis C1 one_point out_var_uvar unrest_as_exists ok_vwb_lens vwb_lens_mwb)
     finally show ?thesis .
    qed
    moreover have "(P ;; ($ok \<and> (\<lceil>II\<rceil>\<^sub>D \<and> $ok\<acute>))) = (P\<^sup>t \<and> $ok\<acute>)"
    proof -
      have "(P ;; ($ok \<and> (\<lceil>II\<rceil>\<^sub>D \<and> $ok\<acute>))) = (P ;; ($ok \<and> II))"
        by (rel_auto)
      also have "... = (P\<^sup>t \<and> $ok\<acute>)"
        by (rel_auto)
      finally show ?thesis .
    qed
    ultimately show ?thesis
      by simp
  qed
  finally show ?thesis .
qed

lemma H2_split:
  shows "H2(P) = (P\<^sup>f \<or> (P\<^sup>t \<and> $ok\<acute>))"
  by (simp add: H2_def J_split)

theorem H2_equivalence:
  "P is H2 \<longleftrightarrow> `P\<^sup>f \<Rightarrow> P\<^sup>t`"
proof -
  have "`P \<Leftrightarrow> (P ;; J)` \<longleftrightarrow> `P \<Leftrightarrow> (P\<^sup>f \<or> (P\<^sup>t \<and> $ok\<acute>))`"
    by (simp add: J_split)
  also have "... \<longleftrightarrow> `(P \<Leftrightarrow> P\<^sup>f \<or> P\<^sup>t \<and> $ok\<acute>)\<^sup>f \<and> (P \<Leftrightarrow> P\<^sup>f \<or> P\<^sup>t \<and> $ok\<acute>)\<^sup>t`"
    by (simp add: subst_bool_split)
  also have "... = `(P\<^sup>f \<Leftrightarrow> P\<^sup>f) \<and> (P\<^sup>t \<Leftrightarrow> P\<^sup>f \<or> P\<^sup>t)`"
    by subst_tac
  also have "... = `P\<^sup>t \<Leftrightarrow> (P\<^sup>f \<or> P\<^sup>t)`"
    by (pred_auto robust)
  also have "... = `(P\<^sup>f \<Rightarrow> P\<^sup>t)`"
    by (pred_auto)
  finally show ?thesis
    by (metis H2_def Healthy_def' taut_iff_eq)
qed

lemma H2_equiv:
  "P is H2 \<longleftrightarrow> P\<^sup>t \<sqsubseteq> P\<^sup>f"
  using H2_equivalence refBy_order by blast

lemma H2_design:
  assumes "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q"
  shows "H2(P \<turnstile> Q) = P \<turnstile> Q"
  using assms
  by (simp add: H2_split design_def usubst unrest, pred_auto)

lemma H2_rdesign:
  "H2(P \<turnstile>\<^sub>r Q) = P \<turnstile>\<^sub>r Q"
  by (simp add: H2_design unrest rdesign_def)

theorem J_idem:
  "(J ;; J) = J"
  by (rel_auto)

theorem H2_idem:
  "H2(H2(P)) = H2(P)"
  by (metis H2_def J_idem seqr_assoc)

theorem H2_Continuous: "Continuous H2"
  by (rel_auto)

theorem H2_not_okay: "H2 (\<not> $ok) = (\<not> $ok)"
proof -
  have "H2 (\<not> $ok) = ((\<not> $ok)\<^sup>f \<or> ((\<not> $ok)\<^sup>t \<and> $ok\<acute>))"
    by (simp add: H2_split)
  also have "... = (\<not> $ok \<or> (\<not> $ok) \<and> $ok\<acute>)"
    by (subst_tac)
  also have "... = (\<not> $ok)"
    by (pred_auto)
  finally show ?thesis .
qed

lemma H2_true: "H2(true) = true"
  by (rel_auto)

lemma H2_choice_closed:
  "\<lbrakk> P is H2; Q is H2 \<rbrakk> \<Longrightarrow> P \<sqinter> Q is H2"
  by (metis H2_def Healthy_def' disj_upred_def seqr_or_distl)

lemma H2_inf_closed:
  assumes "P is H2" "Q is H2"
  shows "P \<squnion> Q is H2"
proof -
  have "P \<squnion> Q = (P\<^sup>f \<or> P\<^sup>t \<and> $ok\<acute>) \<squnion> (Q\<^sup>f \<or> Q\<^sup>t \<and> $ok\<acute>)"
    by (metis H2_def Healthy_def J_split assms(1) assms(2))
  moreover have "H2(...) = ..."
    by (simp add: H2_split usubst, pred_auto)
  ultimately show ?thesis
    by (simp add: Healthy_def)
qed

lemma H2_USUP:
  shows "H2(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> H2(P(i)))"
  by (rel_auto)

theorem H1_H2_commute:
  "H1 (H2 P) = H2 (H1 P)"
proof -
  have "H2 (H1 P) = (($ok \<Rightarrow> P) ;; J)"
    by (simp add: H1_def H2_def)
  also have "... = ((\<not> $ok \<or> P) ;; J)"
    by (rel_auto)
  also have "... = (((\<not> $ok) ;; J) \<or> (P ;; J))"
    using seqr_or_distl by blast
  also have "... =  ((H2 (\<not> $ok)) \<or> H2(P))"
    by (simp add: H2_def)
  also have "... =  ((\<not> $ok) \<or> H2(P))"
    by (simp add: H2_not_okay)
  also have "... = H1(H2(P))"
    by (rel_auto)
  finally show ?thesis by simp
qed

lemma ok_pre: "($ok \<and> \<lceil>pre\<^sub>D(P)\<rceil>\<^sub>D) = ($ok \<and> (\<not> P\<^sup>f))"
  by (pred_auto robust)

lemma ok_post: "($ok \<and> \<lceil>post\<^sub>D(P)\<rceil>\<^sub>D) = ($ok \<and> (P\<^sup>t))"
  by (pred_auto robust)

abbreviation "H1_H2 P \<equiv> H1 (H2 P)"

notation H1_H2 ("\<^bold>H")

lemma H1_H2_comp: "\<^bold>H = H1 \<circ> H2"
  by (auto)

theorem H1_H2_eq_design:
  "\<^bold>H(P) = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
proof -
  have "\<^bold>H(P) = ($ok \<Rightarrow> H2(P))"
    by (simp add: H1_def)
  also have "... = ($ok \<Rightarrow> (P\<^sup>f \<or> (P\<^sup>t \<and> $ok\<acute>)))"
    by (metis H2_split)
  also have "... = ($ok \<and> (\<not> P\<^sup>f) \<Rightarrow> $ok\<acute> \<and> $ok \<and> P\<^sup>t)"
    by (rel_auto)
  also have "... = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
    by (rel_auto)
  finally show ?thesis .
qed

theorem H1_H2_is_design:
  assumes "P is H1" "P is H2"
  shows "P = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
  using assms by (metis H1_H2_eq_design Healthy_def)

theorem H1_H2_eq_rdesign:
  "\<^bold>H(P) = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
proof -
  have "\<^bold>H(P) = ($ok \<Rightarrow> H2(P))"
    by (simp add: H1_def Healthy_def')
  also have "... = ($ok \<Rightarrow> (P\<^sup>f \<or> (P\<^sup>t \<and> $ok\<acute>)))"
    by (metis H2_split)
  also have "... = ($ok \<and> (\<not> P\<^sup>f) \<Rightarrow> $ok\<acute> \<and> P\<^sup>t)"
    by (pred_auto)
  also have "... = ($ok \<and> (\<not> P\<^sup>f) \<Rightarrow> $ok\<acute> \<and> $ok \<and> P\<^sup>t)"
    by (pred_auto)
  also have "... = ($ok \<and> \<lceil>pre\<^sub>D(P)\<rceil>\<^sub>D \<Rightarrow> $ok\<acute> \<and> $ok \<and> \<lceil>post\<^sub>D(P)\<rceil>\<^sub>D)"
    by (simp add: ok_post ok_pre)
  also have "... = ($ok \<and> \<lceil>pre\<^sub>D(P)\<rceil>\<^sub>D \<Rightarrow> $ok\<acute> \<and> \<lceil>post\<^sub>D(P)\<rceil>\<^sub>D)"
    by (pred_auto)
  also have "... =  pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
    by (simp add: rdesign_def design_def)
  finally show ?thesis .
qed

theorem H1_H2_is_rdesign:
  assumes "P is H1" "P is H2"
  shows "P = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
  by (metis H1_H2_eq_rdesign Healthy_def assms(1) assms(2))

lemma H1_H2_idempotent: "\<^bold>H (\<^bold>H P) = \<^bold>H P"
  by (simp add: H1_H2_commute H1_idem H2_idem)

lemma H1_H2_Idempotent: "Idempotent \<^bold>H"
  by (simp add: Idempotent_def H1_H2_idempotent)

lemma H1_H2_monotonic: "Monotonic \<^bold>H"
  by (simp add: H1_monotone H2_def Monotonic_def seqr_mono)

lemma H1_H2_Continuous: "Continuous \<^bold>H"
  by (simp add: Continuous_comp H1_Continuous H1_H2_comp H2_Continuous)

lemma design_is_H1_H2 [closure]:
  "\<lbrakk> $ok\<acute> \<sharp> P; $ok\<acute> \<sharp> Q \<rbrakk> \<Longrightarrow> (P \<turnstile> Q) is \<^bold>H"
  by (simp add: H1_design H2_design Healthy_def')

lemma rdesign_is_H1_H2 [closure]:
  "(P \<turnstile>\<^sub>r Q) is \<^bold>H"
  by (simp add: Healthy_def H1_rdesign H2_rdesign)

lemma assigns_d_is_H1_H2 [closure]:
  "\<langle>\<sigma>\<rangle>\<^sub>D is \<^bold>H"
  by (simp add: assigns_d_def rdesign_is_H1_H2)

lemma seq_r_H1_H2_closed [closure]:
  assumes "P is \<^bold>H" "Q is \<^bold>H"
  shows "(P ;; Q) is \<^bold>H"
proof -
  obtain P\<^sub>1 P\<^sub>2 where "P = P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2"
    by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def assms(1))
  moreover obtain Q\<^sub>1 Q\<^sub>2 where "Q = Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2"
   by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def assms(2))
  moreover have "((P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2) ;; (Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2)) is \<^bold>H"
    by (simp add: rdesign_composition rdesign_is_H1_H2)
  ultimately show ?thesis by simp
qed

lemma assigns_d_comp_ext:
  fixes P :: "'\<alpha> hrel_des"
  assumes "P is \<^bold>H"
  shows "(\<langle>\<sigma>\<rangle>\<^sub>D ;; P) = \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> P"
proof -
  have "(\<langle>\<sigma>\<rangle>\<^sub>D ;; P) = (\<langle>\<sigma>\<rangle>\<^sub>D ;; pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P))"
    by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def' assms)
  also have "... = \<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> pre\<^sub>D(P) \<turnstile>\<^sub>r \<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> post\<^sub>D(P)"
    by (simp add: assign_d_left_comp)
  also have "... = \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> (pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P))"
    by (rel_auto)
  also have "... = \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> P"
    by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def' assms)
  finally show ?thesis .
qed

lemma USUP_H1_H2_closed:
  assumes "A \<noteq> {}" "\<forall> P \<in> A. P is \<^bold>H"
  shows "(\<Sqinter> A) is H1_H2"
proof -
  from assms have A: "A = H1_H2 ` A"
    by (auto simp add: Healthy_def rev_image_eqI)
  also have "(\<Sqinter> ...) = (\<Sqinter> P \<in> A \<bullet> H1_H2(P))"
    by (simp add: USUP_as_Sup_collect)
  also have "... = (\<Sqinter> P \<in> A \<bullet> (\<not> P\<^sup>f) \<turnstile> P\<^sup>t)"
    by (meson H1_H2_eq_design)
  also have "... = (\<Squnion> P \<in> A \<bullet> \<not> P\<^sup>f) \<turnstile> (\<Sqinter> P \<in> A \<bullet> P\<^sup>t)"
    by (simp add: design_USUP assms)
  also have "... is H1_H2"
    by (simp add: design_is_H1_H2 unrest)
  finally show ?thesis .
qed

definition design_sup :: "('\<alpha>, '\<beta>) rel_des set \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" ("\<Sqinter>\<^sub>D_" [900] 900) where
"\<Sqinter>\<^sub>D A = (if (A = {}) then \<top>\<^sub>D else \<Sqinter> A)"

lemma design_sup_H1_H2_closed:
  assumes "\<forall> P \<in> A. P is \<^bold>H"
  shows "(\<Sqinter>\<^sub>D A) is \<^bold>H"
  apply (auto simp add: design_sup_def)
  apply (simp add: H1_def H2_not_okay Healthy_def impl_alt_def)
  using USUP_H1_H2_closed assms apply blast
done

lemma design_sup_empty [simp]: "\<Sqinter>\<^sub>D {} = \<top>\<^sub>D"
  by (simp add: design_sup_def)

lemma design_sup_non_empty [simp]: "A \<noteq> {} \<Longrightarrow> \<Sqinter>\<^sub>D A = \<Sqinter> A"
  by (simp add: design_sup_def)

lemma UINF_H1_H2_closed:
  assumes "\<forall> P \<in> A. P is \<^bold>H"
  shows "(\<Squnion> A) is \<^bold>H"
proof -
  from assms have A: "A = \<^bold>H ` A"
    by (auto simp add: Healthy_def rev_image_eqI)
  also have "(\<Squnion> ...) = (\<Squnion> P \<in> A \<bullet> \<^bold>H(P))"
    by (simp add: UINF_as_Inf_collect)
  also have "... = (\<Squnion> P \<in> A \<bullet> (\<not> P\<^sup>f) \<turnstile> P\<^sup>t)"
    by (meson H1_H2_eq_design)
  also have "... = (\<Sqinter> P \<in> A \<bullet> \<not> P\<^sup>f) \<turnstile> (\<Squnion> P \<in> A \<bullet> \<not> P\<^sup>f \<Rightarrow> P\<^sup>t)"
    by (simp add: design_UINF)
  also have "... is \<^bold>H"
    by (simp add: design_is_H1_H2 unrest)
  finally show ?thesis .
qed

abbreviation design_inf :: "('\<alpha>, '\<beta>) rel_des set \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" ("\<Squnion>\<^sub>D_" [900] 900) where
"\<Squnion>\<^sub>D A \<equiv> \<Squnion> A"

subsection {* H3: The design assumption is a precondition *}

theorem H3_idem:
  "H3(H3(P)) = H3(P)"
  by (metis H3_def design_skip_idem seqr_assoc)

theorem H3_mono:
  "P \<sqsubseteq> Q \<Longrightarrow> H3(P) \<sqsubseteq> H3(Q)"
  by (simp add: H3_def seqr_mono)

theorem H3_Monotonic:
  "Monotonic H3"
  by (simp add: H3_mono Monotonic_def)

theorem H3_Continuous: "Continuous H3"
  by (rel_auto)

theorem design_condition_is_H3:
  assumes "out\<alpha> \<sharp> p"
  shows "(p \<turnstile> Q) is H3"
proof -
  have "((p \<turnstile> Q) ;; II\<^sub>D) = (\<not> ((\<not> p) ;; true)) \<turnstile> (Q\<^sup>t ;; II\<lbrakk>true/$ok\<rbrakk>)"
    by (simp add: skip_d_alt_def design_composition_subst unrest assms)
  also have "... = p \<turnstile> (Q\<^sup>t ;; II\<lbrakk>true/$ok\<rbrakk>)"
    using assms precond_equiv seqr_true_lemma by force
  also have "... = p \<turnstile> Q"
    by (rel_auto)
  finally show ?thesis
    by (simp add: H3_def Healthy_def')
qed

theorem rdesign_H3_iff_pre:
  "P \<turnstile>\<^sub>r Q is H3 \<longleftrightarrow> P = (P ;; true)"
proof -
  have "(P \<turnstile>\<^sub>r Q ;; II\<^sub>D) = (P \<turnstile>\<^sub>r Q ;; true \<turnstile>\<^sub>r II)"
    by (simp add: skip_d_def)
  also have "... = (\<not> ((\<not> P) ;; true) \<and> \<not> (Q ;; (\<not> true))) \<turnstile>\<^sub>r (Q ;; II)"
    by (simp add: rdesign_composition)
  also have "... = (\<not> ((\<not> P) ;; true) \<and> \<not> (Q ;; (\<not> true))) \<turnstile>\<^sub>r Q"
    by simp
  also have "... = (\<not> ((\<not> P) ;; true)) \<turnstile>\<^sub>r Q"
    by (pred_auto)
  finally have "P \<turnstile>\<^sub>r Q is H3 \<longleftrightarrow> P \<turnstile>\<^sub>r Q = (\<not> ((\<not> P) ;; true)) \<turnstile>\<^sub>r Q"
    by (metis H3_def Healthy_def')
  also have "... \<longleftrightarrow> P = (\<not> ((\<not> P) ;; true))"
    by (metis rdesign_pre)
      thm seqr_true_lemma
  also have "... \<longleftrightarrow> P = (P ;; true)"
    by (simp add: seqr_true_lemma)
  finally show ?thesis .
qed

theorem design_H3_iff_pre:
  assumes "$ok \<sharp> P" "$ok\<acute> \<sharp> P" "$ok \<sharp> Q" "$ok\<acute> \<sharp> Q"
  shows "P \<turnstile> Q is H3 \<longleftrightarrow> P = (P ;; true)"
proof -
  have "P \<turnstile> Q = \<lfloor>P\<rfloor>\<^sub>D \<turnstile>\<^sub>r \<lfloor>Q\<rfloor>\<^sub>D"
    by (simp add: assms lift_desr_inv rdesign_def)
  moreover hence "\<lfloor>P\<rfloor>\<^sub>D \<turnstile>\<^sub>r \<lfloor>Q\<rfloor>\<^sub>D is H3 \<longleftrightarrow> \<lfloor>P\<rfloor>\<^sub>D = (\<lfloor>P\<rfloor>\<^sub>D ;; true)"
    using rdesign_H3_iff_pre by blast
  ultimately show ?thesis
    by (metis assms(1,2) drop_desr_inv lift_desr_inv lift_dist_seq aext_true)
qed

theorem H1_H3_commute:
  "H1 (H3 P) = H3 (H1 P)"
  by (rel_auto)

lemma skip_d_absorb_J_1:
  "(II\<^sub>D ;; J) = II\<^sub>D"
  by (metis H2_def H2_rdesign skip_d_def)

lemma skip_d_absorb_J_2:
  "(J ;; II\<^sub>D) = II\<^sub>D"
proof -
  have "(J ;; II\<^sub>D) = ((($ok \<Rightarrow> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D) ;; true \<turnstile> II)"
    by (simp add: J_def skip_d_alt_def)
  also have "... = (\<^bold>\<exists> ok\<^sub>0 \<bullet> (($ok \<Rightarrow> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<acute>\<rbrakk> ;; (true \<turnstile> II)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<rbrakk>)"
    by (subst seqr_middle[of ok], simp_all)
  also have "... = (((($ok \<Rightarrow> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D)\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (true \<turnstile> II)\<lbrakk>false/$ok\<rbrakk>)
                  \<or> ((($ok \<Rightarrow> $ok\<acute>) \<and> \<lceil>II\<rceil>\<^sub>D)\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (true \<turnstile> II)\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: disj_comm false_alt_def true_alt_def)
  also have "... = ((\<not> $ok \<and> \<lceil>II\<rceil>\<^sub>D ;; true) \<or> (\<lceil>II\<rceil>\<^sub>D ;; $ok\<acute> \<and> \<lceil>II\<rceil>\<^sub>D))"
    by (rel_auto)
  also have "... = II\<^sub>D"
    by (rel_auto)
  finally show ?thesis .
qed

lemma H2_H3_absorb:
  "H2 (H3 P) = H3 P"
  by (metis H2_def H3_def seqr_assoc skip_d_absorb_J_1)

lemma H3_H2_absorb:
  "H3 (H2 P) = H3 P"
  by (metis H2_def H3_def seqr_assoc skip_d_absorb_J_2)

theorem H2_H3_commute:
  "H2 (H3 P) = H3 (H2 P)"
  by (simp add: H2_H3_absorb H3_H2_absorb)

theorem H3_design_pre:
  assumes "$ok \<sharp> p" "out\<alpha> \<sharp> p" "$ok \<sharp> Q" "$ok\<acute> \<sharp> Q"
  shows "H3(p \<turnstile> Q) = p \<turnstile> Q"
  using assms
  by (metis Healthy_def' design_H3_iff_pre precond_right_unit unrest_out\<alpha>_var ok_vwb_lens vwb_lens_mwb)

theorem H3_rdesign_pre:
  assumes "out\<alpha> \<sharp> p"
  shows "H3(p \<turnstile>\<^sub>r Q) = p \<turnstile>\<^sub>r Q"
  using assms
  by (simp add: H3_def)

theorem H3_ndesign:
  "H3(p \<turnstile>\<^sub>n Q) = (p \<turnstile>\<^sub>n Q)"
  by (simp add: H3_def ndesign_def unrest_pre_out\<alpha>)

theorem H1_H3_is_design:
  assumes "P is H1" "P is H3"
  shows "P = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
  by (metis H1_H2_eq_design H2_H3_absorb Healthy_def' assms(1) assms(2))

theorem H1_H3_is_rdesign:
  assumes "P is H1" "P is H3"
  shows "P = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
  by (metis H1_H2_is_rdesign H2_H3_absorb Healthy_def' assms)

theorem H1_H3_is_normal_design:
  assumes "P is H1" "P is H3"
  shows "P = \<lfloor>pre\<^sub>D(P)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P)"
  by (metis H1_H3_is_rdesign assms drop_pre_inv ndesign_def precond_equiv rdesign_H3_iff_pre)

abbreviation "H1_H3 p \<equiv> H1 (H3 p)"

notation H1_H3 ("\<^bold>N")

lemma H1_H3_comp: "H1_H3 = H1 \<circ> H3"
  by (auto)

lemma H1_H3_idempotent: "\<^bold>N (\<^bold>N P) = \<^bold>N P"
  by (simp add: H1_H3_commute H1_idem H3_idem)

lemma H1_H3_Idempotent: "Idempotent \<^bold>N"
  by (simp add: Idempotent_def H1_H3_idempotent)

lemma H1_H3_monotonic: "Monotonic \<^bold>N"
  by (simp add: H1_monotone H3_mono Monotonic_def)

lemma H1_H3_Continuous: "Continuous \<^bold>N"
  by (simp add: Continuous_comp H1_Continuous H1_H3_comp H3_Continuous)

lemma H1_H3_impl_H2: "P is H1_H3 \<Longrightarrow> P is H1_H2"
  by (metis H1_H2_commute H1_idem H2_H3_absorb Healthy_def')

lemma H1_H3_eq_design_d_comp: "H1 (H3 P) = ((\<not> P\<^sup>f) \<turnstile> P\<^sup>t ;; II\<^sub>D)"
  by (metis H1_H2_eq_design H1_H3_commute H3_H2_absorb H3_def)

lemma H1_H3_eq_design: "H1 (H3 P) = (\<not> (P\<^sup>f ;; true)) \<turnstile> P\<^sup>t"
  apply (simp add: H1_H3_eq_design_d_comp skip_d_alt_def)
  apply (subst design_composition_subst)
  apply (simp_all add: usubst unrest)
  apply (rel_auto)
done

lemma H3_unrest_out_alpha_nok [unrest]:
  assumes "P is H1_H3"
  shows "out\<alpha> \<sharp> P\<^sup>f"
proof -
  have "P = (\<not> (P\<^sup>f ;; true)) \<turnstile> P\<^sup>t"
    by (metis H1_H3_eq_design Healthy_def assms)
  also have "out\<alpha> \<sharp> (...\<^sup>f)"
    by (simp add: design_def usubst unrest, rel_auto)
  finally show ?thesis .
qed

lemma H3_unrest_out_alpha [unrest]: "P is H1_H3 \<Longrightarrow> out\<alpha> \<sharp> pre\<^sub>D(P)"
  by (metis H1_H3_commute H1_H3_is_rdesign H1_idem Healthy_def' precond_equiv rdesign_H3_iff_pre)

lemma ndesign_H1_H3 [closure]: "p \<turnstile>\<^sub>n Q is \<^bold>N"
  by (simp add: H1_rdesign H3_def Healthy_def' ndesign_def unrest_pre_out\<alpha>)

lemma des_bot_H1_H3 [closure]: "\<bottom>\<^sub>D is \<^bold>N"
  by (metis H1_design H3_def Healthy_def' design_false_pre design_true_left_zero skip_d_alt_def)

lemma assigns_d_H1_H3 [closure]: "\<langle>\<sigma>\<rangle>\<^sub>D is \<^bold>N"
  by (metis H1_rdesign H3_ndesign Healthy_def' aext_true assigns_d_def ndesign_def)

lemma seq_r_H1_H3_closed [closure]:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P ;; Q) is \<^bold>N"
  by (metis (no_types) H1_H2_eq_design H1_H3_eq_design_d_comp H1_H3_impl_H2 Healthy_def assms(1) assms(2) seq_r_H1_H2_closed seqr_assoc)

lemma wp_assigns_d [wp]: "\<langle>\<sigma>\<rangle>\<^sub>D wp\<^sub>D r = \<sigma> \<dagger> r"
  by (rel_auto)

theorem wpd_seq_r_H1_H3 [wp]:
  fixes P Q :: "'\<alpha> hrel_des"
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P ;; Q) wp\<^sub>D r = P wp\<^sub>D (Q wp\<^sub>D r)"
  by (metis H1_H3_commute H1_H3_is_normal_design H1_idem Healthy_def' assms(1) assms(2) wpnd_seq_r)

text {* If two normal designs have the same weakest precondition for any given postcondition, then
  the two designs are equivalent. *}

theorem wpd_eq_intro: "\<lbrakk> \<And> r. (p\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>1) wp\<^sub>D r = (p\<^sub>2 \<turnstile>\<^sub>n Q\<^sub>2) wp\<^sub>D r \<rbrakk> \<Longrightarrow> (p\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>1) = (p\<^sub>2 \<turnstile>\<^sub>n Q\<^sub>2)"
apply (rel_simp robust; metis curry_conv)
done

theorem wpd_H3_eq_intro: "\<lbrakk> P is H1_H3; Q is H1_H3; \<And> r. P wp\<^sub>D r = Q wp\<^sub>D r \<rbrakk> \<Longrightarrow> P = Q"
  by (metis H1_H3_commute H1_H3_is_normal_design H3_idem Healthy_def' wpd_eq_intro)

subsection {* H4: Feasibility *}

theorem H4_idem:
  "H4(H4(P)) = H4(P)"
  by (pred_auto)

lemma is_H4_alt_def:
  "P is H4 \<longleftrightarrow> (P ;; true) = true"
  by (rel_auto)

lemma H4_assigns_d: "\<langle>\<sigma>\<rangle>\<^sub>D is H4"
proof -
  have "(\<langle>\<sigma>\<rangle>\<^sub>D ;; (false \<turnstile>\<^sub>r true\<^sub>h)) = (false \<turnstile>\<^sub>r true)"
    by (simp add: assigns_d_def rdesign_composition assigns_r_feasible)
  moreover have "... = true"
    by (rel_auto)
  ultimately show ?thesis
    using is_H4_alt_def by auto
qed

subsection {* UTP theories *}

typedecl DES
typedecl NDES

abbreviation "DES \<equiv> UTHY(DES, '\<alpha> des)"
abbreviation "NDES \<equiv> UTHY(NDES, '\<alpha> des)"

overloading
  des_hcond == "utp_hcond :: (DES, '\<alpha> des) uthy \<Rightarrow> ('\<alpha> des \<times> '\<alpha> des) health"
  des_unit == "utp_unit :: (DES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> hrel_des" (unchecked)

  ndes_hcond == "utp_hcond :: (NDES, '\<alpha> des) uthy \<Rightarrow> ('\<alpha> des \<times> '\<alpha> des) health"
  ndes_unit == "utp_unit :: (NDES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> hrel_des" (unchecked)

begin
  definition des_hcond :: "(DES, '\<alpha> des) uthy \<Rightarrow> ('\<alpha> des \<times> '\<alpha> des) health" where
  [upred_defs]: "des_hcond t = H1_H2"

  definition des_unit :: "(DES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> hrel_des" where
  [upred_defs]: "des_unit t = II\<^sub>D"

  definition ndes_hcond :: "(NDES, '\<alpha> des) uthy \<Rightarrow> ('\<alpha> des \<times> '\<alpha> des) health" where
  [upred_defs]: "ndes_hcond t = H1_H3"

  definition ndes_unit :: "(NDES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> hrel_des" where
  [upred_defs]: "ndes_unit t = II\<^sub>D"

end

interpretation des_utp_theory: utp_theory DES
  by (simp add: H1_H2_commute H1_idem H2_idem des_hcond_def utp_theory_def)

interpretation ndes_utp_theory: utp_theory NDES
  by (simp add: H1_H3_commute H1_idem H3_idem ndes_hcond_def utp_theory.intro)

interpretation des_left_unital: utp_theory_left_unital DES
  apply (unfold_locales)
  apply (simp_all add: des_hcond_def des_unit_def)
  using seq_r_H1_H2_closed apply blast
  apply (simp add: rdesign_is_H1_H2 skip_d_def)
  apply (metis H1_idem H1_left_unit Healthy_def')
done

interpretation ndes_unital: utp_theory_unital NDES
  apply (unfold_locales, simp_all add: ndes_hcond_def ndes_unit_def)
  using seq_r_H1_H3_closed apply blast
  apply (metis H1_rdesign H3_def Healthy_def' design_skip_idem skip_d_def)
  apply (metis H1_idem H1_left_unit Healthy_def')
  apply (metis H1_H3_commute H3_def H3_idem Healthy_def')
done

interpretation design_theory_continuous: utp_theory_continuous DES
  rewrites "\<And> P. P \<in> carrier (uthy_order DES) \<longleftrightarrow> P is \<^bold>H"
  and "carrier (uthy_order DES) \<rightarrow> carrier (uthy_order DES) \<equiv> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
  and "le (uthy_order DES) = op \<sqsubseteq>"
  and "eq (uthy_order DES) = op ="
  by (unfold_locales, simp_all add: des_hcond_def H1_H2_Continuous utp_order_def)

interpretation normal_design_theory_mono: utp_theory_continuous NDES
  rewrites "\<And> P. P \<in> carrier (uthy_order NDES) \<longleftrightarrow> P is \<^bold>N"
  and "carrier (uthy_order NDES) \<rightarrow> carrier (uthy_order NDES) \<equiv> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
  and "le (uthy_order NDES) = op \<sqsubseteq>"
  and "eq (uthy_order NDES) = op ="
  by (unfold_locales, simp_all add: ndes_hcond_def H1_H3_Continuous utp_order_def)

lemma design_lat_top: "\<^bold>\<top>\<^bsub>DES\<^esub> = \<^bold>H(false)"
  by (simp add: design_theory_continuous.healthy_top, simp add: des_hcond_def)

lemma design_lat_bottom: "\<^bold>\<bottom>\<^bsub>DES\<^esub> = \<^bold>H(true)"
  by (simp add: design_theory_continuous.healthy_bottom, simp add: des_hcond_def)

abbreviation design_lfp :: "('\<alpha> hrel_des \<Rightarrow> '\<alpha> hrel_des) \<Rightarrow> '\<alpha> hrel_des" ("\<mu>\<^sub>D") where
"\<mu>\<^sub>D F \<equiv> \<mu>\<^bsub>uthy_order DES\<^esub> F"

abbreviation design_gfp :: "('\<alpha> hrel_des \<Rightarrow> '\<alpha> hrel_des) \<Rightarrow> '\<alpha> hrel_des" ("\<nu>\<^sub>D") where
"\<nu>\<^sub>D F \<equiv> \<nu>\<^bsub>uthy_order DES\<^esub> F"

thm design_theory_continuous.GFP_unfold
thm design_theory_continuous.LFP_unfold

text {* We also set up local variables for designs. *}

overloading
  des_pvar == "pvar :: (DES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha> des"
  des_assigns == "pvar_assigns :: (DES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel_des"
  ndes_pvar == "pvar :: (NDES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha> des"
  ndes_assigns == "pvar_assigns :: (NDES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel_des"
begin
  definition des_pvar :: "(DES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha> des" where
  [upred_defs]: "des_pvar T = \<Sigma>\<^sub>D"
  definition des_assigns :: "(DES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel_des" where
  [upred_defs]: "des_assigns T \<sigma> = \<langle>\<sigma>\<rangle>\<^sub>D"
  definition ndes_pvar :: "(NDES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha> des" where
  [upred_defs]: "ndes_pvar T = \<Sigma>\<^sub>D"
  definition ndes_assigns :: "(NDES, '\<alpha> des) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel_des" where
  [upred_defs]: "ndes_assigns T \<sigma> = \<langle>\<sigma>\<rangle>\<^sub>D"

end

interpretation des_prog_var: utp_prog_var "UTHY(DES, '\<alpha> des)" "TYPE('\<alpha>)"
  rewrites "\<H>\<^bsub>DES\<^esub> = \<^bold>H"
  apply (unfold_locales, simp_all add: des_pvar_def des_assigns_def des_hcond_def)
  apply (simp add: assigns_d_def rdesign_is_H1_H2)
  apply (simp add: assigns_d_comp_ext assigns_d_is_H1_H2)
  apply (rel_auto)
done

interpretation ndes_prog_var: utp_prog_var "UTHY(NDES, '\<alpha> des)" "TYPE('\<alpha>)"
  rewrites "\<H>\<^bsub>NDES\<^esub> = \<^bold>N"
  apply (unfold_locales, simp_all add: ndes_pvar_def ndes_assigns_def ndes_hcond_def)
  apply (simp add: assigns_d_H1_H3)
  apply (rel_auto)
done

interpretation des_local_var: utp_local_var "UTHY(DES, '\<alpha> des)" "TYPE('\<alpha>)"
  rewrites "\<H>\<^bsub>DES\<^esub> = \<^bold>H"
  by (unfold_locales, simp_all add: des_unit_def des_assigns_def des_hcond_def)

interpretation ndes_local_var: utp_local_var "UTHY(NDES, '\<alpha> des)" "TYPE('\<alpha>)"
  rewrites "\<H>\<^bsub>NDES\<^esub> = \<^bold>N"
  by (unfold_locales, simp_all add: ndes_unit_def ndes_assigns_def ndes_hcond_def)

text {* Weakest precondition laws for design variable scopes *}

lemma wpd_var_begin [wp]:
  fixes x :: "'a list \<Longrightarrow> '\<alpha>" and r :: "'\<alpha> upred"
  shows "(var_begin NDES x) wp\<^sub>D r = r\<lbrakk>\<langle>\<guillemotleft>undefined\<guillemotright>\<rangle> ^\<^sub>u &x/x\<rbrakk>"
  by (simp add: var_begin_def ndes_assigns_def wp)

lemma wpd_var_end [wp]:
  fixes x :: "'a list \<Longrightarrow> '\<alpha>" and r :: "'\<alpha> upred"
  shows "(var_end NDES x) wp\<^sub>D r = r\<lbrakk>tail\<^sub>u(&x)/x\<rbrakk>"
  by (simp add: var_end_def ndes_assigns_def wp)

text {* Example Galois connection between designs and relations. Based on Jim's example in COMPASS
        deliverable D23.5. *}

definition [upred_defs]: "Des(R) = \<^bold>H(\<lceil>R\<rceil>\<^sub>D \<and> $ok\<acute>)"
definition [upred_defs]: "Rel(D) = \<lfloor>D\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>\<rfloor>\<^sub>D"

lemma Des_design: "Des(R) = true \<turnstile>\<^sub>r R"
  by (rel_auto)

lemma Rel_design: "Rel(P \<turnstile>\<^sub>r Q) = (P \<Rightarrow> Q)"
  by (rel_auto)

interpretation Des_Rel_coretract:
  coretract "DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL"
  rewrites
    "\<And> x. x \<in> carrier \<X>\<^bsub>DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL\<^esub> = (x is \<^bold>H)" and
    "\<And> x. x \<in> carrier \<Y>\<^bsub>DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL\<^esub> = True" and
    "\<pi>\<^sub>*\<^bsub>DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL\<^esub> = Des" and
    "\<pi>\<^sup>*\<^bsub>DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL\<^esub> = Rel" and
    "le \<X>\<^bsub>DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL\<^esub> = op \<sqsubseteq>" and
    "le \<Y>\<^bsub>DES \<leftarrow>\<langle>Des,Rel\<rangle>\<rightarrow> REL\<^esub> = op \<sqsubseteq>"
proof (unfold_locales, simp_all add: rel_hcond_def des_hcond_def)
  show "\<And>x. x is id"
    by (simp add: Healthy_def)
next
  show "Rel \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>id\<rbrakk>\<^sub>H"
    by (auto simp add: Rel_def rel_hcond_def Healthy_def)
next
  show "Des \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    by (auto simp add: Des_def des_hcond_def Healthy_def H1_H2_commute H1_idem H2_idem)
next
  fix R :: "'a hrel"
  show "R \<sqsubseteq> Rel (Des R)"
    by (simp add: Des_design Rel_design)
next
  fix R :: "'a hrel" and D :: "'a hrel_des"
  assume a: "D is \<^bold>H"
  then obtain D\<^sub>1 D\<^sub>2 where D: "D = D\<^sub>1 \<turnstile>\<^sub>r D\<^sub>2"
    by (metis H1_H2_commute H1_H2_is_rdesign H1_idem Healthy_def')
  show "(Rel D \<sqsubseteq> R) = (D \<sqsubseteq> Des R)"
  proof -
    have "(D \<sqsubseteq> Des R) = (D\<^sub>1 \<turnstile>\<^sub>r D\<^sub>2 \<sqsubseteq> true \<turnstile>\<^sub>r R)"
      by (simp add: D Des_design)
    also have "... = `D\<^sub>1 \<and> R \<Rightarrow> D\<^sub>2`"
      by (simp add: rdesign_refinement)
    also have "... = ((D\<^sub>1 \<Rightarrow> D\<^sub>2) \<sqsubseteq> R)"
      by (rel_auto)
    also have "... = (Rel D \<sqsubseteq> R)"
      by (simp add: D Rel_design)
    finally show ?thesis ..
  qed
qed

text {* From this interpretation we gain many Galois theorems. Some require simplification to
        remove superfluous assumptions. *}

thm Des_Rel_coretract.deflation[simplified]
thm Des_Rel_coretract.inflation
thm Des_Rel_coretract.upper_comp[simplified]
thm Des_Rel_coretract.lower_comp
end


theory ICF_Test
imports
  "../../Refine_Dflt_ICF"
begin

declare [[autoref_trace_failed_id]]

subsection "Array Hash Map Tests"

schematic_lemma
  "(?f::?'c, [{1::nat} |-> {2::nat}]) \<in> ?R"
  apply (autoref (keep_goal))
  done

schematic_lemma
  "(?f::?'c, \<lambda>m. (m)(1::nat\<mapsto>2::nat)) \<in> ?R"
  apply (autoref (keep_goal))
  done

schematic_lemma
  "(?f::?'c, \<lambda>m. (m:::\<^sub>r\<langle>Id,Id\<rangle>dflt_ahm_rel)(1::nat\<mapsto>2::nat)) \<in> ?R"
  apply (autoref (keep_goal))
  done

schematic_lemma
  "(?f::?'c, Map.empty:::\<^sub>r\<langle>Id,Id\<rangle>dflt_ahm_rel) \<in> ?R"
apply (autoref)
done

schematic_lemma
  fixes mi m
  (* TODO: Obviously, we cannot override the tyREL-rule for
    "nat\<rightharpoonup>nat" with this: *)
  assumes [autoref_rules]: "(mi,m)\<in>\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel"
  shows "(?f::?'c,
    RETURN (card (dom (m:::\<^sub>r\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel)))) \<in> ?R"
  apply (autoref_monadic)
  done

(* Optimizations *)

subsection "List Map Tests"

definition foo::"(nat\<rightharpoonup>nat) nres" where "foo \<equiv>
  do {
    let X = Map.empty;
    ASSERT (1 \<notin> dom X);
    RETURN (X(1 \<mapsto> 2))
  }"

schematic_lemma list_map_update_dj_test:
  "(?f::?'c, foo :::\<^sub>r \<langle>\<langle>Id,Id\<rangle>list_map_rel\<rangle>nres_rel) \<in> ?R"
  unfolding foo_def
  apply autoref_monadic
  done

schematic_lemma
  "(?f::?'c, [1::nat \<mapsto> 2::nat, 3\<mapsto>4] :::\<^sub>r \<langle>nat_rel,nat_rel\<rangle>list_map_rel) \<in> ?R"
  apply autoref
  done

schematic_lemma list_map_test:
  "(?f::?'c, RETURN (([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<^sub>r\<langle>nat_rel,nat_rel\<rangle>list_map_rel) |`(-{1}))) \<in> ?R"
apply (autoref_monadic)
done
concrete_definition list_map_test uses list_map_test
value list_map_test

(* Why does this work:*)
schematic_lemma
  "(?f::?'c, RETURN (card (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<^sub>r\<langle>nat_rel,nat_rel\<rangle>list_map_rel)))) \<in> ?R"
apply (autoref_monadic)
done

(* But this doesn't? This is not specific to list_map;
   it doesn't work with dflt_rbt_rel either.*)
(*schematic_lemma
  "(?f::?'c, RETURN (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<^sub>r\<langle>nat_rel,nat_rel\<rangle>list_map_rel))) \<in> ?R"
apply (autoref_monadic)
done*)

subsection "Array-Map Tests"

term "{1,2::nat} \<union> {3,4}"

schematic_lemma array_set_test_code:
  "(?f::?'c, RETURN (({1,2::nat} \<union> {3,4}
       :::\<^sub>r \<langle>nat_rel\<rangle>iam_set_rel )))\<in>?R"
by (autoref_monadic (trace))

concrete_definition array_set_test uses array_set_test_code
print_theorems
value array_set_test

schematic_lemma
  "(?f::?'c, RETURN (({1} :::\<^sub>r \<langle>nat_rel\<rangle>dflt_rs_rel) = {}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (card {1,2,3::nat}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (\<forall>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (\<exists>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (({1} :::\<^sub>r \<langle>nat_rel\<rangle>iam_set_rel) = {}))\<in>?R"
  apply (autoref_monadic (trace))
  done

schematic_lemma
  assumes [autoref_rules]: "(f,f')\<in>nat_rel\<rightarrow>Rb"
  shows "(?f::?'c,f' 3)\<in>?R"
  by (autoref)

schematic_lemma "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) :::\<^sub>r \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) :::\<^sub>r \<langle>Id\<rangle>list_set_rel)
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) :::\<^sub>r \<langle>Id\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  RETURN (card (dom ([ 1::nat \<mapsto> True, 2\<mapsto>False ] :::\<^sub>r \<langle>Id,Id\<rangle>dflt_rm_rel )))
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  {1,2::'a::numeral} \<times> {3,4::'a}
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::'a::{numeral,hashable}} \<times> ({3,4::'a} :::\<^sub>r \<langle>Id\<rangle>dflt_ahs_rel)
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::nat} \<times> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::nat} \<inter> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) :::\<^sub>r \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

(* TODO: ty_REL hint is ignored. Reason: Seems to not properly work with GAs! *)
schematic_lemma
  notes [autoref_tyrel] = ty_REL[where 'a = "(nat\<times>nat) set"
    and R="\<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel"]
  shows "(?f::?'c,
    RETURN (({1,2::nat} \<times> {3,4::nat}))
  )\<in>?R"
  by autoref_monadic

(* TODO: Iterator optimization does not capture
    foldli ((map fst \<circ> rbt_to_list) x)
pattern!
*)

text {* We have an optimized version for add on red-black trees *}
schematic_lemma "(?f::?'c,
  [ 1::nat \<mapsto> True, 2::nat \<mapsto> False ] ++ [ 3::nat \<mapsto> True, 4::nat \<mapsto> False ]
)\<in>?R"
  by (autoref (keep_goal))

text {* The optimized version is also transfered through the map2set converter *}
schematic_lemma "(?f::?'c,
  {1,2::nat} \<union> {3,4}
)\<in>?R"
  by (autoref (keep_goal))

text {* For list-sets, the generic version is used *}
schematic_lemma "(?f::?'c,
  {1,2::nat} \<union> {3,4} :::\<^sub>r \<langle>Id\<rangle>list_set_rel
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  ({{1::nat}:::\<^sub>r\<langle>Id\<rangle> map2set_rel dflt_rm_rel} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

text {* The next two lemmas demonstrate optimization: The insert-operation
  is translated by @{term "op #"} *}
schematic_lemma "(?f::?'c, {1,2,3,4::nat}:::\<^sub>r\<langle>Id\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_lemma
  "(?f::?'c, {{1},{2},{3},{4::nat}}:::\<^sub>r\<langle>?R'::(?'d\<times>_) set\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}:::\<^sub>r\<langle>Id\<rangle>dflt_rs_rel))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c, do {
  let s = ({1,2,3::nat}:::\<^sub>r\<langle>Id\<rangle>dflt_rs_rel);
  FOREACH s (\<lambda>n s. RETURN (n+s)) 0
}
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c, do {
  let s = ({{1,2,3::nat}, {}, {1,2}});
  FOREACH s (\<lambda>n s. RETURN (n \<union> s)) {}
}
)\<in>?R"
  by (autoref_monadic)

schematic_lemma "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  [ 1::nat \<mapsto> [ 2::nat \<mapsto> 3::nat, 1::nat \<mapsto> 3::nat ] ]
)\<in>?R"
  apply (autoref (keep_goal))
  done

text {* Indirect Annotation *}
consts
  rel_set1 :: rel_name
  rel_set2 :: rel_name

definition
  "algo \<equiv> ( {1,2,3::nat}::#\<^sub>rrel_set1, {1,2,3::nat}::#\<^sub>rrel_set2 )"

schematic_lemma
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>list_set_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

schematic_lemma
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

end


theory TA_NBA
  imports Transition_Systems_and_Automata.NBA TA.Timed_Automata TA_Library.Temporal_Logics
    \<comment> \<open>"LTL_to_GBA.LTL_to_GBA"\<close>
begin

locale TA_NBA_Product_Defs =
  fixes A :: "('a, 'c, 't, 'l) ta" and label :: "'l \<Rightarrow> 'p" and l\<^sub>0 :: 'l
    and B :: "('p, 's) nba"
begin

definition inv :: "'l \<times> 's \<Rightarrow> ('c, 't) cconstraint" where
  "inv \<equiv> \<lambda>(l, _). inv_of A l"

definition trans :: "('a, 'c, 't, 'l \<times> 's) transition set" where
  "trans \<equiv> {((l, q), g, a, r, (l', q')). (l, g, a, r, l') \<in> trans_of A \<and> q' \<in> succ B (label l') q}"

definition prod :: "('a, 'c, 't, 'l \<times> 's) ta" where
  "prod \<equiv> (trans, inv)"

definition inits where
  "inits \<equiv> {q. \<exists>q\<^sub>0 \<in> initial B. q \<in> succ B (label l\<^sub>0) q\<^sub>0}"

definition accept where
  "accept \<equiv> \<lambda>((l, q), u). accepting B q"

end

locale TA_NBA_Product =
  TA_NBA_Product_Defs where A = A and B = B
  for A :: "('a, 'c, 't :: time, 'l) ta" and B :: "('p, 's) nba" +
  assumes labels_alphabet: "range label \<subseteq> alphabet B"
begin

sublocale A: Graph_Defs where
  E = "\<lambda>(l, u) (l', u'). A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>" .

sublocale prod: Graph_Defs
  "\<lambda>(l, u) (l', u'). prod \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>" .

lemma prod_step'_iff:
  "prod \<turnstile>' \<langle>(l, q), u\<rangle> \<rightarrow> \<langle>(l', q'), u'\<rangle> \<longleftrightarrow> A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle> \<and> q' \<in> succ B (label l') q"
  by (auto
        intro!: step'.intros step_t.intros step_a.intros
        elim!: step'.cases step_t.cases step_a.cases
        simp: inv_of_def trans_of_def prod_def trans_def inv_def)

lemma prod_run_A_run:
  "A.run (smap (\<lambda>((l, q), u). (l, u)) xs)" (is "A.run ?xs1") if "prod.run xs"
proof -
  interpret Simulation
    where A = "\<lambda>(l, u) (l', u'). prod \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>"
      and B = "\<lambda>(l, u) (l', u'). A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>"
    and sim = "\<lambda>((l, q), u) (l', u'). l = l' \<and> u = u'"
    by standard (auto simp: prod_step'_iff)
  obtain y ys where "xs = y ## ys"
    by (cases xs)
  obtain l q u where "y = ((l, q), u)"
    by (metis surj_pair)
  from simulation_run[OF that[unfolded \<open>xs = _\<close> \<open>y = _\<close>], of "(l, u)", simplified] obtain zs where
    "A.run ((l, u) ## zs)" "stream_all2 (\<lambda>((l, q), u) (l', u'). l = l' \<and> u = u') ys zs"
    by safe
  from this(2) have "?xs1 = (l, u) ## zs"
    unfolding \<open>xs = _\<close> \<open>y = _\<close>
    by simp (coinduction arbitrary: ys zs, auto 4 3 simp: stream_all2_SCons2)
  with \<open>A.run _\<close> show ?thesis
    by metis
qed

lemma prod_run_iff:
  fixes q\<^sub>0'
  assumes "q \<in> succ B (label l) q\<^sub>0'"
  shows
  "prod.run (((l, q), u) ## xs)
     \<longleftrightarrow> A.run (smap (\<lambda>((l, q), u). (l, u)) (((l, q), u) ## xs))
       \<and> run B (smap (\<lambda>((l, q), u). (label l, q)) (((l, q), u) ## xs)) q\<^sub>0'"
  (is "prod.run ?xs \<longleftrightarrow> A.run (smap ?p1 ?xs) \<and> run B (smap ?p2 ?xs) q\<^sub>0'")
proof -
  have *: "q' \<in> succ B (label l') q" if "prod \<turnstile>' \<langle>(l, q), u\<rangle> \<rightarrow> \<langle>(l', q'), u'\<rangle>" for l q u l' q' u'
    using that by (simp add: prod_step'_iff)
  have "run B (smap ?p2 ?xs) q\<^sub>0'" if "prod.run (((l, q), u) ## xs)"
    using that assms labels_alphabet
    by (coinduction arbitrary: xs l q u q\<^sub>0' rule: nba.run_coinduct)
       (simp split: prod.splits, erule prod.run.cases, auto dest!: * split: prod.splits)
  moreover have "prod.run xs"
    if "A.run (smap ?p1 xs)" "run B (smap ?p2 xs) q\<^sub>0'" for xs
    using that
    apply (coinduction arbitrary: xs q\<^sub>0')
    subgoal for xs q\<^sub>0'
      apply (cases xs)
      subgoal for _ ys
        by (cases ys) (auto simp: prod_step'_iff elim: A.run.cases split: prod.splits)
      done
    done
  ultimately show ?thesis
    using prod_run_A_run by metis
qed

lemma prod_Buechi_run_iff:
  "(\<exists>q \<in> inits. \<exists>xs. prod.run (((l\<^sub>0, q), u) ## xs) \<and> infs accept (((l\<^sub>0, q), u) ## xs))
  \<longleftrightarrow> (\<exists>xs. A.run ((l\<^sub>0, u) ## xs) \<and> label l\<^sub>0 ## smap (\<lambda>(l, u). label l) xs \<in> language B)"
  (is "?l \<longleftrightarrow> ?r")
proof -
  have ?l if ?r
  proof -
    from that obtain xs ys q\<^sub>0 q\<^sub>0' where run:
      "A.run ((l\<^sub>0, u) ## xs)"
      "q\<^sub>0 \<in> initial B"
      "infs (accepting B)
       (trace (smap (\<lambda>(l, u). label l) xs ||| ys) q\<^sub>0')"
      "run B (smap (\<lambda>(l, u). label l) xs ||| ys) q\<^sub>0'"
      "label l\<^sub>0 \<in> alphabet B" "q\<^sub>0' \<in> succ B (label l\<^sub>0) q\<^sub>0"
      unfolding language_def by safe (erule nba.run.cases, auto)
    let ?xs = "smap (\<lambda>((l, u), q). ((l, q), u)) (xs ||| ys)"
    have "smap (\<lambda>((l, q), u). (label l, q)) ?xs = smap (\<lambda>(l, u). label l) xs ||| ys"
      by (coinduction arbitrary: xs ys) (auto split: prod.splits)
    moreover have "smap (case_prod (\<lambda>(l, q). Pair l)) ?xs = xs"
      by (coinduction arbitrary: xs ys) auto
    ultimately have "prod.run (((l\<^sub>0, q\<^sub>0'), u) ## ?xs)"
      using run unfolding prod_run_iff[OF \<open>q\<^sub>0' \<in> _\<close>] by auto
    moreover have "infs accept (((l\<^sub>0, q\<^sub>0'), u) ## ?xs)"
    proof -
      have "stream_all2 (\<lambda>a b. snd b = a) ys (xs ||| ys)"
        by (coinduction arbitrary: xs ys) auto
      then show ?thesis
        using run(3) unfolding accept_def trace_alt_def by (auto elim: alw_ev_lockstep)
    qed
    ultimately show ?thesis
      using \<open>q\<^sub>0' \<in> _\<close> \<open>q\<^sub>0 \<in> _\<close> unfolding inits_def by blast
  qed
  moreover have ?r if ?l
  proof -
    let ?r = "smap (\<lambda>((l, q), u). q)"
    from that obtain q\<^sub>0' q\<^sub>0 xs where
      "q\<^sub>0 \<in> initial B" "q\<^sub>0' \<in> succ B (label l\<^sub>0) q\<^sub>0" "prod.run (((l\<^sub>0, q\<^sub>0'), u) ## xs)" "infs accept xs"
      unfolding inits_def by safe
    moreover have "smap (\<lambda>((l, q), u). (label l, q)) xs = (smap (\<lambda>(l, u). label l)
        (smap (\<lambda>((l, q), u). (l, u)) xs) ||| ?r xs)"
      by (coinduction arbitrary: xs) (auto split: prod.splits)
    ultimately show ?thesis
      by (subst (asm) prod_run_iff)
         (auto 4 4
          simp: holds.simps trace_alt_def accept_def
          elim!: alw_ev_mono language[where r = "q\<^sub>0' ## ?r xs"])
  qed
  ultimately show ?thesis
    by blast
qed

end

locale TA_NBA_LTL_Product1 =
  TA_NBA_Product where A = A and B = B
  for A :: "('a, 'c, 't :: time, 'l) ta" and B :: "('p, 's) nba" +
  fixes \<phi> :: "('l \<Rightarrow> bool) ltlc"
  assumes B_\<phi>: "language B = smap label ` {xs. Graph_Defs.models_ltlc \<phi> xs}"
      and label_formula_compatible: "\<And>xs ys. smap label xs = smap label ys
    \<Longrightarrow> Graph_Defs.models_ltlc \<phi> xs \<longleftrightarrow> Graph_Defs.models_ltlc \<phi> ys"
begin

lemma smap_project:
  "smap (\<lambda>(l, u). label l) xs = smap label (smap fst xs)"
  by (coinduction arbitrary: xs) (auto split: prod.split)

theorem
  "(\<exists>q \<in> inits. \<exists>xs. prod.run (((l\<^sub>0, q), u) ## xs) \<and> infs accept (((l\<^sub>0, q), u) ## xs))
\<longleftrightarrow> (\<exists>xs. A.run ((l\<^sub>0, u) ## xs) \<and> Graph_Defs.models_ltlc \<phi> (l\<^sub>0 ## smap fst xs))"
  unfolding prod_Buechi_run_iff B_\<phi>
  apply safe
  subgoal for xs ys
    apply (intro exI conjI)
     apply assumption
    apply (subst label_formula_compatible)
     apply (auto simp add: smap_project)
    done
  apply (force simp: smap_project)
  done

end

locale TA_NBA_LTL_Product2 =
  TA_NBA_Product where A = A and B = B
  for A :: "('a, 'c, 't :: time, 'l) ta" and B :: "('p, 's) nba" +
  fixes \<phi> :: "('l \<Rightarrow> bool) ltlc" and \<psi> :: "('p \<Rightarrow> bool) ltlc"
  assumes B_\<phi>: "language B = {xs. Graph_Defs.models_ltlc \<psi> xs}"
      and label_formula_compatible:
      "\<And>xs. Graph_Defs.models_ltlc \<phi> xs \<longleftrightarrow> Graph_Defs.models_ltlc \<psi> (smap label xs)"
begin

lemma smap_project:
  "smap (\<lambda>(l, u). label l) xs = smap label (smap fst xs)"
  by (coinduction arbitrary: xs) (auto split: prod.split)

theorem
  "(\<exists>q \<in> inits. \<exists>xs. prod.run (((l\<^sub>0, q), u) ## xs) \<and> infs accept (((l\<^sub>0, q), u) ## xs))
\<longleftrightarrow> (\<exists>xs. A.run ((l\<^sub>0, u) ## xs) \<and> Graph_Defs.models_ltlc \<phi> (l\<^sub>0 ## smap fst xs))"
  unfolding prod_Buechi_run_iff B_\<phi> by (auto simp: label_formula_compatible smap_project)

end

context
  fixes \<phi> :: "'a ltlc" and f :: "'a \<Rightarrow> 'p" and interp :: "'a \<Rightarrow> ('l \<Rightarrow> bool)"
begin

lemma semantics_ltlc_map_prop:
  "(\<lambda>i. {a \<in> interp ` atoms_ltlc \<phi>. a (w i)}) \<Turnstile>\<^sub>c map_ltlc interp \<phi> \<longleftrightarrow>
   (\<lambda>i. {a \<in> atoms_ltlc \<phi>. interp a (w i)}) \<Turnstile>\<^sub>c \<phi>"
proof -
  have [simp]:
    "(\<lambda>i. {a. (a \<in> atoms_ltlc \<phi>1 \<or> a \<in> atoms_ltlc \<phi>2) \<and> interp a (w i)}) \<Turnstile>\<^sub>c \<phi>1
    \<longleftrightarrow> ((\<lambda>i. {a \<in> atoms_ltlc \<phi>1. interp a (w i)}) \<Turnstile>\<^sub>c \<phi>1)"
    "(\<lambda>i. {a. (a \<in> atoms_ltlc \<phi>1 \<or> a \<in> atoms_ltlc \<phi>2) \<and> interp a (w i)}) \<Turnstile>\<^sub>c \<phi>2
    \<longleftrightarrow> ((\<lambda>i. {a \<in> atoms_ltlc \<phi>2. interp a (w i)}) \<Turnstile>\<^sub>c \<phi>2)" for w \<phi>1 \<phi>2
    by (rule ltlc_eq_on; auto simp: pw_eq_on_def)+
  have [simp]:
    "(\<lambda>i. {a \<in> interp ` (atoms_ltlc \<phi>1 \<union> atoms_ltlc \<phi>2). a (w i)}) \<Turnstile>\<^sub>c map_ltlc interp \<phi>1
    \<longleftrightarrow> (\<lambda>i. {a \<in> interp ` atoms_ltlc \<phi>1. a (w i)}) \<Turnstile>\<^sub>c map_ltlc interp \<phi>1"
    "(\<lambda>i. {a \<in> interp ` (atoms_ltlc \<phi>1 \<union> atoms_ltlc \<phi>2). a (w i)}) \<Turnstile>\<^sub>c map_ltlc interp \<phi>2
    \<longleftrightarrow> (\<lambda>i. {a \<in> interp ` atoms_ltlc \<phi>2. a (w i)}) \<Turnstile>\<^sub>c map_ltlc interp \<phi>2" for w \<phi>1 \<phi>2
    by (rule ltlc_eq_on; auto simp: pw_eq_on_def ltlc.set_map)+
  show ?thesis
    by (induction \<phi> arbitrary: w) (simp_all add: suffix_def)
qed

lemma prop_ltlc_abstract:
  assumes f_inj: "inj_on f (atoms_ltlc \<phi>)"
  shows
  "w \<Turnstile>\<^sub>c' map_ltlc interp \<phi> \<longleftrightarrow>
  ((\<lambda>s. f ` {a \<in> atoms_ltlc \<phi>. interp a s}) o w) \<Turnstile>\<^sub>c map_ltlc f \<phi>" (is "?l \<longleftrightarrow> ?r")
proof -
  have "?l \<longleftrightarrow> (\<lambda>i. {a \<in> atoms_ltlc \<phi>. interp a (w i)}) \<Turnstile>\<^sub>c \<phi>"
    by (simp add: semantics_ltlc'_semantics_ltlc_atoms_iff ltlc.set_map semantics_ltlc_map_prop)
  also have "\<dots> \<longleftrightarrow> ?r"
    by (subst map_semantics_ltlc_aux[OF f_inj]) (auto simp: comp_def)
  finally show ?thesis .
qed

end

locale TA_NBA_LTL_Product =
  TA_NBA_Product where A = A and B = B
  for A :: "('a, 'c, 't :: time, 'l) ta" and B :: "('p set, 's) nba" +
  fixes \<phi> :: "'x ltlc" and interp :: "'x \<Rightarrow> ('l \<Rightarrow> bool)" and f :: "'x \<Rightarrow> 'p"
  assumes B_\<phi>: "to_omega ` language B = {w. w \<Turnstile>\<^sub>c map_ltlc f \<phi>}"
      and f_inj: "inj_on f (atoms_ltlc \<phi>)"
      and label: "label s = f ` {a \<in> atoms_ltlc \<phi>. interp a s}"
begin

lemma smap_project:
  "smap (\<lambda>(l, u). label l) xs = smap label (smap fst xs)"
  by (coinduction arbitrary: xs) (auto split: prod.split)

lemma B_\<phi>':
  "language B = {w. to_omega w \<Turnstile>\<^sub>c map_ltlc f \<phi>}"
  using B_\<phi> by auto (metis in_image(1) mem_Collect_eq to_stream_to_omega)

lemma comp_to_omega_is_smap:
  "g o to_omega xs = to_omega (smap g xs)"
  unfolding to_omega_def comp_def by auto

theorem prod_formula_run_iff:
  "(\<exists>q \<in> inits. \<exists>xs. prod.run (((l\<^sub>0, q), u) ## xs) \<and> infs accept (((l\<^sub>0, q), u) ## xs))
\<longleftrightarrow> (\<exists>xs. A.run ((l\<^sub>0, u) ## xs) \<and> Graph_Defs.models_ltlc (map_ltlc interp \<phi>) (l\<^sub>0 ## smap fst xs))"
  unfolding prod_Buechi_run_iff Graph_Defs.models_ltlc_def B_\<phi>'
  by (simp add: prop_ltlc_abstract[OF f_inj] smap_project label[symmetric] comp_to_omega_is_smap)

end

context
  fixes \<phi> :: "('l \<Rightarrow> bool) ltlc" and f :: "('l \<Rightarrow> bool) \<Rightarrow> 'p"
  assumes f_inj: "inj_on f (atoms_ltlc \<phi>)"
begin

lemma
  "w \<Turnstile>\<^sub>c' \<phi> \<longleftrightarrow> (\<lambda>i. (\<lambda>s. f ` {a \<in> atoms_ltlc \<phi>. a s}) (w i)) \<Turnstile>\<^sub>c map_ltlc f \<phi>"
  using f_inj
  apply (subst semantics_ltlc'_semantics_ltlc_atoms_iff)
  apply (subst map_semantics_ltlc_aux[where f = f])
     apply auto
  done

end

context
  fixes collision sent :: "'l \<Rightarrow> bool"
begin

private definition
  "edges = (\<lambda>s n.
    if n = 0 then
      if collision s \<and> sent s then {0}
      else if collision s \<and> \<not> sent s then {0}
      else if \<not> collision s then {1}
      else {}
    else if n = 1 then
      if collision s \<and> sent s then {0}
      else if \<not> collision s then {1}
      else if collision s \<and> \<not> sent s then {2}
      else {}
    else if n = 2 then
      if sent s then {0}
      else {2}
    else {}
   )"

lemma edges_determ:
  "\<exists>x \<in> {0,1,2}. edges s l = {x}" if "l \<in> {0,1,2}"
  using that unfolding edges_def by auto

definition
  "not_fg_collision_impl_g_not_sent = nba
    UNIV {0,1,2} edges (\<lambda>l. l = 0)"

definition
  "formula = not\<^sub>c (F\<^sub>c (G\<^sub>c (prop\<^sub>c(collision) implies\<^sub>c G\<^sub>c (not\<^sub>c(prop\<^sub>c(sent))))))"

schematic_goal
  "formula = TT ?x"
  unfolding formula_def
  oops

lemma
  "\<xi> \<Turnstile>\<^sub>c' formula = \<xi> \<Turnstile>\<^sub>c' G\<^sub>c (F\<^sub>c (prop\<^sub>c(collision) and\<^sub>c F\<^sub>c (prop\<^sub>c(sent))))"
  unfolding semantics_ltlc'_semantics_ltlc_atoms_iff
  unfolding formula_def
  by simp

lemma
  "language not_fg_collision_impl_g_not_sent =
    {xs. Graph_Defs.models_ltlc formula xs}
"
  unfolding Graph_Defs.models_ltlc_def
  apply auto
  oops

end

end


(*<*)
(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory CIMP_pred
imports
  Main
begin

(* Extra HOL *)

lemma triv: "P \<Longrightarrow> P"
by simp

lemma always_eventually_pigeonhole:
  "(\<forall>i. \<exists>n\<ge>i. \<exists>m\<le>k. P m n) \<longleftrightarrow> (\<exists>m\<le>k::nat. \<forall>i::nat. \<exists>n\<ge>i. P m n)"
proof(induct k)
  case (Suc k) then show ?case
    apply (auto 8 0)
    using le_SucI apply blast
    apply (metis (full_types) le_Suc_eq nat_le_linear order_trans)
    done
qed simp

(*>*)
section\<open> Point-free notation \<close>

text\<open>

\label{sec:cimp-lifted-predicates}

Typically we define predicates as functions of a state. The following
provide a somewhat comfortable point-free imitation of Isabelle/HOL's
operators.

\<close>

abbreviation (input)
  pred_K :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("\<langle>_\<rangle>") where
  "\<langle>f\<rangle> \<equiv> \<lambda>s. f"

abbreviation (input)
  pred_not :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("\<^bold>\<not> _" [40] 40) where
  "\<^bold>\<not>a \<equiv> \<lambda>s. \<not>a s"

abbreviation (input)
  pred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<and>" 35) where
  "a \<^bold>\<and> b \<equiv> \<lambda>s. a s \<and> b s"

abbreviation (input)
  pred_disj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<or>" 30) where
  "a \<^bold>\<or> b \<equiv> \<lambda>s. a s \<or> b s"

abbreviation (input)
  pred_implies :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<longrightarrow>" 25) where
  "a \<^bold>\<longrightarrow> b \<equiv> \<lambda>s. a s \<longrightarrow> b s"

abbreviation (input)
  pred_iff :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<longleftrightarrow>" 25) where
  "a \<^bold>\<longleftrightarrow> b \<equiv> \<lambda>s. a s \<longleftrightarrow> b s"

abbreviation (input)
  pred_eq :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>=" 40) where
  "a \<^bold>= b \<equiv> \<lambda>s. a s = b s"

abbreviation (input)
  pred_member :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<in>" 40) where
  "a \<^bold>\<in> b \<equiv> \<lambda>s. a s \<in> b s"

abbreviation (input)
  pred_neq :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<noteq>" 40) where
  "a \<^bold>\<noteq> b \<equiv> \<lambda>s. a s \<noteq> b s"

abbreviation (input)
  pred_If :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("(If (_)/ Then (_)/ Else (_))" [0, 0, 10] 10)
  where "If P Then x Else y \<equiv> \<lambda>s. if P s then x s else y s"

abbreviation (input)
  pred_less :: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold><" 40) where
  "a \<^bold>< b \<equiv> \<lambda>s. a s < b s"

abbreviation (input)
  pred_le :: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<le>" 40) where
  "a \<^bold>\<le> b \<equiv> \<lambda>s. a s \<le> b s"

abbreviation (input)
  pred_plus :: "('a \<Rightarrow> 'b::plus) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "\<^bold>+" 65) where
  "a \<^bold>+ b \<equiv> \<lambda>s. a s + b s"

abbreviation (input)
  pred_minus :: "('a \<Rightarrow> 'b::minus) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "\<^bold>-" 65) where
  "a \<^bold>- b \<equiv> \<lambda>s. a s - b s"

abbreviation (input)
  fun_fanout :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" (infix "\<^bold>\<bowtie>" 35) where
  "f \<^bold>\<bowtie> g \<equiv> \<lambda>x. (f x, g x)"

abbreviation (input)
  pred_all :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "\<^bold>\<forall>" 10) where
  "\<^bold>\<forall>x. P x \<equiv> \<lambda>s. \<forall>x. P x s"

abbreviation (input)
  pred_ex :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "\<^bold>\<exists>" 10) where
  "\<^bold>\<exists>x. P x \<equiv> \<lambda>s. \<exists>x. P x s"

abbreviation (input)
  pred_app :: "('b \<Rightarrow> 'a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" (infixl "\<^bold>$" 100) where
  "f \<^bold>$ g \<equiv> \<lambda>s. f (g s) s"

abbreviation (input)
  pred_subseteq :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<subseteq>" 50) where
  "A \<^bold>\<subseteq> B \<equiv> \<lambda>s. A s \<subseteq> B s"

abbreviation (input)
  pred_union :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" (infixl "\<^bold>\<union>" 65) where
  "a \<^bold>\<union> b \<equiv> \<lambda>s. a s \<union> b s"

abbreviation (input)
  pred_inter :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" (infixl "\<^bold>\<inter>" 65) where
  "a \<^bold>\<inter> b \<equiv> \<lambda>s. a s \<inter> b s"

text\<open>

More application specific.

\<close>

abbreviation (input)
  pred_conjoin :: "('a \<Rightarrow> bool) list \<Rightarrow> 'a \<Rightarrow> bool" where
  "pred_conjoin xs \<equiv> foldr (\<^bold>\<and>) xs \<langle>True\<rangle>"

abbreviation (input)
  pred_disjoin :: "('a \<Rightarrow> bool) list \<Rightarrow> 'a \<Rightarrow> bool" where
  "pred_disjoin xs \<equiv> foldr (\<^bold>\<or>) xs \<langle>False\<rangle>"

abbreviation (input)
  pred_is_none :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> bool" ("NULL _" [40] 40) where
  "NULL a \<equiv> \<lambda>s. a s = None"

abbreviation (input)
  pred_empty :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> bool" ("EMPTY _" [40] 40) where
  "EMPTY a \<equiv> \<lambda>s. a s = {}"

abbreviation (input)
  pred_list_null :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a \<Rightarrow> bool" ("LIST'_NULL _" [40] 40) where
  "LIST_NULL a \<equiv> \<lambda>s. a s = []"

abbreviation (input)
  pred_list_append :: "('a \<Rightarrow> 'b list) \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'a \<Rightarrow> 'b list" (infixr "\<^bold>@" 65) where
  "xs \<^bold>@ ys \<equiv> \<lambda>s. xs s @ ys s"

abbreviation (input)
  pred_pair :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" (infixr "\<^bold>\<otimes>" 60) where
  "a \<^bold>\<otimes> b \<equiv> \<lambda>s. (a s, b s)"

abbreviation (input)
  pred_singleton :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b set" where
  "pred_singleton x \<equiv> \<lambda>s. {x s}"
(*<*)

end
(*>*)