subsection {* Variable blocks *}

theory utp_local
imports utp_theory
begin

text {* Local variables are represented as lenses whose view type is a list of values. A variable
  therefore effectively records the stack of values that variable has had, if any. This allows
  us to denote variable scopes using assignments that push and pop this stack to add or delete
  a particular local variable. *}

type_synonym ('a, '\<alpha>) lvar = "('a list, '\<alpha>) uvar"

text {* Different UTP theories have different assignment operators; consequently in order to
  generically characterise variable blocks we need to abstractly characterise assignments.
  We first create two polymorphic constants that characterise the underlying program state model
  of a UTP theory. *}

consts
  pvar         :: "('\<T>, '\<alpha>) uthy \<Rightarrow> '\<beta> \<Longrightarrow> '\<alpha>" ("\<^bold>v\<index>")
  pvar_assigns :: "('\<T>, '\<alpha>) uthy \<Rightarrow> '\<beta> usubst \<Rightarrow> '\<alpha> hrel" ("\<^bold>\<langle>_\<^bold>\<rangle>\<index>")

text {* @{const pvar} is a lens from the program state, @{typ "'\<beta>"}, to the overall global state
  @{typ "'\<alpha>"}, which also contains none user-space information, such as observational variables.
  @{const pvar_assigns} takes as parameter a UTP theory and returns an assignment operator
  which maps a substitution over the program state to a homogeneous relation on the global
  state. We now set up some syntax translations for these operators. *}

syntax
  "_svid_pvar" :: "('\<T>, '\<alpha>) uthy \<Rightarrow> svid" ("\<^bold>v\<index>")
  "_thy_asgn"  :: "('\<T>, '\<alpha>) uthy \<Rightarrow> svid_list \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr "::=\<index>" 55)

translations
  "_svid_pvar T" => "CONST pvar T"
  "_thy_asgn T xs vs" => "CONST pvar_assigns T (_mk_usubst (CONST id) xs vs)"

text {* Next, we define constants to represent the top most variable on the local variable stack,
  and the remainder after this. We define these in terms of the list lens, and so for each
  another lens is produced. *}

definition top_var :: "('a::two, '\<alpha>) lvar \<Rightarrow> ('a, '\<alpha>) uvar" where
[upred_defs]: "top_var x = (list_lens 0 ;\<^sub>L x)"

text {* The remainder of the local variable stack (the tail) *}

definition rest_var :: "('a::two, '\<alpha>) lvar \<Rightarrow> ('a list, '\<alpha>) uvar" where
[upred_defs]: "rest_var x = (tl_lens ;\<^sub>L x)"

text {* We can show that the top variable is a mainly well-behaved lense, and that the top most
  variable lens is independent of the rest of the stack. *}

lemma top_mwb_lens [simp]: "mwb_lens x \<Longrightarrow> mwb_lens (top_var x)"
  by (simp add: list_mwb_lens top_var_def)

lemma top_rest_var_indep [simp]:
  "mwb_lens x \<Longrightarrow> top_var x \<bowtie> rest_var x"
  by (simp add: lens_indep_left_comp rest_var_def top_var_def)

lemma top_var_pres_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> top_var x \<bowtie> y"
  by (simp add: lens_indep_left_ext top_var_def)

syntax
  "_top_var"             :: "svid \<Rightarrow> svid" ("@_" [999] 999)
  "_rest_var"            :: "svid \<Rightarrow> svid" ("\<down>_" [999] 999)

translations
  "_top_var x" == "CONST top_var x"
  "_rest_var x" == "CONST rest_var x"

text {* With operators to represent local variables, assignments, and stack manipulation defined,
  we can go about defining variable blocks themselves. *}

definition var_begin :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('a, '\<beta>) lvar \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "var_begin T x = x ::=\<^bsub>T\<^esub> \<langle>\<guillemotleft>undefined\<guillemotright>\<rangle> ^\<^sub>u &x"

definition var_end :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('a, '\<beta>) lvar \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "var_end T x = (x ::=\<^bsub>T\<^esub> tail\<^sub>u(&x))"

text {* @{const var_begin} takes as parameters a UTP theory and a local variable, and uses the
  theory assignment operator to push and undefined value onto the variable stack. @{const var_end}
  removes the top most variable from the stack in a similar way. *}

definition var_vlet :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('a, '\<alpha>) lvar \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "var_vlet T x = (($x \<noteq>\<^sub>u \<langle>\<rangle>) \<and> \<I>\<I>\<^bsub>T\<^esub>)"

