section\<open>Pseudo Waisberg Algebra\<close>

theory PseudoWaisbergAlgebra
imports Operations
begin

class impl_lr_algebra = one + left_imp + right_imp +
  assumes W1a [simp]: "1 l\<rightarrow> a = a"
  and W1b [simp]: "1 r\<rightarrow> a = a"

  and W2a: "(a l\<rightarrow> b) r\<rightarrow> b = (b l\<rightarrow> a) r\<rightarrow> a"
  and W2b: "(b l\<rightarrow> a) r\<rightarrow> a = (b r\<rightarrow> a) l\<rightarrow> a"
  and W2c: "(b r\<rightarrow> a) l\<rightarrow> a = (a r\<rightarrow> b) l\<rightarrow> b"

  and W3a: "(a l\<rightarrow> b) l\<rightarrow> ((b l\<rightarrow> c) r\<rightarrow> (a l\<rightarrow> c)) = 1"
  and W3b: "(a r\<rightarrow> b) r\<rightarrow> ((b r\<rightarrow> c) l\<rightarrow> (a r\<rightarrow> c)) = 1"

begin

lemma P1_a [simp]: "x l\<rightarrow> x = 1"
  apply (cut_tac a = 1 and b = 1 and c = x in W3b)
  by simp

lemma P1_b [simp]: "x r\<rightarrow> x = 1"
  apply (cut_tac a = 1 and b = 1 and c = x in W3a)
  by simp

lemma P2_b: "x r\<rightarrow> y = 1 \<Longrightarrow> y r\<rightarrow> x = 1 \<Longrightarrow> x = y"
  apply (subgoal_tac "(y r\<rightarrow> x) l\<rightarrow> x = y")
  apply simp
  apply (subgoal_tac "(x r\<rightarrow> y) l\<rightarrow> y = y")
  apply (unfold W2c)
  by simp_all

lemma P2_c: "x l\<rightarrow> y = 1 \<Longrightarrow> y r\<rightarrow> x = 1 \<Longrightarrow> x = y"
  apply (subgoal_tac "(y r\<rightarrow> x) l\<rightarrow> x = y")
  apply simp
  apply (subgoal_tac "(x l\<rightarrow> y) r\<rightarrow> y = y")
  apply (unfold W2b) [1]
  apply (unfold W2c) [1]
  by simp_all

lemma P3_a: "(x l\<rightarrow> 1) r\<rightarrow> 1 = 1"
  apply (unfold W2a)
  by simp

lemma P3_b: "(x r\<rightarrow> 1) l\<rightarrow> 1 = 1"
  apply (unfold W2c)
  by simp

lemma P4_a [simp]: "x l\<rightarrow> 1 = 1"
  apply (subgoal_tac "x l\<rightarrow> ((x l\<rightarrow> 1) r\<rightarrow> 1) = 1")
  apply (simp add: P3_a)
  apply (cut_tac a = 1 and b = x and c = 1 in W3a)
  by simp

lemma P4_b [simp]: "x r\<rightarrow> 1 = 1"
  apply (subgoal_tac "x r\<rightarrow> ((x r\<rightarrow> 1) l\<rightarrow> 1) = 1")
  apply (simp add: P3_b)
  apply (cut_tac a = 1 and b = x and c = 1 in W3b)
  by simp

lemma P5_a: "x l\<rightarrow> y = 1 \<Longrightarrow> y l\<rightarrow> z = 1 \<Longrightarrow> x l\<rightarrow> z = 1"
  apply (cut_tac a = x and b = y and c = z in W3a)
  by simp

lemma P5_b: "x r\<rightarrow> y = 1 \<Longrightarrow> y r\<rightarrow> z = 1 \<Longrightarrow> x r\<rightarrow> z = 1"
  apply (cut_tac a = x and b = y and c = z in W3b)
  by simp

lemma P6_a: "x l\<rightarrow> (y r\<rightarrow> x) = 1"
  apply (cut_tac a = y and b = 1 and c = x in W3b)
  by simp

lemma P6_b: "x r\<rightarrow> (y l\<rightarrow> x) = 1"
  apply (cut_tac a = y and b = 1 and c = x in W3a)
  by simp

lemma P7: "(x l\<rightarrow> (y r\<rightarrow> z) = 1) = (y r\<rightarrow> (x l\<rightarrow> z) = 1)"
  proof
    fix x y z assume A: "x l\<rightarrow> y r\<rightarrow> z = 1" show "y r\<rightarrow> x l\<rightarrow> z = 1"
      apply (rule_tac y = "(z r\<rightarrow> y) l\<rightarrow> y" in P5_b)
      apply (simp add: P6_b)
      apply (unfold W2c)
      apply (subgoal_tac "(x l\<rightarrow> (y r\<rightarrow> z)) l\<rightarrow> (((y r\<rightarrow> z) l\<rightarrow> z) r\<rightarrow> x l\<rightarrow> z) = 1")
      apply (unfold A) [1]
      apply simp
      by (simp add: W3a)
    next
    fix x y z assume A: "y r\<rightarrow> x l\<rightarrow> z = 1" show "x l\<rightarrow> y r\<rightarrow> z = 1"
      apply (rule_tac y = "(z l\<rightarrow> x) r\<rightarrow> x" in P5_a)
      apply (simp add: P6_a)
      apply (unfold W2a)
      apply (subgoal_tac "(y r\<rightarrow> x l\<rightarrow> z) r\<rightarrow> (((x l\<rightarrow> z) r\<rightarrow> z) l\<rightarrow> y r\<rightarrow> z) = 1")
      apply (unfold A) [1]
      apply simp
      by (simp add: W3b)
    qed

lemma P8_a: "(x l\<rightarrow> y) r\<rightarrow> ((z l\<rightarrow> x) l\<rightarrow> (z l\<rightarrow> y)) = 1"
  by (simp add: W3a P7 [THEN sym])

lemma P8_b: "(x r\<rightarrow> y) l\<rightarrow> ((z r\<rightarrow> x) r\<rightarrow> (z r\<rightarrow> y)) = 1"
  by (simp add: W3b P7)

lemma P9: "x l\<rightarrow> (y r\<rightarrow> z) = y r\<rightarrow> (x l\<rightarrow> z)"
  apply (rule P2_c)
  apply (subst P7)
  apply (rule_tac y = "(z r\<rightarrow> y) l\<rightarrow> y" in P5_b)
  apply (simp add: P6_b)
  apply (subst W2c)
  apply (rule P8_a)
  apply (subst P7 [THEN sym])
  apply (rule_tac y = "(z l\<rightarrow> x) r\<rightarrow> x" in P5_a)
  apply (simp add: P6_a)
  apply (subst W2a)
  by (simp add: P8_b)

definition
  "lesseq_a a b = (a l\<rightarrow> b = 1)"

definition
  "less_a a b = (lesseq_a a b \<and> \<not> lesseq_a b a)"

definition
  "lesseq_b a b = (a r\<rightarrow> b = 1)"

definition
  "less_b a b = (lesseq_b a b \<and> \<not> lesseq_b b a)"

definition
  "sup_a a b = (a l\<rightarrow> b) r\<rightarrow> b"

end

sublocale impl_lr_algebra < order_a:order lesseq_a less_a
  apply unfold_locales
  apply (simp add: less_a_def)
  apply (simp_all add: lesseq_a_def)
  apply (rule P5_a)
  apply simp_all
  apply (rule P2_a)
  by simp_all

sublocale impl_lr_algebra < order_b:order lesseq_b less_b
  apply unfold_locales
  apply (simp add: less_b_def)
  apply (simp_all add: lesseq_b_def)
  apply (rule P5_b)
  apply simp_all
  apply (rule P2_b)
  by simp_all

sublocale impl_lr_algebra < slattice_a:semilattice_sup sup_a lesseq_a less_a
  apply unfold_locales
  apply (simp_all add: lesseq_a_def sup_a_def)
  apply (simp add: P9)
  apply (simp add: P9)
  apply (subst W2a)
  apply (subgoal_tac "((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> ((y l\<rightarrow> x) r\<rightarrow> x) = 1")
  apply simp
  apply (subgoal_tac "((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> ((x l\<rightarrow> y) r\<rightarrow> y) = 1")
  apply (simp add: W2a)
  apply (subgoal_tac "((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> (x l\<rightarrow> y) r\<rightarrow> y = ((x l\<rightarrow> y) r\<rightarrow> (z l\<rightarrow> y)) r\<rightarrow> (((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> (x l\<rightarrow> y) r\<rightarrow> y)")
  apply (simp add: W3b)
  apply (subgoal_tac "(x l\<rightarrow> y) r\<rightarrow> z l\<rightarrow> y = 1")
  apply simp
  apply (cut_tac a = z and b = x and c = y in W3a)
  by simp

sublocale impl_lr_algebra < slattice_b:semilattice_sup sup_a lesseq_b less_b
  apply unfold_locales
  apply (simp_all add: lesseq_b_def sup_a_def)
  apply (simp_all add: W2b)
  apply (simp add: P9 [THEN sym])
  apply (simp add: P9 [THEN sym])
  apply (subst W2c)
  apply (subgoal_tac "((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> ((y r\<rightarrow> x) l\<rightarrow> x) = 1")
  apply simp
  apply (subgoal_tac "((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> ((x r\<rightarrow> y) l\<rightarrow> y) = 1")
  apply (simp add: W2c)
  apply (subgoal_tac "((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> (x r\<rightarrow> y) l\<rightarrow> y = ((x r\<rightarrow> y) l\<rightarrow> (z r\<rightarrow> y)) l\<rightarrow> (((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> (x r\<rightarrow> y) l\<rightarrow> y)")
  apply (simp add: W3a)
  apply (subgoal_tac "(x r\<rightarrow> y) l\<rightarrow> z r\<rightarrow> y = 1")
  apply simp
  apply (cut_tac a = z and b = x and c = y in W3b)
  by simp

context impl_lr_algebra
begin
lemma lesseq_a_b: "lesseq_b = lesseq_a"
  apply (simp add: fun_eq_iff)
  apply clarify
  apply (cut_tac x = x and y = xa in slattice_a.le_iff_sup)
  apply (cut_tac x = x and y = xa in slattice_b.le_iff_sup)
  by simp

lemma P10: "(a l\<rightarrow> b = 1) = (a r\<rightarrow> b = 1)"
  apply (cut_tac lesseq_a_b)
  by (simp add: fun_eq_iff lesseq_a_def lesseq_b_def)
end

class one_ord = one + ord

class impl_lr_ord_algebra = impl_lr_algebra + one_ord +
  assumes
     order: "a \<le> b = (a l\<rightarrow> b = 1)"
  and
     strict: "a < b = (a \<le> b \<and> \<not> b \<le> a)"
begin
lemma order_l: "(a \<le> b) = (a l\<rightarrow> b = 1)"
  by (simp add: order)

lemma order_r: "(a \<le> b) = (a r\<rightarrow> b = 1)"
  by (simp add: order P10)

lemma P11_a: "a \<le> b l\<rightarrow> a"
  by (simp add: order_r P6_b)

lemma P11_b: "a \<le> b r\<rightarrow> a"
  by (simp add: order_l P6_a)

lemma P12: "(a \<le> b l\<rightarrow> c) = (b \<le> a r\<rightarrow> c)"
  apply (subst order_r)
  apply (subst order_l)
  by (simp add: P7)

lemma P13_a: "a \<le> b \<Longrightarrow> b l\<rightarrow> c \<le> a l\<rightarrow> c"
  apply (subst order_r)
  apply (simp add: order_l)
  apply (cut_tac a = a and b = b and c = c in W3a)
  by simp

lemma P13_b: "a \<le> b \<Longrightarrow> b r\<rightarrow> c \<le> a r\<rightarrow> c"
  apply (subst order_l)
  apply (simp add: order_r)
  apply (cut_tac a = a and b = b and c = c in W3b)
  by simp

lemma P14_a: "a \<le> b \<Longrightarrow> c l\<rightarrow> a \<le> c l\<rightarrow> b"
  apply (simp add: order_l)
  apply (cut_tac x = a and y = b and z = c in P8_a)
  by simp

lemma P14_b: "a \<le> b \<Longrightarrow> c r\<rightarrow> a \<le> c r\<rightarrow> b"
  apply (simp add: order_r)
  apply (cut_tac x = a and y = b and z = c in P8_b)
  by simp

subclass order
  apply (subgoal_tac "(\<le>) = lesseq_a \<and> (<) = less_a")
  apply simp
  apply unfold_locales
  apply safe
  by (simp_all add: fun_eq_iff lesseq_a_def less_a_def order_l strict)

end

class one_zero_uminus = one + zero + left_uminus + right_uminus

class impl_neg_lr_algebra = impl_lr_ord_algebra + one_zero_uminus +
  assumes
      W4: "-l 1 = -r 1"
  and W5a: "(-l a r\<rightarrow> -l b) l\<rightarrow> (b l\<rightarrow> a) = 1"
  and W5b: "(-r a l\<rightarrow> -r b) l\<rightarrow> (b r\<rightarrow> a) = 1"
  and zero_def: "0 = -l 1"
begin

lemma zero_r_def: "0 = -r 1"
  by (simp add: zero_def W4)

lemma C1_a [simp]: "(-l x r\<rightarrow> 0) l\<rightarrow> x = 1"
  apply (unfold zero_def)
  apply (cut_tac a = x and b = 1 in W5a)
  by simp

lemma C1_b [simp]: "(-r x l\<rightarrow> 0) r\<rightarrow> x = 1"
  apply (unfold zero_r_def)
  apply (cut_tac a = x and b = 1 in W5b)
  by (simp add: P10)

lemma C2_b [simp]: "0 r\<rightarrow> x = 1"
  apply (cut_tac x= "-r x l\<rightarrow> 0" and y = x and z = 0 in P8_b)
  by (simp add: P6_b)

