chapter\<open>Examples\<close>
text\<open>In this chapter, we provide some examples of EFSMs and proofs over them. We first present a
formalisation of a simple drinks machine. Next, we prove observational equivalence of an alternative
model. Finally, we prove some temporal properties of the first example.\<close>

section\<open>Drinks Machine\<close>
text\<open>This theory formalises a simple drinks machine. The \emph{select} operation takes one
argument - the desired beverage. The \emph{coin} operation also takes one parameter representing
the value of the coin. The \emph{vend} operation has two flavours - one which dispenses the drink if
the customer has inserted enough money, and one which dispenses nothing if the user has not inserted
sufficient funds.

We first define a datatype \emph{statemane} which corresponds to $S$ in the formal definition.
Note that, while statename has four elements, the drinks machine presented here only requires three
states. The fourth element is included here so that the \emph{statename} datatype may be used in
the next example.\<close>
theory Drinks_Machine
  imports "EFSM.EFSM"
begin

text_raw\<open>\snip{selectdef}{1}{2}{%\<close>
definition select :: "transition" where
"select \<equiv> \<lparr>
        Label = STR ''select'',
        Arity = 1,
        Guards = [],
        Outputs = [],
        Updates = [
                    (1, V (I 0)),
                    (2, L (Num 0))
                  ]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{coindef}{1}{2}{%\<close>
definition coin :: "transition" where
"coin \<equiv> \<lparr>
        Label = STR ''coin'',
        Arity = 1,
        Guards = [],
        Outputs = [Plus (V (R 2)) (V (I 0))],
        Updates = [
                    (1, V (R 1)),
                    (2, Plus (V (R 2)) (V (I 0)))
                  ]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{venddef}{1}{2}{%\<close>
definition vend:: "transition" where
"vend\<equiv> \<lparr>
        Label = STR ''vend'',
        Arity = 0,
        Guards = [(Ge (V (R 2)) (L (Num 100)))],
        Outputs =  [(V (R 1))],
        Updates = [(1, V (R 1)), (2, V (R 2))]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{vendfaildef}{1}{2}{%\<close>
definition vend_fail :: "transition" where
"vend_fail \<equiv> \<lparr>
        Label = STR ''vend'',
        Arity = 0,
        Guards = [(Lt (V (R 2)) (L (Num 100)))],
        Outputs =  [],
        Updates = [(1, V (R 1)), (2, V (R 2))]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{drinksdef}{1}{2}{%\<close>
definition drinks :: "transition_matrix" where
"drinks \<equiv> {|
          ((0,1), select),
          ((1,1), coin),
          ((1,1), vend_fail),
          ((1,2), vend)
         |}"
text_raw\<open>}%endsnip\<close>

lemmas transitions = select_def coin_def vend_def vend_fail_def

lemma drinks_states: "S drinks = {|0, 1, 2|}"
  apply (simp add: S_def drinks_def)
  by auto

lemma possible_steps_0:
  "length i = 1 \<Longrightarrow>
   possible_steps drinks 0 r (STR ''select'') i = {|(1, select)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions apply_guards_def)

lemma first_step_select:
  "(s', t) |\<in>| possible_steps drinks 0 r aa b \<Longrightarrow> s' = 1 \<and> t = select"
  apply (simp add: possible_steps_def fimage_def ffilter_def fmember_def Abs_fset_inverse Set.filter_def drinks_def)
  apply safe
  by (simp_all add: transitions)

lemma drinks_vend_insufficient:
  "r $ 2 = Some (Num x1) \<Longrightarrow>
   x1 < 100 \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {|(1, vend_fail)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions apply_guards_def value_gt_def join_ir_def connectives)

lemma drinks_vend_invalid:
  "\<nexists>n. r $ 2 = Some (Num n) \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {||}"
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (simp add: MaybeBoolInt_not_num_1 value_gt_def)

lemma possible_steps_1_coin:
  "length i = 1 \<Longrightarrow> possible_steps drinks 1 r (STR ''coin'') i = {|(1, coin)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions)

lemma possible_steps_2_vend:
  "\<exists>n. r $ 2 = Some (Num n) \<and> n \<ge> 100 \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {|(2, vend)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions apply_guards_def value_gt_def join_ir_def connectives)

lemma recognises_from_2:
  "recognises_execution drinks 1 <1 $:= d, 2 $:= Some (Num 100)> [(STR ''vend'', [])]"
  apply (rule recognises_execution.step)
  apply (rule_tac x="(2, vend)" in fBexI)
   apply simp
  by (simp add: possible_steps_2_vend)

lemma recognises_from_1a:
  "recognises_execution drinks 1 <1 $:= d, 2 $:= Some (Num 50)> [(STR ''coin'', [Num 50]), (STR ''vend'', [])]"
  apply (rule recognises_execution.step)
  apply (rule_tac x="(1, coin)" in fBexI)
   apply (simp add: apply_updates_def coin_def finfun_update_twist value_plus_def recognises_from_2)
  by (simp add: possible_steps_1_coin)

lemma recognises_from_1: "recognises_execution drinks 1 <2 $:= Some (Num 0), 1 $:= Some d>
     [(STR ''coin'', [Num 50]), (STR ''coin'', [Num 50]), (STR ''vend'', [])]"
  apply (rule recognises_execution.step)
  apply (rule_tac x="(1, coin)" in fBexI)
   apply (simp add: apply_updates_def coin_def value_plus_def finfun_update_twist recognises_from_1a)
  by (simp add: possible_steps_1_coin)

lemma rejects_input:
  "l \<noteq> STR ''coin'' \<Longrightarrow>
   l \<noteq> STR ''vend'' \<Longrightarrow>
   \<not> recognises_execution drinks 1 d' [(l, i)]"
  apply (rule no_possible_steps_rejects)
  by (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)

lemma rejects_recognises_prefix: "l \<noteq> STR ''coin'' \<Longrightarrow>
   l \<noteq> STR ''vend'' \<Longrightarrow>
   \<not> (recognises drinks [(STR ''select'', [Str ''coke'']), (l, i)])"
  apply (rule trace_reject_later)
  apply (simp add: possible_steps_0 select_def join_ir_def input2state_def)
  using rejects_input by blast

lemma rejects_termination:
  "observe_execution drinks 0 <> [(STR ''select'', [Str ''coke'']), (STR ''rejects'', [Num 50]), (STR ''coin'', [Num 50])] = [[]]"
  apply (rule observe_execution_step)
   apply (simp add: step_def possible_steps_0 select_def)
  apply (rule observe_execution_no_possible_step)
  by (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)

(* Part of Example 2 in Foster et. al. *)
lemma r2_0_vend:
  "can_take_transition vend i r \<Longrightarrow>
   \<exists>n. r $ 2 = Some (Num n) \<and> n \<ge> 100" (* You can't take vendimmediately after taking select *)
  apply (simp add: can_take_transition_def can_take_def vend_def apply_guards_def maybe_negate_true maybe_or_false connectives value_gt_def)
  using MaybeBoolInt.elims by force

lemma drinks_vend_sufficient: "r $ 2 = Some (Num x1) \<Longrightarrow>
                x1 \<ge> 100 \<Longrightarrow>
                possible_steps drinks 1 r (STR ''vend'') [] = {|(2, vend)|}"
  using possible_steps_2_vend by blast

lemma drinks_end: "possible_steps drinks 2 r a b = {||}"
  apply (simp add: possible_steps_def drinks_def transitions)
  by force

lemma drinks_vend_r2_String:
  "r $ 2 = Some (value.Str x2) \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {||}"
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (simp add: value_gt_def)

lemma drinks_vend_r2_rejects:
  "\<nexists>n. r $ 2 = Some (Num n) \<Longrightarrow> step drinks 1 r (STR ''vend'') [] = None"
  apply (rule no_possible_steps_1)
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (simp add: MaybeBoolInt_not_num_1 value_gt_def)

lemma drinks_0_rejects:
  "\<not> (fst a = STR ''select'' \<and> length (snd a) = 1) \<Longrightarrow>
    (possible_steps drinks 0 r (fst a) (snd a)) = {||}"
  apply (simp add: drinks_def possible_steps_def transitions)
  by force

lemma drinks_vend_empty: "(possible_steps drinks 0 <> (STR ''vend'') []) = {||}"
  using drinks_0_rejects
  by auto

lemma drinks_1_rejects:
  "fst a = STR ''coin'' \<longrightarrow> length (snd a) \<noteq> 1 \<Longrightarrow>
          a \<noteq> (STR ''vend'', []) \<Longrightarrow>
          possible_steps drinks 1 r (fst a) (snd a) = {||}"
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (metis prod.collapse)

lemma drinks_rejects_future: "\<not> recognises_execution drinks 2 d ((l, i)#t)"
  apply (rule no_possible_steps_rejects)
  by (simp add: possible_steps_empty drinks_def)

lemma drinks_1_rejects_trace:
  assumes not_vend: "e \<noteq> (STR ''vend'', [])"
      and not_coin: "\<nexists>i. e = (STR ''coin'', [i])"
  shows "\<not> recognises_execution drinks 1 r (e # es)"
proof-
  show ?thesis
    apply (cases e, simp)
    apply (rule no_possible_steps_rejects)
    apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
    apply (case_tac b)
    using not_vend apply simp
    using not_coin by auto
qed

lemma rejects_state_step: "s > 1 \<Longrightarrow> step drinks s r l i = None"
  apply (rule no_possible_steps_1)
  by (simp add: possible_steps_empty drinks_def)

lemma invalid_other_states:
  "s > 1 \<Longrightarrow> \<not> recognises_execution drinks s r ((aa, b) # t)"
  apply (rule no_possible_steps_rejects)
  by (simp add: possible_steps_empty drinks_def)

lemma vend_ge_100:
  "possible_steps drinks 1 r l i = {|(2, vend)|} \<Longrightarrow>
   \<not>? value_gt (Some (Num 100)) (r $ 2) = trilean.true"
  apply (insert possible_steps_apply_guards[of drinks 1 r l i 2 vend])
  by (simp add: possible_steps_def apply_guards_def vend_def)

lemma drinks_no_possible_steps_1:
  assumes not_coin: "\<not> (a = STR ''coin'' \<and> length b = 1)"
      and not_vend: "\<not> (a = STR ''vend'' \<and> b = [])"
    shows "possible_steps drinks 1 r a b = {||}"
  using drinks_1_rejects not_coin not_vend by auto

lemma possible_steps_select_wrong_arity: "a = STR ''select'' \<Longrightarrow>
       length b \<noteq> 1 \<Longrightarrow>
       possible_steps drinks 0 <> a b = {||}"
  apply (simp add: possible_steps_def ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def drinks_def)
  apply safe
  by (simp_all add: select_def)

lemma possible_steps_0_invalid:
  "\<not> (l = STR ''select'' \<and> length i = 1) \<Longrightarrow>
   possible_steps drinks 0 <> l i = {||}"
  using possible_steps_0_not_select possible_steps_select_wrong_arity by fastforce

end


(*  Title:    HOL/Library/Nonpos_Ints.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Non-negative, non-positive integers and reals\<close>

theory Nonpos_Ints
imports Complex_MainRLT
begin

subsection\<open>Non-positive integers\<close>
text \<open>
  The set of non-positive integers on a ring. (in analogy to the set of non-negative
  integers \<^term>\<open>\<nat>\<close>) This is useful e.g. for the Gamma function.
\<close>

definition nonpos_Ints ("\<int>\<^sub>\<le>\<^sub>0") where "\<int>\<^sub>\<le>\<^sub>0 = {of_int n |n. n \<le> 0}"

lemma zero_in_nonpos_Ints [simp,intro]: "0 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "0::int"])

lemma neg_one_in_nonpos_Ints [simp,intro]: "-1 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-1::int"])

lemma neg_numeral_in_nonpos_Ints [simp,intro]: "-numeral n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-numeral n::int"])