text {* Next we set up the typical UTP variable block syntax, though with a suitable subscript index
  to represent the UTP theory parameter. *}

syntax
  "_var_begin"     :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("var\<index> _" [100] 100)
  "_var_begin_asn" :: "logic \<Rightarrow> svid \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ := _")
  "_var_end"       :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("end\<index> _" [100] 100)
  "_var_vlet"      :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("vlet\<index> _" [100] 100)
  "_var_scope"           :: "logic \<Rightarrow> svid \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ \<bullet> _" [0,10] 10)
  "_var_scope_ty"        :: "logic \<Rightarrow> svid \<Rightarrow> type \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ :: _ \<bullet> _" [0,0,10] 10)
  "_var_scope_ty_assign" :: "logic \<Rightarrow> svid \<Rightarrow> type \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ :: _ := _ \<bullet> _" [0,0,0,10] 10)

translations
  "_var_begin T x"       == "CONST var_begin T x"
  "_var_begin_asn T x e" => "var\<^bsub>T\<^esub> x ;; @x ::=\<^bsub>T\<^esub> e"
  "_var_end T x"         == "CONST var_end T x"
  "_var_vlet T x"        == "CONST var_vlet T x"
  "var\<^bsub>T\<^esub> x \<bullet> P" => "var\<^bsub>T\<^esub> x ;; ((\<lambda> x. P) (CONST top_var x)) ;; end\<^bsub>T\<^esub> x"
  "var\<^bsub>T\<^esub> x \<bullet> P" => "var\<^bsub>T\<^esub> x ;; ((\<lambda> x. P) (CONST top_var x)) ;; end\<^bsub>T\<^esub> x"

text {* In order to substantiate standard variable block laws, we need some underlying laws about
  assignments, which is the purpose of the following locales. *}

locale utp_prog_var = utp_theory \<T> for \<T> :: "('\<T>, '\<alpha>) uthy" (structure) +
  fixes \<V>\<T> :: "'\<beta> itself"
  assumes pvar_uvar: "vwb_lens (\<^bold>v :: '\<beta> \<Longrightarrow> '\<alpha>)"
  and Healthy_pvar_assigns [closure]: "\<^bold>\<langle>\<sigma> :: '\<beta> usubst\<^bold>\<rangle> is \<H>"
  and pvar_assigns_comp: "(\<^bold>\<langle>\<sigma>\<^bold>\<rangle> ;; \<^bold>\<langle>\<rho>\<^bold>\<rangle>) = \<^bold>\<langle>\<rho> \<circ> \<sigma>\<^bold>\<rangle>"

text {* We require that (1) the user-space variable is a very well-behaved lens, (2) that the
  assignment operator is healthy, and (3) that composing two assignments is equivalent to
  composing their substitutions. The next locale extends this with a left unit. *}

locale utp_local_var = utp_prog_var \<T> V + utp_theory_left_unital \<T> for \<T> :: "('\<T>, '\<alpha>) uthy" (structure) and V :: "'\<beta> itself" +
  assumes pvar_assign_unit: "\<^bold>\<langle>id :: '\<beta> usubst\<^bold>\<rangle> = \<I>\<I>"
begin

text {* If a left unit exists then an assignment with an identity substitution should yield the
  identity relation, as the above assumption requires. With these laws available, we can
  prove the main laws of variable blocks. *}

lemma var_begin_healthy [closure]:
  fixes x :: "('a, '\<beta>) lvar"
  shows "var x is \<H>"
  by (simp add: var_begin_def Healthy_pvar_assigns)

lemma var_end_healthy [closure]:
  fixes x :: "('a, '\<beta>) lvar"
  shows "end x is \<H>"
  by (simp add: var_end_def Healthy_pvar_assigns)

text {* The beginning and end of a variable block are both healthy theory elements. *}

lemma var_open_close:
  fixes x :: "('a, '\<beta>) lvar"
  assumes "vwb_lens x"
  shows "(var x ;; end x) = \<I>\<I>"
  by (simp add: var_begin_def var_end_def shEx_lift_seq_1 Healthy_pvar_assigns pvar_assigns_comp pvar_assign_unit usubst assms)

text {* Opening and then immediately closing a variable blocks yields a skip. *}

lemma var_open_close_commute:
  fixes x :: "('a, '\<beta>) lvar" and y :: "('b, '\<beta>) lvar"
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "(var x ;; end y) = (end y ;; var x)"
  by (simp add: var_begin_def var_end_def shEx_lift_seq_1 shEx_lift_seq_2
                Healthy_pvar_assigns pvar_assigns_comp
                assms usubst unrest  lens_indep_sym, simp add: assms usubst_upd_comm)