lemma C2_a [simp]: "0 l\<rightarrow> x = 1"
  by (simp add: P10)

lemma C3_a: "x l\<rightarrow> 0 = -l x"
  proof -
    have A: "-l x l\<rightarrow> (x l\<rightarrow> 0) = 1"
      apply (cut_tac x = "-l x" and y = "-l (-r 1)" in P6_a)
      apply (cut_tac a = "-r 1" and b = "x" in W5a)
      apply (unfold zero_r_def)
      apply (rule_tac y = " -l (-r (1::'a)) r\<rightarrow> -l x" in P5_a)
      by simp_all
    have B: "(x l\<rightarrow> 0) r\<rightarrow> -l x = 1"
      apply (cut_tac a = "-l x r\<rightarrow> 0" and b = x and c = 0 in W3a)
      apply simp
      apply (cut_tac b = "-l x" and a = 0 in W2c)
      by simp
    show "x l\<rightarrow> 0 = -l x"
      apply (rule antisym)
      apply (simp add: order_r B)
      by (simp add: order_l A)
    qed

lemma C3_b: "x r\<rightarrow> 0 = -r x"
  apply (rule antisym)
  apply (simp add: order_l)
  apply (cut_tac x = x in C1_b)
  apply (cut_tac a = "-r x l\<rightarrow> 0" and b = x and c = 0 in W3b)
  apply simp
  apply (cut_tac b = "-r x" and a = 0 in W2a)
  apply simp
  apply (cut_tac x = "-r x" and y = "-r (-l 1)" in P6_b)
  apply (cut_tac a = "-l 1" and b = "x" in W5b)
  apply (unfold zero_def order_r)
  apply (rule_tac y = " -r (-l (1::'a)) l\<rightarrow> -r x" in P5_b)
  by (simp_all add: P10)

lemma C4_a [simp]: "-r (-l x) = x"
  apply (unfold C3_b [THEN sym] C3_a [THEN sym])
  apply (subst W2a)
  by simp

lemma C4_b [simp]: "-l (-r x) = x"
  apply (unfold C3_b [THEN sym] C3_a [THEN sym])
  apply (subst W2c)
  by simp

lemma C5_a: "-r x l\<rightarrow> -r y = y r\<rightarrow> x"
  apply (rule antisym)
  apply (simp add: order_l W5b)
  apply (cut_tac a = "-r y" and b = "-r x" in W5a)
  by (simp add: order_l)

lemma C5_b: "-l x r\<rightarrow> -l y = y l\<rightarrow> x"
  apply (rule antisym)
  apply (simp add: order_l W5a)
  apply (cut_tac a = "-l y" and b = "-l x" in W5b)
  by (simp add: order_l)

lemma C6: "-r x l\<rightarrow> y = -l y r\<rightarrow> x"
  apply (cut_tac x = x and y = "-l y" in C5_a)
  by simp

lemma C7_a: "(x \<le> y) = (-l y \<le> -l x)"
  apply (subst order_l)
  apply (subst order_r)
  by (simp add: C5_b)

lemma C7_b: "(x \<le> y) = (-r y \<le> -r x)"
  apply (subst order_r)
  apply (subst order_l)
  by (simp add: C5_a)

end

class pseudo_wajsberg_algebra = impl_neg_lr_algebra +
  assumes
  W6: "-r (a l\<rightarrow> -l b) = -l (b r\<rightarrow> -r a)"
begin
definition
  "mult a b = -r (a l\<rightarrow> -l b)"

definition
  "inf_a a b = -l (a r\<rightarrow> -r (a l\<rightarrow> b))"

definition
  "inf_b a b = -r (b l\<rightarrow> -l (b r\<rightarrow> a))"

end

sublocale pseudo_wajsberg_algebra < slattice_inf_a:semilattice_inf inf_a "(\<le>)" "(<)"
  apply unfold_locales
  apply (simp_all add: inf_a_def)
  apply (subst C7_b)
  apply (simp add: order_l P9 C5_a P10 [THEN sym] P6_a)
  apply (subst C7_b)
  apply (simp add: order_l P9 C5_a P10 [THEN sym] P6_a)
  apply (subst W6 [THEN sym])
  apply (subst C7_a)
  apply simp
  proof -
    fix x y z
    assume A: "x \<le> y"
    assume B: "x \<le> z"
    have C: "x l\<rightarrow> y = 1" by (simp add: order_l [THEN sym] A)
    have E: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> -l x = ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((x l\<rightarrow> y) l\<rightarrow> -l x)"
      by (simp add: C)
    have F: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((x l\<rightarrow> y) l\<rightarrow> -l x) =  ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l y r\<rightarrow> -l x) l\<rightarrow> -l x)"
      by (simp add: C5_b)
    have G: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l y r\<rightarrow> -l x) l\<rightarrow> -l x) = ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l x r\<rightarrow> -l y) l\<rightarrow> -l y)"
      by (simp add: W2c)
    have H: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l x r\<rightarrow> -l y) l\<rightarrow> -l y) = ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((y l\<rightarrow> x) l\<rightarrow> -l y)"
      by (simp add: C5_b)
    have I: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((y l\<rightarrow> x) l\<rightarrow> -l y) = 1"
      apply (simp add: order_l [THEN sym] P14_a)
      apply (rule P13_a)
      apply (rule P14_a)
      by (simp add: B)
    show "(y l\<rightarrow> z) l\<rightarrow> -l y \<le> -l x"
      by (simp add: order_l E F G H I)
    next
    qed

sublocale pseudo_wajsberg_algebra < slattice_inf_b:semilattice_inf inf_b "(\<le>)" "(<)"
  apply unfold_locales
  apply (simp_all add: inf_b_def)
  apply (subst C7_a)
  apply (simp add: order_r P9 [THEN sym] C5_b P10 P6_b)
  apply (subst C7_a)
  apply (simp add: order_r P9 [THEN sym] C5_b P10 P6_b)
  apply (subst W6)
  apply (subst C7_b)
  apply simp
  proof -
    fix x y z
    assume A: "x \<le> y"
    assume B: "x \<le> z"
    have C: "x r\<rightarrow> z = 1" by (simp add: order_r [THEN sym] B)
    have E: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> -r x = ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((x r\<rightarrow> z) r\<rightarrow> -r x)"
      by (simp add: C)
    have F: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((x r\<rightarrow> z) r\<rightarrow> -r x) =  ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r z l\<rightarrow> -r x) r\<rightarrow> -r x)"
      by (simp add: C5_a)
    have G: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r z l\<rightarrow> -r x) r\<rightarrow> -r x) = ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r x l\<rightarrow> -r z) r\<rightarrow> -r z)"
      by (simp add: W2a)
    have H: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r x l\<rightarrow> -r z) r\<rightarrow> -r z) = ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((z r\<rightarrow> x) r\<rightarrow> -r z)"
      by (simp add: C5_a)
    have I: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((z r\<rightarrow> x) r\<rightarrow> -r z) = 1"
      apply (simp add: order_r [THEN sym])
      apply (rule P13_b)
      apply (rule P14_b)
      by (simp add: A)
    show "(z r\<rightarrow> y) r\<rightarrow> -r z \<le> -r x"
      by (simp add: order_r E F G H I)
    next
    qed

context pseudo_wajsberg_algebra
begin
lemma inf_a_b: "inf_a = inf_b"
  apply (simp add: fun_eq_iff)
  apply clarify
  apply (rule antisym)
  by simp_all

end
end


theory Reactive
  imports Temporal Refinement
