header{* Some Classes of Pseudo-Hoops *}

theory SpecialPseudoHoops
imports PseudoHoopFilters PseudoWaisbergAlgebra
begin

class cancel_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes mult_cancel_left: "a * b = a * c \<Longrightarrow> b = c"
  and mult_cancel_right: "b * a = c * a \<Longrightarrow> b = c"
begin
lemma cancel_left_a: "b l\<rightarrow> (a * b) = a"
  apply (rule_tac a = b in mult_cancel_right)
  apply (subst inf_l_def [THEN sym])
  apply (rule antisym)
  by simp_all

lemma cancel_right_a: "b r\<rightarrow> (b * a) = a"
  apply (rule_tac a = b in mult_cancel_left)
  apply (subst inf_r_def [THEN sym])
  apply (rule antisym)
  by simp_all

end

class cancel_pseudo_hoop_algebra_2 = pseudo_hoop_algebra +
  assumes cancel_left: "b l\<rightarrow> (a * b) = a"
  and cancel_right: "b r\<rightarrow> (b * a) = a"

begin
subclass cancel_pseudo_hoop_algebra
  apply unfold_locales
  apply (subgoal_tac "b = a r\<rightarrow> (a * b) \<and> a r\<rightarrow> (a * b) = a r\<rightarrow> (a * c) \<and> a r\<rightarrow> (a * c) = c")
  apply simp
  apply (rule conjI)
  apply (subst cancel_right)
  apply simp
  apply (rule conjI)
  apply simp
  apply (subst cancel_right)
  apply simp
  apply (subgoal_tac "b = a l\<rightarrow> (b * a) \<and> a l\<rightarrow> (b * a) = a l\<rightarrow> (c * a) \<and> a l\<rightarrow> (c * a) = c")
  apply simp
  apply (rule conjI)
  apply (subst cancel_left)
  apply simp
  apply (rule conjI)
  apply simp
  apply (subst cancel_left)
  by simp

end

context cancel_pseudo_hoop_algebra
begin

lemma lemma_4_2_i: "a l\<rightarrow> b = (a * c) l\<rightarrow> (b * c)"
  apply (subgoal_tac "a l\<rightarrow> b = a l\<rightarrow> (c l\<rightarrow> (b * c)) \<and> a l\<rightarrow> (c l\<rightarrow> (b * c)) = (a * c) l\<rightarrow> (b * c)")
  apply simp
  apply (rule conjI)
  apply (simp add: cancel_left_a)
  by (simp add: left_impl_ded)

lemma lemma_4_2_ii: "a r\<rightarrow> b = (c * a) r\<rightarrow> (c * b)"
  apply (subgoal_tac "a r\<rightarrow> b = a r\<rightarrow> (c r\<rightarrow> (c * b)) \<and> a r\<rightarrow> (c r\<rightarrow> (c * b)) = (c * a) r\<rightarrow> (c * b)")
  apply simp
  apply (rule conjI)
  apply (simp add: cancel_right_a)
  by (simp add: right_impl_ded)

lemma lemma_4_2_iii: "(a * c \<le> b * c) = (a \<le> b)"
  by (simp add: left_lesseq lemma_4_2_i [THEN sym])

lemma lemma_4_2_iv: "(c * a \<le> c * b) = (a \<le> b)"
  by (simp add: right_lesseq lemma_4_2_ii [THEN sym])

end

class wajsberg_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes wajsberg1: "(a l\<rightarrow> b) r\<rightarrow> b = (b l\<rightarrow> a) r\<rightarrow> a"
  and wajsberg2: "(a r\<rightarrow> b) l\<rightarrow> b = (b r\<rightarrow> a) l\<rightarrow> a"

context wajsberg_pseudo_hoop_algebra
begin

lemma lemma_4_3_i_a: "a \<squnion>1 b = (a l\<rightarrow> b) r\<rightarrow> b"
  by (simp add: sup1_def wajsberg1)

lemma lemma_4_3_ii_a: "a \<squnion>2 b = (a r\<rightarrow> b) l\<rightarrow> b"
  by (simp add: sup2_def wajsberg2)

lemma lemma_4_3_ii_b: "a \<squnion>2 b = (b r\<rightarrow> a) l\<rightarrow> a"
  by (simp add: sup2_def wajsberg2)
end

sublocale wajsberg_pseudo_hoop_algebra < lattice1!:pseudo_hoop_lattice_b "op \<squnion>1" "op *" "op \<sqinter>" "op l\<rightarrow>" "op \<le>" "op <" 1 "op r\<rightarrow>"
  apply unfold_locales
  apply (simp add: lemma_4_3_i_a)
  by (simp add: lemma_2_5_13_b lemma_2_5_13_a)

class zero_one = zero + one

class bounded_wajsberg_pseudo_hoop_algebra = zero_one + wajsberg_pseudo_hoop_algebra +
  assumes zero_smallest [simp]: "0 \<le> a"
begin
end

sublocale wajsberg_pseudo_hoop_algebra < lattice2!:pseudo_hoop_lattice_b "op \<squnion>2" "op *" "op \<sqinter>" "op l\<rightarrow>" "op \<le>" "op <" 1 "op r\<rightarrow>"
  apply unfold_locales
  apply (simp add: lemma_4_3_ii_a)
  by (simp add: lemma_2_5_13_b lemma_2_5_13_a)

lemma (in wajsberg_pseudo_hoop_algebra) sup1_eq_sup2: "op \<squnion>1 = op \<squnion>2"
  apply (simp add: fun_eq_iff)
  apply safe
  apply (cut_tac a = x and b = xa in lattice1.supremum_pair)
  apply (cut_tac a = x and b = xa in lattice2.supremum_pair)
  by blast

context bounded_wajsberg_pseudo_hoop_algebra
begin
definition
  "negl a = a l\<rightarrow> 0"

definition
  "negr a = a r\<rightarrow> 0"