text {* The beginning and end of variable blocks from different variables commute. *}

lemma var_block_vacuous:
  fixes x :: "('a::two, '\<beta>) lvar"
  assumes "vwb_lens x"
  shows "(var x \<bullet> \<I>\<I>) = \<I>\<I>"
  by (simp add: Left_Unit assms var_end_healthy var_open_close)

text {* A variable block with a skip inside results in a skip. *}
end

text {* Example instantiation for the theory of relations *}

overloading
  rel_pvar == "pvar :: (REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha>"
  rel_pvar_assigns == "pvar_assigns :: (REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel"
begin
  definition rel_pvar :: "(REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha>" where
  [upred_defs]: "rel_pvar T = 1\<^sub>L"
  definition rel_pvar_assigns :: "(REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel" where
  [upred_defs]: "rel_pvar_assigns T \<sigma> = \<langle>\<sigma>\<rangle>\<^sub>a"
end

interpretation rel_local_var: utp_local_var "UTHY(REL, '\<alpha>)" "TYPE('\<alpha>)"
proof -
  interpret vw: vwb_lens "pvar REL :: '\<alpha> \<Longrightarrow> '\<alpha>"
    by (simp add: rel_pvar_def id_vwb_lens)
  show "utp_local_var TYPE('\<alpha>) UTHY(REL, '\<alpha>)"
  proof
    show "\<And>\<sigma>::'\<alpha> \<Rightarrow> '\<alpha>. \<^bold>\<langle>\<sigma>\<^bold>\<rangle>\<^bsub>REL\<^esub> is \<H>\<^bsub>REL\<^esub>"
      by (simp add: rel_pvar_assigns_def rel_hcond_def Healthy_def)
    show "\<And>(\<sigma>::'\<alpha> \<Rightarrow> '\<alpha>) \<rho>. \<^bold>\<langle>\<sigma>\<^bold>\<rangle>\<^bsub>UTHY(REL, '\<alpha>)\<^esub> ;; \<^bold>\<langle>\<rho>\<^bold>\<rangle>\<^bsub>REL\<^esub> = \<^bold>\<langle>\<rho> \<circ> \<sigma>\<^bold>\<rangle>\<^bsub>REL\<^esub>"
      by (simp add: rel_pvar_assigns_def assigns_comp)
    show "\<^bold>\<langle>id::'\<alpha> \<Rightarrow> '\<alpha>\<^bold>\<rangle>\<^bsub>UTHY(REL, '\<alpha>)\<^esub> = \<I>\<I>\<^bsub>REL\<^esub>"
      by (simp add: rel_pvar_assigns_def rel_unit_def skip_r_def)
  qed
qed
end


theory Balance_LR
  imports
    "../Setup"
    "../Utilities"
    "../Insert/Balance"
    "../Free"
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

subsection \<open>Balance Left\<close>

subsubsection \<open>Patterns\<close>

abbreviation "bl_pat_1 \<equiv> RP_Branch CP_R RP_Var RP_Var"
abbreviation "bl_pat_2 \<equiv> RP_Branch CP_B RP_Var RP_Var"
abbreviation "bl_pat_3 \<equiv> RP_Branch CP_R (RP_Branch CP_B RP_Var RP_Var) RP_Var"

subsubsection \<open>Adjusted Function\<close>

fun rbt_balance_left_ad where
  "rbt_balance_left_ad l key val r =
    (
      if matches_rbt bl_pat_1 l
      then case l of (rbt.Branch color.R a k x b) \<Rightarrow>
        rbt.Branch color.R (rbt.Branch color.B a k x b) key val r
      else if matches_rbt bl_pat_2 r
      then case r of (rbt.Branch color.B a s y b) \<Rightarrow>
        rbt_balance l key val (rbt.Branch color.R a s y b)
      else if matches_rbt bl_pat_3 r
      then case r of (rbt.Branch color.R (rbt.Branch color.B a s y b) t z c) \<Rightarrow>
        rbt.Branch color.R (rbt.Branch color.B l key val a) s y (rbt_balance b t z (paint color.R c))
      else rbt.Empty
    )"

lemma rbt_balance_left_ad_correct:
  "rbt_balance_left_ad l k v r = rbt_balance_left l k v r"
  apply(induction l k v r rule: RBT_Impl.balance_left.induct)
  by auto

subsubsection \<open>Concrete Implementation\<close>

definition "bl_case_1 l_p k v r_p \<equiv>
  do {
    set_color_p 1 l_p;
    new (RBT_NODE 0 l_p k v r_p)
  }"