begin
  section{*Reactive Systems*}
  (*declare [[show_types]]*)

  text{*
    In this section we introduce reactive systems which are modeled as
    monotonic property transformers where properties are predicates on
    traces. We start with introducing some examples that uses LTL to
    specify global behaviour on traces, and later we introduce property
    transformers based on symbolic transition systems.
    *}

  definition "HAVOC = [:x \<leadsto> y . True:]"
  definition "ASSERT_LIVE = {. \<box> \<diamondsuit> (\<lambda> x . x 0).}"
  definition "GUARANTY_LIVE = [:x \<leadsto> y . \<box> \<diamondsuit> (\<lambda> y . y 0):]"
  definition "AE = ASSERT_LIVE o HAVOC"
  definition "SKIP = [:x \<leadsto> y . x = y:]"

  definition "REQ_RESP = [: \<box>(\<lambda> xs ys . xs (0::nat) \<longrightarrow> (\<diamondsuit> (\<lambda> ys . ys (0::nat))) ys) :]"
  definition "FAIL = \<bottom>"

  lemma "HAVOC o ASSERT_LIVE = FAIL"
    by (auto simp add: HAVOC_def AE_def FAIL_def ASSERT_LIVE_def fun_eq_iff assert_def demonic_def always_def at_fun_def le_fun_def eventually_def)

  lemma "HAVOC o AE = FAIL"
    by (auto simp add: HAVOC_def AE_def FAIL_def ASSERT_LIVE_def fun_eq_iff assert_def demonic_def always_def at_fun_def le_fun_def eventually_def)

  lemma "HAVOC o ASSERT_LIVE = FAIL"
    by (auto simp add: HAVOC_def AE_def FAIL_def ASSERT_LIVE_def fun_eq_iff assert_def demonic_def always_def  at_fun_def eventually_def)

  lemma "SKIP o AE = AE"
    by simp

  lemma "(REQ_RESP o AE) = AE"
    proof (auto simp add: fun_eq_iff HAVOC_def AE_def FAIL_def REQ_RESP_def ASSERT_LIVE_def  assert_def
      demonic_def always_def le_fun_def eventually_def at_fun_def)
      fix x :: "'a \<Rightarrow> bool"
      fix xa :: "nat \<Rightarrow> bool"
      fix xb :: nat
      assume "\<forall>xb::nat \<Rightarrow> bool . (\<forall>x. xa x \<longrightarrow> Ex (xb[x ..])) \<longrightarrow> (\<forall>x. \<exists>a. xb (x + a)) \<and> All x"
      then have "(\<forall>x. xa x \<longrightarrow> Ex (xa[x ..])) \<longrightarrow> (\<forall>x. \<exists>a. xa (x + a)) \<and> All x"
        by auto
      then show "\<exists>x. xa (xb + x)"
        by (auto, rule_tac x = 0 in exI, simp)
    next
      fix x :: "'a \<Rightarrow> bool"
      fix xa :: "nat \<Rightarrow> bool"
      fix xb :: 'a
      assume "\<forall>xb::nat \<Rightarrow> bool . (\<forall>x. xa x \<longrightarrow> Ex (xb[x ..])) \<longrightarrow> (\<forall>x. \<exists>a. xb (x + a)) \<and> All x"
      from this show "x xb"
        by (metis at_trace_def le0)
    next
      fix x :: "'a \<Rightarrow> bool" and xa :: "nat \<Rightarrow> bool" and xb :: "nat \<Rightarrow> bool" and xc :: nat
      assume A: "\<forall>x. xa x \<longrightarrow> Ex (xb[x ..])"
      assume B: "\<forall>x. \<exists>xb. xa (x + xb)"
      have "\<exists>x1. xc \<le> AbsNat x1" by (metis (full_types) le_add2 plus_Nat_def)
      thus "\<exists>x. xb (xc + x)" using A B by (metis AbsNat_plus add.commute at_trace_def le_Suc_ex trans_le_add2)
   qed

  subsection{*Symbolic transition systems*}

  text{*
    In this section we introduce property transformers basend on symbolic
    transition systems. These are systems with local state. The execution
    starts in some initial state, and with some input value the system computes
    a new state and an output value. Then using the current state, and a
    new input value the system computes a new state, and a new output, and
    so on. The system may fail if at some point the input and the current
    state do not statisfy a required predicate.

    In the folowing definitions the variables $u$, $x$, $y$ stand for the
    state of the system, the input, and the output respectively. The $init$
    is the property that the initial state should satisfy. The predicate
    $p$ is the precondition of the input and the current state, and the
    relation $r$ gives the next state and the output based on the
    input and the current state.
*}

  definition "fail_sys init p r x = (\<exists> n u y . u \<in> init \<and> (\<forall> i < n . r (u i) (u (Suc i)) (x i) (y i)) \<and> (\<not> p (u n) (u (Suc n)) (x n)))"
  definition "run r u x y = (\<forall> i . r (u i) (u (Suc i)) (x i) (y i))"
  definition "LocalSystem init p r q x = (\<not> fail_sys init p r x \<and> (\<forall> u y . (u \<in> init \<and> run r u x y) \<longrightarrow> q y))"

  lemma "fail (LocalSystem init p r) = fail_sys init p r"
    by (simp add: fun_eq_iff LocalSystem_def fail_def fail_sys_def run_def)

  definition "inpt_st r u u' x =  (\<exists> y . r u u' x y)"

  definition "lft_pred_st p u x = p (u (0::nat)) (u 1) (x (0::nat))"

  definition "lft_pred_loc_st p u x = p (u (0::nat)) (x (0::nat))"

  definition "lft_rel_st r u x y = r (u (0::nat)) (u 1) (x (0::nat)) (y (0::nat))"

  definition "prec_st p r = -((lft_pred_st (inpt_st r)) until -(lft_pred_st p))"

  lemma prec_st_simp: "prec_st p r u x = (\<forall> n . (\<forall> i < n . inpt_st r (u i) (u (Suc i)) (x i)) \<longrightarrow> p (u n) (u (Suc n)) (x n))"
    by (simp add: prec_st_def until_def lft_pred_st_def inpt_st_def at_fun_def, metis)

  definition "SymSystem init p r = [:z \<leadsto>  u, x . u \<in> init \<and> z = x:] o {.u, x . prec_st p r u x.} o
      [:u, x \<leadsto> y . (\<box> (lft_rel_st r)) u x y :]"

  lemma SymSystem_rel: "SymSystem init p r = {. x . \<forall>u. u \<in> init \<longrightarrow> prec_st p r u x .} \<circ>
    [: x \<leadsto> y . \<exists> u . u \<in> init \<and> (\<box> lft_rel_st r) u x y :] "
    proof -
      have [simp]:  "((\<lambda>z (u, x). u \<in> init \<and> z = x) OO (\<lambda>(x, y). (\<box> lft_rel_st r) x y)) = (\<lambda>x y. \<exists>u. u \<in> init \<and> (\<box> lft_rel_st r) u x y)"
        by auto
      show ?thesis by  (simp add: SymSystem_def demonic_assert_comp comp_assoc demonic_demonic)
    qed

  theorem "SymSystem init p r q x = LocalSystem init p r q x"
    proof
      assume "SymSystem init p r q x"
      then show "LocalSystem init p r q x"
        apply (auto simp add: SymSystem_def LocalSystem_def assert_def
          demonic_def prec_st_simp lft_rel_st_def lft_pred_st_def inpt_st_def
          always_def  le_fun_def fail_sys_def run_def at_fun_def)
        by metis
    next
      assume "LocalSystem init p r q x"
      then show "SymSystem init p r q x"
        apply (auto simp add: SymSystem_def LocalSystem_def assert_def
          demonic_def prec_st_simp lft_rel_st_def lft_pred_st_def inpt_st_def
          always_def  le_fun_def fail_sys_def run_def at_fun_def)
        by metis
    qed

  definition "local_init init S = INFIMUM init S"

  definition "zip_set A B = {u . ((fst o u) \<in> A) \<and> ((snd o u) \<in> B)}"
  definition nzip:: "('x \<Rightarrow> 'a) \<Rightarrow> ('x \<Rightarrow> 'b) \<Rightarrow> 'x \<Rightarrow> ('a\<times>'b)" (infixl "||" 65) where "(xs || ys) i = (xs i, ys i)"

  lemma [simp]: "fst \<circ> x || y = x"
    by (simp add: fun_eq_iff nzip_def)

  lemma [simp]: "snd \<circ> x || y = y"
    by (simp add: fun_eq_iff nzip_def)

  lemma [simp]: "x \<in> A \<Longrightarrow> y \<in> B \<Longrightarrow> (x || y) \<in> zip_set A B"
    by (simp add: zip_set_def)

  lemma local_demonic_init: "local_init init (\<lambda> u . {. x . p u x.} o [:x \<leadsto> y . r u x y :]) =
        [:z \<leadsto> u, x . u \<in> init \<and> z = x:] o {.u, x . p u x.} o [:u, x \<leadsto> y . r u x y :]"
    by (auto simp add: fun_eq_iff demonic_def assert_def local_init_def le_fun_def)

  lemma local_init_comp: "u' \<in> init' \<Longrightarrow> (\<forall> u. sconjunctive (S u)) \<Longrightarrow> (local_init init S) o (local_init init' S')
                       = local_init (zip_set init init') (\<lambda> u . (S (fst o u)) o (S' (snd o u)))"
      proof (subst fun_eq_iff, auto)
        fix x :: 'f
        assume A: "u' \<in> init'"
        assume "\<forall> u . sconjunctive (S u)"
        from this have [simp]: "\<And> u . sconjunctive (S u)" by simp
        from A have [simp]: "\<And> y . S y (INF y' : init'. S' y' x) =  (INF y' : init' . S y (S' y' x))"
          by (simp add: sconjunctive_INF_simp)

        have [simp]: "(INF y : init . (INF y' : init' . S y (S' y' x))) \<le> (INF u : zip_set init init'. S (fst \<circ> u) (S' (snd \<circ> u) x))"
          proof (rule INF_greatest, auto simp add: zip_set_def)
            fix u :: "'a \<Rightarrow> 'c \<times> 'b"
            assume [simp]: "fst \<circ> u \<in> init"
            assume [simp]: "snd \<circ> u \<in> init'"
            have "(INF y : init. INF y' : init'. S y (S' y' x)) \<le> (INF y' : init'. S (fst o u) (S' y' x))"
              by (rule INF_lower, simp)
            also have "... \<le> S (fst o u) (S' (snd o u) x)"
              by (rule INF_lower, simp)
            finally show "(INF y : init. INF y' : init'. S y (S' y' x)) \<le> S (fst o u) (S' (snd o u) x)"
              by simp
          qed
        have [simp]: "(INF u : zip_set init init'. S (fst \<circ> u) (S' (snd \<circ> u) x)) \<le> (INF y : init . (INF y' : init' . S y (S' y' x)))"
          proof (rule INF_greatest, rule INF_greatest)
            fix y :: "'a \<Rightarrow> 'c" and y':: "'a \<Rightarrow> 'b"
            assume [simp]: "y \<in> init"
            assume [simp]: "y' \<in> init'"
            have "(INF u : zip_set init init'. S (fst \<circ> u) (S' (snd \<circ> u) x)) \<le> S (fst o (y || y')) (S' (snd o (y || y')) x)"
              by (rule INF_lower, simp)
            also have "... \<le>  S y (S' y' x)"
              by simp
            finally show "(INF u\<Colon>'a \<Rightarrow> 'c \<times> 'b:zip_set init init'. S (fst \<circ> u) (S' (snd \<circ> u) x)) \<le> S y (S' y' x)"
              by simp
          qed
        have "local_init init S (local_init init' S' x) = (INF y : init. S y (INF y' : init'. S' y' x)) "
          by (simp add: local_init_def)
        also have "... = (INF y : init . (INF y' : init' . S y (S' y' x)))"
          by simp
        also have "... = (INF u : zip_set init init'. S (fst \<circ> u) \<circ> S' (snd \<circ> u)) x"
         by (rule antisym, auto)
        also have "... = local_init (zip_set init init') (\<lambda> u . (S (fst o u)) o (S' (snd o u))) x"
          by (simp add: local_init_def)
        finally show "local_init init S (local_init init' S' x) = local_init (zip_set init init') (\<lambda>u\<Colon>'a \<Rightarrow> 'c \<times> 'b. S (fst \<circ> u) \<circ> S' (snd \<circ> u)) x"
          by simp
      qed

  lemma init_state: "[:z \<leadsto> u, x . u \<in> init \<and> z = x:] o {.u, x . p u x.} o [:u, x \<leadsto> y . r u x y :]
      = [:z \<leadsto> u, x . z = x:] o {.u, x . u \<in> init \<longrightarrow> p u x.} o [:u, x \<leadsto> y . u \<in> init \<and> r u x y :]"
    by (auto simp add: fun_eq_iff demonic_def assert_def local_init_def le_fun_def)

  lemma always_lft_rel_comp: "(\<box> lft_rel_st r) (fst \<circ> u) OO (\<box> lft_rel_st r') (snd \<circ> u)
              = (\<box> lft_rel_st (\<lambda> (u, v) (u', v') . ((r u u') OO (r' v v')))) u"
    proof (auto simp add: fun_eq_iff lft_rel_st_def always_def at_fun_def relcompp_exists)
      fix x::"nat \<Rightarrow>'a" and
          y::"nat \<Rightarrow> 'b" and
          v::"nat \<Rightarrow> 'c" and
          n:: nat
      assume "\<forall>i . r (fst (u i)) (fst (u (Suc i))) (x i) (v i)"
      and "\<forall>i . r' (snd (u i)) (snd (u (Suc i))) (v i) (y i)"
      from this show "(case u n of (u, v) \<Rightarrow> \<lambda>(u', v'). r u u' OO r' v v') (u (Suc n)) (x n) (y n)"
        by (metis (mono_tags, lifting)  prod.case_eq_if relcompp.relcompI)
    next
      fix x::"nat \<Rightarrow>'a" and
          z::"nat \<Rightarrow> 'b"
      def A: a == "(\<lambda> n . SOME y . r (fst (u n)) (fst (u (Suc n))) (x n) y \<and> r' (snd (u n)) (snd (u (Suc n))) y (z n))"
      assume "\<forall>i . (case u i of (u, v) \<Rightarrow> \<lambda>(u', v'). r u u' OO r' v v') (u (Suc i)) (x i) (z i)"
      from this and A have "(\<forall>i :: nat. r (fst (u i)) (fst (u (Suc i))) (x i) (a i)) \<and> (\<forall>i :: nat. r' (snd (u i)) (snd (u (Suc i))) (a i) (z i))"
        apply auto
          apply (metis (mono_tags, lifting) pick_middlep prod.collapse split_conv tfl_some)
          by (metis (mono_tags, lifting) pick_middlep prod.collapse split_conv tfl_some)
     from this show "\<exists> a . (\<forall>i . r (fst (u i)) (fst (u (Suc i))) (x i) (a i)) \<and> (\<forall>i . r' (snd (u i)) (snd (u (Suc i))) (a i) (z i))"
      by blast
    qed

 theorem SymSystem_comp: "u' \<in> init' \<Longrightarrow> SymSystem init p r o SymSystem init' p' r'
                   = [:z \<leadsto> u, x . fst o u \<in> init \<and> snd o u \<in> init' \<and> z = x:]
                   o {. u, x . prec_st p r (fst \<circ> u) x \<and> (\<forall>y. (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> prec_st p' r' (snd \<circ> u) y) .}
                   o [: u, x \<leadsto> y . (\<box> lft_rel_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v')) u x y :]"
                   (is "?p \<Longrightarrow> ?S  = ?T")
    proof -
      assume A: "?p"
      have "?S =
        [: z \<leadsto> (u, x) . u \<in> init \<and> z = x :] \<circ> {.x, y. prec_st p r x y.} \<circ>
        [: id (\<lambda>(u, x). id ((\<box> lft_rel_st r) u x)) :] \<circ>
        ([: z \<leadsto> u, x . u \<in> init' \<and> z = x :] \<circ> {.x, y. prec_st p' r' x y.} \<circ>
        [: id (\<lambda>(u, x). id ((\<box> lft_rel_st r') u x)) :])"
        by (unfold SymSystem_def, simp)
      also have "... =  local_init init (\<lambda>u\<Colon>nat \<Rightarrow> 'e. {. id (prec_st p r u) .} \<circ> [: id (\<lambda>x. id ((\<box> lft_rel_st r) u x)) :]) \<circ>
          local_init init' (\<lambda>u. {. id (prec_st p' r' u) .} \<circ> [: id (\<lambda>x\<Colon>nat \<Rightarrow> 'd. id ((\<box> lft_rel_st r') u x)) :])"
        by (unfold local_demonic_init [THEN sym], simp)
      also from A have "... = local_init (zip_set init init')
            (\<lambda>u. {. prec_st p r (fst \<circ> u) .} \<circ> [: (\<box> lft_rel_st r) (fst \<circ> u) :] \<circ> ({. prec_st p' r' (snd \<circ> u) .} \<circ> [: (\<box> lft_rel_st r') (snd \<circ> u) :]))"
              by (simp add: local_init_comp)
      also have " ... = local_init (zip_set init init')
         (\<lambda>u. {. prec_st p r (fst \<circ> u) .} \<circ> [: (\<box> lft_rel_st r) (fst \<circ> u) :] \<circ> {. prec_st p' r' (snd \<circ> u) .} \<circ> [: (\<box> lft_rel_st r') (snd \<circ> u) :])"
      by (simp add: comp_assoc [THEN sym])
      also have "... =  local_init (zip_set init init')
        (\<lambda>u.{. x . prec_st p r (fst \<circ> u) x \<and> (\<forall>y. (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> prec_st p' r' (snd \<circ> u) y) .} \<circ>
            [: (\<box> lft_rel_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v')) u :]) "
         by (simp add: assert_demonic_comp always_lft_rel_comp)
    also have "... = local_init (zip_set init init')
     (\<lambda>u.{.x. prec_st p r (fst \<circ> u) x \<and> (\<forall>y\<Colon>nat \<Rightarrow> 'd. (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> prec_st p' r' (snd \<circ> u) y).} \<circ>
         [: id (\<lambda>x\<Colon>nat \<Rightarrow> 'c. id ((\<box> lft_rel_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v')) u x)) :])"
       by simp
    also have "... = ?T"
     by (unfold local_demonic_init, simp add: zip_set_def)
   finally show ?thesis by simp
   qed

  lemma always_lft_rel_comp_a: "(\<box> lft_rel_st r) u OO (\<box> lft_rel_st r') v
              = (\<box> lft_rel_st (\<lambda> (u, v) (u', v') . ((r u u') OO (r' v v')))) (u || v)"
      by (unfold always_lft_rel_comp [THEN sym], auto)

  theorem SymSystem_comp_a: "u' \<in> init' \<Longrightarrow> SymSystem init p r o SymSystem init' p' r'
                   = {.x . \<forall> u v . u \<in> init \<and> v \<in> init' \<longrightarrow> (prec_st p r u x \<and> (\<forall>y. (\<box> lft_rel_st r) u x y \<longrightarrow> prec_st p' r' v y)) .}
                   o [: x \<leadsto> y . \<exists> u v . u \<in> init \<and> v \<in> init' \<and> (\<box> lft_rel_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v')) (u || v) x y :]"
                   (is "?p \<Longrightarrow> ?S = ?T")
    proof -
      assume A: "u' \<in> init'"
      from A have [simp]: "(\<lambda>x. (\<forall>u. u \<in> init \<longrightarrow> prec_st p r u x) \<and> (\<forall>y. (\<exists>u. u \<in> init \<and> (\<box> lft_rel_st r) u x y) \<longrightarrow> (\<forall>u. u \<in> init' \<longrightarrow> prec_st p' r' u y)))
          = (\<lambda>x. \<forall>u v. u \<in> init \<and> v \<in> init' \<longrightarrow> prec_st p r u x \<and> (\<forall>y. (\<box> lft_rel_st r) u x y \<longrightarrow> prec_st p' r' v y))"
          by (auto simp add: fun_eq_iff)
      have [simp]: "(\<lambda>x y. \<exists>u. u \<in> init \<and> (\<box> lft_rel_st r) u x y) OO (\<lambda>x y. \<exists>u. u \<in> init' \<and> (\<box> lft_rel_st r') u x y)
        = (\<lambda> x y . \<exists> u v . u \<in> init \<and> v \<in> init' \<and> (((\<box> lft_rel_st r) u) OO ((\<box> lft_rel_st r') v)) x y)"
        by (auto simp add: fun_eq_iff)

      from A have "?S = {.x . \<forall>u . u \<in> init \<longrightarrow> prec_st p r u x.} \<circ>
            [: x \<leadsto> y . \<exists>u\<Colon>nat \<Rightarrow> 'e. u \<in> init \<and> (\<box> lft_rel_st r) u x y :] \<circ>
            ({.x. \<forall>u . u \<in> init' \<longrightarrow> prec_st p' r' u x.} \<circ> [: x \<leadsto> y . \<exists>u . u \<in> init' \<and> (\<box> lft_rel_st r') u x y :])"
        by (simp add: SymSystem_rel)
       also have "... = {. \<lambda>x . \<forall>u . u \<in> init \<longrightarrow> prec_st p r u x .} \<circ> [: x \<leadsto> y . \<exists>u . u \<in> init \<and> (\<box> lft_rel_st r) u x y :] \<circ>
          {. x . \<forall>u . u \<in> init' \<longrightarrow> prec_st p' r' u x .} \<circ> [: x \<leadsto> y . \<exists>u . u \<in> init' \<and> (\<box> lft_rel_st r') u x y :]"
          by (simp add: comp_assoc [THEN sym])
       also have "... = ?T"
          by (simp add: assert_demonic_comp always_lft_rel_comp_a)
      finally show ?thesis
        by simp
     qed

  text{*We show next that the composition of two SymSystem $S$ and $S'$ is not equal to the SymSystem of the
  compostion of local transitions of $S$ and $S'$*}

  definition "initS = {u . fst (u (0::nat)) = (0::nat)}"
  definition "localPrecS = (\<top>:: nat \<times> nat  \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<Rightarrow> bool)"
  definition "localRelS = (\<lambda> (u::nat, v) (u', v'::nat) (x::nat) (y::nat) . u = 0 \<and> u' = 1 \<and> v = v')"

  definition "initS' = (\<top>::(nat \<Rightarrow> (nat \<times> nat)) set)"
  definition "localPrecS' = (\<bottom>:: nat \<times> nat  \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<Rightarrow> bool)"
  definition "localRelS' = (\<lambda> (u::nat, v) (u', v'::nat) (x::nat) (y::nat) . u = u')"

  definition "symbS = SymSystem initS localPrecS localRelS"
  definition "symbS' = SymSystem initS' localPrecS' localRelS'"

  definition "localPrecSS' = (\<lambda>(u::nat, v::nat) (u', v') (x::nat) . 0 < u)"
  definition "localRelSS' = (\<lambda> (u, v::nat) (u'::nat, v'::nat) (x::nat) (z::nat) . (u::nat) = 0 \<and> u' = 1)"

  lemma localSS'_aux: "( \<lambda>x. \<forall> (a::nat) (aa::nat) (b::nat). \<not> (case x of (x::nat, u::nat, v::nat) \<Rightarrow> \<lambda>ab. u = 0 \<and>
    (case ab of (y, u', v') \<Rightarrow> u' = Suc 0 \<and> v = v')) (a, aa, b))
    = (\<lambda> (x, u, v) . u > 0)"
    by (auto simp add: fun_eq_iff)

  lemma localSS'_aux_b: "((\<lambda>(x, u, v) ab. u = 0 \<and> (case ab of (y, u', v') \<Rightarrow> u' = Suc 0 \<and> v = v')) OO (\<lambda>(x, u, v) (y, u', v'). u = u'))
    = (\<lambda> (x, u, v) (y, u', v') . u = 0 \<and> u' = 1)"
    by (simp add: fun_eq_iff relcompp_exists)

  lemma "{.x, (u, v) . localPrecS (u, v) (a,b) x.} o [:x, (u,v) \<leadsto> y, (u',v') . localRelS (u,v) (u',v') x y:] o
         {.x, (u, v) . localPrecS' (u, v) (c, d) x.} o [:x, (u,v) \<leadsto> y, (u',v') . localRelS' (u,v) (u',v') x y:]
       = {.x, (u, v) . localPrecSS' (u, v) (e, f) x.} o [:x, (u,v) \<leadsto> y, (u',v') . localRelSS' (u,v) (u',v') x y:]"
    by (simp add: assert_demonic_comp localPrecS'_def localPrecS_def localRelS_def localRelS'_def
      relcompp_exists localPrecSS'_def localRelSS'_def localSS'_aux localSS'_aux_b)

  lemma [simp]: "[: \<bottom>::('a \<Rightarrow> 'b => ('c::boolean_algebra)) :] = \<top>"
    by (simp add: fun_eq_iff demonic_def)

  definition "symbSS' = SymSystem initS localPrecSS' localRelSS'"

  lemma symbSS'_aux: "( \<lambda>x. \<forall>u. fst (u 0) = 0 \<longrightarrow>
                (\<forall>n. (\<forall>i<n. Ex ((case u i of (u, v) \<Rightarrow> \<lambda>(u', v'::nat) x z. u = 0 \<and> u' = Suc 0) (u (Suc i)) (x i)))
                \<longrightarrow> (case u n of (u, v) \<Rightarrow> \<lambda>(u', v') x. 0 < u) (u (Suc n)) (x n)) ) = \<bottom>"
    apply (auto simp add: fun_eq_iff)
    by (rule_tac x = "\<lambda> i . (i::nat, i)" in exI, simp)

  lemma symbSS': "symbSS' = \<bottom>"
    by (simp add: symbSS'_def SymSystem_rel initS_def localPrecSS'_def localRelSS'_def prec_st_simp inpt_st_def symbSS'_aux)

  lemma symbS: "symbS = \<top>"
    proof (simp add: symbS_def SymSystem_rel initS_def localPrecS_def localRelS_def)
      have [simp]: "(\<lambda>x. \<forall>u. fst (u 0) = 0 \<longrightarrow> prec_st \<top> (\<lambda> (u, v) (u', v') x y . u = 0 \<and> u' = Suc 0 \<and> v = v') u x) = \<top>"
        by (simp_all add: fun_eq_iff prec_st_def always_def lft_rel_st_def at_fun_def lft_pred_st_def inpt_st_def until_def)

    have [simp]: "(\<lambda>x y. \<exists>u. fst (u 0) = 0 \<and> (\<box> lft_rel_st (\<lambda> (u, v) (u', v') (x) (y). u = 0 \<and> u' = Suc 0 \<and> v = v')) u x y) = \<bottom>"
      proof (auto simp add: fun_eq_iff always_def lft_rel_st_def at_fun_def)
      fix x::"nat \<Rightarrow> 'a" and xa :: "nat \<Rightarrow> 'b" and u::"nat \<Rightarrow> nat \<times> 'c"
      assume A: "\<forall>a . (case u a of (e, f) \<Rightarrow> \<lambda>(u', v') x y. e = 0 \<and> u' = Suc 0 \<and> f = v') (u (Suc a)) (x a) (xa a)"
      {fix n:: nat
        from A have "fst (u n) = 0 \<and> fst (u (Suc n)) = Suc 0"
          by (drule_tac x = n in spec, case_tac "u n", case_tac "u (Suc n)", auto)
      }
      note B = this
      then have "fst (u (Suc 0)) =  0" by auto
      moreover have "fst (u (Suc 0)) =  Suc 0" by (cut_tac n2 = 0 in B, auto)
      ultimately show "(0) < fst (u (0))" by auto
    qed

    show "{. \<lambda>x. \<forall>u. fst (u 0) = 0 \<longrightarrow> prec_st \<top> (\<lambda>(u, v) (u', v') x y. u = 0 \<and> u' = Suc 0 \<and> v = v') u x .} \<circ>
            [: \<lambda> x y . \<exists>u . fst (u 0) = 0 \<and> (\<box> lft_rel_st (\<lambda>(u, v) (u', v') x y. u = 0 \<and> u' = Suc 0 \<and> v = v')) u x y :] =
            \<top>"
      by simp
    qed

  lemma "symbS o symbS' \<noteq> symbSS'"
    by (simp add: symbSS' symbS fun_eq_iff)

  lemma prec_st_inpt: "prec_st (inpt_st r) r = (\<box> (lft_pred_st (inpt_st r)))"
    by (simp add: prec_st_def neg_until_always)

  lemma "grd (SymSystem init p r) = SUPREMUM init (-prec_st p r \<squnion> (\<box> (lft_pred_st (inpt_st r))))"
    proof (unfold fun_eq_iff, auto simp add: grd_def SymSystem_rel demonic_def assert_def)
      fix x :: "nat \<Rightarrow> 'a" and  xa :: "nat \<Rightarrow> 'b" and  u :: "nat \<Rightarrow> 'c"
      assume "\<forall>xa\<Colon>nat \<Rightarrow> 'c\<in>init. prec_st p r xa x \<and> \<not> (\<box> lft_pred_st (inpt_st r)) xa x"
      and "u \<in> init"
      and "(\<box> lft_rel_st r) u x xa"
      then show "False"
        by (auto simp add: always_def lft_pred_st_def inpt_st_def at_fun_def lft_rel_st_def)
    next
      fix x :: "nat \<Rightarrow> 'a" and  xa :: "nat \<Rightarrow> 'c"
      assume B: "xa \<in> init"
      assume "(\<lambda>y . \<exists>u . u \<in> init \<and> (\<box> lft_rel_st r) u x y) \<le> \<bottom>"
      then have A: "\<forall> y u . u \<notin> init \<or> \<not> (\<box> lft_rel_st r) u x y"
        by auto
      let ?y = "\<lambda> n . (SOME z . r (xa n) (xa (Suc n)) (x n) z)"
      from B and A have "\<not> (\<box> lft_rel_st r) xa x ?y" by simp
      moreover assume "(\<box> lft_pred_st (inpt_st r)) xa x"
      ultimately show "False"
        apply (simp add: always_def lft_pred_st_def inpt_st_def at_fun_def lft_rel_st_def)
        by (metis (full_types) tfl_some)
   qed

  definition "guard S = {.((grd S)::'a\<Rightarrow>bool).} o S"

  lemma "((grd (local_init init S))::'a\<Rightarrow>bool) = SUPREMUM init (grd o S)"
    by (simp add: fun_eq_iff local_init_def assert_def grd_def)

  lemma "u \<in> init \<Longrightarrow> guard ([:z \<leadsto> u, x . u \<in> init \<and> z = x:] o {.u, x . p u x.} o [:u, x \<leadsto> y . r u x y :])
      = [:z \<leadsto> u, x . u \<in> init \<and> z = x:] o {.u, x . u \<in> init \<and> (\<exists>a. a \<in> init \<and> (p a x \<longrightarrow> Ex (r a x))) \<and> p u x.} o [:u, x \<leadsto> y . ((r u x y)::bool) :]"
    by (auto simp add: fun_eq_iff local_init_def guard_def grd_def assert_def demonic_def le_fun_def)

  lemma inpt_str_comp_aux: "(\<forall>n. (\<forall>i<n. inpt_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v') (u i) (u (Suc i)) (x i)) \<longrightarrow>
        inpt_st r (fst (u n)) (fst (u (Suc n))) (x n) \<and> (\<forall>y. r (fst (u n)) (fst (u (Suc n))) (x n) y \<longrightarrow> inpt_st r' (snd (u n)) (snd (u (Suc n))) y)) \<longrightarrow>
        (\<forall> i < n . inpt_st r ((fst o u) i) ((fst o u) (Suc i)) (x i) \<and> (\<forall>y. r (fst (u i)) (fst (u (Suc i))) (x i) y \<longrightarrow> inpt_st r' (snd (u i)) (snd (u (Suc i))) y))"
        (is "(\<forall> n . ?p n) \<longrightarrow> ?q n")
    proof (induction n)
      case 0
      show ?case by auto
    next
      case (Suc n)
      show ?case
        proof auto
          fix i::nat
          assume B: "\<forall> n . ?p n"
          then have A: "?p n" (is "?A \<longrightarrow> ?B")
               by simp
          from Suc and B have C: "?q n"
            by simp
          assume "i < Suc n"
          then show "inpt_st r (fst (u i)) (fst (u (Suc i))) (x i)"
            proof cases
              assume "i < n"
              then show ?thesis
                by (metis Suc.IH B comp_apply)
           next
             assume "\<not> i < n"
             from this and `i < Suc n` have [simp]: "i = n" by simp
             show ?thesis
               proof cases
                assume "?A"
                from this and A have D: "?B" by simp
                from D show ?thesis
                  by (metis `i = n`)
              next
                assume "\<not> ?A"
                then obtain j where "j < n \<and> \<not> inpt_st (\<lambda> (u, v) . \<lambda> (u', v') . r u u' OO r' v v') (u j) (u (Suc j)) (x j)"
                  by auto
                moreover from this and C have "inpt_st r (fst (u j)) (fst (u (Suc j))) (x j) \<and> (\<forall>y. r (fst (u j)) (fst (u (Suc j))) (x j) y \<longrightarrow> inpt_st r' (snd (u j)) (snd (u (Suc j))) y)"
                  by auto
                ultimately show ?thesis
                  apply (case_tac "u j")
                  apply (case_tac "u (Suc j)")
                  apply (simp add: inpt_st_def)
                  by (metis relcompp.relcompI)
              qed
         qed
     next
          fix i::nat fix y :: 'e
          assume B: "\<forall> n . ?p n"
          then have A: "?p n" (is "?A \<longrightarrow> ?B")
               by simp
          from Suc and B have C: "\<forall>i<n. inpt_st r (fst (u i)) (fst (u (Suc i))) (x i) \<and> (\<forall>y. r (fst (u i)) (fst (u (Suc i))) (x i) y \<longrightarrow> inpt_st r' (snd (u i)) (snd (u (Suc i))) y)"
            by simp
          assume E: "r (fst (u i)) (fst (u (Suc i))) (x i) y"
          assume "i < Suc n"
          then show "inpt_st r' (snd (u i)) (snd (u (Suc i))) y"
            proof cases
              assume "i < n"
              from this and E and C show ?thesis
                by simp
           next
             assume "\<not> i < n"
             from this and `i < Suc n` have [simp]: "i = n" by simp
             show ?thesis
               proof cases
                assume "?A"
                from this and A have D: "?B" by simp
                from D and E show ?thesis
                  by (metis `i = n`)
              next
                assume "\<not> ?A"
                then obtain j where "j < n \<and> \<not> inpt_st (\<lambda> (u, v) . \<lambda> (u', v') . r u u' OO r' v v') (u j) (u (Suc j)) (x j)"
                  by auto
                moreover from this and C have "inpt_st r (fst (u j)) (fst (u (Suc j))) (x j) \<and> (\<forall>y. r (fst (u j)) (fst (u (Suc j))) (x j) y \<longrightarrow> inpt_st r' (snd (u j)) (snd (u (Suc j))) y)"
                  by auto
                ultimately show ?thesis
                  by (case_tac "u j", case_tac "u (Suc j)", simp add: inpt_st_def, metis relcompp.relcompI)
              qed
         qed
     qed
  qed

  lemma inpt_str_comp_aux_a: "(\<forall>n. (\<forall>i<n. inpt_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v') (u i) (u (Suc i)) (x i)) \<longrightarrow>
        inpt_st r (fst (u n)) (fst (u (Suc n))) (x n) \<and> (\<forall>y. r (fst (u n)) (fst (u (Suc n))) (x n) y \<longrightarrow> inpt_st r' (snd (u n)) (snd (u (Suc n))) y)) \<Longrightarrow>
        inpt_st r ((fst o u) n) ((fst o u) (Suc n)) (x n) \<and> (\<forall>y. r (fst (u n)) (fst (u (Suc n))) (x n) y \<longrightarrow> inpt_st r' (snd (u n)) (snd (u (Suc n))) y)"
    by (cut_tac n = "Suc n" and r = r and r' = r' and u = u and x = x in inpt_str_comp_aux, simp)

  definition "rel_st r r' = (\<lambda> (u, v) (u', v') x z . inpt_st r u u' x \<and> (\<forall> y . r u u' x y \<longrightarrow> inpt_st r' v v' y) \<and> (r u u' OO r' v v') x z)"

  lemma inpt_str_comp_a: "(prec_st (inpt_st r) r (fst \<circ> u) x \<and> (\<forall>y. (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> prec_st (inpt_st r') r' (snd \<circ> u) y)) =
    prec_st (\<lambda> u u' x . inpt_st r (fst u) (fst u') x \<and> (\<forall> y . r (fst u) (fst u') x y \<longrightarrow> (inpt_st r' (snd u) (snd u') y))) (\<lambda>(u, v) (u', v'). r u u' OO r' v v') u x"
    proof (auto simp add: prec_st_inpt prec_st_simp)
      fix n:: nat
      assume "(\<box> lft_pred_st (inpt_st r)) (fst \<circ> u) x"
      then show "inpt_st r (fst (u n)) (fst (u (Suc n))) (x n)"
        by (simp add: always_def lft_pred_st_def at_fun_def)
    next
      fix n:: nat and y :: 'c
      assume A: "(\<box> lft_pred_st (inpt_st r)) (fst \<circ> u) x"
      assume B: "r (fst (u n)) (fst (u (Suc n))) (x n) y"
      assume C: "\<forall>i<n. inpt_st (\<lambda>(u\<Colon>'a, v\<Colon>'d) (u'\<Colon>'a, v'\<Colon>'d). r u u' OO r' v v') (u i) (u (Suc i)) (x i)"
      let ?y = "\<lambda> i . (if i = n then y else (SOME y . r ((fst o u) i) ((fst o u) (Suc i)) (x i) y))"
      assume "\<forall>y . (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> (\<box> lft_pred_st (inpt_st r')) (snd \<circ> u) y"
      then have D: "(\<box> lft_rel_st r) (fst \<circ> u) x ?y \<longrightarrow> (\<box> lft_pred_st (inpt_st r')) (snd \<circ> u) ?y"
        by simp
      from A and B have E: "(\<box> lft_rel_st r) (fst \<circ> u) x ?y"
        apply (auto simp add: always_def at_fun_def lft_rel_st_def lft_pred_st_def inpt_st_def)
        by (metis tfl_some)
      from D and E have "(\<box> lft_pred_st (inpt_st r')) (snd \<circ> u) ?y" by simp

      from A and E and this show "inpt_st r' (snd (u n)) (snd (u (Suc n))) y"
        apply (simp add: always_def lft_pred_st_def at_fun_def)
        apply (drule_tac x = n in spec)
        apply (drule_tac x = n in spec)
        by (drule_tac x = n in spec, simp)
    next
      assume "\<forall> n . (\<forall>i<n. inpt_st (\<lambda>(u\<Colon>'a, v\<Colon>'d) (u'\<Colon>'a, v'\<Colon>'d). r u u' OO r' v v') (u i) (u (Suc i)) (x i)) \<longrightarrow>
            inpt_st r (fst (u n)) (fst (u (Suc n))) (x n) \<and> (\<forall>y\<Colon>'c. r (fst (u n)) (fst (u (Suc n))) (x n) y \<longrightarrow> inpt_st r' (snd (u n)) (snd (u (Suc n))) y)"
      then show "(\<box> lft_pred_st (inpt_st r)) (fst \<circ> u) x"
        apply (auto simp add: always_def lft_pred_st_def at_fun_def)
        apply (drule inpt_str_comp_aux_a)
        by auto
   next
      fix y::"nat \<Rightarrow> 'c"
      assume "\<forall> n . (\<forall>i<n. inpt_st (\<lambda>(u\<Colon>'a, v\<Colon>'d) (u'\<Colon>'a, v'\<Colon>'d). r u u' OO r' v v') (u i) (u (Suc i)) (x i)) \<longrightarrow>
            inpt_st r (fst (u n)) (fst (u (Suc n))) (x n) \<and> (\<forall>y\<Colon>'c. r (fst (u n)) (fst (u (Suc n))) (x n) y \<longrightarrow> inpt_st r' (snd (u n)) (snd (u (Suc n))) y)"
      moreover assume " (\<box> lft_rel_st r) (fst \<circ> u) x y"
      ultimately show "(\<box> lft_pred_st (inpt_st r')) (snd \<circ> u) y"
        apply (auto simp add: always_def lft_pred_st_def at_fun_def)
        apply (drule inpt_str_comp_aux_a)
        by (auto simp add:  lft_rel_st_def)
   qed

  lemma inpt_str_comp_b: "prec_st (\<lambda> u u' x . inpt_st r (fst u) (fst u') x \<and>
    (\<forall> y . r (fst u) (fst u') x y \<longrightarrow> (inpt_st r' (snd u) (snd u') y))) (\<lambda>(u, v) (u', v'). r u u' OO r' v v') u x
    =  (\<box> (lft_pred_st (inpt_st (rel_st r r')))) u x"
    proof (auto simp add: prec_st_simp always_def lft_pred_st_def at_fun_def rel_st_def)
      fix m::nat
      assume A: "\<forall>n . (\<forall>i<n. inpt_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v') (u i) (u (Suc i)) (x i)) \<longrightarrow>
                      inpt_st r (fst (u n)) (fst (u (Suc n))) (x n)
                      \<and> (\<forall>y. r (fst (u n)) (fst (u (Suc n))) (x n) y \<longrightarrow> inpt_st r' (snd (u n)) (snd (u (Suc n))) y)" (is "\<forall> n . ?p n \<longrightarrow> ?q n \<and> ?r n")
      then have "?q m"
        by (drule_tac n = m in inpt_str_comp_aux_a, simp)
      then obtain y where B: "r ((fst \<circ> u) m) ((fst \<circ> u) (Suc m)) (x m) y" by (auto simp add: inpt_st_def)
      from A have "?r m"
        by (drule_tac n = m in inpt_str_comp_aux_a, simp)
      from this B show "inpt_st (\<lambda>(u, v) (u', v') (x\<Colon>'c) z. inpt_st r u u' x \<and> (\<forall>y. r u u' x y
          \<longrightarrow> inpt_st r' v v' y) \<and> (r u u' OO r' v v') x z) (u m) (u (Suc m)) (x m)"
      apply (case_tac "u m")
      apply (case_tac "u (Suc m)")
      apply (simp add: inpt_st_def)
      by (metis relcompp.relcompI)
    next
      fix m::nat
      assume " \<forall> m. inpt_st (\<lambda>(u, v) (u', v') (x) z. inpt_st r u u' x \<and> (\<forall>y. r u u' x y \<longrightarrow> inpt_st r' v v' y)
          \<and> (r u u' OO r' v v') x z) (u m) (u (Suc m)) (x m)" (is "\<forall> m . ?p m")
      then have "?p m" by simp
      then show " inpt_st r (fst (u m)) (fst (u (Suc m))) (x m)"
        apply (simp add: inpt_st_def)
        by (case_tac "u m", case_tac "u (Suc m)", simp)
    next
      fix m::nat and y :: 'e
      assume " \<forall> m. inpt_st (\<lambda>(u, v) (u', v') (x) z. inpt_st r u u' x \<and> (\<forall>y. r u u' x y \<longrightarrow> inpt_st r' v v' y)
          \<and> (r u u' OO r' v v') x z) (u m) (u (Suc m)) (x m)" (is "\<forall> m . ?p m")
      then have "?p m" by simp
      moreover assume "r (fst (u m)) (fst (u (Suc m))) (x m) y"
      ultimately show " inpt_st r' (snd (u m)) (snd (u (Suc m))) y"
        apply (simp add: inpt_st_def)
        by (case_tac "u m", case_tac "u (Suc m)", simp)
    qed

  lemma inpt_str_comp: "(prec_st (inpt_st r) r (fst \<circ> u) x \<and> (\<forall>y. (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> prec_st (inpt_st r') r' (snd \<circ> u) y))
               = (\<box> (lft_pred_st (inpt_st (rel_st r r')))) u x"
    by (simp add: inpt_str_comp_a inpt_str_comp_b)

  lemma RSysTmp_inpt_comp: "u' \<in> init' \<Longrightarrow> SymSystem init (inpt_st r) r o SymSystem init'(inpt_st r') r'
      =  SymSystem (zip_set init init') (inpt_st (rel_st r r')) (rel_st r r')"
    proof -
      assume A : "u' \<in> init'"
      have [simp]: "( \<lambda>x y. (case x of (x, xa) \<Rightarrow> (\<box> lft_pred_st (inpt_st (rel_st r r'))) x xa) \<and>
        (case x of (x, xa) \<Rightarrow> (\<box> lft_rel_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v')) x xa) y)
        =  (\<lambda>(x, y). (\<box> lft_rel_st (rel_st r r')) x y)" (is "?a = ?b")
        proof (auto simp add: fun_eq_iff always_def at_fun_def lft_pred_st_def lft_rel_st_def rel_st_def inpt_st_def)
          fix a :: "nat \<Rightarrow> 'e \<times> 'a" and  b :: "nat \<Rightarrow> 'c" and  x :: "nat \<Rightarrow> 'b" and  xa :: nat
          assume "\<forall>xa\<Colon>nat. (case a xa of (u\<Colon>'e, v\<Colon>'a) \<Rightarrow> \<lambda>(u'\<Colon>'e, v'\<Colon>'a). r u u' OO r' v v') (a (Suc xa)) (b xa) (x xa)" (is "\<forall> xa . ?P xa")
          then have A: "?P xa" by simp
          assume "\<forall>x . Ex ((case a x of (u, v) \<Rightarrow> \<lambda>(u', v') (x) z. Ex (r u u' x) \<and> (\<forall>y. r u u' x y \<longrightarrow> Ex (r' v v' y)) \<and> (r u u' OO r' v v') x z) (a (Suc x)) (b x))" (is "\<forall> xa . ?Q xa")
          then have "?Q xa" by simp
          from this and A show "(case a xa of (u, v) \<Rightarrow> \<lambda>(u', v') (x) z. Ex (r u u' x) \<and> (\<forall>y. r u u' x y \<longrightarrow> Ex (r' v v' y)) \<and> (r u u' OO r' v v') x z) (a (Suc xa)) (b xa) (x xa)"
            by (case_tac "a xa", case_tac "a (Suc xa)", simp)
        next
          fix a :: "nat \<Rightarrow> 'e \<times> 'a" and  b :: "nat \<Rightarrow> 'c" and  x :: "nat \<Rightarrow> 'b" and xa :: nat
          assume "\<forall>xa . (case a xa of (u\<Colon>'e, v\<Colon>'a) \<Rightarrow> \<lambda>(u'\<Colon>'e, v'\<Colon>'a) (x\<Colon>'c) z\<Colon>'b. Ex (r u u' x) \<and> (\<forall>y\<Colon>'d. r u u' x y \<longrightarrow> Ex (r' v v' y)) \<and> (r u u' OO r' v v') x z) (a (Suc xa)) (b xa) (x xa)" (is "\<forall> xa . ?Q xa")
          then have "?Q xa" by simp
          then show "(case a xa of (u\<Colon>'e, v\<Colon>'a) \<Rightarrow> \<lambda>(u'\<Colon>'e, v'\<Colon>'a). r u u' OO r' v v') (a (Suc xa)) (b xa) (x xa)"
          by (case_tac "a xa", case_tac "a (Suc xa)", simp)
        qed

     from A have "SymSystem init (inpt_st r) r o SymSystem init'(inpt_st r') r' = [: z \<leadsto> u, x . fst \<circ> u \<in> init \<and> snd \<circ> u \<in> init' \<and> z = x :] \<circ>
      ({.u, x . prec_st (inpt_st r) r (fst \<circ> u) x \<and> (\<forall>y\<Colon>nat \<Rightarrow> 'd. (\<box> lft_rel_st r) (fst \<circ> u) x y \<longrightarrow> prec_st (inpt_st r') r' (snd \<circ> u) y).} \<circ>
      [:  (\<lambda>(u, x).  ((\<box> lft_rel_st (\<lambda>(u, v) (u', v'). r u u' OO r' v v')) u x)) :])"
      by (unfold SymSystem_comp, simp add: comp_assoc)
      also have "... = [: z \<leadsto> u, x . fst \<circ> u \<in> init \<and> snd \<circ> u \<in> init' \<and> z = x :] \<circ> ({. x, y . (\<box> lft_pred_st (inpt_st (rel_st r r'))) x y .} \<circ> [: ?b :])"
          by (subst assert_demonic, simp add: inpt_str_comp)
      also have "... = SymSystem (zip_set init init') (inpt_st (rel_st r r')) (rel_st r r')"
        by (simp add: SymSystem_def prec_st_inpt comp_assoc zip_set_def)
      finally show ?thesis by simp
    qed

  definition "GrdSymSystem init r = [:z \<leadsto> u, x . u \<in> init \<and> z = x:] o trs (\<lambda> (u, x) y . (\<box>(lft_rel_st r)) u x y)"

  lemma inpt_always: "inpt (\<lambda>(x, y). (\<box> lft_rel_st r) x y) = (\<lambda>(x, y). (\<box> lft_pred_st (inpt_st r)) x y)"
    proof (auto simp add: fun_eq_iff)
    fix a :: "nat \<Rightarrow> 'a" and  b :: "nat \<Rightarrow> 'b"
    assume "inpt (\<lambda>(x, y).(\<box> lft_rel_st r) x y) (a, b)"
    then show "(\<box> lft_pred_st (inpt_st r)) a b"
      by (auto simp add: inpt_def lft_pred_st_def inpt_st_def always_def at_fun_def lft_rel_st_def)
    next
      fix a :: "nat \<Rightarrow> 'a" and  b :: "nat \<Rightarrow> 'b"
      let ?y = "\<lambda> n . (SOME y . r (a n) (a (Suc n)) (b n) y)"
      assume "(\<box> lft_pred_st (inpt_st r)) a b"
      then have "(\<box> lft_rel_st r) a b ?y"
        apply (auto simp add: always_def at_fun_def lft_rel_st_def inpt_st_def lft_pred_st_def)
        by (metis tfl_some)
      then show "inpt (\<lambda>(x, y). (\<box> lft_rel_st r) x y) (a, b)"
        by (auto simp add: inpt_def)
    qed

  lemma "GrdSymSystem init r = SymSystem init (inpt_st r) r"
    by (simp add: GrdSymSystem_def SymSystem_def trs_def  prec_st_inpt comp_assoc inpt_always)

  subsection{*Example: COUNTER*}
  text{*
    In this section we introduce an example counter that counts how many times
    the input variable $x$ is true. The input is a sequence of boolen values
    and the output is a sequence of natural numbers. The output at some moment in
    time is the number of true values seen so far in the input.

    We defined the system counter in two different ways and we show that the
    two definitions are equivalent. The first definition takes the entire
    input sequence and it computes the corresponding output sequence. We introduce
    the second version of the counter as a reactive system based on a symbolic
    transition system. We use a local variable to record the number of true
    values seen so far, and initially the local variable is zero. At every step
    we increase the local variable if the input is true. The output of the
    system at every step is equal to the local variable.
  *}

  primrec count :: "bool trace \<Rightarrow> nat trace" where
    "count x 0 = (if x 0 then 1 else 0)" |
    "count x (Suc n) = (if x (Suc n) then count x n + 1 else count x n)"

  definition "Counter_global n = {.x . (\<forall> k . count x k \<le> n).} o [:x \<leadsto> y . y = count x:]"

  definition "prec_count M u u' x = (u \<le> M)"
  definition "rel_count u u' x y = ((x \<longrightarrow> u' = Suc u) \<and> (\<not> x \<longrightarrow> u' = u) \<and> y = u')"

  lemma counter_a_aux: "u 0 = 0 \<Longrightarrow> \<forall>i < n. (x i \<longrightarrow> u (Suc i) = Suc (u i)) \<and> (\<not> x i \<longrightarrow> u (Suc i) = u i) \<Longrightarrow> (\<forall> i < n . count x i = u (Suc i))"
      proof (induction n)
        case 0
        show ?case by simp
      next
        case (Suc n)
        {fix j::nat
          assume "\<forall>i<Suc n. (x i \<longrightarrow> u (Suc i) = Suc (u i)) \<and> (\<not> x i \<longrightarrow> u (Suc i) = u i)"
          and "j < Suc n"
          and "u (0\<Colon>nat) = (0\<Colon>nat)"
          from this and Suc have "count x j = u (Suc j)"
            by (case_tac j, auto)
        }
        from Suc and this show ?case
          by auto
      qed

  lemma counter_b_aux: "u 0 = 0 \<Longrightarrow> \<forall>n. (xa n \<longrightarrow> u (Suc n) = Suc (u n)) \<and> (\<not> xa n \<longrightarrow> u (Suc n) = u n) \<and> xb n = u (Suc n)
                \<Longrightarrow> count xa n = u (Suc n)"
    by (induction n, simp_all)

  definition "COUNTER M = SymSystem {u . u 0 = 0} (prec_count M) rel_count"

  lemma "COUNTER = Counter_global"
    proof -
      have A:"(\<lambda>x y . \<exists>u\<Colon>nat \<Rightarrow> nat. u (0\<Colon>nat) = (0\<Colon>nat) \<and> (\<box> lft_rel_st rel_count) u x y)
        = (\<lambda> x y . y = count x)"
        proof (simp add: fun_eq_iff lft_rel_st_def rel_count_def always_def at_fun_def, safe)
          fix x :: "nat \<Rightarrow> bool" and  xa :: "nat \<Rightarrow> nat" and u:: "nat \<Rightarrow> nat" and xb :: nat
          assume A: "u 0 = 0"
          assume B: "\<forall>xb . (x xb \<longrightarrow> u (Suc xb) = Suc (u xb)) \<and> (\<not> x xb \<longrightarrow> u (Suc xb) = u xb) \<and> xa xb = u (Suc xb)"
          from A and this have "count x xb = xa xb"
             by (drule_tac counter_b_aux, auto)
          then show "xa xb = count x xb" by simp
        next
          fix x::"nat \<Rightarrow> bool" and xa::"nat \<Rightarrow> nat"
          def A: u == "\<lambda> i . if i = 0 then 0 else count x (i - 1)"
          assume B: "\<forall>xb\<Colon>nat. xa xb = count x xb"
          {fix xb::nat
          from A and B have "u 0 = 0 \<and> ( (x xb \<longrightarrow> u (Suc xb) = Suc (u xb)) \<and> (\<not> x xb \<longrightarrow> u (Suc xb) = u xb) \<and> xa xb = u (Suc xb))"
            by (case_tac xb, auto)
          }
          then show "\<exists>u\<Colon>nat \<Rightarrow> nat. u 0 = 0 \<and> (\<forall>xb. (x xb \<longrightarrow> u (Suc xb) = Suc (u xb)) \<and> (\<not> x xb \<longrightarrow> u (Suc xb) = u xb) \<and>
              xa xb = u (Suc xb))"
          by auto
       qed
      {fix x :: nat
        have "(\<lambda>xa . \<forall>u . u (0\<Colon>nat) = (0\<Colon>nat) \<longrightarrow> prec_st (prec_count x) rel_count u xa) =
          (\<lambda>xa\<Colon>nat \<Rightarrow> bool. \<forall>k\<Colon>nat. count xa k \<le> x)"
        proof (simp add: fun_eq_iff lft_rel_st_def  prec_st_def until_def
            lft_pred_st_def prec_count_def at_fun_def inpt_st_def rel_count_def, safe)
          fix xa::"nat \<Rightarrow> bool" and k:: nat
          def A: uu == "\<lambda> i . if i = 0 then 0 else count xa (i - 1)"
          assume "(\<forall>u . u 0 = 0 \<longrightarrow> (\<forall>xb . (\<exists>x<xb. xa x \<and> u (Suc x) \<noteq> Suc (u x) \<or> \<not> xa x \<and> u (Suc x) \<noteq> u x) \<or> u xb \<le> x))" (is "\<forall> u . ?s u")
          then have "?s uu" (is "?p \<longrightarrow> (\<forall>xb . (\<exists> x < xb . ?q xb x) \<or> ?r xb)")
            by auto
          from this and A  have "(\<forall>xb . (\<exists> x < xb . ?q xb x) \<or> ?r xb)"
            by simp
          then have "(\<exists> x < (Suc k) . ?q (Suc k) x) \<or> ?r (Suc k)"
            by simp
          then obtain xb where "xb < (Suc k) \<and> (?q (Suc k) xb \<or> ?r (Suc k))"
            by auto
          from this and A show "count xa k \<le> x"
             by (case_tac xb, auto)
        next
          fix xa:: "nat \<Rightarrow> bool" and  u::"nat \<Rightarrow> nat" and xaa::nat
          assume C: "\<forall>k\<Colon>nat. count xa k \<le> x"
          assume A: "u (0\<Colon>nat) = (0\<Colon>nat)"
          assume B: "\<not> u xaa \<le> x"
          from A and B have D: "xaa > 0"
            by (metis le0 neq0_conv)
          from this and B and C have "count xa (xaa - 1) \<noteq> u xaa"
            by metis
          from this and D have E: "\<exists>i < xaa. count xa i \<noteq> u (Suc i)"
            by (metis One_nat_def Suc_diff_1 diff_Suc_less)
          have "u 0 = 0 \<Longrightarrow> \<forall>i<xaa. (xa i \<longrightarrow> u (Suc i) = Suc (u i)) \<and> (\<not> xa i \<longrightarrow> u (Suc i) = u i) \<Longrightarrow> \<forall>i<xaa. count xa i = u (Suc i)"
            by (rule counter_a_aux, simp)
          from this and A and E show "(\<exists>x<xaa. xa x \<and> u (Suc x) \<noteq> Suc (u x) \<or> \<not> xa x \<and> u (Suc x) \<noteq> u x)"
            by auto
        qed
        }
      note B = this
     show ?thesis
      by (simp add: fun_eq_iff COUNTER_def SymSystem_rel Counter_global_def A B)

   qed

  subsection{*Example: LIVE*}

  text{*
    The last example of this formalization introduces a system which does some
    local computation, and ensures some global liveness property.
    We show that this example is the fusion of a symbolic transition system and a demonic
    choice which ensures the liveness property of the output sequence.
    We also show that asumming some liveness property for the input, we can refine
    the example into an executable system that does not ensure the liveness
    property of the output on its own, but relies on the liveness of the input.
  *}

  definition "rel_ex u u' x y = (((x \<and> u' = u + (1::int)) \<or> (\<not> x \<and> u' = u - 1) \<or> u' = 0) \<and> (y = (u' = 0)))"
  definition "prec_ex u u' x = (-1 \<le> u \<and> u \<le> 3)"

  definition "LIVE = [:x \<leadsto> u, x' . u (0::nat) = 0 \<and> x = x':] o {.u, x . prec_st prec_ex rel_ex u x.}
    o [:u, x \<leadsto> y . (\<box>(\<lambda> u x y . rel_ex (u 0) (u 1) (x 0) (y 0))) u x y  \<and> (\<box> (\<diamondsuit> (\<lambda> y . y 0))) y :]"

thm fusion_spec_local_a

  lemma LIVE_fusion: "LIVE = (SymSystem {u . u 0 = 0} prec_ex rel_ex) \<parallel> [:x \<leadsto> y . (\<box> (\<diamondsuit> (\<lambda> y . y 0))) y:]"
    proof -
      def B: init == "{u . u (0::nat) = (0::int)}"
      then have A: "(\<lambda> i::nat . 0::int) \<in> init"
        by simp
      then have "([: x \<leadsto> (u, y). u \<in> init \<and> x = y :] \<circ> {.(x, y). prec_st prec_ex rel_ex x y .} \<circ> [: \<lambda>(x, y). (\<box> lft_rel_st rel_ex) x y :]) \<parallel>
          [: \<lambda>x. \<box> \<diamondsuit> (\<lambda>y. y 0) :] =
          [: x \<leadsto> (u, y). u \<in> init \<and> x = y :] \<circ> {. (x, y). prec_st prec_ex rel_ex x y .} \<circ>
          [: (u, x) \<leadsto> y. (\<box> lft_rel_st rel_ex) u x y \<and> (\<box> \<diamondsuit> (\<lambda>y. y 0)) y :]"
        by (unfold fusion_spec_local_a, auto)
      from B and this show ?thesis
        apply (simp add: SymSystem_def)
        by (auto simp add: LIVE_def lft_rel_st_def always_def at_fun_def)
   qed

  definition "preca_ex x = (x 1 = (\<not>x 0))"

  lemma monotonic_SymSystem[simp]: "mono (SymSystem init p r)"
    by (simp add: SymSystem_def)

  lemma event_ex_aux_a: "a 0 = (0::int) \<Longrightarrow> \<forall>n. xa (Suc n) = (\<not> xa n) \<Longrightarrow>
        \<forall>n. (xa n \<and> a (Suc n) = a n + 1 \<or> \<not> xa n \<and> a (Suc n) = a n - 1 \<or> a (Suc n) = 0) \<Longrightarrow>
        (a n = -1 \<longrightarrow> xa n) \<and> (a n = 1 \<longrightarrow> \<not> xa n) \<and> -1 \<le> a n \<and> a n \<le> 1"
    proof (induction n)
      case 0
      show ?case
        by (metis "0.prems"(1) le_minus_one_simps(1) minus_zero zero_le_one zero_neq_neg_one)
    next
      case (Suc n)
      {assume "a (Suc n) = - (1\<Colon>int)" from this and Suc have "xa (Suc n)"
        by (metis add.commute add_le_same_cancel2 not_one_le_zero zero_neq_neg_one)}
      note A = this
      {assume "a (Suc n) = (1\<Colon>int)" and "xa (Suc n)" from this and Suc have "False"
        by (metis eq_iff le_iff_diff_le_0 not_one_le_zero)}
      note B = this
      {assume "a n \<noteq> - (1\<Colon>int)" from this and Suc have " - (1\<Colon>int) \<le> a (Suc n)"
         by (metis add.commute comm_monoid_add_class.add.left_neutral le_less not_le right_minus uminus_add_conv_diff zle_add1_eq_le)}
      note C = this
      {assume "a n = - (1\<Colon>int)" from this and Suc have " - (1\<Colon>int) \<le> a (Suc n)"
        by (metis add.commute le_minus_one_simps(4) monoid_add_class.add.right_neutral not_le right_minus zle_add1_eq_le)}
      note D = this
      from C and D and Suc have  E: " - (1\<Colon>int) \<le> a (Suc n)" by auto
      from Suc have F: "a (Suc n) \<le> (1\<Colon>int)"
        by (metis eq_iff int_one_le_iff_zero_less le_iff_diff_le_0 le_less not_le zle_add1_eq_le)
      from A B E F show ?case by auto
    qed

  lemma event_ex_aux: "a 0 = (0::int) \<Longrightarrow> \<forall>n. xa (Suc n) = (\<not> xa n) \<Longrightarrow>
         \<forall>n. (xa n \<and> a (Suc n) = a n + 1 \<or> \<not> xa n \<and> a (Suc n) = a n - 1 \<or> a (Suc n) = 0) \<Longrightarrow>
        (\<forall> n . (a n = -1 \<longrightarrow> xa n) \<and> (a n = 1 \<longrightarrow> \<not> xa n) \<and> -1 \<le> a n \<and> a n \<le> 1)"
    by (clarify, drule event_ex_aux_a, auto)

  lemma "{.\<box> preca_ex.} o LIVE \<le> SymSystem {u . u 0 = 0} prec_ex rel_ex"
    proof (unfold LIVE_fusion SymSystem_def, rule fusion_local_refinement, simp_all)
      fix z::"nat \<Rightarrow> bool" and u :: "nat \<Rightarrow> int" and x::"nat \<Rightarrow> bool"
      assume A: "u 0 = 0"
      assume "(\<box> preca_ex) z"
      then have B: "\<forall>x\<Colon>nat. z (Suc x) = (\<not> z x)"
        by (auto simp add: preca_ex_def lft_rel_st_def rel_ex_def always_def at_fun_def)
      assume "(\<box> lft_rel_st rel_ex) u z x"
      then have C: "\<forall>xa . (z xa \<and> u (Suc xa) = u xa + 1 \<or> \<not> z xa \<and> u (Suc xa) = u xa - 1 \<or> u (Suc xa) = 0) \<and> x xa = (u (Suc xa) = 0)"
        by (auto simp add: preca_ex_def lft_rel_st_def rel_ex_def always_def at_fun_def)
      have D: "(\<forall> n . (u n = -1 \<longrightarrow> z n) \<and> (u n = 1 \<longrightarrow> \<not> z n) \<and> -1 \<le> u n \<and> u n \<le> 1)"
        by (cut_tac A B C, rule event_ex_aux, auto)
      {
          fix a::nat
          {assume "u (Suc a) = 0" from this A B C have "\<exists>b . u (Suc (a + b)) = 0"
            by (metis monoid_add_class.add.right_neutral)}
          note 1 = this
          {assume "u (Suc a) = -1" from this A B C D have "\<exists>b . u (Suc (a + b)) = 0"
            by (metis add_Suc_right diff_minus_eq_add diff_self monoid_add_class.add.right_neutral)}
          note 2 = this
          {assume "u (Suc a) = 1" from this A B C D have "\<exists>b . u (Suc (a + b)) = 0"
            by (metis add_Suc_right diff_self monoid_add_class.add.right_neutral)}
          note 3 = this
          from 1 2 3 A B C D have "\<exists>b . x (a + b)"
            by (simp, metis diff_0 int_one_le_iff_zero_less le_less not_le zle_diff1_eq)
      }
      then show "(\<box> \<diamondsuit> (\<lambda>y . y 0)) x"
        by (simp add: always_def eventually_def preca_ex_def at_fun_def rel_ex_def lft_rel_st_def)
   qed
  end


(*  Title:      ZF/UNITY/State.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Formalizes UNITY-program states using dependent types so that:
 - variables are typed.
 - the state space is uniform, common to all defined programs.
 - variables can be quantified over.
*)

section\<open>UNITY Program States\<close>

theory State imports ZF begin

consts var :: i
datatype var = Var("i \<in> list(nat)")
  type_intros  nat_subset_univ [THEN list_subset_univ, THEN subsetD]

consts
  type_of :: "i=>i"
  default_val :: "i=>i"

definition
  "state == \<Prod>x \<in> var. cons(default_val(x), type_of(x))"

definition
  "st0 == \<lambda>x \<in> var. default_val(x)"

definition
  st_set  :: "i=>o"  where
(* To prevent typing conditions like `A<=state' from
   being used in combination with the rules `constrains_weaken', etc. *)
  "st_set(A) == A<=state"

definition
  st_compl :: "i=>i"  where
  "st_compl(A) == state-A"

lemma st0_in_state [simp,TC]: "st0 \<in> state"
by (simp add: state_def st0_def)

lemma st_set_Collect [iff]: "st_set({x \<in> state. P(x)})"
by (simp add: st_set_def, auto)

lemma st_set_0 [iff]: "st_set(0)"
by (simp add: st_set_def)

lemma st_set_state [iff]: "st_set(state)"
by (simp add: st_set_def)

(* Union *)

lemma st_set_Un_iff [iff]: "st_set(A \<union> B) \<longleftrightarrow> st_set(A) & st_set(B)"
by (simp add: st_set_def, auto)

lemma st_set_Union_iff [iff]: "st_set(\<Union>(S)) \<longleftrightarrow> (\<forall>A \<in> S. st_set(A))"
by (simp add: st_set_def, auto)

(* Intersection *)

lemma st_set_Int [intro!]: "st_set(A) | st_set(B) ==> st_set(A \<inter> B)"
by (simp add: st_set_def, auto)

lemma st_set_Inter [intro!]:
   "(S=0) | (\<exists>A \<in> S. st_set(A)) ==> st_set(\<Inter>(S))"
apply (simp add: st_set_def Inter_def, auto)
done

(* Diff *)
lemma st_set_DiffI [intro!]: "st_set(A) ==> st_set(A - B)"
by (simp add: st_set_def, auto)

lemma Collect_Int_state [simp]: "Collect(state,P) \<inter> state = Collect(state,P)"
by auto

lemma state_Int_Collect [simp]: "state \<inter> Collect(state,P) = Collect(state,P)"
by auto

(* Introduction and destruction rules for st_set *)

lemma st_setI: "A \<subseteq> state ==> st_set(A)"
by (simp add: st_set_def)

lemma st_setD: "st_set(A) ==> A<=state"
by (simp add: st_set_def)

lemma st_set_subset: "[| st_set(A); B<=A |] ==> st_set(B)"
by (simp add: st_set_def, auto)

lemma state_update_type:
     "[| s \<in> state; x \<in> var; y \<in> type_of(x) |] ==> s(x:=y):state"
apply (simp add: state_def)
apply (blast intro: update_type)
done

lemma st_set_compl [simp]: "st_set(st_compl(A))"
by (simp add: st_compl_def, auto)

lemma st_compl_iff [simp]: "x \<in> st_compl(A) \<longleftrightarrow> x \<in> state & x \<notin> A"
by (simp add: st_compl_def)

lemma st_compl_Collect [simp]:
     "st_compl({s \<in> state. P(s)}) = {s \<in> state. ~P(s)}"
by (simp add: st_compl_def, auto)

(*For using "disjunction" (union over an index set) to eliminate a variable.*)
lemma UN_conj_eq:
     "\<forall>d\<in>D. f(d) \<in> A ==> (\<Union>k\<in>A. {d\<in>D. P(d) & f(d) = k}) = {d\<in>D. P(d)}"
by blast

end


(*  Title:      ZF/UNITY/State.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Formalizes UNITY-program states using dependent types so that:
 - variables are typed.
 - the state space is uniform, common to all defined programs.
 - variables can be quantified over.
*)

section\<open>UNITY Program States\<close>

theory State imports Main begin

consts var :: i
datatype var = Var("i \<in> list(nat)")
  type_intros  nat_subset_univ [THEN list_subset_univ, THEN subsetD]

consts
  type_of :: "i=>i"
  default_val :: "i=>i"

definition
  "state == \<Prod>x \<in> var. cons(default_val(x), type_of(x))"

definition
  "st0 == \<lambda>x \<in> var. default_val(x)"

definition
  st_set  :: "i=>o"  where
(* To prevent typing conditions like `A<=state' from
   being used in combination with the rules `constrains_weaken', etc. *)
  "st_set(A) == A<=state"

definition
  st_compl :: "i=>i"  where
  "st_compl(A) == state-A"

lemma st0_in_state [simp,TC]: "st0 \<in> state"
by (simp add: state_def st0_def)

lemma st_set_Collect [iff]: "st_set({x \<in> state. P(x)})"
by (simp add: st_set_def, auto)

lemma st_set_0 [iff]: "st_set(0)"
by (simp add: st_set_def)

lemma st_set_state [iff]: "st_set(state)"
by (simp add: st_set_def)

(* Union *)

lemma st_set_Un_iff [iff]: "st_set(A \<union> B) \<longleftrightarrow> st_set(A) & st_set(B)"
by (simp add: st_set_def, auto)

lemma st_set_Union_iff [iff]: "st_set(\<Union>(S)) \<longleftrightarrow> (\<forall>A \<in> S. st_set(A))"
by (simp add: st_set_def, auto)

(* Intersection *)

lemma st_set_Int [intro!]: "st_set(A) | st_set(B) ==> st_set(A \<inter> B)"
by (simp add: st_set_def, auto)

lemma st_set_Inter [intro!]:
   "(S=0) | (\<exists>A \<in> S. st_set(A)) ==> st_set(\<Inter>(S))"
apply (simp add: st_set_def Inter_def, auto)
done

(* Diff *)
lemma st_set_DiffI [intro!]: "st_set(A) ==> st_set(A - B)"
by (simp add: st_set_def, auto)

lemma Collect_Int_state [simp]: "Collect(state,P) \<inter> state = Collect(state,P)"
by auto

lemma state_Int_Collect [simp]: "state \<inter> Collect(state,P) = Collect(state,P)"
by auto

(* Introduction and destruction rules for st_set *)

lemma st_setI: "A \<subseteq> state ==> st_set(A)"
by (simp add: st_set_def)

lemma st_setD: "st_set(A) ==> A<=state"
by (simp add: st_set_def)

lemma st_set_subset: "[| st_set(A); B<=A |] ==> st_set(B)"
by (simp add: st_set_def, auto)

lemma state_update_type:
     "[| s \<in> state; x \<in> var; y \<in> type_of(x) |] ==> s(x:=y):state"
apply (simp add: state_def)
apply (blast intro: update_type)
done

lemma st_set_compl [simp]: "st_set(st_compl(A))"
by (simp add: st_compl_def, auto)

lemma st_compl_iff [simp]: "x \<in> st_compl(A) \<longleftrightarrow> x \<in> state & x \<notin> A"
by (simp add: st_compl_def)

lemma st_compl_Collect [simp]:
     "st_compl({s \<in> state. P(s)}) = {s \<in> state. ~P(s)}"
by (simp add: st_compl_def, auto)

(*For using "disjunction" (union over an index set) to eliminate a variable.*)
lemma UN_conj_eq:
     "\<forall>d\<in>D. f(d) \<in> A ==> (\<Union>k\<in>A. {d\<in>D. P(d) & f(d) = k}) = {d\<in>D. P(d)}"
by blast

end


theory Hotel_Example
imports MainRLT
begin

datatype guest = Guest0 | Guest1
datatype key = Key0 | Key1 | Key2 | Key3
datatype room = Room0

type_synonym card = "key * key"

datatype event =
   Check_in guest room card | Enter guest room card | Exit guest room

definition initk :: "room \<Rightarrow> key"
  where "initk = (%r. Key0)"

declare initk_def[code_pred_def, code]

primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option"
where
  "owns [] r = None"
| "owns (e#s) r = (case e of
    Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
    Enter g r' c \<Rightarrow> owns s r |
    Exit g r' \<Rightarrow> owns s r)"

primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "currk [] r = initk r"
| "currk (e#s) r = (let k = currk s r in
    case e of Check_in g r' (k1, k2) \<Rightarrow> if r' = r then k2 else k
            | Enter g r' c \<Rightarrow> k
            | Exit g r \<Rightarrow> k)"

primrec issued :: "event list \<Rightarrow> key set"
where
  "issued [] = range initk"
| "issued (e#s) = issued s \<union>
  (case e of Check_in g r (k1, k2) \<Rightarrow> {k2} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"

primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set"
where
  "cards [] g = {}"
| "cards (e#s) g = (let C = cards s g in
                    case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
                                                else C
                            | Enter g r c \<Rightarrow> C
                            | Exit g r \<Rightarrow> C)"

primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "roomk [] r = initk r"
| "roomk (e#s) r = (let k = roomk s r in
    case e of Check_in g r' c \<Rightarrow> k
            | Enter g r' (x,y) \<Rightarrow> if r' = r \<^cancel>\<open>\<and> x = k\<close> then y else k
            | Exit g r \<Rightarrow> k)"

primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set"
where
  "isin [] r = {}"
| "isin (e#s) r = (let G = isin s r in
                 case e of Check_in g r c \<Rightarrow> G
                 | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
                 | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"

primrec hotel :: "event list \<Rightarrow> bool"
where
  "hotel []  = True"
| "hotel (e # s) = (hotel s \<and> (case e of
  Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
  Enter g r (k,k') \<Rightarrow> (k,k') \<in> cards s g \<and> (roomk s r \<in> {k, k'}) |
  Exit g r \<Rightarrow> g \<in> isin s r))"

definition no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
[code del]: "no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"

definition feels_safe :: "event list \<Rightarrow> room \<Rightarrow> bool"
where
  "feels_safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
   s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 \<and>
   no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"

section \<open>Some setup\<close>

lemma issued_nil: "issued [] = {Key0}"
by (auto simp add: initk_def)

lemmas issued_simps[code, code_pred_def] = issued_nil issued.simps(2)

end


theory Equivalence_Implies_Bisimilarity
imports
  Logical_Equivalence
begin

section \<open>Logical Equivalence Implies Bisimilarity\<close>

context indexed_nominal_ts
begin

  definition is_distinguishing_formula :: "('idx, 'pred, 'act) formula \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> bool"
    ("_ distinguishes _ from _" [100,100,100] 100)
  where
    "x distinguishes P from Q \<equiv> P \<Turnstile> x \<and> \<not> Q \<Turnstile> x"

  lemma is_distinguishing_formula_eqvt (*[eqvt]*):
    assumes "x distinguishes P from Q" shows "(p \<bullet> x) distinguishes (p \<bullet> P) from (p \<bullet> Q)"
  using assms unfolding is_distinguishing_formula_def
  by (metis permute_minus_cancel(2) valid_eqvt)

  text \<open>There exists a distinguishing formula for~@{term P} and~@{term Q} whose support is contained
  in~@{term "supp P"}.\<close>

  lemma distinguished_bounded_support:
    assumes "x distinguishes P from Q"
    obtains y where "supp y \<subseteq> supp P" and "y distinguishes P from Q"
  proof -
    let ?B = "{p \<bullet> x|p. supp P \<sharp>* p}"
    have "supp P supports ?B"
    unfolding supports_def proof (clarify)
      fix a b
      assume a: "a \<notin> supp P" and b: "b \<notin> supp P"
      have "(a \<rightleftharpoons> b) \<bullet> ?B \<subseteq> ?B"
      proof
        fix x'
        assume "x' \<in> (a \<rightleftharpoons> b) \<bullet> ?B"
        then obtain p where 1: "x' = (a \<rightleftharpoons> b) \<bullet> p \<bullet> x" and 2: "supp P \<sharp>* p"
          by (auto simp add: permute_set_def)
        let ?q = "(a \<rightleftharpoons> b) + p"
        from 1 have "x' = ?q \<bullet> x"
          by simp
        moreover from a and b and 2 have "supp P \<sharp>* ?q"
          by (metis fresh_perm fresh_star_def fresh_star_plus swap_atom_simps(3))
        ultimately show "x' \<in> ?B" by blast
      qed
      moreover have "?B \<subseteq> (a \<rightleftharpoons> b) \<bullet> ?B"
      proof
        fix x'
        assume "x' \<in> ?B"
        then obtain p where 1: "x' = p \<bullet> x" and 2: "supp P \<sharp>* p"
          by auto
        let ?q = "(a \<rightleftharpoons> b) + p"
        from 1 have "x' = (a \<rightleftharpoons> b) \<bullet> ?q \<bullet> x"
          by simp
        moreover from a and b and 2 have "supp P \<sharp>* ?q"
          by (metis fresh_perm fresh_star_def fresh_star_plus swap_atom_simps(3))
        ultimately show "x' \<in> (a \<rightleftharpoons> b) \<bullet> ?B"
          using mem_permute_iff by blast
      qed
      ultimately show "(a \<rightleftharpoons> b) \<bullet> ?B = ?B" ..
    qed
    then have supp_B_subset_supp_P: "supp ?B \<subseteq> supp P"
      by (metis (erased, lifting) finite_supp supp_is_subset)
    then have finite_supp_B: "finite (supp ?B)"
      using finite_supp rev_finite_subset by blast
    have "?B \<subseteq> (\<lambda>p. p \<bullet> x) ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: perm set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: perm set| <o |UNIV :: 'idx set|"
      by (metis card_idx_perm)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally have card_B: "|?B| <o natLeq +c |UNIV :: 'idx set|" .
    let ?y = "Conj (Abs_bset ?B) :: ('idx, 'pred, 'act) formula"
    from finite_supp_B and card_B and supp_B_subset_supp_P have "supp ?y \<subseteq> supp P"
      by simp
    moreover have "?y distinguishes P from Q"
      unfolding is_distinguishing_formula_def proof
        from assms show "P \<Turnstile> ?y"
          by (auto simp add: card_B finite_supp_B) (metis is_distinguishing_formula_def supp_perm_eq valid_eqvt)
      next
        from assms show "\<not> Q \<Turnstile> ?y"
          by (auto simp add: card_B finite_supp_B) (metis is_distinguishing_formula_def permute_zero fresh_star_zero)
      qed
    ultimately show ?thesis ..
  qed

  lemma equivalence_is_bisimulation: "is_bisimulation logically_equivalent"
  proof -
    have "symp logically_equivalent"
      by (metis logically_equivalent_def sympI)
    moreover
    {
      fix P Q \<phi> assume "P =\<cdot> Q" then have "P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>"
        by (metis logically_equivalent_def valid_Pred)
    }
    moreover
    {
      fix P Q \<alpha> P' assume "P =\<cdot> Q" and "bn \<alpha> \<sharp>* Q" and "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
      then have "\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> P' =\<cdot> Q'"
        proof -
          {
            let ?Q' = "{Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>}"
            assume "\<forall>Q'\<in>?Q'. \<not> P' =\<cdot> Q'"
            then have "\<forall>Q'\<in>?Q'. \<exists>x :: ('idx, 'pred, 'act) formula. x distinguishes P' from Q'"
              by (metis equivalent_iff_not_distinguished)
            then have "\<forall>Q'\<in>?Q'. \<exists>x :: ('idx, 'pred, 'act) formula. supp x \<subseteq> supp P' \<and> x distinguishes P' from Q'"
              by (metis distinguished_bounded_support)
            then obtain f :: "'state \<Rightarrow> ('idx, 'pred, 'act) formula" where
              *: "\<forall>Q'\<in>?Q'. supp (f Q') \<subseteq> supp P' \<and> (f Q') distinguishes P' from Q'"
              by metis
            have "supp (f ` ?Q') \<subseteq> supp P'"
              by (rule set_bounded_supp, fact finite_supp, cut_tac "*", blast)
            then have finite_supp_image: "finite (supp (f ` ?Q'))"
              using finite_supp rev_finite_subset by blast
            have "|f ` ?Q'| \<le>o |UNIV :: 'state set|"
              by (metis card_of_UNIV card_of_image ordLeq_transitive)
            also have "|UNIV :: 'state set| <o |UNIV :: 'idx set|"
              by (metis card_idx_state)
            also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
              by (metis Cnotzero_UNIV ordLeq_csum2)
            finally have card_image: "|f ` ?Q'| <o natLeq +c |UNIV :: 'idx set|" .
            let ?y = "Conj (Abs_bset (f ` ?Q')) :: ('idx, 'pred, 'act) formula"
            have "P \<Turnstile> Act \<alpha> ?y"
              unfolding valid_Act proof (standard+)
                show "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>" by fact
              next
                {
                  fix Q'
                  assume "Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>"
                  with "*" have "P' \<Turnstile> f Q'"
                    by (metis is_distinguishing_formula_def mem_Collect_eq)
                }
                then show "P' \<Turnstile> ?y"
                  by (simp add: finite_supp_image card_image)
              qed
            moreover have "\<not> Q \<Turnstile> Act \<alpha> ?y"
              proof
                assume "Q \<Turnstile> Act \<alpha> ?y"
                then obtain Q' where 1: "Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>" and 2: "Q' \<Turnstile> ?y"
                  using \<open>bn \<alpha> \<sharp>* Q\<close> by (metis valid_Act_fresh)
                from 2 have "\<And>Q''. Q \<rightarrow> \<langle>\<alpha>,Q''\<rangle> \<longrightarrow> Q' \<Turnstile> f Q''"
                  by (simp add: finite_supp_image card_image)
                with 1 and "*" show False
                  using is_distinguishing_formula_def by blast
              qed
            ultimately have False
              by (metis \<open>P =\<cdot> Q\<close> logically_equivalent_def)
          }
          then show ?thesis by auto
        qed
    }
    ultimately show ?thesis
      unfolding is_bisimulation_def by metis
  qed

  theorem equivalence_implies_bisimilarity: assumes "P =\<cdot> Q" shows "P \<sim>\<cdot> Q"
  using assms by (metis bisimilar_def equivalence_is_bisimulation)

end

end


(* Author: Tobias Nipkow *)

subsection "Verification Condition Generation"

theory VCG imports Hoare begin

subsubsection "Annotated Commands"

text\<open>Commands where loops are annotated with invariants.\<close>

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

text\<open>Strip annotations:\<close>

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

subsubsection "Weeakest Precondistion and Verification Condition"

text\<open>Weakest precondition:\<close>

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I} WHILE b DO C) Q = I"

text\<open>Verification condition:\<close>

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =
  ((\<forall>s. (I s \<and> bval b s \<longrightarrow> pre C I s) \<and>
        (I s \<and> \<not> bval b s \<longrightarrow> Q s)) \<and>
    vc C I)"

subsubsection "Soundness"

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile> {pre C Q} strip C {Q}"
proof(induction C arbitrary: Q)
  case (Awhile I b C)
  show ?case
  proof(simp, rule While')
    from \<open>vc (Awhile I b C) Q\<close>
    have vc: "vc C I" and IQ: "\<forall>s. I s \<and> \<not> bval b s \<longrightarrow> Q s" and
         pre: "\<forall>s. I s \<and> bval b s \<longrightarrow> pre C I s" by simp_all
    have "\<turnstile> {pre C I} strip C {I}" by(rule Awhile.IH[OF vc])
    with pre show "\<turnstile> {\<lambda>s. I s \<and> bval b s} strip C {I}"
      by(rule strengthen_pre)
    show "\<forall>s. I s \<and> \<not>bval b s \<longrightarrow> Q s" by(rule IQ)
  qed
qed (auto intro: hoare.conseq)

corollary vc_sound':
  "\<lbrakk> vc C Q; \<forall>s. P s \<longrightarrow> pre C Q s \<rbrakk> \<Longrightarrow> \<turnstile> {P} strip C {Q}"
by (metis strengthen_pre vc_sound)

subsubsection "Completeness"

lemma pre_mono:
  "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> pre C P s \<Longrightarrow> pre C P' s"
proof (induction C arbitrary: P P' s)
  case Aseq thus ?case by simp metis
qed simp_all

lemma vc_mono:
  "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> vc C P \<Longrightarrow> vc C P'"
proof(induction C arbitrary: P P')
  case Aseq thus ?case by simp (metis pre_mono)
qed simp_all

lemma vc_complete:
 "\<turnstile> {P}c{Q} \<Longrightarrow> \<exists>C. strip C = c \<and> vc C Q \<and> (\<forall>s. P s \<longrightarrow> pre C Q s)"
  (is "_ \<Longrightarrow> \<exists>C. ?G P c Q C")
proof (induction rule: hoare.induct)
  case Skip
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by simp qed
next
  case (Assign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" by simp qed
next
  case (Seq P c1 Q c2 R)
  from Seq.IH obtain C1 where ih1: "?G P c1 Q C1" by blast
  from Seq.IH obtain C2 where ih2: "?G Q c2 R C2" by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aseq C1 C2)"
      using ih1 ih2 by (fastforce elim!: pre_mono vc_mono)
  qed
next
  case (If P b c1 Q c2)
  from If.IH obtain C1 where ih1: "?G (\<lambda>s. P s \<and> bval b s) c1 Q C1"
    by blast
  from If.IH obtain C2 where ih2: "?G (\<lambda>s. P s \<and> \<not>bval b s) c2 Q C2"
    by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aif b C1 C2)" using ih1 ih2 by simp
  qed
next
  case (While P b c)
  from While.IH obtain C where ih: "?G (\<lambda>s. P s \<and> bval b s) c P C" by blast
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Awhile P b C)" using ih by simp qed
next
  case conseq thus ?case by(fast elim!: pre_mono vc_mono)
qed

end


theory weird_nat_mul3_rot
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S y2) z = S (add3 Z y2 z)"
| "add3 (S x2) y z = S (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
"mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3 (S (Z)) (S (Z)) (S (S x5)) =
     S (add3
          (mul3 Z Z (S x5))
          (add3 (mul3 (S Z) Z (S x5)) (mul3 Z (S Z) (S x5)) (mul3 Z Z (S Z)))
          (add3 Z Z (S x5)))"
| "mul3 (S (Z)) (S (S x6)) (S x4) =
     S (add3
          (mul3 Z (S x6) x4)
          (add3
             (mul3 (S Z) (S x6) x4) (mul3 Z (S Z) x4) (mul3 Z (S x6) (S Z)))
          (add3 Z (S x6) x4))"
| "mul3 (S (S x7)) (S x3) (S x4) =
     S (add3
          (mul3 (S x7) x3 x4)
          (add3
             (mul3 (S Z) x3 x4) (mul3 (S x7) (S Z) x4) (mul3 (S x7) x3 (S Z)))
          (add3 (S x7) x3 x4))"

(*hipster add3 mul3 *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) . (mul3 x y z) = (mul3 y x z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end