sublocale bounded_wajsberg_pseudo_hoop_algebra < wajsberg!: pseudo_wajsberg_algebra "1"  "op l\<rightarrow>"  "op r\<rightarrow>"  "op \<le>" "op <" "0" "negl" "negr"
  apply unfold_locales
  apply simp_all
  apply (simp add:  lemma_4_3_i_a [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (simp add:  lemma_4_3_i_a [THEN sym] lemma_4_3_ii_a [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (simp add:  lemma_4_3_i_a [THEN sym] lemma_4_3_ii_a [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (subst left_lesseq [THEN sym])
  apply (simp add: lemma_2_5_16)
  apply (subst right_lesseq [THEN sym])
  apply (simp add: lemma_2_5_17)
  apply (simp add: left_lesseq)
  apply (simp add: less_def)
  apply (simp_all add: negl_def negr_def)
  apply (subst left_lesseq [THEN sym])
  apply (subgoal_tac "b l\<rightarrow> a = ((b l\<rightarrow> 0) r\<rightarrow> 0) l\<rightarrow> ((a l\<rightarrow> 0) r\<rightarrow> 0)")
  apply (simp add: lemma_2_5_17)
  apply (subst wajsberg1)
  apply simp
  apply (subst wajsberg1)
  apply simp
  apply (subst left_lesseq [THEN sym])
  apply (subgoal_tac "b r\<rightarrow> a = ((b r\<rightarrow> 0) l\<rightarrow> 0) r\<rightarrow> ((a r\<rightarrow> 0) l\<rightarrow> 0)")
  apply (simp add: lemma_2_5_16)
  apply (subst wajsberg2)
  apply simp
  apply (subst wajsberg2)
  apply simp
  apply (simp add: left_impl_ded [THEN sym])
  apply (simp add: right_impl_ded [THEN sym])
  apply (simp add:  lemma_4_3_i_a [THEN sym] lemma_4_3_ii_a [THEN sym])
  apply (rule antisym)
  by simp_all

context pseudo_wajsberg_algebra
begin
  lemma "class.bounded_wajsberg_pseudo_hoop_algebra mult inf_a (op l\<rightarrow>) (op \<le>) (op <) 1 (op r\<rightarrow>) (0::'a)"
  apply unfold_locales
  apply (simp add: inf_a_def mult_def W6)
  apply (simp add: strict)
  apply (simp_all add: mult_def order_l strict)
  apply (simp add: zero_def [THEN sym] C3_a)
  apply (simp add: W6 inf_a_def [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (simp add: C6 P9 [THEN sym] C5_b)
  apply (simp add: inf_b_def [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (simp add: inf_b_def [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (simp add: W6)
  apply (simp add: C6 [THEN sym])
  apply (simp add: P9 C5_a)
  apply (simp add: inf_b_def [THEN sym])
  apply (simp add: W6 inf_a_def [THEN sym])
  apply (rule antisym)
  apply simp_all
  apply (simp add: W2a)
  by (simp add: W2c)

end

class basic_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes B1: "(a l\<rightarrow> b) l\<rightarrow> c \<le> ((b l\<rightarrow> a) l\<rightarrow> c) l\<rightarrow> c"
  and B2: "(a r\<rightarrow> b) r\<rightarrow> c \<le> ((b r\<rightarrow> a) r\<rightarrow> c) r\<rightarrow> c"
begin
lemma lemma_4_5_i: "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) = 1"
  apply (cut_tac a = a and b = b and c = "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a)" in B1)
  apply (subgoal_tac "(a l\<rightarrow> b) l\<rightarrow> (a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) = 1 \<and> ((b l\<rightarrow> a) l\<rightarrow> (a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a)) = 1")
  apply (erule conjE)
  apply simp
  apply (rule antisym)
  apply simp
  apply simp
  apply safe
  apply (subst left_lesseq [THEN sym])
  apply simp
  apply (subst left_lesseq [THEN sym])
  by simp

lemma lemma_4_5_ii: "(a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a) = 1"
  apply (cut_tac a = a and b = b and c = "(a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a)" in B2)
  apply (subgoal_tac "(a r\<rightarrow> b) r\<rightarrow> (a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a) = 1 \<and> ((b r\<rightarrow> a) r\<rightarrow> (a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a)) = 1")
  apply (erule conjE)
  apply simp
  apply (rule antisym)
  apply simp
  apply simp
  apply safe
  apply (subst right_lesseq [THEN sym])
  apply simp
  apply (subst right_lesseq [THEN sym])
  by simp

lemma lemma_4_5_iii: "a l\<rightarrow> b = (a \<squnion>1 b) l\<rightarrow> b"
  apply (rule antisym)
  apply (rule_tac y = "((a l\<rightarrow> b) r\<rightarrow> b) l\<rightarrow> b" in order_trans)
  apply (rule lemma_2_10_26)
  apply (rule lemma_2_5_13_a)
  apply (simp add: sup1_def)
  apply (rule lemma_2_5_13_a)
  by simp

lemma lemma_4_5_iv: "a r\<rightarrow> b = (a \<squnion>2 b) r\<rightarrow> b"
  apply (rule antisym)
  apply (rule_tac y = "((a r\<rightarrow> b) l\<rightarrow> b) r\<rightarrow> b" in order_trans)
  apply (rule lemma_2_10_24)
  apply (rule lemma_2_5_13_b)
  apply (simp add: sup2_def)
  apply (rule lemma_2_5_13_b)
  by simp

lemma lemma_4_5_v: "(a \<squnion>1 b) l\<rightarrow> c = (a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c)"
  apply (rule antisym)
  apply simp
  apply safe
  apply (rule lemma_2_5_13_a)
  apply simp
  apply (rule lemma_2_5_13_a)
  apply simp
  apply (subst right_lesseq)
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "(a l\<rightarrow> b) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c)" in order_trans)
  apply (subst left_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iii)
  apply (subst right_residual [THEN sym])
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "b \<sqinter> c" in order_trans)
  apply (subst (2) inf_l_def)
  apply (rule_tac y = "((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c)) * ((a \<squnion>1 b) \<sqinter> b)" in order_trans)
  apply (subst (3) inf_l_def)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>1 b \<sqinter> b) = b")
  apply simp
  apply (rule antisym, simp)
  apply simp
  apply simp
  apply (rule_tac y = "((b l\<rightarrow> a) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c)) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c)" in order_trans)
  apply (rule B1)
  apply (subgoal_tac "(b l\<rightarrow> a) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c) = 1")
  apply simp
  apply (rule antisym)
  apply simp
  apply (subst left_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iii)
  apply (subst right_residual [THEN sym])
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "a \<sqinter> c" in order_trans)
  apply (subst (2) inf_l_def)
  apply (rule_tac y = "((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c)) * ((a \<squnion>1 b) \<sqinter> a)" in order_trans)
  apply (subst (3) inf_l_def)
  apply (subst sup1.sup_comute1)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>1 b \<sqinter> a) = a")
  apply simp
  apply (rule antisym, simp)
  apply simp
  by simp

lemma lemma_4_5_vi: "(a \<squnion>2 b) r\<rightarrow> c = (a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c)"
  apply (rule antisym)
  apply simp
  apply safe
  apply (rule lemma_2_5_13_b)
  apply simp
  apply (rule lemma_2_5_13_b)
  apply simp
  apply (subst left_lesseq)
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "(a r\<rightarrow> b) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c)" in order_trans)
  apply (subst right_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iv)
  apply (subst left_residual [THEN sym])
  apply (subst right_residual [THEN sym])
  apply (rule_tac y = "b \<sqinter> c" in order_trans)
  apply (subst (2) inf_r_def)
  apply (rule_tac y = "((a \<squnion>2 b) \<sqinter> b) * ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c))" in order_trans)
  apply (subst (2) inf_r_def)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>2 b \<sqinter> b) = b")
  apply simp
  apply (rule antisym, simp)
  apply simp
  apply simp
  apply (rule_tac y = "((b r\<rightarrow> a) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c)) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c)" in order_trans)
  apply (rule B2)
  apply (subgoal_tac "(b r\<rightarrow> a) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c) = 1")
  apply simp
  apply (rule antisym)
  apply simp
  apply (subst right_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iv)
  apply (subst left_residual [THEN sym])
  apply (subst right_residual [THEN sym])
  apply (rule_tac y = "a \<sqinter> c" in order_trans)
  apply (subst (2) inf_r_def)
  apply (rule_tac y = "((a \<squnion>2 b) \<sqinter> a) * ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c))" in order_trans)
  apply (subst (2) inf_r_def)
  apply (subst (2) sup2.sup_comute)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>2 b \<sqinter> a) = a")
  apply simp
  apply (rule antisym, simp)
  apply simp
  by simp

lemma lemma_4_5_a: "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> a \<squnion>1 b \<le> c"
  apply (subst left_lesseq)
  apply (subst lemma_4_5_v)
  by simp

lemma lemma_4_5_b: "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> a \<squnion>2 b \<le> c"
  apply (subst right_lesseq)
  apply (subst lemma_4_5_vi)
  by simp

lemma lemma_4_5: "a \<squnion>1 b = a \<squnion>2 b"
  apply (rule antisym)
  by (simp_all add: lemma_4_5_a lemma_4_5_b)
end

sublocale basic_pseudo_hoop_algebra <  basic_lattice!:lattice "op \<sqinter>" "op \<le>" "op <" "op \<squnion>1"
  apply unfold_locales
  by (simp_all add: lemma_4_5_a)

context pseudo_hoop_lattice begin end

sublocale basic_pseudo_hoop_algebra <  pseudo_hoop_lattice "op \<squnion>1" "op *" "op \<sqinter>" "op l\<rightarrow>" "op \<le>" "op <" 1 "op r\<rightarrow>"
  apply unfold_locales
  by (simp_all add: basic_lattice.sup_assoc)

class sup_assoc_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes sup1_assoc: "a \<squnion>1 (b \<squnion>1 c) = (a \<squnion>1 b) \<squnion>1 c"
  and sup2_assoc: "a \<squnion>2 (b \<squnion>2 c) = (a \<squnion>2 b) \<squnion>2 c"

sublocale sup_assoc_pseudo_hoop_algebra <  sup1_lattice: pseudo_hoop_lattice "op \<squnion>1" "op *" "op \<sqinter>" "op l\<rightarrow>" "op \<le>" "op <" 1 "op r\<rightarrow>"
  apply unfold_locales
  by (simp add: sup1_assoc)

sublocale sup_assoc_pseudo_hoop_algebra <  sup2_lattice: pseudo_hoop_lattice "op \<squnion>2" "op *" "op \<sqinter>" "op l\<rightarrow>" "op \<le>" "op <" 1 "op r\<rightarrow>"
  apply unfold_locales
  by (simp add: sup2_assoc)

class sup_assoc_pseudo_hoop_algebra_1 = sup_assoc_pseudo_hoop_algebra +
  assumes union_impl: "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) = 1"
  and union_impr: "(a r\<rightarrow> b) \<squnion>1 (b r\<rightarrow> a) = 1"

lemma (in pseudo_hoop_algebra) [simp]: "infimum {a, b} = {a \<sqinter> b}"
  apply (simp add: infimum_def lower_bound_def)
  apply safe
  apply (rule antisym)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_impl_inf:
  "(a \<squnion> b) l\<rightarrow> c = (a l\<rightarrow> c) \<sqinter> (b l\<rightarrow>c)"
  apply (cut_tac A = "{a, b}" and a = "a \<squnion> b" and b = c in lemma_2_8_i)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_impr_inf:
  "(a \<squnion> b) r\<rightarrow> c = (a r\<rightarrow> c) \<sqinter> (b r\<rightarrow>c)"
  apply (cut_tac A = "{a, b}" and a = "a \<squnion> b" and b = c in lemma_2_8_i1)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_times:
  "a * (b \<squnion> c) = (a * b) \<squnion> (a * c)"
  apply (cut_tac A = "{b, c}" and b = "b \<squnion> c" and a = a in lemma_2_9_i)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_times_right:
  "(b \<squnion> c) * a = (b * a) \<squnion> (c * a)"
  apply (cut_tac A = "{b, c}" and b = "b \<squnion> c" and a = a in lemma_2_9_i1)
  by simp_all

context basic_pseudo_hoop_algebra begin end

sublocale sup_assoc_pseudo_hoop_algebra_1 <  basic_1: basic_pseudo_hoop_algebra  "op *" "op \<sqinter>" "op l\<rightarrow>" "op \<le>" "op <" 1 "op r\<rightarrow>"
  apply unfold_locales
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) l\<rightarrow> c" in order_trans)
  apply (subst sup1_lattice.sup_impl_inf)
  apply (simp add: lemma_2_5_11)
  apply (simp add: union_impl)
   apply (subst right_residual [THEN sym])
  apply (rule_tac y = "(b r\<rightarrow> a) \<squnion>1 (a r\<rightarrow> b) r\<rightarrow> c" in order_trans)
  apply (subst sup1_lattice.sup_impr_inf)
  apply (simp add: lemma_2_5_11)
  by (simp add: union_impr)

context basic_pseudo_hoop_algebra
begin

lemma lemma_4_8_i: "a * (b \<sqinter> c) = (a * b) \<sqinter> (a * c)"
  apply (rule antisym)
  apply simp
  apply (subgoal_tac "a * (b \<sqinter> c) = (a * (b * (b r\<rightarrow> c))) \<squnion>1 (a * (c * (c r\<rightarrow> b)))")
  apply simp
  apply (drule drop_assumption)
  apply (rule_tac y = "(((a * b) \<sqinter> (a * c)) * (b r\<rightarrow> c)) \<squnion>1 (((a * b) \<sqinter> (a * c)) * (c r\<rightarrow> b))" in order_trans)
  apply (subst sup_times [THEN sym])
  apply (simp add: lemma_4_5 lemma_4_5_ii)
  apply (simp add: mult.assoc [THEN sym])
  apply safe
  apply (rule_tac y = "a * b * (b r\<rightarrow> c)" in order_trans)
  apply simp
  apply simp
  apply (rule_tac y = "a * c * (c r\<rightarrow> b)" in order_trans)
  apply simp
  apply simp
  apply (simp add: inf_r_def [THEN sym])
  apply (subgoal_tac "b \<sqinter> c = c \<sqinter> b")
  apply simp
  apply (rule antisym)
  by simp_all

lemma lemma_4_8_ii: "(b \<sqinter> c) * a = (b * a) \<sqinter> (c * a)"
  apply (rule antisym)
  apply simp
  apply (subgoal_tac "(b \<sqinter> c) * a = (((b l\<rightarrow> c) * b) * a) \<squnion>1 (((c l\<rightarrow> b) * c) * a)")
  apply simp
  apply (drule drop_assumption)
  apply (rule_tac y = "((b l\<rightarrow> c) * ((b * a) \<sqinter> (c * a))) \<squnion>1 ((c l\<rightarrow> b) * ((b * a) \<sqinter> (c * a)))" in order_trans)
  apply (subst sup_times_right [THEN sym])
  apply (simp add: lemma_4_5_i)
  apply (simp add: mult.assoc)
  apply safe
  apply (rule_tac y = "(b l\<rightarrow> c) * (b * a)" in order_trans)
  apply simp_all
  apply (rule_tac y = "(c l\<rightarrow> b) * (c * a)" in order_trans)
  apply simp_all
  apply (simp add: inf_l_def [THEN sym])
  apply (subgoal_tac "b \<sqinter> c = c \<sqinter> b")
  apply simp
  apply (rule antisym)
  by simp_all

lemma lemma_4_8_iii: "(a l\<rightarrow> b) l\<rightarrow> (b l\<rightarrow> a) = b l\<rightarrow> a"
  apply (rule antisym)
  apply (cut_tac a = a and b = b in lemma_4_5_i)
  apply (unfold sup1_def right_lesseq, simp)
  by (simp add: lemma_2_5_9_a)

 lemma lemma_4_8_iv: "(a r\<rightarrow> b) r\<rightarrow> (b r\<rightarrow> a) = b r\<rightarrow> a"
  apply (rule antisym)
  apply (cut_tac a = a and b = b in lemma_4_5_ii)
  apply (unfold sup2_def left_lesseq, simp)
  by (simp add: lemma_2_5_9_b)

end

context wajsberg_pseudo_hoop_algebra
begin
subclass sup_assoc_pseudo_hoop_algebra_1
  apply unfold_locales
  apply (simp add: lattice1.sup_assoc)
  apply (simp add: lattice2.sup_assoc)
  apply (simp add: lemma_4_3_i_a)
  apply (subgoal_tac "(a l\<rightarrow> b) l\<rightarrow> (b l\<rightarrow> a) = b l\<rightarrow> a")
  apply simp
  apply (subst lemma_2_10_30 [THEN sym])
  apply (subst wajsberg1)
  apply (simp add: lemma_2_10_32)
  apply (subst sup1_eq_sup2)
  apply (simp add: lemma_4_3_ii_a)
  apply (subgoal_tac "(a r\<rightarrow> b) r\<rightarrow> (b r\<rightarrow> a) = b r\<rightarrow> a")
  apply simp
  apply (subst lemma_2_10_31 [THEN sym])
  apply (subst wajsberg2)
  by (simp add: lemma_2_10_33)
end

class bounded_basic_pseudo_hoop_algebra = zero_one + basic_pseudo_hoop_algebra +
  assumes zero_smallest [simp]: "0 \<le> a"
begin
end

class inf_a =
  fixes inf_a :: "'a => 'a => 'a" (infixl "\<sqinter>1" 65)

class pseudo_bl_algebra = zero + sup + inf + monoid_mult + ord + left_imp + right_imp +
  assumes  bounded_lattice: "class.bounded_lattice inf (op \<le>) (op <) sup 0 1"
  and left_residual_bl: "(x * a \<le> b) = (x \<le> a l\<rightarrow> b)"
  and right_residual_bl: "(a * x \<le> b) = (x \<le> a r\<rightarrow> b)"
  and inf_l_bl_def: "a \<sqinter> b = (a l\<rightarrow> b) * a"
  and inf_r_bl_def: "a \<sqinter> b = a * (a r\<rightarrow> b)"
  and impl_sup_bl: "(a l\<rightarrow> b) \<squnion> (b l\<rightarrow> a) = 1"
  and impr_sup_bl: "(a r\<rightarrow> b) \<squnion> (b r\<rightarrow> a) = 1"
begin
end

context pseudo_bl_algebra begin end

sublocale bounded_basic_pseudo_hoop_algebra < basic!:pseudo_bl_algebra 1 "op *" "0"  "op \<sqinter>" "op \<squnion>1" "op l\<rightarrow>" "op r\<rightarrow>" "op \<le>" "op <"
  apply unfold_locales
  apply (rule zero_smallest)
  apply (rule left_residual)
  apply (rule right_residual)
  apply (rule inf_l_def)
  apply (simp add: inf_r_def [THEN sym])
  apply (rule lemma_4_5_i)
  apply (simp add: lemma_4_5)
  by (rule lemma_4_5_ii)

sublocale pseudo_bl_algebra < bounded_lattice!: bounded_lattice "inf" "op \<le>" "op <" "sup" "0" "1"
  by (rule bounded_lattice)

context pseudo_bl_algebra
begin
  lemma impl_one_bl [simp]: "a l\<rightarrow> a = 1"
    apply (rule bounded_lattice.antisym)
    apply simp_all
    apply (subst left_residual_bl [THEN sym])
    by simp

  lemma impr_one_bl [simp]: "a r\<rightarrow> a = 1"
    apply (rule bounded_lattice.antisym)
    apply simp_all
    apply (subst right_residual_bl [THEN sym])
    by simp

  lemma impl_ded_bl: "((a * b) l\<rightarrow> c) = (a l\<rightarrow> (b l\<rightarrow> c))"
    apply (rule bounded_lattice.antisym)
    apply (case_tac "(a * b l\<rightarrow> c \<le> a l\<rightarrow> b l\<rightarrow> c) = ((a * b l\<rightarrow> c) * a \<le> b l\<rightarrow> c)
      \<and> ((a * b l\<rightarrow> c) * a \<le> b l\<rightarrow> c) = (((a * b l\<rightarrow> c) * a) * b \<le> c)
      \<and> (((a * b l\<rightarrow> c) * a) * b \<le> c) = ((a * b l\<rightarrow> c) * (a * b) \<le> c)
      \<and> ((a * b l\<rightarrow> c) * (a * b) \<le> c) = ((a * b l\<rightarrow> c) \<le> (a * b l\<rightarrow> c))")
    apply simp
    apply (erule notE)
    apply (rule conjI)
    apply (simp add: left_residual_bl)
    apply (rule conjI)
    apply (simp add: left_residual_bl)
    apply (rule conjI)
    apply (simp add: mult.assoc)
    apply (simp add: left_residual_bl)
    apply (simp add: left_residual_bl [THEN sym])
    apply (rule_tac y="(b l\<rightarrow> c) * b" in bounded_lattice.order_trans)
    apply (simp add: mult.assoc [THEN sym])
    apply (subst inf_l_bl_def [THEN sym])
    apply (subst bounded_lattice.inf_commute)
    apply (subst inf_l_bl_def)
    apply (subst mult.assoc)
    apply (subst left_residual_bl)
    apply simp
    apply (subst left_residual_bl)
    by simp

  lemma impr_ded_bl: "(b * a r\<rightarrow> c) = (a r\<rightarrow> (b r\<rightarrow> c))"
    apply (rule bounded_lattice.antisym)
    apply (case_tac "(b * a r\<rightarrow> c \<le> a r\<rightarrow> b r\<rightarrow> c) = (a * (b * a r\<rightarrow> c) \<le> b r\<rightarrow> c)
      \<and> (a * (b * a r\<rightarrow> c) \<le> b r\<rightarrow> c) = (b * (a * (b * a r\<rightarrow> c)) \<le> c)
      \<and> (b * ( a* (b * a r\<rightarrow> c)) \<le> c) = ((b * a) * (b * a r\<rightarrow> c) \<le> c)
      \<and> ((b * a) * (b * a r\<rightarrow> c) \<le> c) = ((b * a r\<rightarrow> c) \<le> (b * a r\<rightarrow> c))")
    apply simp
    apply (erule notE)
    apply (rule conjI)
    apply (simp add: right_residual_bl)
    apply (rule conjI)
    apply (simp add: right_residual_bl)
    apply (rule conjI)
    apply (simp add: mult.assoc)
    apply (simp add: right_residual_bl)
    apply (simp add: right_residual_bl [THEN sym])
    apply (rule_tac y="b * (b r\<rightarrow> c)" in bounded_lattice.order_trans)
    apply (simp add: mult.assoc)
    apply (subst inf_r_bl_def [THEN sym])
    apply (subst bounded_lattice.inf_commute)
    apply (subst inf_r_bl_def)
    apply (subst mult.assoc [THEN sym])
    apply (subst right_residual_bl)
    apply simp
    apply (subst right_residual_bl)
    by simp

  lemma lesseq_impl_bl: "(a \<le> b) = (a l\<rightarrow> b = 1)"
    apply (rule iffI)
    apply (rule  bounded_lattice.antisym)
    apply simp
    apply (simp add: left_residual_bl [THEN sym])
    apply (subgoal_tac "1 \<le> a l\<rightarrow> b")
    apply (subst (asm) left_residual_bl [THEN sym])
    by simp_all

end

context pseudo_bl_algebra
begin
subclass pseudo_hoop_lattice
  apply unfold_locales
  apply (rule inf_l_bl_def)
  apply (simp add: bounded_lattice.less_le_not_le)
  apply (simp add: mult_1_left)
  apply (simp add: mult_1_right)
  apply (simp add: impl_one_bl)
  apply (simp add: inf_l_bl_def [THEN sym])
  apply (rule bounded_lattice.inf_commute)
  apply (rule impl_ded_bl)
  apply (rule lesseq_impl_bl)
  apply (rule inf_r_bl_def)
  apply (simp add: impr_one_bl)
  apply (simp add: inf_r_bl_def [THEN sym])
  apply (rule bounded_lattice.inf_commute)
  apply (rule impr_ded_bl)
  apply (simp add: inf_r_bl_def [THEN sym] inf_l_bl_def [THEN sym])
  apply (rule bounded_lattice.sup_commute)
  apply simp
  apply safe
  apply (rule bounded_lattice.antisym)
  apply simp_all
  apply (subgoal_tac "a \<le>  a \<squnion> b")
  apply simp
  apply (drule drop_assumption)
  apply simp
  by (simp add: bounded_lattice.sup_assoc)

subclass bounded_basic_pseudo_hoop_algebra
  apply unfold_locales
  apply simp_all
  apply (simp add: left_residual [THEN sym])
  apply (rule_tac y = "((a l\<rightarrow> b) \<squnion> (b l\<rightarrow> a)) l\<rightarrow> c" in bounded_lattice.order_trans)
  apply (simp add: sup_impl_inf)
  apply (simp add: impl_sup_bl)

  apply (simp add: right_residual [THEN sym])
  apply (rule_tac y = "((a r\<rightarrow> b) \<squnion> (b r\<rightarrow> a)) r\<rightarrow> c" in bounded_lattice.order_trans)
  apply (simp add: sup_impr_inf)
  by (simp add: impr_sup_bl)

end

class product_pseudo_hoop_algebra = basic_pseudo_hoop_algebra +
  assumes P1: "b l\<rightarrow> b * b \<le> (a \<sqinter> (a l\<rightarrow> b)) l\<rightarrow> b"
  and P2: "b r\<rightarrow> b * b \<le> (a \<sqinter> (a r\<rightarrow> b)) r\<rightarrow> b"
  and P3: "((a l\<rightarrow> b) l\<rightarrow> b) * (c * a l\<rightarrow> d * a) * (c * b l\<rightarrow> d * b) \<le> c l\<rightarrow> d"
  and P4: "((a r\<rightarrow> b) r\<rightarrow> b) * (a * c r\<rightarrow> a * d) * (b * c r\<rightarrow> b * d) \<le> c r\<rightarrow> d"

class cancel_basic_pseudo_hoop_algebra = basic_pseudo_hoop_algebra + cancel_pseudo_hoop_algebra
begin
subclass product_pseudo_hoop_algebra
  apply unfold_locales
  apply (rule_tac y = "1 l\<rightarrow> b" in order_trans)
  apply (cut_tac a = 1 and b = b and c = b in lemma_4_2_i)
  apply simp
  apply (simp add: lemma_2_5_9_a)

  apply (rule_tac y = "1 r\<rightarrow> b" in order_trans)
  apply (cut_tac a = 1 and b = b and c = b in lemma_4_2_ii)
  apply simp
  apply (simp add: lemma_2_5_9_b)
  apply (simp add: lemma_4_2_i [THEN sym])
  by (simp add: lemma_4_2_ii [THEN sym])

end

class simple_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes simple: "normalfilters \<inter> properfilters = {{1}}"

class proper = one +
  assumes proper: "\<exists> a . a \<noteq> 1"

class strong_simple_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes strong_simple: "properfilters = {{1}}"
begin

subclass proper
  apply unfold_locales
  apply (cut_tac strong_simple)
  apply (simp add: properfilters_def)
  apply (case_tac "{1} = UNIV")
  apply blast
  by blast

lemma lemma_4_12_i_ii: "a \<noteq> 1 \<Longrightarrow> filterof({a}) = UNIV"
  apply (cut_tac strong_simple)
  apply (simp add: properfilters_def)
  apply (subgoal_tac "filterof {a} \<notin> {F \<in> filters. F \<noteq> UNIV}")
  apply (drule drop_assumption)
  apply (drule drop_assumption)
  apply simp
  apply simp
  apply safe
  apply (subgoal_tac "a \<in> filterof {a}")
  apply simp
  apply (subst filterof_def)
  by simp

lemma lemma_4_12_i_iii: "a \<noteq> 1 \<Longrightarrow> (\<exists> n . a ^ n \<le> b)"
  apply (drule lemma_4_12_i_ii)
  apply (simp add: prop_3_2_i)
  by blast

lemma lemma_4_12_i_iv: "a \<noteq> 1 \<Longrightarrow> (\<exists> n . a l-n\<rightarrow> b = 1)"
  apply (subst lemma_2_4_7_a)
  apply (subst left_lesseq [THEN sym])
  by (simp add: lemma_4_12_i_iii)

lemma lemma_4_12_i_v: "a \<noteq> 1 \<Longrightarrow> (\<exists> n . a r-n\<rightarrow> b = 1)"
  apply (subst lemma_2_4_7_b)
  apply (subst right_lesseq [THEN sym])
  by (simp add: lemma_4_12_i_iii)

end

lemma (in pseudo_hoop_algebra) [simp]: "{1} \<in> filters"
  apply (simp add: filters_def)
  apply safe
  apply (rule antisym)
  by simp_all

class strong_simple_pseudo_hoop_algebra_a = pseudo_hoop_algebra + proper +
  assumes strong_simple_a: "a \<noteq> 1 \<Longrightarrow> filterof({a}) = UNIV"
begin
  subclass  strong_simple_pseudo_hoop_algebra
    apply unfold_locales
    apply (simp add: properfilters_def)
    apply safe
    apply simp_all
    apply (case_tac "xb = 1")
    apply simp
    apply (cut_tac a = xb in strong_simple_a)
    apply simp
    apply (simp add: filterof_def)
    apply blast
    apply (cut_tac proper)
    by blast
end

sublocale strong_simple_pseudo_hoop_algebra < strong_simple_pseudo_hoop_algebra_a
  apply unfold_locales
  by (simp add: lemma_4_12_i_ii)

lemma (in pseudo_hoop_algebra) power_impl: "b l\<rightarrow> a = a \<Longrightarrow> b ^ n l\<rightarrow> a = a"
  apply (induct_tac n)
  apply simp
  by (simp add: left_impl_ded)

lemma (in pseudo_hoop_algebra) power_impr: "b r\<rightarrow> a = a \<Longrightarrow> b ^ n r\<rightarrow> a = a"
  apply (induct_tac n)
  apply simp
  by (simp add: right_impl_ded)

context strong_simple_pseudo_hoop_algebra
begin

lemma lemma_4_13_i: "b l\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
  apply safe
  apply (drule_tac a = b and b = a in lemma_4_12_i_iii)
  apply safe
  apply (subst (asm) left_lesseq)
  apply (drule_tac n = n in power_impl)
  by simp

lemma lemma_4_13_ii: "b r\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
  apply safe
  apply (drule_tac a = b and b = a in lemma_4_12_i_iii)
  apply safe
  apply (subst (asm) right_lesseq)
  apply (drule_tac n = n in power_impr)
  by simp
end

class basic_pseudo_hoop_algebra_A = basic_pseudo_hoop_algebra +
  assumes left_impl_one: "b l\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
  and right_impl_one: "b r\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
begin
subclass linorder
  apply unfold_locales
  apply (cut_tac a = "x" and b = "y" in lemma_4_8_iii)
  apply (drule left_impl_one)
  apply (simp add: left_lesseq)
  by blast

lemma [simp]: "(a l\<rightarrow> b) r\<rightarrow> b \<le> (b l\<rightarrow> a) r\<rightarrow> a"
  apply (case_tac "a = b")
  apply simp
  apply (cut_tac x = a and y =b in linear)
  apply safe
  apply (subst (asm) left_lesseq)
  apply (simp add: lemma_2_10_24)
  apply (subst (asm) left_lesseq)
  apply simp
  apply (subst left_lesseq)
  apply (cut_tac b = "((a l\<rightarrow> b) r\<rightarrow> b) l\<rightarrow> a" and a = "a l\<rightarrow> b" in left_impl_one)
  apply (simp add: lemma_2_10_32)
  apply (simp add: left_lesseq [THEN sym])
  apply safe
  apply (erule notE)
  by simp

end

context basic_pseudo_hoop_algebra_A begin

lemma [simp]: "(a r\<rightarrow> b) l\<rightarrow> b \<le> (b r\<rightarrow> a) l\<rightarrow> a"
  apply (case_tac "a = b")
  apply simp
  apply (cut_tac x = a and y =b in linear)
  apply safe
  apply (subst (asm) right_lesseq)
  apply simp
  apply (simp add: lemma_2_10_26)
  apply (unfold right_lesseq)
  apply (cut_tac b = "((a r\<rightarrow> b) l\<rightarrow> b) r\<rightarrow> a" and a = "a r\<rightarrow> b" in right_impl_one)
  apply (simp add: lemma_2_10_33)
  apply (simp add: right_lesseq [THEN sym])
  apply safe
  apply (erule notE)
  by simp

subclass wajsberg_pseudo_hoop_algebra
  apply unfold_locales
  apply (rule antisym)
  apply simp_all
  apply (rule antisym)
  by simp_all

end

class strong_simple_basic_pseudo_hoop_algebra = strong_simple_pseudo_hoop_algebra + basic_pseudo_hoop_algebra
begin
subclass basic_pseudo_hoop_algebra_A
  apply unfold_locales
  apply (simp add: lemma_4_13_i)
  by (simp add: lemma_4_13_ii)

subclass wajsberg_pseudo_hoop_algebra
  by unfold_locales

end

end


theory "Abstract-Denotational-Props"
  imports AbstractDenotational Substitution
begin

context semantic_domain
begin

subsubsection \<open>The semantics ignores fresh variables\<close>

lemma ESem_considers_fv': "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho> f|` (fv e)\<^esub>"
proof (induct e arbitrary: \<rho> rule:exp_induct)
  case Var
  show ?case by simp
next
  have [simp]: "\<And> S x. S \<inter> insert x S = S" by auto
  case App
  show ?case
    by (simp, subst (1 2) App, simp)
next
  case (Lam x e)
  show ?case by simp
next
  case (IfThenElse scrut e\<^sub>1 e\<^sub>2)
  have [simp]: "(fv scrut \<inter> (fv scrut \<union> fv e\<^sub>1 \<union> fv e\<^sub>2)) = fv scrut" by auto
  have [simp]: "(fv e\<^sub>1 \<inter> (fv scrut \<union> fv e\<^sub>1 \<union> fv e\<^sub>2)) = fv e\<^sub>1" by auto
  have [simp]: "(fv e\<^sub>2 \<inter> (fv scrut \<union> fv e\<^sub>1 \<union> fv e\<^sub>2)) = fv e\<^sub>2" by auto
  show ?case
    apply simp
    apply (subst (1 2) IfThenElse(1))
    apply (subst (1 2) IfThenElse(2))
    apply (subst (1 2) IfThenElse(3))
    apply (simp)
    done
next
  case (Let as e)

  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>(\<lbrace>as\<rbrace>\<rho>) f|` (fv as \<union> fv e)\<^esub>"
    apply (subst (1 2) Let(2))
    apply simp
    apply (metis inf_sup_absorb sup_commute)
    done
  also
  have "fv as \<subseteq> fv as \<union> fv e" by (rule inf_sup_ord(3))
  hence "(\<lbrace>as\<rbrace>\<rho>) f|` (fv as \<union> fv e) = \<lbrace>as\<rbrace>(\<rho> f|` (fv as \<union> fv e))"
     by (rule HSem_ignores_fresh_restr'[OF _ Let(1)])
  also
  have "\<lbrace>as\<rbrace>(\<rho> f|` (fv as \<union> fv e)) = \<lbrace>as\<rbrace>\<rho> f|` (fv as \<union> fv e - domA as)"
    by (rule HSem_restr_cong) (auto simp add: lookup_env_restr_eq)
  finally
  show ?case by simp
qed auto

sublocale has_ignore_fresh_ESem ESem
  by standard (rule fv_supp_exp, rule ESem_considers_fv')

subsubsection \<open>Nicer equations for ESem, without freshness requirements\<close>

lemma ESem_Lam[simp]: "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>))"
proof-
  have *: "\<And> v. ((\<rho> f|` (fv e - {x}))(x := v)) f|` fv e = (\<rho>(x := v)) f|` fv e"
    by (rule ext) (auto simp add: lookup_env_restr_eq)

  have "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>env_delete x \<rho>\<^esub>"
    by (rule ESem_fresh_cong) simp
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>(\<rho> f|` (fv e - {x}))(x := v)\<^esub>))"
    by simp
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>((\<rho> f|` (fv e - {x}))(x := v)) f|` fv e\<^esub>))"
    by (subst  ESem_considers_fv, rule)
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v) f|` fv e\<^esub>))"
    unfolding *..
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>))"
    unfolding  ESem_considers_fv[symmetric]..
  finally show ?thesis.