definition "bl_case_2 l_p k v r_p \<equiv>
  do {
    set_color_p 0 r_p;
    balance l_p k v r_p
  }"

definition "bl_case_3 l_p k v r_p \<equiv>
  do {
    let bl=l_p; k=k; x=v in
    do {
      r \<leftarrow> ll_load r_p;
      case r of (RBT_NODE r_col rl_p t z c) \<Rightarrow>
      do {
        rl \<leftarrow> ll_load rl_p;
        case rl of (RBT_NODE rl_col a s y b) \<Rightarrow>
        do {
          (if c \<noteq> null then set_color_p 0 c else return ());
          balanced \<leftarrow> balance b t z c;
          ll_store (RBT_NODE 1 bl k x a) rl_p;
          ll_store (RBT_NODE 0 rl_p s y balanced) r_p;
          return r_p
        }
      }
    }
  }"

definition "balance_left l_p k v r_p \<equiv>
  do {
    if! ll_matches_rbt bl_pat_1 l_p
    then! bl_case_1 l_p k v r_p
    else! if! ll_matches_rbt bl_pat_2 r_p
    then! bl_case_2 l_p k v r_p
    else! if! ll_matches_rbt bl_pat_3 r_p
    then! bl_case_3 l_p k v r_p
    else! do {
      key_free k;
      value_free v;
      free l_p; free r_p;
      empty
    }
  }"

lemmas [llvm_inline] =
  bl_case_1_def
  bl_case_2_def
  bl_case_3_def

lemmas [llvm_code] = balance_left_def

lemma balance_left_correct':
  "
    llvm_htriple
    (rbt_assn l li ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** rbt_assn r ri)
    (balance_left li ki vi ri)
    (\<lambda>x. rbt_assn (rbt_balance_left_ad l k v r) x)
  "
  unfolding
    balance_left_def
    bl_case_1_def
    bl_case_2_def
    bl_case_3_def
  by vcg

lemma balance_left_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn l li ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** rbt_assn r ri)
    (balance_left li ki vi ri)
    (\<lambda>x. rbt_assn (rbt_balance_left l k v r) x)
  "
  using balance_left_correct' rbt_balance_left_ad_correct by metis

subsection \<open>Balance Right\<close>

subsubsection \<open>Patterns\<close>

abbreviation "br_pat_1 \<equiv> RP_Branch CP_R RP_Var RP_Var"
abbreviation "br_pat_2 \<equiv> RP_Branch CP_B RP_Var RP_Var"
abbreviation "br_pat_3 \<equiv> RP_Branch CP_R RP_Var (RP_Branch CP_B RP_Var RP_Var)"

subsubsection \<open>Concrete Implementation\<close>

definition "br_case_1 l_p k v r_p \<equiv>
  do {
    set_color_p 1 r_p;
    new (RBT_NODE 0 l_p k v r_p)
  }"

definition "br_case_2 l_p k v r_p \<equiv>
  do {
    set_color_p 0 l_p;
    balance l_p k v r_p
  }"

definition "br_case_3 l_p k v r_p \<equiv>
  do {
    let bl=r_p; t=k; z=v in
    do {
      l \<leftarrow> ll_load l_p;
      case l of (RBT_NODE l_col a k x lr_p) \<Rightarrow>
      do {
        lr \<leftarrow> ll_load lr_p;
        case lr of (RBT_NODE lr_col b s y c) \<Rightarrow>
        do {
          (if a \<noteq> null then set_color_p 0 a else return ());
          balanced \<leftarrow> balance a k x b;
          ll_store (RBT_NODE 1 c t z bl) lr_p;
          ll_store (RBT_NODE 0 balanced s y lr_p) l_p;
          return l_p
        }
      }
    }
  }"

definition "balance_right l_p k v r_p \<equiv>
  do {
    if! ll_matches_rbt br_pat_1 r_p
    then! br_case_1 l_p k v r_p
    else! if! ll_matches_rbt br_pat_2 l_p
    then! br_case_2 l_p k v r_p
    else! if! ll_matches_rbt br_pat_3 l_p
    then! br_case_3 l_p k v r_p
    else! do {
      key_free k;
      value_free v;
      free l_p; free r_p;
      empty
    }
  }
"

lemma neq_Red: "(c \<noteq> color.R) = (c = color.B)"
  using color.exhaust by blast

method resolve_rbt_pat_mat' =
  ((erule matches_rbt.elims(2-3) | simp add: neq_Red)+)[1]