lemma one_notin_nonpos_Ints [simp]: "(1 :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma numeral_notin_nonpos_Ints [simp]: "(numeral n :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma minus_of_nat_in_nonpos_Ints [simp, intro]: "- of_nat n \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  have "- of_nat n = of_int (-int n)" by simp
  also have "-int n \<le> 0" by simp
  hence "of_int (-int n) \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
  finally show ?thesis .
qed

lemma of_nat_in_nonpos_Ints_iff: "(of_nat n :: 'a :: {ring_1,ring_char_0}) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n = 0"
proof
  assume "(of_nat n :: 'a) \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain m where "of_nat n = (of_int m :: 'a)" "m \<le> 0" by (auto simp: nonpos_Ints_def)
  hence "(of_int m :: 'a) = of_nat n" by simp
  also have "... = of_int (int n)" by simp
  finally have "m = int n" by (subst (asm) of_int_eq_iff)
  with \<open>m \<le> 0\<close> show "n = 0" by auto
qed simp

lemma nonpos_Ints_of_int: "n \<le> 0 \<Longrightarrow> of_int n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by blast

lemma nonpos_IntsI:
  "x \<in> \<int> \<Longrightarrow> x \<le> 0 \<Longrightarrow> (x :: 'a :: linordered_idom) \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def Ints_def by auto

lemma nonpos_Ints_subset_Ints: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_nonpos [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<le> (0 :: 'a :: linordered_idom)"
  unfolding nonpos_Ints_def by auto

lemma nonpos_Ints_Int [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_cases:
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = of_int n" "n \<le> 0"
  using assms unfolding nonpos_Ints_def by (auto elim!: Ints_cases)

lemma nonpos_Ints_cases':
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = -of_nat n"
proof -
  from assms obtain m where "x = of_int m" and m: "m \<le> 0" by (auto elim!: nonpos_Ints_cases)
  hence "x = - of_int (-m)" by auto
  also from m have "(of_int (-m) :: 'a) = of_nat (nat (-m))" by simp_all
  finally show ?thesis by (rule that)
qed

lemma of_real_in_nonpos_Ints_iff: "(of_real x :: 'a :: real_algebra_1) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "of_real x \<in> (\<int>\<^sub>\<le>\<^sub>0 :: 'a set)"
  then obtain n where "(of_real x :: 'a) = of_int n" "n \<le> 0" by (erule nonpos_Ints_cases)
  note \<open>of_real x = of_int n\<close>
  also have "of_int n = of_real (of_int n)" by (rule of_real_of_int_eq [symmetric])
  finally have "x = of_int n" by (subst (asm) of_real_eq_iff)
  with \<open>n \<le> 0\<close> show "x \<in> \<int>\<^sub>\<le>\<^sub>0" by (simp add: nonpos_Ints_of_int)
qed (auto elim!: nonpos_Ints_cases intro!: nonpos_Ints_of_int)

lemma nonpos_Ints_altdef: "\<int>\<^sub>\<le>\<^sub>0 = {n \<in> \<int>. (n :: 'a :: linordered_idom) \<le> 0}"
  by (auto intro!: nonpos_IntsI elim!: nonpos_Ints_cases)

lemma uminus_in_Nats_iff: "-x \<in> \<nat> \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "-x \<in> \<nat>"
  then obtain n where "n \<ge> 0" "-x = of_int n" by (auto simp: Nats_altdef1)
  hence "-n \<le> 0" "x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "x \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
next
  assume "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain n where "n \<le> 0" "x = of_int n" by (auto simp: nonpos_Ints_def)
  hence "-n \<ge> 0" "-x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "-x \<in> \<nat>" unfolding Nats_altdef1 by blast
qed

lemma uminus_in_nonpos_Ints_iff: "-x \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<nat>"
  using uminus_in_Nats_iff[of "-x"] by simp

lemma nonpos_Ints_mult: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<nat>"
  using Nats_mult[of "-x" "-y"] by (simp add: uminus_in_Nats_iff)

lemma Nats_mult_nonpos_Ints: "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of x "-y"] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_mult_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of "-x" y] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_add:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x + y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "-y"] uminus_in_Nats_iff[of "y+x", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma nonpos_Ints_diff_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x - y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "y"] uminus_in_Nats_iff[of "x-y", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma Nats_diff_nonpos_Ints:
  "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x - y \<in> \<nat>"
  using Nats_add[of "x" "-y"] by (simp add: uminus_in_Nats_iff add.commute)

lemma plus_of_nat_eq_0_imp: "z + of_nat n = 0 \<Longrightarrow> z \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  assume "z + of_nat n = 0"
  hence A: "z = - of_nat n" by (simp add: eq_neg_iff_add_eq_0)
  show "z \<in> \<int>\<^sub>\<le>\<^sub>0" by (subst A) simp
qed

subsection\<open>Non-negative reals\<close>

definition nonneg_Reals :: "'a::real_algebra_1 set"  ("\<real>\<^sub>\<ge>\<^sub>0")
  where "\<real>\<^sub>\<ge>\<^sub>0 = {of_real r | r. r \<ge> 0}"

lemma nonneg_Reals_of_real_iff [simp]: "of_real r \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> r \<ge> 0"
  by (force simp add: nonneg_Reals_def)

lemma nonneg_Reals_subset_Reals: "\<real>\<^sub>\<ge>\<^sub>0 \<subseteq> \<real>"
  unfolding nonneg_Reals_def Reals_def by blast

lemma nonneg_Reals_Real [dest]: "x \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> x \<in> \<real>"
  unfolding nonneg_Reals_def Reals_def by blast

lemma nonneg_Reals_of_nat_I [simp]: "of_nat n \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis nonneg_Reals_of_real_iff of_nat_0_le_iff of_real_of_nat_eq)

lemma nonneg_Reals_cases:
  assumes "x \<in> \<real>\<^sub>\<ge>\<^sub>0"
  obtains r where "x = of_real r" "r \<ge> 0"
  using assms unfolding nonneg_Reals_def by (auto elim!: Reals_cases)

lemma nonneg_Reals_zero_I [simp]: "0 \<in> \<real>\<^sub>\<ge>\<^sub>0"
  unfolding nonneg_Reals_def by auto

lemma nonneg_Reals_one_I [simp]: "1 \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (mono_tags, lifting) nonneg_Reals_of_nat_I of_nat_1)

lemma nonneg_Reals_minus_one_I [simp]: "-1 \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis nonneg_Reals_of_real_iff le_minus_one_simps(3) of_real_1 of_real_def real_vector.scale_minus_left)

lemma nonneg_Reals_numeral_I [simp]: "numeral w \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (no_types) nonneg_Reals_of_nat_I of_nat_numeral)

lemma nonneg_Reals_minus_numeral_I [simp]: "- numeral w \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  using nonneg_Reals_of_real_iff not_zero_le_neg_numeral by fastforce

lemma nonneg_Reals_add_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a + b \<in> \<real>\<^sub>\<ge>\<^sub>0"
apply (simp add: nonneg_Reals_def)
apply clarify
apply (rename_tac r s)
apply (rule_tac x="r+s" in exI, auto)
done

lemma nonneg_Reals_mult_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<ge>\<^sub>0"
  unfolding nonneg_Reals_def  by (auto simp: of_real_def)

lemma nonneg_Reals_inverse_I [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "a \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> inverse a \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: nonneg_Reals_def image_iff) (metis inverse_nonnegative_iff_nonnegative of_real_inverse)

lemma nonneg_Reals_divide_I [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: divide_inverse)

lemma nonneg_Reals_pow_I [simp]: "a \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> a^n \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (induction n) auto

lemma complex_nonneg_Reals_iff: "z \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> Re z \<ge> 0 \<and> Im z = 0"
  by (auto simp: nonneg_Reals_def) (metis complex_of_real_def complex_surj)

lemma ii_not_nonneg_Reals [iff]: "\<i> \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: complex_nonneg_Reals_iff)

subsection\<open>Non-positive reals\<close>

definition nonpos_Reals :: "'a::real_algebra_1 set"  ("\<real>\<^sub>\<le>\<^sub>0")
  where "\<real>\<^sub>\<le>\<^sub>0 = {of_real r | r. r \<le> 0}"

lemma nonpos_Reals_of_real_iff [simp]: "of_real r \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> r \<le> 0"
  by (force simp add: nonpos_Reals_def)

lemma nonpos_Reals_subset_Reals: "\<real>\<^sub>\<le>\<^sub>0 \<subseteq> \<real>"
  unfolding nonpos_Reals_def Reals_def by blast

lemma nonpos_Ints_subset_nonpos_Reals: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonpos_Ints_cases nonpos_Ints_nonpos nonpos_Ints_of_int
    nonpos_Reals_of_real_iff of_real_of_int_eq subsetI)

lemma nonpos_Reals_of_nat_iff [simp]: "of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n=0"
  by (metis nonpos_Reals_of_real_iff of_nat_le_0_iff of_real_of_nat_eq)

lemma nonpos_Reals_Real [dest]: "x \<in> \<real>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<real>"
  unfolding nonpos_Reals_def Reals_def by blast

lemma nonpos_Reals_cases:
  assumes "x \<in> \<real>\<^sub>\<le>\<^sub>0"
  obtains r where "x = of_real r" "r \<le> 0"
  using assms unfolding nonpos_Reals_def by (auto elim!: Reals_cases)

lemma uminus_nonneg_Reals_iff [simp]: "-x \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> x \<in> \<real>\<^sub>\<le>\<^sub>0"
  apply (auto simp: nonpos_Reals_def nonneg_Reals_def)
  apply (metis nonpos_Reals_of_real_iff minus_minus neg_le_0_iff_le of_real_minus)
  done

lemma uminus_nonpos_Reals_iff [simp]: "-x \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (no_types) minus_minus uminus_nonneg_Reals_iff)

lemma nonpos_Reals_zero_I [simp]: "0 \<in> \<real>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Reals_def by force

lemma nonpos_Reals_one_I [simp]: "1 \<notin> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_minus_one_I uminus_nonneg_Reals_iff by blast

lemma nonpos_Reals_numeral_I [simp]: "numeral w \<notin> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_minus_numeral_I uminus_nonneg_Reals_iff by blast

lemma nonpos_Reals_add_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a + b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_add_I add_uminus_conv_diff minus_diff_eq minus_minus uminus_nonpos_Reals_iff)

lemma nonpos_Reals_mult_I1: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_mult_I mult_minus_right uminus_nonneg_Reals_iff)

lemma nonpos_Reals_mult_I2: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_mult_I mult_minus_left uminus_nonneg_Reals_iff)

lemma nonpos_Reals_mult_of_nat_iff:
  fixes a:: "'a :: real_div_algebra" shows "a * of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0 \<or> n=0"
  apply (auto intro: nonpos_Reals_mult_I2)
  apply (auto simp: nonpos_Reals_def)
  apply (rule_tac x="r/n" in exI)
  apply (auto simp: field_split_simps)
  done

lemma nonpos_Reals_inverse_I:
    fixes a :: "'a::real_div_algebra"
    shows "a \<in> \<real>\<^sub>\<le>\<^sub>0 \<Longrightarrow> inverse a \<in> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_inverse_I uminus_nonneg_Reals_iff by fastforce

lemma nonpos_Reals_divide_I1:
    fixes a :: "'a::real_div_algebra"
    shows "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (simp add: nonpos_Reals_inverse_I nonpos_Reals_mult_I1 divide_inverse)

lemma nonpos_Reals_divide_I2:
    fixes a :: "'a::real_div_algebra"
    shows "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_divide_I minus_divide_left uminus_nonneg_Reals_iff)

lemma nonpos_Reals_divide_of_nat_iff:
  fixes a:: "'a :: real_div_algebra" shows "a / of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0 \<or> n=0"
  apply (auto intro: nonpos_Reals_divide_I2)
  apply (auto simp: nonpos_Reals_def)
  apply (rule_tac x="r*n" in exI)
  apply (auto simp: field_split_simps mult_le_0_iff)
  done

lemma nonpos_Reals_inverse_iff [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "inverse a \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0"
  using nonpos_Reals_inverse_I by fastforce

lemma nonpos_Reals_pow_I: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; odd n\<rbrakk> \<Longrightarrow> a^n \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_pow_I power_minus_odd uminus_nonneg_Reals_iff)

lemma complex_nonpos_Reals_iff: "z \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> Re z \<le> 0 \<and> Im z = 0"
   using complex_is_Real_iff by (force simp add: nonpos_Reals_def)

lemma ii_not_nonpos_Reals [iff]: "\<i> \<notin> \<real>\<^sub>\<le>\<^sub>0"
  by (simp add: complex_nonpos_Reals_iff)

end


theory concrete_05
  imports Main
begin

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app [] ys = ys" |
"app (x # xs) ys = x # app xs ys"

thm app.simps
thm app.simps(1)
thm app.simps(1-2)

thm surj_def

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>y. \<exists>x. y = f x" by (simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma "\<not>surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  from this show "False" by blast
qed

lemma "\<not>surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  thus "False" by blast
qed

lemma "\<not>surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  have 1: "\<exists>a. {x. x \<notin> f x} = f a" using 0 by (auto simp: surj_def)
  show "False" using 1 by blast
qed

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -
  have "\<exists>a. {x. x \<notin> f x} = f a" using s
    by (auto simp: surj_def)
  thus "False" by blast
qed

lemma "\<not>surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

lemma fixes a b :: int assumes "b dvd (a + b)" shows "b dvd a"
proof -
  have "\<exists>k'. a = b * k'" if asm: "a + b = b * k" for k
  proof
    show "a = b * (k - 1)" using asm by (simp add: algebra_simps)
  qed
  then show ?thesis using assms by (auto simp add: dvd_def)
qed

end


theory Order_Relations
  imports Comparison_Sort_Lower_Bound.Linorder_Relations
begin

text \<open>Weaker versions of \<^term>\<open>refl_on\<close> (and \<^term>\<open>preorder_on\<close>/\<^term>\<open>linorder_on\<close>) that don't enforce
that the relation is only defined on the given set. Alternative would be to weaken later lemmas
by using stronger assumptions.\<close>
definition "refl_on' S r \<longleftrightarrow> (\<forall>x\<in>S. (x,x) \<in> r)"
definition "preorder_on' S r \<longleftrightarrow> refl_on' S r \<and> trans r"
definition "linorder_on' S r \<longleftrightarrow> refl_on' S r \<and> antisym r \<and> trans r \<and> total_on S r"

definition "preorders_on S \<equiv> {r. preorder_on S r}"

lemma refl_on'D: "refl_on' S r \<Longrightarrow> a \<in> S \<Longrightarrow> (a,a) \<in> r"
  unfolding refl_on'_def
  by blast

lemma refl_on'_Restr: "refl_on' S r \<Longrightarrow> refl_on' S (Restr r S)"
  unfolding refl_on'_def
  by blast

lemma linorder_on'_refl_on'D: "linorder_on' S r \<Longrightarrow> refl_on' S r"
  unfolding linorder_on'_def
  by blast

lemma linorder_on'_transD: "linorder_on' S r \<Longrightarrow> trans r"
  unfolding linorder_on'_def
  by blast

lemma linorder_on'_antisymD: "linorder_on' S r \<Longrightarrow> antisym r"
  unfolding linorder_on'_def
  by blast

lemma preorders_onD: "r \<in> preorders_on S \<Longrightarrow> preorder_on S r"
  unfolding preorders_on_def
  by blast

lemma preorders_onI[intro]: "preorder_on S r \<Longrightarrow> r \<in> preorders_on S"
  unfolding preorders_on_def
  by blast

lemma preorder_on_subset_Times: "preorder_on S r \<Longrightarrow> r \<subseteq> S \<times> S"
  unfolding preorder_on_def
  by (auto dest: refl_onD1 refl_onD2)

lemma preorders_on_subset_Pow: "preorders_on S \<subseteq> Pow (S \<times> S)"
  by (auto dest: preorders_onD preorder_on_subset_Times)

lemma finite_preorders_on[intro]:
  assumes "finite S"
  shows "finite (preorders_on S)"
  using assms
  by (auto intro: finite_subset[OF preorders_on_subset_Pow])

lemma refl_on_imp_refl_on': "refl_on S r \<Longrightarrow> refl_on' S r"
  unfolding refl_on_def refl_on'_def
  by blast

lemma linorder_on_imp_linorder_on': "linorder_on S r \<Longrightarrow> linorder_on' S r"
  unfolding linorder_on_def linorder_on'_def
  by (auto dest: refl_on_imp_refl_on')

lemma linorder_on_imp_preorder_on: "linorder_on S r \<Longrightarrow> preorder_on S r"
  unfolding linorder_on_def preorder_on_def
  by blast

lemma linorder_on'_imp_preorder_on': "linorder_on' S r \<Longrightarrow> preorder_on' S r"
  unfolding linorder_on'_def preorder_on'_def
  by blast

lemma preorder_on_imp_preorder_on': "preorder_on S r \<Longrightarrow> preorder_on' S r"
  unfolding preorder_on_def preorder_on'_def
  by (blast intro: refl_on_imp_refl_on')

lemma refl_on'_subset:
  "refl_on' S r \<Longrightarrow> T \<subseteq> S \<Longrightarrow> refl_on' T r"
  unfolding refl_on'_def
  by blast

lemma linorder_on'_subset:
  "linorder_on' S r \<Longrightarrow> T \<subseteq> S \<Longrightarrow> linorder_on' T r"
  unfolding linorder_on'_def
  by (auto intro: refl_on'_subset total_on_subset)

lemma preorder_on'_subset:
  "preorder_on' S r \<Longrightarrow> T \<subseteq> S \<Longrightarrow> preorder_on' T r"
  unfolding preorder_on'_def
  by (auto intro: refl_on'_subset total_on_subset)

lemma total_on_Restr:
  "total_on S r \<Longrightarrow> total_on S (Restr r S)"
  unfolding total_on_def
  by blast

lemma linorder_on'_Restr:
  "linorder_on' S r \<Longrightarrow> linorder_on' S (Restr r S)"
  unfolding linorder_on'_def
  by (auto intro: refl_on'_Restr antisym_subset trans_Restr total_on_Restr)

definition is_min_rel :: "('a \<Rightarrow> bool) \<Rightarrow> 'a rel \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_min_rel P r x = (P x \<and> (\<nexists>y. P y \<and> (y, x) \<in> r \<and> (x, y) \<notin> r))"

definition min_rel :: "('a \<Rightarrow> bool) \<Rightarrow> 'a rel \<Rightarrow> 'a" where
  "min_rel P r = (SOME x. is_min_rel P r x)"

\<comment> \<open>use \<^term>\<open>Restr\<close> to make minimum deterministic in some cases\<close>
definition min_on_rel :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a" where
  "min_on_rel S r = min_rel (\<lambda>x. x \<in> S) (Restr r S)"

lemma ex_min_if_finite:
  "\<lbrakk> finite S; S \<noteq> {}; preorder_on' S r \<rbrakk> \<Longrightarrow> \<exists>m\<in>S. \<not>(\<exists>x\<in>S. (x,m) \<in> Restr r S \<and> (m,x) \<notin> Restr r S)"
proof (induction arbitrary: r rule: finite.induct)
  case (insertI A a)
  then show ?case
  proof (cases "A \<noteq> {}")
    case True
    from insertI have "preorder_on' A r"
      by (auto intro: preorder_on'_subset)

    with True insertI obtain m where m: "m\<in>A" "\<not>(\<exists>x\<in>A. (x,m) \<in> r \<and> (m,x) \<notin> r)"
      by blast

    with \<open>preorder_on' (insert a A) r\<close> show ?thesis
      unfolding preorder_on'_def
      by (auto dest: transD)
  qed simp
qed simp

lemma ex_is_min_if_finite:
  assumes "preorder_on' S r"
  assumes "finite S" "S \<noteq> {}"
  shows "\<exists>x. is_min_rel (\<lambda>x. x \<in> S) (Restr r S) x"
  using assms
  unfolding is_min_rel_def
  using ex_min_if_finite
  by fast

lemma min_if_finite':
  assumes "preorder_on' S r"
  assumes "finite S" "S \<noteq> {}"
  shows "min_on_rel S r \<in> S" and "\<not>(\<exists>x\<in>S. (x, min_on_rel S r) \<in> Restr r S \<and> (min_on_rel S r, x) \<notin> Restr r S)"
  using assms
  by (metis ex_is_min_if_finite is_min_rel_def min_on_rel_def min_rel_def some_eq_ex)+

lemma min_if_finite:
  assumes "preorder_on' S r"
  assumes "finite S" and "S \<noteq> {}"
  shows "min_on_rel S r \<in> S"
    and "\<not>(\<exists>x\<in>S. (x, min_on_rel S r) \<in> r \<and> (min_on_rel S r, x) \<notin> r)"
  using assms min_if_finite' by force+

lemma min_rel_linorder_eq:
  assumes "linorder_on' {x. P x} r"
  assumes "P a"
  assumes "\<forall>y. P y \<longrightarrow> (a,y) \<in> r"
  shows "min_rel P r = a"
  unfolding min_rel_def is_min_rel_def
  by (rule someI2[of _ a])
     (use assms in \<open>auto simp add: antisym_def linorder_on'_def\<close>)

lemma min_on_rel_linorder_eq:
  assumes "linorder_on' S r"
  assumes "a \<in> S"
  assumes "\<forall>y\<in>S. (a,y) \<in> r"
  shows "min_on_rel S r = a"
  using assms
  unfolding min_on_rel_def
  by (auto intro!: min_rel_linorder_eq intro: linorder_on'_Restr)

lemma min_on_rel_singleton:
  shows "min_on_rel {a} r = a"
  by (auto simp: min_on_rel_def min_rel_def is_min_rel_def)

lemma min_on_rel_least:
  assumes "linorder_on' S r"
  assumes S: "finite S" "S \<noteq> {}"
  assumes "y \<in> S"
  shows "(min_on_rel S r, y) \<in> r"
  using S assms
proof (induction S arbitrary: y rule: finite_induct)
  case (insert s S)

  show ?case
  proof (cases "S = {}")
    case True
    with insert.prems show ?thesis
      by (auto simp: min_on_rel_singleton linorder_on'_def refl_on'_def)
  next
    case False
    let ?min = "min_on_rel S r"

    from insert.prems False have IH: "y' \<in> S \<Longrightarrow> (?min, y') \<in> r" for y'
      by (intro insert.IH) (auto intro: linorder_on'_subset)

    from False insert.prems have "?min \<in> S"
      by (auto intro: min_if_finite linorder_on'_imp_preorder_on' dest: linorder_on'_subset)

    with insert.prems
    consider (less) "(s, ?min) \<in> r" "(?min, s) \<notin> r" | (eq) "(s, ?min) \<in> r" "(?min, s) \<in> r" | (gt) "(s, ?min) \<notin> r" "(?min, s) \<in> r"
      unfolding total_on_def linorder_on'_def refl_on'_def
      by force

    then show ?thesis
    proof cases
      case less
      with insert.prems have "min_on_rel (insert s S) r = s"
        by (intro min_on_rel_linorder_eq)
           (auto dest: linorder_on'_refl_on'D refl_on'D linorder_on'_transD IH transD)

      with insert.prems less show ?thesis
        by (auto dest: linorder_on'_refl_on'D refl_on'D linorder_on'_transD IH transD)
    next
      case eq
      with insert.prems \<open>?min \<in> S\<close> \<open>s \<notin> S\<close> have "min_on_rel (insert s S) r = s"
        by (auto dest!: linorder_on'_antisymD simp: antisym_def) blast+

      with insert.prems eq show ?thesis
        by (auto dest: linorder_on'_refl_on'D refl_on'D linorder_on'_transD IH transD)
    next
      case gt
      with insert.prems \<open>?min \<in> S\<close> have "min_on_rel (insert s S) r = ?min"
        by (intro min_on_rel_linorder_eq) (auto dest: IH)

      with insert.prems gt show ?thesis
        by (auto dest: IH)
    qed
  qed
qed blast

subsection \<open>\<^term>\<open>\<pi> permutes A\<close>\<close>
lemma refl_on_permutes: "refl_on A r \<Longrightarrow> \<pi> permutes A \<Longrightarrow> refl_on A {(x,y). x \<in> A \<and> y \<in> A \<and> (\<pi> x, \<pi> y) \<in> r}"
  unfolding refl_on_def
  by (auto simp: permutes_in_image)

lemma trans_permutes: "trans r \<Longrightarrow> trans {(x,y). x \<in> A \<and> y \<in> A \<and> (\<pi> x, \<pi> y) \<in> r}"
  unfolding trans_def
  by auto

lemma preorder_on_permutes: "preorder_on A r \<Longrightarrow> \<pi> permutes A \<Longrightarrow> preorder_on A {(x,y). x \<in> A \<and> y \<in> A \<and> (\<pi> x, \<pi> y) \<in> r}"
  unfolding preorder_on_def
  by (auto intro: refl_on_permutes trans_permutes)

end


(*
 * Copyright 2014, 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 StaticFun
imports
  Main
begin

datatype ('a, 'b) Tree = Node 'a 'b "('a, 'b) Tree" "('a, 'b) Tree" | Leaf

primrec
  lookup_tree :: "('a, 'b) Tree \<Rightarrow> ('a \<Rightarrow> 'c :: linorder) \<Rightarrow> 'a \<Rightarrow> 'b option"
where
  "lookup_tree Leaf fn x = None"
| "lookup_tree (Node y v l r) fn x = (if fn x = fn y then Some v
                                      else if fn x < fn y then lookup_tree l fn x
                                      else lookup_tree r fn x)"

definition optional_strict_range :: "('a :: linorder) option \<Rightarrow> 'a option \<Rightarrow> 'a set"
where
  "optional_strict_range x y = {z. (x = None \<or> the x < z) \<and> (y = None \<or> z < the y)}"

lemma optional_strict_range_split:
  "z \<in> optional_strict_range x y
    \<Longrightarrow> optional_strict_range x (Some z) = ({..< z} \<inter> optional_strict_range x y)
        \<and> optional_strict_range (Some z) y = ({z <..} \<inter> optional_strict_range x y)"
  by (auto simp add: optional_strict_range_def)

lemma optional_strict_rangeI:
  "z \<in> optional_strict_range None None"
  "z < y \<Longrightarrow> z \<in> optional_strict_range None (Some y)"
  "x < z \<Longrightarrow> z \<in> optional_strict_range (Some x) None"
  "x < z \<Longrightarrow> z < y \<Longrightarrow> z \<in> optional_strict_range (Some x) (Some y)"
  by (simp_all add: optional_strict_range_def)

definition
  tree_eq_fun_in_range :: "('a, 'b) Tree \<Rightarrow> ('a \<Rightarrow> 'c :: linorder) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'c set \<Rightarrow> bool"
where
 "tree_eq_fun_in_range T ord f S \<equiv> \<forall>x. (ord x \<in> S) \<longrightarrow> f x = lookup_tree T ord x"

lemma tree_eq_fun_in_range_from_def:
  "\<lbrakk> f \<equiv> lookup_tree T ord \<rbrakk>
    \<Longrightarrow> tree_eq_fun_in_range T ord f (optional_strict_range None None)"
  by (simp add: tree_eq_fun_in_range_def)

lemma tree_eq_fun_in_range_split:
  "tree_eq_fun_in_range (Node z v l r) ord f (optional_strict_range x y)
    \<Longrightarrow> ord z \<in> optional_strict_range x y
    \<Longrightarrow> tree_eq_fun_in_range l ord f (optional_strict_range x (Some (ord z)))
        \<and> f z = Some v
        \<and> tree_eq_fun_in_range r ord f (optional_strict_range (Some (ord z)) y)"
  apply (simp add: tree_eq_fun_in_range_def optional_strict_range_split)
  apply fastforce
  done

ML \<open>

structure StaticFun = struct

(* Actually build the tree -- theta (n lg(n)) *)
fun build_tree' _ mk_leaf [] = mk_leaf
  | build_tree' mk_node mk_leaf xs = let
    val len = length xs
    val (ys, zs) = chop (len div 2) xs
  in case zs of [] => error "build_tree': impossible"
    | ((a, b) :: zs) => mk_node a b (build_tree' mk_node mk_leaf ys)
        (build_tree' mk_node mk_leaf zs)
  end

fun build_tree ord xs = case xs of [] => error "build_tree : empty"
  | (idx, v) :: _ => let
    val idxT = fastype_of idx
    val vT = fastype_of v
    val treeT = Type (@{type_name StaticFun.Tree}, [idxT, vT])
    val mk_leaf = Const (@{const_name StaticFun.Leaf}, treeT)
    val node = Const (@{const_name StaticFun.Node},
        idxT --> vT --> treeT --> treeT --> treeT)
    fun mk_node a b l r = node $ a $ b $ l $ r
    val lookup = Const (@{const_name StaticFun.lookup_tree},
        treeT --> fastype_of ord --> idxT
            --> Type (@{type_name option}, [vT]))
  in
    lookup $ (build_tree' mk_node mk_leaf xs) $ ord
  end

fun define_partial_map_tree name mappings ord ctxt = let
    val tree = build_tree ord mappings
  in Local_Theory.define
    ((name, NoSyn), ((Thm.def_binding name, []), tree)) ctxt
    |> apfst (apsnd snd)
  end

fun prove_partial_map_thms thm ctxt = let
    val init = thm RS @{thm tree_eq_fun_in_range_from_def}
    fun rec_tree thm = case Thm.concl_of thm of
    @{term Trueprop} $ (Const (@{const_name tree_eq_fun_in_range}, _)
        $ (Const (@{const_name Node}, _) $ z $ v $ _ $ _) $ _ $ _ $ _) => let
        val t' = thm RS @{thm tree_eq_fun_in_range_split}
        val solve_simp_tac = SUBGOAL (fn (t, i) =>
            (simp_tac ctxt THEN_ALL_NEW SUBGOAL (fn (t', _) =>
                raise TERM ("prove_partial_map_thms: unsolved", [t, t']))) i)
        val r = t' |> (resolve_tac ctxt @{thms optional_strict_rangeI}
            THEN_ALL_NEW solve_simp_tac) 1 |> Seq.hd
        val l = r RS @{thm conjunct1}
        val kr = r RS @{thm conjunct2}
        val k = kr RS @{thm conjunct1}
        val r = kr RS @{thm conjunct2}
      in rec_tree l @ [((z, v), k)] @ rec_tree r end
    | _ => []
  in rec_tree init end

fun define_tree_and_save_thms name names mappings ord exsimps ctxt = let
    val ((tree, def_thm), ctxt) = define_partial_map_tree name mappings ord ctxt
    val thms = prove_partial_map_thms def_thm (ctxt addsimps exsimps)
    val (idents, thms) = map_split I thms
    val _ = map (fn ((x, y), (x', y')) => (x aconv x' andalso y aconv y')
        orelse raise TERM ("define_tree_and_thms: different", [x, y, x', y']))
        (mappings ~~ idents)
    val (_, ctxt) = Local_Theory.notes
        (map (fn (s, t) => ((Binding.name s, []), [([t], [])]))
        (names ~~ thms)) ctxt
  in (tree, ctxt) end

fun define_tree_and_thms_with_defs name names key_defs opt_values ord ctxt = let
    val data = names ~~ (key_defs ~~ opt_values)
        |> map_filter (fn (_, (_, NONE)) => NONE | (nm, (thm, SOME v))
            => SOME (nm, (fst (Logic.dest_equals (Thm.concl_of thm)), v)))
    val (names, mappings) = map_split I data
  in define_tree_and_save_thms name names mappings ord key_defs ctxt end

end

\<close>

(* testing

local_setup {* StaticFun.define_tree_and_save_thms @{binding tree}
  ["one", "two", "three"]
  [(@{term "Suc 0"}, @{term "Suc 0"}),
    (@{term "2 :: nat"}, @{term "15 :: nat"}),
    (@{term "3 :: nat"}, @{term "1 :: nat"})]
  @{term "id :: nat \<Rightarrow> nat"}
  #> snd
*}
print_theorems

*)

end


theory Refinement imports Main
begin
  section\<open>Monotonic Predicate Transformers\<close>
text\<open>
  In this section we introduce the basics of refinement calculus \<^cite>\<open>"back-wright-98"\<close>.
  Part of this theory is a reformulation of some definitions from \<^cite>\<open>"preoteasa:back:2010a"\<close>,
  but here they are given for predicates, while \<^cite>\<open>"preoteasa:back:2010a"\<close> uses
  sets.
\<close>

  notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70)
    and sup (infixl "\<squnion>" 65)

  subsection\<open>Basic predicate transformers\<close>

  definition
    demonic :: "('a => 'b::lattice) => 'b => 'a \<Rightarrow> bool" ("[: _ :]" [0] 1000) where
    "[:Q:] p s = (Q s \<le> p)"

  definition
    assert::"'a::semilattice_inf => 'a => 'a" ("{. _ .}" [0] 1000) where
    "{.p.} q \<equiv>  p \<sqinter> q"

  definition
    "assume"::"('a::boolean_algebra) => 'a => 'a" ("[. _ .]" [0] 1000) where
    "[.p.] q \<equiv>  (-p \<squnion> q)"

  definition
    angelic :: "('a \<Rightarrow> 'b::{semilattice_inf,order_bot}) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool" ("{: _ :}" [0] 1000) where
    "{:Q:} p s = (Q s \<sqinter> p \<noteq> \<bottom>)"

  syntax
    "_assert" :: "patterns => logic => logic"    ("(1{._./ _.})")
  translations
    "_assert (_patterns x xs) P" == "CONST assert (CONST id (_abs (_pattern x xs) P))"
    "_assert x P" == "CONST assert (CONST id (_abs x P))"

  term "{.x,z . P x y.}"

  syntax "_update" :: "patterns => patterns => logic => logic" ("_ \<leadsto> _ . _" 0)
  translations
    "_update (_patterns x xs) (_patterns y ys) t" == "CONST id (_abs
         (_pattern x xs) (CONST id (_abs (_pattern y ys) t)))"
    "_update x y t" == "CONST id (_abs x (CONST id (_abs y t)))"

  term "[: x \<leadsto> z . (P::'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) x y y' z :]"
  term "[: x, y \<leadsto> y', z . (P::'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) x y y' z :]"
  term "{: x, y \<leadsto> y', z . (P::'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) x y y' z :}"

  lemma demonic_demonic: "[:r:] o [:r':] = [:r OO r':]"
    by (simp add: fun_eq_iff le_fun_def demonic_def, auto)

  lemma assert_demonic_comp: "{.p.} o [:r:] o {.p'.} o [:r':] =
      {.x . p x \<and> (\<forall> y . r x y \<longrightarrow> p' y).} o [:r OO r':]"
      by (auto simp add: fun_eq_iff le_fun_def assert_def demonic_def)

  lemma demonic_assert_comp: "[:r:] o {.p.} = {.x.(\<forall> y . r x y \<longrightarrow> p y).} o [:r:]"
      by (auto simp add: fun_eq_iff le_fun_def assert_def demonic_def)

  lemma assert_assert_comp: "{.p::'a::lattice.} o {.p'.} = {.p \<sqinter> p'.}"
      by (simp add: fun_eq_iff le_fun_def assert_def demonic_def inf_assoc)

  definition "inpt r x = (\<exists> y . r x y)"

  definition "trs r = {. inpt r.} o [:r:]"

  lemma "trs (\<lambda> x y . x = y) q x = q x"
    by (simp add: trs_def fun_eq_iff assert_def demonic_def inpt_def bot_fun_def le_fun_def)

  lemma assert_demonic_prop: "{.p.} o [:r:] = {.p.} o [:(\<lambda> x y . p x) \<sqinter> r:]"
    by (auto simp add: fun_eq_iff assert_def demonic_def)

  lemma relcompp_exists: "relcompp r r' x y = (\<exists> u . r x u \<and> r' u y)"
    by auto

  lemma trs_trs: "(trs r) o (trs r') = trs ((\<lambda> s t. (\<forall> s' . r s s' \<longrightarrow> (inpt r' s'))) \<sqinter> (r OO r'))" (is "?S = ?T")
    proof -
      have [simp]: "(\<lambda>x. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y)) = inpt ((\<lambda>s t. \<forall>s'. r s s' \<longrightarrow> inpt r' s') \<sqinter> r OO r')"
        by (auto simp add: fun_eq_iff inpt_def relcompp_exists, blast)
      have [simp]: "(\<lambda>x y. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y)) \<sqinter> r OO r' = (\<lambda>s t. \<forall>s'. r s s' \<longrightarrow> inpt r' s') \<sqinter> r OO r'"
        by (auto simp add: fun_eq_iff inpt_def)
      have "?S = {. inpt r .} \<circ> [: r :] \<circ> {. inpt r' .} \<circ> [: r' :]"
        by (simp add: trs_def comp_assoc[symmetric])
      also have "... = {. \<lambda>x. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y) .} \<circ> [: r OO r' :]"
        by (simp add: assert_demonic_comp)
      also have "... =  {. \<lambda>x. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y) .} o [:(\<lambda> x y . inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y))  \<sqinter> (r OO r'):]"
        by (subst assert_demonic_prop, simp)
      also have "... = ?T"
        by (simp add: trs_def)
      finally show ?thesis by simp
    qed

  lemma assert_demonic_refinement: "({.p.} o [:r:] \<le> {.p'.} o [:r':]) = (p \<le> p' \<and> (\<forall> x . p x \<longrightarrow> r' x \<le> r x))"
    by  (auto simp add: le_fun_def assert_def demonic_def)

  lemma trs_refinement: "(trs r \<le> trs r') = ((\<forall> x . inpt r x \<longrightarrow> inpt r' x) \<and> (\<forall> x . inpt r x \<longrightarrow> r' x \<le> r x))"
    by (simp add: trs_def assert_demonic_refinement, simp add: le_fun_def)

  lemma "trs (\<lambda> x y . x \<ge> 0) \<le> trs (\<lambda> x y . x = y)"
    by (simp add: trs_def le_fun_def assert_def demonic_def inpt_def)

  lemma "trs (\<lambda> x y . x \<ge> 0) q x = (if q = \<top> then x \<ge> 0 else False)"
     by (auto simp add: trs_def fun_eq_iff assert_def demonic_def inpt_def bot_fun_def)

  lemma "[:r:] \<sqinter> [:r':] = [:r \<squnion> r':]"
    by (simp add: fun_eq_iff demonic_def)

  lemma spec_demonic_choice: "({.p.} o [:r:]) \<sqinter> ({.p'.} o [:r':]) = ({.p \<sqinter> p'.} o [:r \<squnion> r':])"
    by (auto simp add: fun_eq_iff demonic_def assert_def)

  lemma trs_demonic_choice: "trs r \<sqinter> trs r' = trs ((\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r'))"
    proof -
      have [simp]: "inpt ((\<lambda>x y. inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r')) = inpt r \<sqinter> inpt r'"
        by (auto simp add: fun_eq_iff inpt_def)
      have "trs r \<sqinter> trs r' = {. inpt r \<sqinter> inpt r' .} \<circ> [: r \<squnion> r' :]"
        by (simp add: trs_def spec_demonic_choice)
      also have "... = {. inpt r \<sqinter> inpt r' .} \<circ> [: (\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r') :]"
        by (subst assert_demonic_prop, simp)
      also have "... = trs ((\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r'))"
        by (simp add: trs_def)
      finally show ?thesis by simp
    qed

  lemma "p \<sqinter> p' = \<bottom> \<Longrightarrow> ({.p.} o [:r:]) \<squnion> ({.p'.} o [:r':]) = {.p \<squnion> p'.} o [:(\<lambda> x y . p x \<longrightarrow> r x y) \<sqinter> ((\<lambda> x y . p' x \<longrightarrow> r' x y)):]"
    by (simp add: fun_eq_iff assert_def demonic_def, auto)

  subsection\<open>Conjunctive predicate transformers\<close>

  definition "conjunctive (S::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) = (\<forall> Q . S (Inf Q) = Inf (S ` Q))"
  definition "sconjunctive (S::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) = (\<forall> Q . (\<exists> x . x \<in> Q) \<longrightarrow> S (Inf Q) = Inf (S ` Q))"

  lemma [simp]: "conjunctive \<top>"
    by (simp add: conjunctive_def)

  lemma conjuncive_demonic [simp]: "conjunctive [:r:]"
    proof (auto simp add: conjunctive_def fun_eq_iff demonic_def)
      fix Q:: "'a set" fix y::'a fix x :: 'b
      assume A: "y \<in> Q"
      assume "r x \<le> Inf Q"
      also from A have "Inf Q \<le> y"
        by (rule Inf_lower)
      finally show "r x \<le> y" by simp
    next
      fix Q:: "'a set" fix x :: 'b
      assume A : "\<forall>y\<in>Q. r x \<le> y"
      show "r x \<le> Inf Q"
        by (rule Inf_greatest, simp add: A)
    qed

  lemma sconjunctive_assert [simp]: "sconjunctive {.p.}"
    proof (auto simp add: sconjunctive_def assert_def image_def cong: INF_cong_simp, rule antisym, auto)
      fix Q :: "'a set"
      have [simp]: "\<And> x . x \<in> Q \<Longrightarrow> Inf Q \<le> x"
        by (rule Inf_lower, simp)
      have A: "\<And> x . x \<in> Q \<Longrightarrow> p \<sqinter> Inf Q \<le> p \<sqinter> x"
        by (simp, rule_tac y = "Inf Q" in order_trans, simp_all)
      show "p \<sqinter> Inf Q \<le> (INF x\<in>Q. p \<sqinter> x)"
        by (rule Inf_greatest, safe, rule A, simp)
    next
      fix Q :: "'a set"
      fix x :: 'a
      assume A: "x \<in> Q"
      have "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> p \<sqinter> x"
        by (rule Inf_lower, cut_tac A, auto)
      also have "... \<le> p"
        by simp
      finally show "(INF x\<in>Q. p \<sqinter> x) \<le> p"
        by (simp only: image_def)
   next
      fix Q :: "'a set"
      show "(INF x\<in>Q. p \<sqinter> x) \<le> Inf Q"
        proof (rule Inf_greatest)
          fix x::'a
          assume A: "x \<in> Q"
          have "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> p \<sqinter> x"
            by (cut_tac A, rule Inf_lower, blast)
          also have "... \<le> x"
            by simp
         finally show "(INF x\<in>Q. p \<sqinter> x) \<le> x"
            by (simp only: image_def)
       qed
   qed

  lemma sconjunctive_simp: "x \<in> Q \<Longrightarrow> sconjunctive S \<Longrightarrow> S (Inf Q) = Inf (S ` Q)"
    by (auto simp add: sconjunctive_def)

  lemma sconjunctive_INF_simp: "x \<in> X \<Longrightarrow> sconjunctive S \<Longrightarrow> S (Inf (Q ` X)) = Inf (S ` (Q ` X))"
    by (cut_tac x = "Q x" and Q = "Q ` X" in sconjunctive_simp, auto)

  lemma demonic_comp [simp]: "sconjunctive S \<Longrightarrow> sconjunctive S' \<Longrightarrow> sconjunctive (S o S')"
    proof (subst sconjunctive_def, safe)
      fix X :: "'c set"
      fix a :: 'c
      assume [simp]: "sconjunctive S"
      assume [simp]: "sconjunctive S'"
      assume [simp]: "a \<in> X"
      have A: "S' (Inf X) = Inf (S' ` X)"
        by (rule_tac x = a in sconjunctive_simp, auto)
      also have B: "S (Inf (S' ` X)) = Inf (S ` (S' ` X))"
        by (rule_tac x = "S' a" in sconjunctive_simp, auto)
      finally show "(S o S') (Inf X) = Inf ((S \<circ> S') ` X)" by (simp add: image_comp)
    qed

  lemma [simp]:"conjunctive S \<Longrightarrow> S (Inf (Q ` X)) = (Inf ((S o Q) ` X))"
    by (metis INF_image conjunctive_def)

  lemma conjunctive_simp: "conjunctive S \<Longrightarrow>  S (Inf Q) = Inf (S ` Q)"
    by (metis conjunctive_def)

  lemma conjunctive_monotonic: "sconjunctive S \<Longrightarrow> mono S"
    proof (rule monoI)
      fix a b :: 'a
      assume [simp]: "a \<le> b"
      assume [simp]: "sconjunctive S"
      have [simp]: "a \<sqinter> b = a"
        by (rule antisym, auto)
      have A: "S a = S a \<sqinter> S b"
        by (cut_tac S = S and x = a and Q = "{a, b}" in sconjunctive_simp, auto)
      show "S a \<le> S b"
        by (subst A, simp)
    qed

  definition "grd S = - S \<bottom>"

  lemma "grd [:r:] = inpt r"
    by (simp add: fun_eq_iff grd_def demonic_def le_fun_def inpt_def)

  definition "fail S = -(S \<top>)"
  definition "term S = (S \<top>)"

  lemma "fail ({.p.} o [:r :: 'a \<Rightarrow> 'b \<Rightarrow> bool:]) = -p"
    by (simp add: fail_def fun_eq_iff assert_def demonic_def le_fun_def top_fun_def)

  definition "Fail = \<bottom>"

  lemma "mono (S::'a::boolean_algebra \<Rightarrow> 'b::boolean_algebra) \<Longrightarrow> (S = Fail) = (fail S = \<top>)"
    proof auto
      show "fail (Fail::'a \<Rightarrow> 'b) = \<top>"
        by (metis Fail_def bot_apply compl_bot_eq fail_def)
    next
      assume A: "mono S"
      assume B: "fail S = \<top>"
      show "S = Fail"
        proof (rule antisym)
          show "S \<le> Fail"
            by (metis (opaque_lifting, no_types) A B bot.extremum_unique compl_le_compl_iff fail_def le_fun_def monoD top_greatest)
          next
            show "Fail \<le> S"
              by (metis Fail_def bot.extremum)
        qed
   qed

  definition "Skip = id"

  lemma [simp]: "{.\<top>::'a::bounded_lattice.} = Skip"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]:"Skip o S = S"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]:"S o Skip = S"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]: "mono S \<Longrightarrow> mono S' \<Longrightarrow> mono (S o S')"
    by (simp add: mono_def)

  lemma [simp]: "mono {.p::('a \<Rightarrow> bool).}"
    by (simp add: conjunctive_monotonic)

  lemma [simp]: "mono [:r::('a \<Rightarrow> 'b \<Rightarrow> bool):]"
    by (simp add: conjunctive_monotonic)

  lemma [simp]:"{. \<lambda> x . True .} = Skip"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]: "\<bottom> o S = \<bottom>"
    by (simp add: fun_eq_iff)

  lemma [simp]: "{.\<bottom>::'a::boolean_algebra.}  = \<bottom>"
    by (simp add: fun_eq_iff assert_def)

  lemma [simp]: "\<top> o S = \<top>"
    by (simp add: fun_eq_iff)

  lemma left_comp: "T o U = T' o U' \<Longrightarrow> S o T o U = S o T' o U'"
    by (simp add: comp_assoc)

  lemma assert_demonic: "{.p.} o [:r:] = {.p.} o [:\<lambda> x y . p x \<and> r x y:]"
    by (auto simp add: fun_eq_iff assert_def demonic_def le_fun_def)

  lemma "trs r \<sqinter> trs r' = trs (\<lambda> x y . inpt r x \<and> inpt r' x \<and> (r x y \<or> r' x y))"
    by (auto simp add: fun_eq_iff trs_def assert_def demonic_def inpt_def)

  subsection\<open>Fusion of predicate transformers\<close>

  text\<open>
  In this section we define the fusion operator from \<^cite>\<open>"back:butler:1995"\<close>. The fusion
  of two programs $S$ and $T$ is intuitively equivalent with the parallel execution of the two
  programs. If $S$ and $T$ assign nondeterministically some value to some program variable
  $x$, then the fusion of $S$ and $T$ will assign a value to $x$ which can be assigned by
  both $S$ and $T$.
\<close>

  definition fusion :: "(('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool))" (infixl "\<parallel>" 70) where
    "(S \<parallel> S') q x = (\<exists> (p::'a\<Rightarrow>bool) p' . p \<sqinter> p' \<le> q \<and> S p x \<and> S' p' x)"

  lemma fusion_spec: "({.p.} \<circ> [:r:]) \<parallel> ({.p'.} \<circ> [:r':]) = ({.p \<sqinter> p'.} \<circ> [:r \<sqinter> r':])"
    by (auto simp add: fun_eq_iff fusion_def assert_def demonic_def le_fun_def)

  lemma fusion_assoc: "S \<parallel> (T \<parallel> U) = (S \<parallel> T) \<parallel> U"
    proof (rule antisym, auto simp add: fusion_def)
      fix p p' q s s' :: "'a \<Rightarrow> bool"
      fix a
      assume A: "p \<sqinter> p' \<le> q" and B: "s \<sqinter> s' \<le> p'"
      assume C: "S p a" and D: "T s a" and E: "U s' a"
      from A and B  have F: "(p \<sqinter> s) \<sqinter> s' \<le> q"
        by (simp add: le_fun_def)
      have "(\<exists>v v'. v \<sqinter> v' \<le> (p \<sqinter> s) \<and> S v a \<and> T v' a)"
        by (metis C D order_refl)
      show "\<exists>u u' . u \<sqinter> u' \<le> q \<and> (\<exists>v v'. v \<sqinter> v' \<le> u \<and> S v a \<and> T v' a) \<and> U u' a"
        by (metis F C D E order_refl)
    next
      fix p p' q s s' :: "'a \<Rightarrow> bool"
      fix a
      assume A: "p \<sqinter> p' \<le> q" and B: "s \<sqinter> s' \<le> p"
      assume C: "S s a" and D: "T s' a" and E: "U p' a"
      from A and B  have F: "s \<sqinter> (s' \<sqinter> p')  \<le> q"
        by (simp add: le_fun_def)
      have "(\<exists>v v'. v \<sqinter> v' \<le> s' \<sqinter> p' \<and> T v a \<and> U v' a)"
        by (metis D E eq_iff)
      show "\<exists>u u'. u \<sqinter> u' \<le> q \<and> S u a \<and> (\<exists>v v'. v \<sqinter> v' \<le> u' \<and> T v a \<and> U v' a)"
        by (metis F C D E order_refl)
    qed

  lemma "P \<le> Q \<Longrightarrow> P' \<le> Q' \<Longrightarrow> P \<parallel> P' \<le> Q \<parallel> Q'"
    by (simp add: le_fun_def fusion_def, metis)

  lemma "conjunctive S \<Longrightarrow> S \<parallel> \<top> = \<top>"
    by (auto simp add: fun_eq_iff fusion_def le_fun_def conjunctive_def)

  lemma fusion_spec_local: "a \<in> init \<Longrightarrow> ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> ({.p'.} \<circ> [:r':])
      = [:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.u,x . p (u, x) \<and> p' x.} \<circ> [:u, x \<leadsto> y . r (u, x) y \<and> r' x y:]" (is "?p \<Longrightarrow> ?S = ?T")
    proof -
      assume "?p"
      from this have [simp]: "(\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) \<and> p' x) = (\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x)) \<sqinter> p'"
         by auto
      have [simp]: "(\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) = (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r \<sqinter> r'"
        by auto
      have "?S =
        ({. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> [: r :]) \<parallel> ({. p' .} \<circ> [: r' :])"
        by (simp add: demonic_assert_comp)
      also have "... =  {. (\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x)) \<sqinter> p' .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r \<sqinter> r' :]"
        by (simp add: comp_assoc demonic_demonic fusion_spec)
      also have "... = ?T"
        by (simp add: demonic_assert_comp comp_assoc demonic_demonic fusion_spec)
      finally show ?thesis by simp
    qed

  lemma fusion_spec_local_a: "a \<in> init \<Longrightarrow> ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> [:r':]
      = ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:u, x \<leadsto> y . r (u, x) y \<and> r' x y:])"
    by (cut_tac p' = "\<top>" and init = init and p = p and r = r and r' = r' in fusion_spec_local, auto)

  lemma fusion_local_refinement:
    "a \<in> init \<Longrightarrow> (\<And> x u y . u \<in> init \<Longrightarrow> p' x \<Longrightarrow> r (u, x) y \<Longrightarrow> r' x y) \<Longrightarrow>
      {.p'.} o (([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> [:r':]) \<le> [:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]"
    proof -
     assume A: "a \<in> init"
     assume [simp]: "(\<And> x u y . u \<in> init \<Longrightarrow> p' x \<Longrightarrow> r (u, x) y \<Longrightarrow> r' x y)"
     have " {. x. p' x \<and> (\<forall>a. a \<in> init \<longrightarrow> p (a, x)) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) :]
              \<le> {. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r :]"
      by (auto simp add: assert_demonic_refinement)
    from this have " {. x. p' x \<and> (\<forall>a. a \<in> init \<longrightarrow> p (a, x)) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) :]
            \<le> {. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> [: r :]"
      by (simp add: comp_assoc demonic_demonic)
    from this have "{. p' .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: \<lambda>(u, x) y. r (u, x) y \<and> r' x y :]
            \<le> [: x \<leadsto> u, y. u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: r :]"
      by (simp add: demonic_assert_comp assert_demonic_comp)
    from this have "{. p' .} \<circ> ([: x \<leadsto> (u, y) . u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: (u, x) \<leadsto> y . r (u, x) y \<and> r' x y :])
          \<le> [: x \<leadsto> (u, y) . u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: r :]"
      by (simp add: comp_assoc [THEN sym])
    from A and this show ?thesis
      by  (unfold fusion_spec_local_a, simp)
  qed
end


theory conditions_infinitary
  imports conditions boolean_algebra_infinitary
begin

(**We define and interrelate infinitary variants for some previously introduced
 axiomatic conditions on operators.*)

(**Distribution over infinite meets (infima) or infinite multiplicativity (iMULT).*)
definition iMULT::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iMULT")
  where "iMULT \<phi>   \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<approx> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"
definition iMULT_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iMULT\<^sup>a")
  where "iMULT\<^sup>a \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<preceq> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"
definition iMULT_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iMULT\<^sup>b")
  where "iMULT\<^sup>b \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<succeq> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"

declare iMULT_def[cond] iMULT_a_def[cond] iMULT_b_def[cond]

(**Distribution over infinite joins (suprema) or infinite additivity (iADDI).*)
definition iADDI::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iADDI")
  where "iADDI \<phi>   \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<approx> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"
definition iADDI_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iADDI\<^sup>a")
  where "iADDI\<^sup>a \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"
definition iADDI_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iADDI\<^sup>b")
  where "iADDI\<^sup>b \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<succeq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"

declare iADDI_def[cond] iADDI_a_def[cond] iADDI_b_def[cond]

lemma iMULT_char: "iMULT \<phi> = (iMULT\<^sup>a \<phi> \<and> iMULT\<^sup>b \<phi>)" using iMULT_a_def iMULT_b_def iMULT_def by (metis setequ_def)
lemma iADDI_char: "iADDI \<phi> = (iADDI\<^sup>a \<phi> \<and> iADDI\<^sup>b \<phi>)" using iADDI_a_def iADDI_b_def iADDI_def by (metis setequ_def)

(**MULT-a and iMULT-a are in fact equivalent.*)
lemma iMULTa_equ: "iMULT\<^sup>a \<phi> = MULT\<^sup>a \<phi>" proof -
  have lr: "iMULT\<^sup>a \<phi> \<Longrightarrow> MULT\<^sup>a \<phi>" proof - (*prove as a one-liner by instantiating iMULT_a_def with S=(\<lambda>Z. Z=A \<or> Z=B)*)
  assume imulta: "iMULT\<^sup>a \<phi>"
  { fix A::"'a \<sigma>" and B::"'a \<sigma>"
    let ?S="\<lambda>Z. Z=A \<or> Z=B"
    have "\<^bold>\<And>?S = A \<^bold>\<and> B" unfolding infimum_def meet_def by blast
    hence p1: "\<phi>(\<^bold>\<And>?S) = \<phi>(A \<^bold>\<and> B)" by simp
    have "\<lbrakk>\<phi> ?S\<rbrakk> = (\<lambda>Z. Z=(\<phi> A) \<or> Z=(\<phi> B))" unfolding img_dir_def by blast
    hence p2: "\<^bold>\<And>\<lbrakk>\<phi> ?S\<rbrakk> = (\<phi> A) \<^bold>\<and> (\<phi> B)" unfolding infimum_def meet_def by auto
    have "\<phi>(\<^bold>\<And>?S) \<preceq> \<^bold>\<And>\<lbrakk>\<phi> ?S\<rbrakk>" using imulta iMULT_a_def by blast
    hence "\<phi>(A \<^bold>\<and> B) \<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" using p1 p2 by simp
  } thus ?thesis by (simp add: MULT_a_def) qed
  have rl: "MULT\<^sup>a \<phi> \<Longrightarrow> iMULT\<^sup>a \<phi>" by (smt (verit, best) MONO_MULTa MONO_def iMULT_a_def img_dir_def inf_char)
  from lr rl show ?thesis by blast
qed
(**ADDI-b and iADDI-b are also equivalent.*)
lemma iADDIb_equ: "iADDI\<^sup>b \<phi> = ADDI\<^sup>b \<phi>" proof -
  have lr: "iADDI\<^sup>b \<phi> \<Longrightarrow> ADDI\<^sup>b \<phi>" proof - (*prove as a one-liner by instantiating iADDI_b_def with S=(\<lambda>Z. Z=A \<or> Z=B)*)
  assume iaddib: "iADDI\<^sup>b \<phi>"
  { fix A::"'a \<sigma>" and B::"'a \<sigma>" (* for some reason Isabelle doesn't like other letters as type variable. Why?*)
    let ?S="\<lambda>Z. Z=A \<or> Z=B"
    have "\<^bold>\<Or>?S = A \<^bold>\<or> B" unfolding supremum_def join_def by blast
    hence p1: "\<phi>(\<^bold>\<Or>?S) = \<phi>(A \<^bold>\<or> B)" by simp
    have "\<lbrakk>\<phi> ?S\<rbrakk> = (\<lambda>Z. Z=(\<phi> A) \<or> Z=(\<phi> B))" unfolding img_dir_def by blast
    hence p2: "\<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> = (\<phi> A) \<^bold>\<or> (\<phi> B)" unfolding supremum_def join_def by auto
    have " \<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> \<preceq> \<phi>(\<^bold>\<Or>?S)" using iaddib iADDI_b_def by blast
    hence "(\<phi> A) \<^bold>\<or> (\<phi> B) \<preceq> \<phi>(A \<^bold>\<or> B)" using p1 p2 by simp
  } thus ?thesis by (simp add: ADDI_b_def) qed
  have rl: "ADDI\<^sup>b \<phi> \<Longrightarrow> iADDI\<^sup>b \<phi>"  by (smt (verit, best) MONO_ADDIb MONO_def iADDI_b_def img_dir_def sup_char)
  from lr rl show ?thesis by auto
qed

(**Thus we have that MONO, MULT-a/iMULT-a and ADDI-b/iADDI-b are all equivalent.*)
lemma MONO_iADDIb: "iADDI\<^sup>b \<phi> = MONO \<phi>" unfolding MONO_ADDIb iADDIb_equ by simp
lemma MONO_iMULTa: "iMULT\<^sup>a \<phi> = MONO \<phi>" unfolding MONO_MULTa iMULTa_equ by simp

(**Below we prove several duality relationships between iADDI(a/b) and iMULT(a/b).*)

(**The first duality is an easy corollary of the previous equivalence.*)
lemma iMULTa_iADDIb_dual1: "iMULT\<^sup>a \<phi> = iADDI\<^sup>b \<phi>\<^sup>d" by (simp add: MULTa_ADDIb_dual1 iADDIb_equ iMULTa_equ)
lemma iMULTa_iADDIb_dual2: "iADDI\<^sup>b \<phi> = iMULT\<^sup>a \<phi>\<^sup>d" using MONO_dual MONO_iADDIb MONO_iMULTa by auto

(*these two lemmas below are introduced for technical reasons (as stepping stones)*)
lemma iADDIa_impl_iMULTb: "\<forall>\<phi>. iADDI\<^sup>a \<phi> \<longrightarrow> iMULT\<^sup>b \<phi>\<^sup>d" unfolding iADDI_a_def iMULT_b_def using iDM_a iDM_b Ra_dual1 using order compl_def op_dual_def by (smt (verit, del_insts) setequ_equ)
lemma iMULTb_impl_iADDIa: "\<forall>\<phi>. iMULT\<^sup>b \<phi> \<longrightarrow> iADDI\<^sup>a \<phi>\<^sup>d" unfolding iADDI_a_def iMULT_b_def by (smt (verit, del_insts) Ra_dual3 compl_def iDM_b infimum_def op_dual_def setequ_equ subset_def)

(**Duality between iADDI-a and iMULT-b.*)
lemma iADDIa_iMULTb_dual1: "iADDI\<^sup>a \<phi> = iMULT\<^sup>b \<phi>\<^sup>d" by (metis dual_invol iADDIa_impl_iMULTb iMULTb_impl_iADDIa op_equal_equ)
lemma iADDIa_iMULTb_dual2: "iMULT\<^sup>b \<phi> = iADDI\<^sup>a \<phi>\<^sup>d" by (metis dual_invol iADDIa_iMULTb_dual1 op_equal_equ)

(**Duality between iADDI and iMULT.*)
lemma iADDI_iMULT_dual1: "iADDI \<phi> = iMULT \<phi>\<^sup>d" by (meson MONO_dual MONO_iADDIb MONO_iMULTa iADDI_char iADDIa_iMULTb_dual1 iMULT_char)
lemma iADDI_iMULT_dual2: "iMULT \<phi> = iADDI \<phi>\<^sup>d" by (metis dual_invol iADDI_iMULT_dual1 op_equal_equ)

(**Other (not really surprising) result:*)
lemma iMULT_DNRM: "iMULT \<phi> \<Longrightarrow> DNRM \<phi>" by (metis (no_types) BA_dn DNRM_def NORM_def bottom_def comp_invol fp_c_rel fp_rel iADDI_def iADDI_iMULT_dual2 img_dir_def ofp_c ofp_invol op_compl_def op_dual_def op_equal_equ setequ_def setequ_equ subset_def sup_char)
lemma iADDI_NORM: "iADDI \<phi> \<Longrightarrow> NORM \<phi>" by (simp add: NOR_dual1 iADDI_iMULT_dual1 iMULT_DNRM)

(**Interestingly, we can show that suitable conditions on an operation can make the set
of its fixed points closed under infinite meets/joins.*)
lemma fp_inf_closed_cond1: "iMULT \<phi> \<Longrightarrow> infimum_closed (fp \<phi>)"
  unfolding iMULT_def infimum_closed_def fixpoint_pred_def by (smt (verit, best) img_dir_def inf_char setequ_def setequ_equ)
lemma fp_inf_closed_cond2: "iMULT\<^sup>b \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> infimum_closed (fp \<phi>)"
  by (smt (z3) CNTR_def fixpoint_pred_def iMULT_b_def img_dir_def infimum_closed_def infimum_def setequ_def subset_def)
lemma fp_inf_closed_cond3: "MONO \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> infimum_closed (fp \<phi>)" by (smt (z3) EXPN_def MONO_def fixpoint_pred_def inf_char infimum_closed_def setequ_def setequ_equ)
lemma "MONO \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> IDEM \<phi> \<Longrightarrow> infimum_closed (\<lbrakk>\<phi> -\<rbrakk>)" by (simp add: IDEM_Ra_fp fp_inf_closed_cond3)

lemma fp_sup_closed_cond1: "iADDI \<phi> \<Longrightarrow> supremum_closed (fp \<phi>)" by (metis dual_invol fp_inf_closed_cond1 fp_inf_sup_closed_dual iADDI_iMULT_dual1 op_equal_equ)

lemma fp_sup_closed_cond2: "iADDI\<^sup>a \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> supremum_closed (fp \<phi>)" by (smt (verit, best) BA_dn EXPN_CNTR_dual2 dom_compl_def fp_d fp_inf_closed_cond2 iADDIa_impl_iMULTb iDM_b infimum_closed_def setequ_equ supremum_closed_def)
lemma fp_sup_closed_cond3: "MONO \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> supremum_closed (fp \<phi>)" by (metis CNTR_impl_NORM EXPN_CNTR_dual2 MONO_dual NORM_def dual_invol fixpoint_pred_def fp_inf_closed_cond3 fp_inf_sup_closed_dual inf_closed_char op_equal_equ sup_closed_char)
lemma "MONO \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> IDEM \<phi> \<Longrightarrow> supremum_closed (\<lbrakk>\<phi> -\<rbrakk>)" by (simp add: IDEM_Ra_fp fp_sup_closed_cond3)

(**OTOH, the converse conjectures have (finite) countermodels. They need additional assumptions.*)
lemma "infimum_closed (fp \<phi>) \<Longrightarrow> iMULT \<phi>" nitpick oops
lemma "supremum_closed (fp \<phi>) \<Longrightarrow> iADDI \<phi>" nitpick oops
lemma fp_inf_closed_iMULT: "MONO \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> IDEM\<^sup>a \<phi> \<Longrightarrow> infimum_closed (fp \<phi>) \<Longrightarrow> iMULT \<phi>"
proof -
  assume mono: "MONO \<phi>" and cntr: "CNTR \<phi>" and idem:"IDEM\<^sup>a \<phi>" and ic:"infimum_closed (fp \<phi>)"
  { fix S
    from ic have "\<forall>D. D \<sqsubseteq> (fp \<phi>) \<longrightarrow> (fp \<phi>)(\<^bold>\<And>D)" unfolding infimum_closed_def by simp
    hence "let D=\<lbrakk>\<phi> S\<rbrakk> in (\<forall>X. D X \<longrightarrow> (X \<approx> \<phi> X)) \<longrightarrow> \<^bold>\<And>D \<approx> \<phi> \<^bold>\<And>D" by (simp add: fixpoint_pred_def setequ_equ)
    moreover from idem have "(\<forall>X. \<lbrakk>\<phi> S\<rbrakk> X \<longrightarrow> (X \<approx> \<phi> X))" by (metis (mono_tags, lifting) CNTR_def IDEM_a_def cntr img_dir_def setequ_def)
    ultimately have aux: "\<^bold>\<And>(\<lbrakk>\<phi> S\<rbrakk>) \<approx> \<phi>(\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>)" by meson
    from cntr have "\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<^bold>\<And>S" by (smt (verit, best) CNTR_def img_dir_def infimum_def subset_def)
    hence "\<phi>(\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>) \<preceq> \<phi>(\<^bold>\<And>S)" using mono by (simp add: MONO_def)
    from this aux have "\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<And>S)" by (simp add: setequ_equ)
  } hence "\<forall>S. \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<And>S)" by (rule allI)
  thus ?thesis using MONO_iMULTa iMULT_b_def iMULT_char mono by blast
qed
lemma fp_sup_closed_iADDI: "MONO \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> IDEM\<^sup>b \<phi> \<Longrightarrow> supremum_closed (fp \<phi>) \<Longrightarrow> iADDI \<phi>"
  using fp_inf_closed_iMULT EXPN_CNTR_dual2 IDEM_dual2 MONO_dual fp_sup_inf_closed_dual iADDI_iMULT_dual1 by blast
(*
proof -
  assume mono: "MONO \<phi>" and expn: "EXPN \<phi>" and idem:"IDEM\<^sup>b \<phi>" and sc:"supremum_closed (fp \<phi>)"
  { fix S
    from sc have "\<forall>D. D \<sqsubseteq> (fp \<phi>) \<longrightarrow> (fp \<phi>)(\<^bold>\<Or>D)" unfolding supremum_closed_def by simp
    hence "let D=\<lbrakk>\<phi> S\<rbrakk> in (\<forall>X. D X \<longrightarrow> (X \<approx> \<phi> X)) \<longrightarrow> \<^bold>\<Or>D \<approx> \<phi> \<^bold>\<Or>D" by (simp add: fixpoint_pred_def setequ_def)
    moreover have "(\<forall>X. \<lbrakk>\<phi> S\<rbrakk> X \<longrightarrow> (X \<approx> \<phi> X))" by (metis (mono_tags, lifting) EXPN_def IDEM_b_def expn idem img_dir_def setequ_def)
    ultimately have aux: "\<^bold>\<Or>(\<lbrakk>\<phi> S\<rbrakk>) \<approx> \<phi>(\<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>)" by meson
    have "\<^bold>\<Or>S \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>" by (metis EXPN_CNTR_dual2 EXPN_def IDEM_dual2 MONO_dual expn fp_inf_closed_iMULT fp_sup_inf_closed_dual iADDI_def iADDI_iMULT_dual1 idem mono sc setequ_equ)
    hence "\<phi>(\<^bold>\<Or>S) \<preceq> \<phi>(\<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>)" using mono by (simp add: MONO_def)
    from this aux have "\<phi>(\<^bold>\<Or>S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>" by (metis setequ_equ)
  } hence "\<forall>S. \<phi>(\<^bold>\<Or>S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>" by (rule allI)
  thus ?thesis by (simp add: MONO_iADDIb iADDI_a_def iADDI_char mono)
qed
*)

end