qed
declare ESem.simps(1)[simp del]

lemma ESem_Let[simp]: "\<lbrakk>Let as body\<rbrakk>\<^bsub>\<rho>\<^esub> = tick \<cdot> (\<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>)"
proof-
  have "\<lbrakk> Let as body \<rbrakk>\<^bsub>\<rho>\<^esub> = tick \<cdot> (\<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>(\<rho> f|` fv (Let as body))\<^esub>)"
    by simp
  also have "\<lbrace>as\<rbrace>(\<rho> f|` fv(Let as body)) = \<lbrace>as\<rbrace>(\<rho> f|` (fv as \<union> fv body))"
    by (rule HSem_restr_cong) (auto simp add: lookup_env_restr_eq)
  also have "\<dots> = (\<lbrace>as\<rbrace>\<rho>) f|` (fv as \<union> fv body)"
    by (rule HSem_ignores_fresh_restr'[symmetric, OF _ ESem_considers_fv]) simp
  also have "\<lbrakk>body\<rbrakk>\<^bsub>\<dots>\<^esub> = \<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>"
    by (rule ESem_fresh_cong) (auto simp add: lookup_env_restr_eq)
  finally show ?thesis.
qed
declare ESem.simps(4)[simp del]

subsubsection \<open>Denotation of Substitution\<close>

lemma ESem_subst_same: "\<rho> x = \<rho> y \<Longrightarrow>  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<rho>\<^esub>"
  and
  "\<rho> x = \<rho> y  \<Longrightarrow>  (\<^bold>\<lbrakk> as \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>) = \<^bold>\<lbrakk> as[x::h=y] \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>"
proof (nominal_induct e and as avoiding: x y arbitrary: \<rho> and \<rho> rule:exp_heap_strong_induct)
case Var thus ?case by auto
next
case App
  from App(1)[OF App(2)] App(2)
  show ?case by auto
next
case (Let as exp x y \<rho>)
  from \<open>atom ` domA as \<sharp>* x\<close> \<open>atom ` domA as  \<sharp>* y\<close>
  have "x \<notin> domA as" "y \<notin> domA as"
    by (metis fresh_star_at_base imageI)+
  hence [simp]:"domA (as[x::h=y]) = domA as"
    by (metis bn_subst)

  from \<open>\<rho> x = \<rho> y\<close>
  have "(\<lbrace>as\<rbrace>\<rho>) x = (\<lbrace>as\<rbrace>\<rho>) y"
    using \<open>x \<notin> domA as\<close> \<open>y \<notin> domA as\<close>
    by (simp add: lookup_HSem_other)
  hence "\<lbrakk>exp\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub> = \<lbrakk>exp[x::=y]\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>"
    by (rule Let)
  moreover
  from \<open>\<rho> x = \<rho> y\<close>
  have "\<lbrace>as\<rbrace>\<rho> = \<lbrace>as[x::h=y]\<rbrace>\<rho>" and "(\<lbrace>as\<rbrace>\<rho>) x = (\<lbrace>as[x::h=y]\<rbrace>\<rho>) y"
    apply (induction rule: parallel_HSem_ind)
    apply (intro adm_lemmas cont2cont cont2cont_fun)
    apply simp
    apply simp
    apply simp
    apply (erule arg_cong[OF Let(3)])
    using \<open>x \<notin> domA as\<close> \<open>y \<notin> domA as\<close>
    apply simp
    done
  ultimately
  show ?case using Let(1,2,3) by (simp add: fresh_star_Pair)
next
case (Lam var exp x y \<rho>)
  from \<open>\<rho> x = \<rho> y\<close>
  have "\<And>v. (\<rho>(var := v)) x = (\<rho>(var := v)) y"
    using Lam(1,2) by (simp add: fresh_at_base)
  hence "\<And> v. \<lbrakk>exp\<rbrakk>\<^bsub>\<rho>(var := v)\<^esub> = \<lbrakk>exp[x::=y]\<rbrakk>\<^bsub>\<rho>(var := v)\<^esub>"
    by (rule Lam)
  thus ?case using Lam(1,2) by simp
next
case IfThenElse
  from IfThenElse(1)[OF IfThenElse(4)] IfThenElse(2)[OF IfThenElse(4)] IfThenElse(3)[OF IfThenElse(4)]
  show ?case
    by simp
next
case Nil thus ?case by auto
next
case Cons
  from Cons(1,2)[OF Cons(3)] Cons(3)
  show ?case by auto
qed auto

lemma ESem_subst:
  shows "\<lbrakk> e \<rbrakk>\<^bsub>\<sigma>(x := \<sigma> y)\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<sigma>\<^esub>"
proof(cases "x = y")
  case False
  hence [simp]: "x \<notin> fv e[x::=y]" by (auto simp add: fv_def supp_subst supp_at_base dest: subsetD[OF supp_subst])

  have "\<lbrakk> e \<rbrakk>\<^bsub>\<sigma>(x := \<sigma> y)\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<sigma>(x := \<sigma> y)\<^esub>"
    by (rule ESem_subst_same) simp
  also have "\<dots> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<sigma>\<^esub>"
    by (rule ESem_fresh_cong) simp
  finally
  show ?thesis.
next
  case True
  thus ?thesis by simp
qed

end

end


(*  Title:      HOL/Hoare/Pointers0.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

This is like Pointers.thy, but instead of a type constructor 'a ref
that adjoins Null to a type, Null is simply a distinguished element of
the address type. This avoids the Ref constructor and thus simplifies
specifications (a bit). However, the proofs don't seem to get simpler
- in fact in some case they appear to get (a bit) more complicated.
*)

section \<open>Alternative pointers\<close>

theory Pointers0
  imports Hoare_Logic
begin

subsection "References"

class ref =
  fixes Null :: 'a

subsection "Field access and update"

syntax
  "_fassign"  :: "'a::ref => id => 'v => 's com"
   ("(2_^._ :=/ _)" [70,1000,65] 61)
  "_faccess"  :: "'a::ref => ('a::ref \<Rightarrow> 'v) => 'v"
   ("_^._" [65,1000] 65)
translations
  "p^.f := e"  =>  "f := CONST fun_upd f p e"
  "p^.f"       =>  "f p"

text "An example due to Suzuki:"

lemma "VARS v n
  {distinct[w,x,y,z]}
  w^.v := (1::int); w^.n := x;
  x^.v := 2; x^.n := y;
  y^.v := 3; y^.n := z;
  z^.v := 4; x^.n := z
  {w^.n^.n^.v = 4}"
by vcg_simp

subsection "The heap"

subsubsection "Paths in the heap"

primrec Path :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
  "Path h x [] y = (x = y)"
| "Path h x (a#as) y = (x \<noteq> Null \<and> x = a \<and> Path h (h a) as y)"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by(induct as, simp+)

lemma [simp]: "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by(induct as, simp, simp add:eq_sym_conv)

subsubsection "Lists on the heap"

paragraph "Relational abstraction"

definition List :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool"
  where "List h x as = Path h x as Null"

lemma [simp]: "List h x [] = (x = Null)"
by(simp add:List_def)

lemma [simp]: "List h x (a#as) = (x \<noteq> Null \<and> x = a \<and> List h (h a) as)"
by(simp add:List_def)

lemma [simp]: "List h Null as = (as = [])"
by(case_tac as, simp_all)

lemma List_Ref[simp]:
 "a \<noteq> Null \<Longrightarrow> List h a as = (\<exists>bs. as = a#bs \<and> List h (h a) bs)"
by(case_tac as, simp_all, fast)

declare fun_upd_apply[simp del]fun_upd_same[simp] fun_upd_other[simp]

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by(blast intro:List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List h (h a) as \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
apply(induct as, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

subsubsection "Functional abstraction"

definition islist :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool"
  where "islist h p \<longleftrightarrow> (\<exists>as. List h p as)"

definition list :: "('a::ref \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "list h p = (SOME as. List h p as)"

lemma List_conv_islist_list: "List h p as = (islist h p \<and> as = list h p)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst some1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply(rule someI_ex)
apply fast
done

lemma [simp]: "islist h Null"
by(simp add:islist_def)

lemma [simp]: "a \<noteq> Null \<Longrightarrow> islist h a = islist h (h a)"
by(simp add:islist_def)

lemma [simp]: "list h Null = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk> a \<noteq> Null; islist h (h a) \<rbrakk> \<Longrightarrow> list h a = a # list h (h a)"
apply(insert List_Ref[of _ h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist h (h a) \<Longrightarrow> a \<notin> set(list h (h a))"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> list (h(y := q)) p = list h p"
apply(drule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> islist (h(y := q)) p"
apply(frule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

subsection "Verifications"

subsubsection "List reversal"

text "A short but unreadable proof:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
  apply(fastforce intro:notin_List_update[THEN iffD2])
  \<comment> \<open>explicit:\<close>
  \<^cancel>\<open>apply clarify\<close>
  \<^cancel>\<open>apply(rename_tac ps qs)\<close>
  \<^cancel>\<open>apply clarsimp\<close>
  \<^cancel>\<open>apply(rename_tac ps')\<close>
  \<^cancel>\<open>apply(rule_tac x = ps' in exI)\<close>
  \<^cancel>\<open>apply simp\<close>
  \<^cancel>\<open>apply(rule_tac x = "p#qs" in exI)\<close>
  \<^cancel>\<open>apply simp\<close>
  done

text "A longer readable version:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
proof vcg
  fix tl p q r
  assume "List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}"
  thus "\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                rev ps @ qs = rev Ps @ Qs" by fastforce
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> p \<noteq> Null"
         (is "(\<exists>ps qs. ?I ps qs) \<and> _")
  then obtain ps qs where I: "?I ps qs \<and> p \<noteq> Null" by fast
  then obtain ps' where "ps = p # ps'" by fastforce
  hence "List (tl(p := q)) (p^.tl) ps' \<and>
         List (tl(p := q)) p       (p#qs) \<and>
         set ps' \<inter> set (p#qs) = {} \<and>
         rev ps' @ (p#qs) = rev Ps @ Qs"
    using I by fastforce
  thus "\<exists>ps' qs'. List (tl(p := q)) (p^.tl) ps' \<and>
                  List (tl(p := q)) p       qs' \<and>
                  set ps' \<inter> set qs' = {} \<and>
                  rev ps' @ qs' = rev Ps @ Qs" by fast
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> \<not> p \<noteq> Null"
  thus "List tl q (rev Ps @ Qs)" by fastforce
qed

text\<open>Finaly, the functional version. A bit more verbose, but automatic!\<close>

lemma "VARS tl p q r
  {islist tl p \<and> islist tl q \<and>
   Ps = list tl p \<and> Qs = list tl q \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {islist tl p \<and> islist tl q \<and>
       set(list tl p) \<inter> set(list tl q) = {} \<and>
       rev(list tl p) @ (list tl q) = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {islist tl q \<and> list tl q = rev Ps @ Qs}"
apply vcg_simp
  apply clarsimp
 apply clarsimp
done

subsubsection "Searching in a list"

text\<open>What follows is a sequence of successively more intelligent proofs that
a simple loop finds an element in a linked list.

We start with a proof based on the \<^term>\<open>List\<close> predicate. This means it only
works for acyclic lists.\<close>

lemma "VARS tl p
  {List tl p Ps \<and> X \<in> set Ps}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {p \<noteq> Null \<and> (\<exists>ps. List tl p ps \<and> X \<in> set ps)}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply(case_tac "p = Null")
   apply clarsimp
  apply fastforce
 apply clarsimp
 apply fastforce
apply clarsimp
done

text\<open>Using \<^term>\<open>Path\<close> instead of \<^term>\<open>List\<close> generalizes the correctness
statement to cyclic lists as well:\<close>

lemma "VARS tl p
  {Path tl p Ps X}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {\<exists>ps. Path tl p ps X}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply blast
 apply fastforce
apply clarsimp
done

text\<open>Now it dawns on us that we do not need the list witness at all --- it
suffices to talk about reachability, i.e.\ we can use relations directly.\<close>

lemma "VARS tl p
  {(p,X) \<in> {(x,y). y = tl x & x \<noteq> Null}\<^sup>*}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {(p,X) \<in> {(x,y). y = tl x & x \<noteq> Null}\<^sup>*}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply(simp)
apply(fastforce elim:converse_rtranclE)
done

subsubsection "Merging two lists"

text"This is still a bit rough, especially the proof."

fun merge :: "'a list * 'a list * ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list" where
"merge(x#xs,y#ys,f) = (if f x y then x # merge(xs,y#ys,f)
                                else y # merge(x#xs,ys,f))" |
"merge(x#xs,[],f) = x # merge(xs,[],f)" |
"merge([],y#ys,f) = y # merge([],ys,f)" |
"merge([],[],f) = []"

lemma imp_disjCL: "(P|Q \<longrightarrow> R) = ((P \<longrightarrow> R) \<and> (~P \<longrightarrow> Q \<longrightarrow> R))"
by blast

declare disj_not1[simp del] imp_disjL[simp del] imp_disjCL[simp]

lemma "VARS hd tl p q r s
 {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF if q = Null then True else p ~= Null & p^.hd \<le> q^.hd
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {\<exists>rs ps qs. Path tl r rs s \<and> List tl p ps \<and> List tl q qs \<and>
      distinct(s # ps @ qs @ rs) \<and> s \<noteq> Null \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ s # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl s = p \<or> tl s = q)}
 DO IF if q = Null then True else p \<noteq> Null \<and> p^.hd \<le> q^.hd
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {List tl r (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(simp add:eq_sym_conv)
apply(rule_tac x = "rs @ [s]" in exI)
apply simp
apply(rule_tac x = "bs" in exI)
apply (fastforce simp:eq_sym_conv)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(rule_tac x = "rs @ [s]" in exI)
apply simp
apply(rule_tac x = "bsa" in exI)
apply(rule conjI)
apply (simp add:eq_sym_conv)
apply(rule exI)
apply(rule conjI)
apply(rule_tac x = bs in exI)
apply(rule conjI)
apply(rule refl)
apply (simp add:eq_sym_conv)
apply (simp add:eq_sym_conv)

apply(rule conjI)
apply clarsimp
apply(rule_tac x = "rs @ [s]" in exI)
apply simp
apply(rule_tac x = bs in exI)
apply (simp add:eq_sym_conv)
apply clarsimp
apply(rule_tac x = "rs @ [s]" in exI)
apply (simp add:eq_sym_conv)
apply(rule exI)
apply(rule conjI)
apply(rule_tac x = bsa in exI)
apply(rule conjI)
apply(rule refl)
apply (simp add:eq_sym_conv)
apply(rule_tac x = bs in exI)
apply (simp add:eq_sym_conv)

apply(clarsimp simp add:List_app)
done

(* TODO: merging with islist/list instead of List: an improvement?
   needs (is)path, which is not so easy to prove either. *)

subsubsection "Storage allocation"

definition new :: "'a set \<Rightarrow> 'a::ref"
  where "new A = (SOME a. a \<notin> A & a \<noteq> Null)"

lemma new_notin:
 "\<lbrakk> ~finite(UNIV::('a::ref)set); finite(A::'a set); B \<subseteq> A \<rbrakk> \<Longrightarrow>
  new (A) \<notin> B & new A \<noteq> Null"
apply(unfold new_def)
apply(rule someI2_ex)
 apply (fast dest:ex_new_if_finite[of "insert Null A"])
apply (fast)
done

lemma "~finite(UNIV::('a::ref)set) \<Longrightarrow>
  VARS xs elem next alloc p q
  {Xs = xs \<and> p = (Null::'a)}
  WHILE xs \<noteq> []
  INV {islist next p \<and> set(list next p) \<subseteq> set alloc \<and>
       map elem (rev(list next p)) @ xs = Xs}
  DO q := new(set alloc); alloc := q#alloc;
     q^.next := p; q^.elem := hd xs; xs := tl xs; p := q
  OD
  {islist next p \<and> map elem (rev(list next p)) = Xs}"
apply vcg_simp
 apply (clarsimp simp: subset_insert_iff neq_Nil_conv fun_upd_apply new_notin)
done

end


(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>Relationship to Strong List Specification\<close>

text\<open>In this section we show that our list specification is stronger than the
$\mathcal{A}_\textsf{strong}$ specification of collaborative text editing by
Attiya et al.~\cite{Attiya:2016kh}. We do this by showing that the OpSet
interpretation of any set of insertion and deletion operations satisfies all
of the consistency criteria that constitute the $\mathcal{A}_\textsf{strong}$
specification.

Attiya et al.'s specification is as follows~\cite{Attiya:2016kh}:

\begin{displayquote}
An abstract execution $A = (H, \textsf{vis})$ belongs to the
\emph{strong list specification} $\mathcal{A}_\textsf{strong}$ if and only if
there is a relation
$\textsf{lo} \subseteq \textsf{elems}(A) \times \textsf{elems}(A)$, called the
\emph{list order}, such that:
\begin{enumerate}
\item Each event $e = \mathit{do}(\mathit{op}, w) \in H$ returns a sequence of
elements $w=a_0 \dots a_{n-1}$, where $a_i \in \textsf{elems}(A)$, such that
\begin{enumerate}
\item $w$ contains exactly the elements visible to $e$ that have been inserted,
but not deleted:
\[ \forall a.\; a \in w \quad\Longleftrightarrow\quad (\mathit{do}(\textsf{ins}(a, \_), \_) \le_\textsf{vis} e)
\;\wedge\; \neg(\mathit{do}(\textsf{del}(a), \_) \le_\textsf{vis} e). \]
\item The order of the elements is consistent with the list order:
\[ \forall i, j.\; (i < j) \;\Longrightarrow\; (a_i, a_j) \in \textsf{lo}. \]
\item Elements are inserted at the specified position:
if $\mathit{op} = \textsf{ins}(a, k)$, then $a = a_{\mathrm{min} \{k,\; n-1\}}$.
\end{enumerate}
\item The list order $\textsf{lo}$ is transitive, irreflexive and total, and
thus determines the order of all insert operations in the execution.
\end{enumerate}
\end{displayquote}

This specification considers only insertion and deletion operations, but no
assignment. Moreover, it considers only a single list object, not a graph of
composable objects like in our paper. Thus, we prove the relationship to
$\mathcal{A}_\textsf{strong}$ using a simplified interpretation function that
defines only insertion and deletion on a single list.\<close>

theory List_Spec
  imports Insert_Spec
begin

text\<open>We first define a datatype for list operations, with two constructors:
\isa{Insert ref val}, and \isa{Delete ref}. For insertion, the \isa{ref} argument
is the ID of the existing element after which we want to insert, or \isa{None}
to insert at the head of the list.
The \isa{val} argument is an arbitrary value to associate with the list element.
For deletion, the \isa{ref} argument is the ID of the existing list element
to delete.\<close>

datatype ('oid, 'val) list_op =
  Insert "'oid option" "'val" |
  Delete "'oid"

text\<open>When interpreting operations, the result is a pair (\isa{list, vals}).
The \isa{list} contains the IDs of list elements in the correct order
(equivalent to the list relation in the paper), and \isa{vals} is a mapping
from list element IDs to values (equivalent to the element relation in the paper).

Insertion delegates to the previously defined \isa{insert-spec} interpretation
function. Deleting a list element removes it from \isa{vals}.\<close>

fun interp_op :: "('oid list \<times> ('oid \<rightharpoonup> 'val)) \<Rightarrow> ('oid \<times> ('oid, 'val) list_op)
               \<Rightarrow> ('oid list \<times> ('oid \<rightharpoonup> 'val))" where
  "interp_op (list, vals) (oid, Insert ref val) = (insert_spec list (oid, ref), vals(oid \<mapsto> val))" |
  "interp_op (list, vals) (oid, Delete ref    ) = (list, vals(ref := None))"

definition interp_ops :: "('oid \<times> ('oid, 'val) list_op) list \<Rightarrow> ('oid list \<times> ('oid \<rightharpoonup> 'val))" where
  "interp_ops ops \<equiv> foldl interp_op ([], Map.empty) ops"

text\<open>\isa{list-order ops x y} holds iff, after interpreting the list of
operations \isa{ops}, the list element with ID \isa{x} appears before the
list element with ID \isa{y} in the resulting list.\<close>

definition list_order :: "('oid \<times> ('oid, 'val) list_op) list \<Rightarrow> 'oid \<Rightarrow> 'oid \<Rightarrow> bool" where
  "list_order ops x y \<equiv> \<exists>xs ys zs. fst (interp_ops ops) = xs @ [x] @ ys @ [y] @ zs"

text\<open>The \isa{make-insert} function generates a new operation for insertion into
a given index in a given list.
The exclamation mark is Isabelle's list subscript operator.\<close>

fun make_insert :: "'oid list \<Rightarrow> 'val \<Rightarrow> nat \<Rightarrow> ('oid, 'val) list_op" where
  "make_insert list val 0       = Insert None val" |
  "make_insert []   val k       = Insert None val" |
  "make_insert list val (Suc k) = Insert (Some (list ! (min k (length list - 1)))) val"

text\<open>The \isa{list-ops} predicate is a specialisation of \isa{spec-ops} to
the \isa{list-op} datatype: it describes a list of (ID, operation) pairs that
is sorted by ID, and can thus be used for the sequential interpretation of
the OpSet.\<close>

fun list_op_deps :: "('oid, 'val) list_op \<Rightarrow> 'oid set" where
  "list_op_deps (Insert (Some ref) _) = {ref}" |
  "list_op_deps (Insert  None      _) = {}"    |
  "list_op_deps (Delete  ref        ) = {ref}"

locale list_opset = opset opset list_op_deps
  for opset :: "('oid::{linorder} \<times> ('oid, 'val) list_op) set"

definition list_ops :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> bool" where
  "list_ops ops \<equiv> spec_ops ops list_op_deps"

subsection\<open>Lemmas about insertion and deletion\<close>

definition insertions :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> ('oid \<times> 'oid option) list" where
  "insertions ops \<equiv> List.map_filter (\<lambda>oper.
      case oper of (oid, Insert ref val) \<Rightarrow> Some (oid, ref) |
                   (oid, Delete ref    ) \<Rightarrow> None) ops"

definition inserted_ids :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> 'oid list" where
  "inserted_ids ops \<equiv> List.map_filter (\<lambda>oper.
      case oper of (oid, Insert ref val) \<Rightarrow> Some oid |
                   (oid, Delete ref    ) \<Rightarrow> None) ops"

definition deleted_ids :: "('oid::{linorder} \<times> ('oid, 'val) list_op) list \<Rightarrow> 'oid list" where
  "deleted_ids ops \<equiv> List.map_filter (\<lambda>oper.
      case oper of (oid, Insert ref val) \<Rightarrow> None |
                   (oid, Delete ref    ) \<Rightarrow> Some ref) ops"

lemma interp_ops_unfold_last:
  shows "interp_ops (xs @ [x]) = interp_op (interp_ops xs) x"
  by (simp add: interp_ops_def)

lemma map_filter_append:
  shows "List.map_filter P (xs @ ys) = List.map_filter P xs @ List.map_filter P ys"
  by (auto simp add: List.map_filter_def)

lemma map_filter_Some:
  assumes "P x = Some y"
  shows "List.map_filter P [x] = [y]"
  by (simp add: assms map_filter_simps(1) map_filter_simps(2))

lemma map_filter_None:
  assumes "P x = None"
  shows "List.map_filter P [x] = []"
  by (simp add: assms map_filter_simps(1) map_filter_simps(2))

lemma insertions_last_ins:
  shows "insertions (xs @ [(oid, Insert ref val)]) = insertions xs @ [(oid, ref)]"
  by (simp add: insertions_def map_filter_Some map_filter_append)

lemma insertions_last_del:
  shows "insertions (xs @ [(oid, Delete ref)]) = insertions xs"
  by (simp add: insertions_def map_filter_None map_filter_append)

lemma insertions_fst_subset:
  shows "set (map fst (insertions ops)) \<subseteq> set (map fst ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  then show "set (map fst (insertions [])) \<subseteq> set (map fst [])"
    by (simp add: insert_ops_def spec_ops_def insertions_def map_filter_def)
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "set (map fst (insertions (ops @ [a]))) \<subseteq> set (map fst (ops @ [a]))"
  proof(cases oper)
    case (Insert ref val)
    hence "insertions (ops @ [a]) = insertions ops @ [(oid, ref)]"
      by (simp add: a_pair insertions_last_ins)
    then show ?thesis using snoc.IH a_pair by auto
  next
    case (Delete ref)
    hence "insertions (ops @ [a]) = insertions ops"
      by (simp add: a_pair insertions_last_del)
    then show ?thesis using snoc.IH by auto
  qed
qed

lemma insertions_subset:
  assumes "list_ops A" and "list_ops B"
    and "set A \<subseteq> set B"
  shows "set (insertions A) \<subseteq> set (insertions B)"
  using assms proof(induction B arbitrary: A rule: List.rev_induct)
  case Nil
  then show "set (insertions A) \<subseteq> set (insertions [])"
    by (simp add: insertions_def map_filter_simps(2))
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  have "list_ops ops"
    using list_ops_def spec_ops_rem_last snoc.prems(2) by blast
  then show "set (insertions A) \<subseteq> set (insertions (ops @ [a]))"
  proof(cases "a \<in> set A")
    case True
    then obtain as bs where A_split: "A = as @ a # bs \<and> a \<notin> set as"
      by (meson split_list_first)
    hence "remove1 a A = as @ bs"
      by (simp add: remove1_append)
    hence as_bs: "insertions (remove1 a A) = insertions as @ insertions bs"
      by (simp add: insertions_def map_filter_append)
    moreover have "A = as @ [a] @ bs"
      by (simp add: A_split)
    hence as_a_bs: "insertions A = insertions as @ insertions [a] @ insertions bs"
      by (metis insertions_def map_filter_append)
    moreover have IH: "set (insertions (remove1 a A)) \<subseteq> set (insertions ops)"
    proof -
      have "list_ops (remove1 a A)"
        using snoc.prems(1) list_ops_def spec_ops_remove1 by blast
      moreover have "set (remove1 a A) \<subseteq> set ops"
      proof -
        have "distinct A"
          using snoc.prems(1) list_ops_def spec_ops_distinct by blast
        hence "a \<notin> set (remove1 a A)"
          by auto
        moreover have "set (ops @ [a]) = set ops \<union> {a}"
          by auto
        moreover have "set (remove1 a A) \<subseteq> set A"
          by (simp add: set_remove1_subset)
        ultimately show "set (remove1 a A) \<subseteq> set ops"
          using snoc.prems(3) by blast
      qed
      ultimately show ?thesis
        by (simp add: \<open>list_ops ops\<close> snoc.IH)
    qed
    ultimately show ?thesis
    proof(cases oper)
      case (Insert ref val)
      hence "insertions [a] = [(oid, ref)]"
        by (simp add: insertions_def map_filter_Some a_pair)
      hence "set (insertions A) = set (insertions (remove1 a A)) \<union> {(oid, ref)}"
        using as_a_bs as_bs by auto
      moreover have "set (insertions (ops @ [a])) = set (insertions ops) \<union> {(oid, ref)}"
        by (simp add: Insert a_pair insertions_last_ins)
      ultimately show ?thesis
        using IH by auto
    next
      case (Delete ref)
      hence "insertions [a] = []"
        by (simp add: insertions_def map_filter_None a_pair)
      hence "set (insertions A) = set (insertions (remove1 a A))"
        using as_a_bs as_bs by auto
      moreover have "set (insertions (ops @ [a])) = set (insertions ops)"
        by (simp add: Delete a_pair insertions_last_del)
      ultimately show ?thesis
        using IH by auto
    qed
  next
    case False
    hence "set A \<subseteq> set ops"
      using DiffE snoc.prems by auto
    hence "set (insertions A) \<subseteq> set (insertions ops)"
      using snoc.IH snoc.prems(1) \<open>list_ops ops\<close> by blast
    moreover have "set (insertions ops) \<subseteq> set (insertions (ops @ [a]))"
      by (simp add: insertions_def map_filter_append)
    ultimately show ?thesis
      by blast
  qed
qed

lemma list_ops_insertions:
  assumes "list_ops ops"
  shows "insert_ops (insertions ops)"
  using assms proof(induction ops rule: List.rev_induct)
  case Nil
  then show "insert_ops (insertions [])"
    by (simp add: insert_ops_def spec_ops_def insertions_def map_filter_def)
next
  case (snoc a ops)
  hence IH: "insert_ops (insertions ops)"
    using list_ops_def spec_ops_rem_last by blast
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "insert_ops (insertions (ops @ [a]))"
  proof(cases oper)
    case (Insert ref val)
    hence "insertions (ops @ [a]) = insertions ops @ [(oid, ref)]"
      by (simp add: a_pair insertions_last_ins)
    moreover have "\<And>i. i \<in> set (map fst ops) \<Longrightarrow> i < oid"
      using a_pair list_ops_def snoc.prems spec_ops_id_inc by fastforce
    hence "\<And>i. i \<in> set (map fst (insertions ops)) \<Longrightarrow> i < oid"
      using insertions_fst_subset by blast
    moreover have "list_op_deps oper = set_option ref"
      using Insert by (cases ref, auto)
    hence "\<And>r. r \<in> set_option ref \<Longrightarrow> r < oid"
      using list_ops_def spec_ops_ref_less
      by (metis a_pair last_in_set snoc.prems snoc_eq_iff_butlast)
    ultimately show ?thesis
      using IH insert_ops_def spec_ops_add_last by metis
  next
    case (Delete ref)
    hence "insertions (ops @ [a]) = insertions ops"
      by (simp add: a_pair insertions_last_del)
    then show ?thesis by (simp add: IH)
  qed
qed

lemma inserted_ids_last_ins:
  shows "inserted_ids (xs @ [(oid, Insert ref val)]) = inserted_ids xs @ [oid]"
  by (simp add: inserted_ids_def map_filter_Some map_filter_append)

lemma inserted_ids_last_del:
  shows "inserted_ids (xs @ [(oid, Delete ref)]) = inserted_ids xs"
  by (simp add: inserted_ids_def map_filter_None map_filter_append)

lemma inserted_ids_exist:
  shows "oid \<in> set (inserted_ids ops) \<longleftrightarrow> (\<exists>ref val. (oid, Insert ref val) \<in> set ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  then show "oid \<in> set (inserted_ids []) \<longleftrightarrow> (\<exists>ref val. (oid, Insert ref val) \<in> set [])"
    by (simp add: inserted_ids_def List.map_filter_def)
next
  case (snoc a ops)
  obtain i oper where a_pair: "a = (i, oper)"
    by fastforce
  then show "oid \<in> set (inserted_ids (ops @ [a])) \<longleftrightarrow>
             (\<exists>ref val. (oid, Insert ref val) \<in> set (ops @ [a]))"
  proof(cases oper)
    case (Insert r v)
    moreover from this have "inserted_ids (ops @ [a]) = inserted_ids ops @ [i]"
      by (simp add: a_pair inserted_ids_last_ins)
    ultimately show ?thesis
      using snoc.IH a_pair by auto
  next
    case (Delete r)
    moreover from this have "inserted_ids (ops @ [a]) = inserted_ids ops"
      by (simp add: a_pair inserted_ids_last_del)
    ultimately show ?thesis
      by (simp add: a_pair snoc.IH)
  qed
qed

lemma deleted_ids_last_ins:
  shows "deleted_ids (xs @ [(oid, Insert ref val)]) = deleted_ids xs"
  by (simp add: deleted_ids_def map_filter_None map_filter_append)

lemma deleted_ids_last_del:
  shows "deleted_ids (xs @ [(oid, Delete ref)]) = deleted_ids xs @ [ref]"
  by (simp add: deleted_ids_def map_filter_Some map_filter_append)

lemma deleted_ids_exist:
  shows "ref \<in> set (deleted_ids ops) \<longleftrightarrow> (\<exists>i. (i, Delete ref) \<in> set ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  then show "ref \<in> set (deleted_ids []) \<longleftrightarrow> (\<exists>i. (i, Delete ref) \<in> set [])"
    by (simp add: deleted_ids_def List.map_filter_def)
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "ref \<in> set (deleted_ids (ops @ [a])) \<longleftrightarrow> (\<exists>i. (i, Delete ref) \<in> set (ops @ [a]))"
  proof(cases oper)
    case (Insert r v)
    moreover from this have "deleted_ids (ops @ [a]) = deleted_ids ops"
      by (simp add: a_pair deleted_ids_last_ins)
    ultimately show ?thesis
      using a_pair snoc.IH by auto
  next
    case (Delete r)
    moreover from this have "deleted_ids (ops @ [a]) = deleted_ids ops @ [r]"
      by (simp add: a_pair deleted_ids_last_del)
    ultimately show ?thesis
      using a_pair snoc.IH by auto
  qed
qed

lemma deleted_ids_refs_older:
  assumes "list_ops (ops @ [(oid, oper)])"
  shows "\<And>ref. ref \<in> set (deleted_ids ops) \<Longrightarrow> ref < oid"
proof -
  fix ref
  assume "ref \<in> set (deleted_ids ops)"
  then obtain i where in_ops: "(i, Delete ref) \<in> set ops"
    using deleted_ids_exist by blast
  have "ref < i"
  proof -
    have "\<And>i oper r. (i, oper) \<in> set ops \<Longrightarrow> r \<in> list_op_deps oper \<Longrightarrow> r < i"
      by (meson assms list_ops_def spec_ops_ref_less spec_ops_rem_last)
    thus "ref < i"
      using in_ops by auto
  qed
  moreover have "i < oid"
  proof -
    have "\<And>i. i \<in> set (map fst ops) \<Longrightarrow> i < oid"
      using assms by (simp add: list_ops_def spec_ops_id_inc)
    thus ?thesis
      by (metis in_ops in_set_zipE zip_map_fst_snd)
  qed
  ultimately show "ref < oid"
    using order.strict_trans by blast
qed

subsection\<open>Lemmas about interpreting operations\<close>

lemma interp_ops_list_equiv:
  shows "fst (interp_ops ops) = interp_ins (insertions ops)"
proof(induction ops rule: List.rev_induct)
  case Nil
  have 1: "fst (interp_ops []) = []"
    by (simp add: interp_ops_def)
  have 2: "interp_ins (insertions []) = []"
    by (simp add: insertions_def map_filter_def interp_ins_def)
  show "fst (interp_ops []) = interp_ins (insertions [])"
    by (simp add: 1 2)
next
  case (snoc a ops)
  obtain oid oper where a_pair: "a = (oid, oper)"
    by fastforce
  then show "fst (interp_ops (ops @ [a])) = interp_ins (insertions (ops @ [a]))"
  proof(cases oper)
    case (Insert ref val)
    hence "insertions (ops @ [a]) = insertions ops @ [(oid, ref)]"
      by (simp add: a_pair insertions_last_ins)
    hence "interp_ins (insertions (ops @ [a])) = insert_spec (interp_ins (insertions ops)) (oid, ref)"
      by (simp add: interp_ins_tail_unfold)
    moreover have "fst (interp_ops (ops @ [a])) = insert_spec (fst (interp_ops ops)) (oid, ref)"
      by (metis Insert a_pair fst_conv interp_op.simps(1) interp_ops_unfold_last prod.collapse)
    ultimately show ?thesis
      using snoc.IH by auto
  next
    case (Delete ref)
    hence "insertions (ops @ [a]) = insertions ops"
      by (simp add: a_pair insertions_last_del)
    moreover have "fst (interp_ops (ops @ [a])) = fst (interp_ops ops)"
      by (metis Delete a_pair eq_fst_iff interp_op.simps(2) interp_ops_unfold_last)
    ultimately show ?thesis
      using snoc.IH by auto
  qed
qed

lemma interp_ops_distinct:
  assumes "list_ops ops"
  shows "distinct (fst (interp_ops ops))"
  by (simp add: assms interp_ins_distinct interp_ops_list_equiv list_ops_insertions)

lemma list_order_equiv:
  shows "list_order ops x y \<longleftrightarrow> Insert_Spec.list_order (insertions ops) x y"
  by (simp add: Insert_Spec.list_order_def List_Spec.list_order_def interp_ops_list_equiv)

lemma interp_ops_vals_domain:
  assumes "list_ops ops"
  shows "dom (snd (interp_ops ops)) = set (inserted_ids ops) - set (deleted_ids ops)"
  using assms proof(induction ops rule: List.rev_induct)
  case Nil
  have 1: "interp_ops [] = ([], Map.empty)"
    by (simp add: interp_ops_def)
  moreover have 2: "inserted_ids [] = []" and "deleted_ids [] = []"
    by (auto simp add: inserted_ids_def deleted_ids_def map_filter_simps(2))
  ultimately show "dom (snd (interp_ops [])) = set (inserted_ids []) - set (deleted_ids [])"
    by (simp add: 1 2)
next
  case (snoc x xs)
  hence IH: "dom (snd (interp_ops xs)) = set (inserted_ids xs) - set (deleted_ids xs)"
    using list_ops_def spec_ops_rem_last by blast
  obtain oid oper where x_pair: "x = (oid, oper)"
    by fastforce
  obtain list vals where interp_xs: "interp_ops xs = (list, vals)"
    by fastforce
  then show "dom (snd (interp_ops (xs @ [x]))) =
             set (inserted_ids (xs @ [x])) - set (deleted_ids (xs @ [x]))"
  proof(cases oper)
    case (Insert ref val)
    hence "interp_ops (xs @ [x]) = (insert_spec list (oid, ref), vals(oid \<mapsto> val))"
      by (simp add: interp_ops_unfold_last interp_xs x_pair)
    hence "dom (snd (interp_ops (xs @ [x]))) = (dom vals) \<union> {oid}"
      by simp
    moreover have "set (inserted_ids xs) - set (deleted_ids xs) = dom vals"
      using IH interp_xs by auto
    moreover have "inserted_ids (xs @ [x]) = inserted_ids xs @ [oid]"
      by (simp add: Insert inserted_ids_last_ins x_pair)
    moreover have "deleted_ids (xs @ [x]) = deleted_ids xs"
      by (simp add: Insert deleted_ids_last_ins x_pair)
    hence "set (inserted_ids (xs @ [x])) - set (deleted_ids (xs @ [x])) =
           {oid} \<union> set (inserted_ids xs) - set (deleted_ids xs)"
      using calculation(3) by auto
    moreover have "... = {oid} \<union> (set (inserted_ids xs) - set (deleted_ids xs))"
      using deleted_ids_refs_older snoc.prems x_pair by blast
    ultimately show ?thesis by auto
  next
    case (Delete ref)
    hence "interp_ops (xs @ [x]) = (list, vals(ref := None))"
      by (simp add: interp_ops_unfold_last interp_xs x_pair)
    hence "dom (snd (interp_ops (xs @ [x]))) = (dom vals) - {ref}"
      by simp
    moreover have "set (inserted_ids xs) - set (deleted_ids xs) = dom vals"
      using IH interp_xs by auto
    moreover have "inserted_ids (xs @ [x]) = inserted_ids xs"
      by (simp add: Delete inserted_ids_last_del x_pair)
    moreover have "deleted_ids (xs @ [x]) = deleted_ids xs @ [ref]"
      by (simp add: Delete deleted_ids_last_del x_pair)
    hence "set (inserted_ids (xs @ [x])) - set (deleted_ids (xs @ [x])) =
           set (inserted_ids xs) - (set (deleted_ids xs) \<union> {ref})"
      using calculation(3) by auto
    moreover have "... = set (inserted_ids xs) - set (deleted_ids xs) - {ref}"
      by blast
    ultimately show ?thesis by auto
  qed
qed

lemma insert_spec_nth_oid:
  assumes "distinct xs"
    and "n < length xs"
  shows "insert_spec xs (oid, Some (xs ! n)) ! Suc n = oid"
  using assms proof(induction xs arbitrary: n)
  case Nil
  then show "insert_spec [] (oid, Some ([] ! n)) ! Suc n = oid"
    by simp
next
  case (Cons a xs)
  have "distinct (a # xs)"
    using Cons.prems(1) by auto
  then show "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) ! Suc n = oid"
  proof(cases "a = (a # xs) ! n")
    case True
    then have "n = 0"
      using \<open>distinct (a # xs)\<close> Cons.prems(2) gr_implies_not_zero by force
    then show "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) ! Suc n = oid"
      by auto
  next
    case False
    then have "n > 0"
      using \<open>distinct (a # xs)\<close> Cons.prems(2) gr_implies_not_zero by force
    then obtain m where "n = Suc m"
      using Suc_pred' by blast
    then show "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) ! Suc n = oid"
      using Cons.IH Cons.prems by auto
  qed
qed

lemma insert_spec_inc_length:
  assumes "distinct xs"
    and "n < length xs"
  shows "length (insert_spec xs (oid, Some (xs ! n))) = Suc (length xs)"
  using assms proof(induction xs arbitrary: n, simp)
  case (Cons a xs)
  have "distinct (a # xs)"
    using Cons.prems(1) by auto
  then show "length (insert_spec (a # xs) (oid, Some ((a # xs) ! n))) = Suc (length (a # xs))"
  proof(cases n)
    case 0
    hence "insert_spec (a # xs) (oid, Some ((a # xs) ! n)) = a # oid # xs"
      by simp
    then show ?thesis
      by simp
  next
    case (Suc nat)
    hence "nat < length xs"
      using Cons.prems(2) by auto
    hence "length (insert_spec xs (oid, Some (xs ! nat))) = Suc (length xs)"
      using Cons.IH Cons.prems(1) by auto
    then show ?thesis
      by (simp add: Suc)
  qed
qed

lemma list_split_two_elems:
  assumes "distinct xs"
    and "x \<in> set xs" and "y \<in> set xs"
    and "x \<noteq> y"
  shows "\<exists>pre mid suf. xs = pre @ x # mid @ y # suf \<or> xs = pre @ y # mid @ x # suf"
proof -
  obtain as bs where as_bs: "xs = as @ [x] @ bs"
    using assms(2) split_list_first by fastforce
  show ?thesis
  proof(cases "y \<in> set as")
    case True
    then obtain cs ds where "as = cs @ [y] @ ds"
      using assms(3) split_list_first by fastforce
    then show ?thesis
      by (auto simp add: as_bs)
  next
    case False
    then have "y \<in> set bs"
      using as_bs assms(3) assms(4) by auto
    then obtain cs ds where "bs = cs @ [y] @ ds"
      using assms(3) split_list_first by fastforce
    then show ?thesis
      by (auto simp add: as_bs)
  qed
qed

subsection\<open>Satisfying all conditions of $\mathcal{A}_\textsf{strong}$\<close>

text\<open>Part 1(a) of Attiya et al.'s specification states that whenever the
list is observed, the elements of the list are exactly those that have
been inserted but not deleted. $\mathcal{A}_\textsf{strong}$ uses the
visibility relation $\le_\textsf{vis}$ to capture the operations known
to a node at some arbitrary point in the execution; in the OpSet model,
we can simply prove the theorem for an arbitrary OpSet, since the
contents of the OpSet at a particular time on a particular node correspond
exactly to the set of operations known to that node at that time.\<close>

theorem inserted_but_not_deleted:
  assumes "list_ops ops"
    and "interp_ops ops = (list, vals)"
  shows "a \<in> dom (vals) \<longleftrightarrow> (\<exists>ref val. (a, Insert ref val) \<in> set ops) \<and>
                            (\<nexists>i. (i, Delete a) \<in> set ops)"
  using assms deleted_ids_exist inserted_ids_exist interp_ops_vals_domain
  by (metis Diff_iff snd_conv)

text\<open>Part 1(b) states that whenever the list is observed, the order of
list elements is consistent with the global list order. We can define the
global list order simply as the list order that arises from interpreting
the OpSet containing all operations in the entire execution. Then, at any
point in the execution, the OpSet is some subset of the set of all
operations.

We can then rephrase condition 1(b) as follows: whenever list element \isa{x}
appears before list element \isa{y} in the interpretation of \isa{some-ops},
then for any OpSet \isa{all-ops} that is a superset of \isa{some-ops},
\isa{x} must also appear before \isa{y} in the interpretation of \isa{all-ops}.
In other words, adding more operations to the OpSet does not change the
relative order of any existing list elements.\<close>

theorem list_order_consistent:
  assumes "list_ops some_ops" and "list_ops all_ops"
    and "set some_ops \<subseteq> set all_ops"
    and "list_order some_ops x y"
  shows "list_order all_ops x y"
  using assms list_order_monotonic list_ops_insertions insertions_subset list_order_equiv by metis

text\<open>Part 1(c) states that inserted elements appear at the specified position:
that is, immediately after an insertion of \isa{oid} at index \isa{k}, the list
index \isa{k} does indeed contain \isa{oid} (provided that \isa{k} is less than the
length of the list). We prove this property below.\<close>

theorem correct_position_insert:
  assumes "list_ops (ops @ [(oid, ins)])"
    and "ins = make_insert (fst (interp_ops ops)) val k"
    and "list = fst (interp_ops (ops @ [(oid, ins)]))"
  shows "list ! (min k (length list - 1)) = oid"
proof(cases "k = 0 \<or> fst (interp_ops ops) = []")
  case True
  moreover from this
  have "make_insert (fst (interp_ops ops)) val k = Insert None val"
    and min_k: "min k (length (fst (interp_ops ops))) = 0"
    by (cases k, auto)
  hence "fst (interp_ops (ops @ [(oid, ins)])) = oid # fst (interp_ops ops)"
    using assms(2) interp_ops_unfold_last
    by (metis fst_conv insert_spec.simps(1) interp_op.simps(1) prod.collapse)
  ultimately show ?thesis
    by (simp add: min_k assms(3))
next
  case False
  moreover from this have "k > 0" and "fst (interp_ops ops) \<noteq> []"
    using neq0_conv by blast+
  from this obtain nat where "k = Suc nat"
    using gr0_implies_Suc by blast
  hence "make_insert (fst (interp_ops ops)) val k =
      Insert (Some ((fst (interp_ops ops)) ! (min nat (length (fst (interp_ops ops)) - 1)))) val"
    using False by (cases "fst (interp_ops ops)", auto)
  hence "fst (interp_ops (ops @ [(oid, ins)])) =
         insert_spec (fst (interp_ops ops)) (oid, Some ((fst (interp_ops ops)) ! (min nat (length (fst (interp_ops ops)) - 1))))"
    by (metis assms(2) fst_conv interp_op.simps(1) interp_ops_unfold_last prod.collapse)
  moreover have "min nat (length (fst (interp_ops ops)) - 1) < length (fst (interp_ops ops))"
    by (simp add: \<open>fst (interp_ops ops) \<noteq> []\<close> min.strict_coboundedI2)
  moreover have "distinct (fst (interp_ops ops))"
    using interp_ops_distinct list_ops_def spec_ops_rem_last assms(1) by blast
  moreover have "length list = Suc (length (fst (interp_ops ops)))"
    using assms(3) calculation by (simp add: insert_spec_inc_length)
  ultimately show ?thesis
    using assms insert_spec_nth_oid
    by (metis Suc_diff_1 \<open>k = Suc nat\<close> diff_Suc_1 length_greater_0_conv min_Suc_Suc)
qed

text\<open>Part 2 states that the list order relation must be transitive, irreflexive,
and total. These three properties are straightforward to prove, using our
definition of the \isa{list-order} predicate.\<close>

theorem list_order_trans:
  assumes "list_ops ops"
    and "list_order ops x y"
    and "list_order ops y z"
  shows "list_order ops x z"
  using assms list_order_trans list_ops_insertions list_order_equiv by blast

theorem list_order_irrefl:
  assumes "list_ops ops"
  shows "\<not> list_order ops x x"
proof -
  have "list_order ops x x \<Longrightarrow> False"
  proof -
    assume "list_order ops x x"
    then obtain xs ys zs where split: "fst (interp_ops ops) = xs @ [x] @ ys @ [x] @ zs"
      by (meson List_Spec.list_order_def)
    moreover have "distinct (fst (interp_ops ops))"
      by (simp add: assms interp_ops_distinct)
    ultimately show False
      by (simp add: split)
  qed
  thus "\<not> list_order ops x x"
    by blast
qed

theorem list_order_total:
  assumes "list_ops ops"
    and "x \<in> set (fst (interp_ops ops))"
    and "y \<in> set (fst (interp_ops ops))"
    and "x \<noteq> y"
  shows "list_order ops x y \<or> list_order ops y x"
proof -
  have "distinct (fst (interp_ops ops))"
    using assms(1) by (simp add: interp_ops_distinct)
  then obtain pre mid suf
    where "fst (interp_ops ops) = pre @ x # mid @ y # suf \<or>
           fst (interp_ops ops) = pre @ y # mid @ x # suf"
    using list_split_two_elems assms by metis
  then show "list_order ops x y \<or> list_order ops y x"
    by (simp add: list_order_def, blast)
qed

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Cong
  imports Weak_Late_Bisim Weak_Late_Step_Sim Strong_Late_Bisim
begin

definition congruence :: "(pi \<times> pi) set" where
  "congruence \<equiv> {(P, Q) |P Q. P \<leadsto><weakBisim> Q \<and> Q \<leadsto><weakBisim> P}"
abbreviation congruenceJudge (infixr "\<simeq>" 65) where "P \<simeq> Q \<equiv> (P, Q) \<in> congruence"

lemma unfoldE:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<simeq> Q"

  shows "P \<leadsto><weakBisim> Q"
  and   "Q \<leadsto><weakBisim> P"
proof -
  from assms show "P \<leadsto><weakBisim> Q" by(force simp add: congruence_def)
next
  from assms show "Q \<leadsto><weakBisim> P" by(force simp add: congruence_def)
qed

lemma unfoldI:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<leadsto><weakBisim> Q"
  and     "Q \<leadsto><weakBisim> P"

  shows "P \<simeq> Q"
using assms by(force simp add: congruence_def)

lemma eqvt:
  shows "eqvt congruence"
proof -
  have "\<And>P Q (perm::name prm). P \<leadsto><weakBisim> Q \<Longrightarrow> (perm \<bullet> P) \<leadsto><weakBisim> (perm \<bullet> Q)"
  proof -
    fix P Q perm
    assume "P \<leadsto><weakBisim> Q"
    thus "((perm::name prm) \<bullet> P) \<leadsto><weakBisim> (perm \<bullet> Q)"
      apply -
      by(blast intro: Weak_Late_Step_Sim.eqvtI Weak_Late_Bisim.eqvt)
  qed
  thus ?thesis
    by(simp add: congruence_def eqvt_def)
qed

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<simeq> Q"

  shows "(perm \<bullet> P) \<simeq> (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma strongBisimWeakEq:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "P \<simeq> Q"
proof -
  have "\<And>P Q. P \<leadsto>[bisim] Q \<Longrightarrow> P \<leadsto><weakBisim> Q"
  proof -
    fix P Q
    assume "P \<leadsto>[bisim] Q"
    hence "P \<leadsto><bisim> Q" by(rule strongSimWeakEqSim)
    moreover have "bisim \<subseteq> weakBisim"
      by(auto intro: strongBisimWeakBisim)
    ultimately show "P \<leadsto><weakBisim> Q" by(rule Weak_Late_Step_Sim.monotonic)
  qed
  with assms show ?thesis
    by(blast intro: unfoldI dest: Strong_Late_Bisim.bisimE Strong_Late_Bisim.symmetric)
qed

lemma congruenceWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "P \<approx> Q"
proof -
  let ?X = "{(P, Q) | P Q. P \<simeq> Q}"
  from assms have "(P, Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    {
      fix P Q
      assume "P \<simeq> Q"
      hence "P \<leadsto><weakBisim> Q" by(simp add: congruence_def)
      hence "P \<leadsto><(?X \<union> weakBisim)> Q" by(rule_tac Weak_Late_Step_Sim.monotonic) auto
      hence "P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> Q" by(rule Weak_Late_Step_Sim.weakSimWeakEqSim)
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto simp add: congruence_def)
  qed
qed

lemma congruenceSubsetWeakBisim:
  shows "congruence \<subseteq> weakBisim"
by(auto intro: congruenceWeakBisim)

lemma reflexive:
  fixes P :: pi

  shows "P \<simeq> P"
proof -
  from Weak_Late_Bisim.reflexive have "\<And>P. P \<leadsto><weakBisim> P"
    by(blast intro: Weak_Late_Step_Sim.reflexive)
  thus ?thesis
    by(force simp add: substClosed_def congruence_def)
qed

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "Q \<simeq> P"
using assms
by(force simp add: substClosed_def congruence_def)

end