lemma balance_right_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn l li ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** rbt_assn r ri)
    (balance_right li ki vi ri)
    (\<lambda>x. rbt_assn (rbt_balance_right l k v r) x)
  "
  unfolding
    balance_right_def
    br_case_1_def
    br_case_2_def
    br_case_3_def
  apply vcg
  subgoal (*case 2*)
    apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases, auto)
     apply vcg
    done
  subgoal (*case 3+*)
    apply vcg
    subgoal (*case 3a*)
      apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases, auto)
       apply vcg
      done
    subgoal (*case 3b*)
      apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases, auto)
       apply vcg
      done

    subgoal (*case 4*)
      apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases, auto)
           apply vcg
      done
    done
  done

lemmas [llvm_inline] =
  br_case_1_def
  br_case_2_def
  br_case_3_def

lemmas [llvm_code] = balance_right_def

end

end


(*  Title:      HOL/HOLCF/One.thy
    Author:     Oscar Slotosch
*)

section {* The unit domain *}

theory One
imports Lift
begin

type_synonym
  one = "unit lift"

translations
  (type) "one" <= (type) "unit lift"

definition ONE :: "one"
  where "ONE == Def ()"

text {* Exhaustion and Elimination for type @{typ one} *}

lemma Exh_one: "t = \<bottom> \<or> t = ONE"
unfolding ONE_def by (induct t) simp_all

lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
unfolding ONE_def by (induct p) simp_all

lemma one_induct [case_names bottom ONE]: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
by (cases x rule: oneE) simp_all

lemma dist_below_one [simp]: "ONE \<notsqsubseteq> \<bottom>"
unfolding ONE_def by simp

lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
by (induct x rule: one_induct) simp_all

lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
by (induct x rule: one_induct) simp_all

lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
unfolding ONE_def by simp

lemma one_neq_iffs [simp]:
  "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
  "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
  "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
  "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
by (induct x rule: one_induct) simp_all

lemma compact_ONE: "compact ONE"
by (rule compact_chfin)

text {* Case analysis function for type @{typ one} *}

definition
  one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a" where
  "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"

translations
  "case x of XCONST ONE \<Rightarrow> t" == "CONST one_case\<cdot>t\<cdot>x"
  "case x of XCONST ONE :: 'a \<Rightarrow> t" => "CONST one_case\<cdot>t\<cdot>x"
  "\<Lambda> (XCONST ONE). t" == "CONST one_case\<cdot>t"

lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
by (simp add: one_case_def)

lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
by (simp add: one_case_def)

lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
by (induct x rule: one_induct) simp_all

end


section \<open> Design Proof Tactics \<close>

theory utp_des_tactics
  imports utp_des_theory
begin

text \<open> The tactics split apart a healthy normal design predicate into its pre-postcondition form,
  using elimination rules, and then attempt to prove refinement conjectures. \<close>

named_theorems ND_elim

lemma ndes_elim: "\<lbrakk> P is \<^bold>N; Q(\<lfloor>pre\<^sub>D(P)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P)) \<rbrakk> \<Longrightarrow> Q(P)"
  by (simp add: ndesign_form)

lemma ndes_ind_elim: "\<lbrakk> \<And> i. P i is \<^bold>N; Q(\<lambda> i. \<lfloor>pre\<^sub>D(P i)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P i)) \<rbrakk> \<Longrightarrow> Q(P)"
  by (simp add: ndesign_form)

lemma ndes_split [ND_elim]: "\<lbrakk> P is \<^bold>N; \<And> pre post. Q(pre \<turnstile>\<^sub>n post) \<rbrakk> \<Longrightarrow> Q(P)"
  by (metis H1_H2_eq_rdesign H1_H3_impl_H2 H3_unrest_out_alpha Healthy_def drop_pre_inv ndesign_def)

text \<open> Use given closure laws (cls) to expand normal design predicates \<close>

method ndes_expand uses cls = (insert cls, (erule ND_elim)+)

text \<open> Expand and simplify normal designs \<close>

method ndes_simp uses cls =
  ((ndes_expand cls: cls)?, (simp add: ndes_simp closure alpha usubst unrest wp prod.case_eq_if))

text \<open> Attempt to discharge a refinement between two normal designs \<close>

method ndes_refine uses cls =
  (ndes_simp cls: cls; rule_tac ndesign_refine_intro; (insert cls; rel_simp; auto?))

text \<open> Attempt to discharge an equality between two normal designs \<close>

method ndes_eq uses cls =
  (ndes_simp cls: cls; rule_tac antisym; rule_tac ndesign_refine_intro; (insert cls; rel_simp; auto?))

end