(*  Title:      HOL/HOLCF/ex/Loop.thy
    Author:     Franz Regensburger
*)

section {* Theory for a loop primitive like while *}

theory Loop
imports HOLCF
begin

definition
  step  :: "('a -> tr)->('a -> 'a)->'a->'a" where
  "step = (LAM b g x. If b$x then g$x else x)"

definition
  while :: "('a -> tr)->('a -> 'a)->'a->'a" where
  "while = (LAM b g. fix$(LAM f x. If b$x then f$(g$x) else x))"

(* ------------------------------------------------------------------------- *)
(* access to definitions                                                     *)
(* ------------------------------------------------------------------------- *)

lemma step_def2: "step$b$g$x = If b$x then g$x else x"
apply (unfold step_def)
apply simp
done

lemma while_def2: "while$b$g = fix$(LAM f x. If b$x then f$(g$x) else x)"
apply (unfold while_def)
apply simp
done

(* ------------------------------------------------------------------------- *)
(* rekursive properties of while                                             *)
(* ------------------------------------------------------------------------- *)

lemma while_unfold: "while$b$g$x = If b$x then while$b$g$(g$x) else x"
apply (rule trans)
apply (rule while_def2 [THEN fix_eq5])
apply simp
done

lemma while_unfold2: "ALL x. while$b$g$x = while$b$g$(iterate k$(step$b$g)$x)"
apply (induct_tac k)
apply simp
apply (rule allI)
apply (rule trans)
apply (rule while_unfold)
apply (subst iterate_Suc2)
apply (rule trans)
apply (erule_tac [2] spec)
apply (subst step_def2)
apply (rule_tac p = "b$x" in trE)
apply simp
apply (subst while_unfold)
apply (rule_tac s = "UU" and t = "b$UU" in ssubst)
apply (erule strictI)
apply simp
apply simp
apply simp
apply (subst while_unfold)
apply simp
done

lemma while_unfold3: "while$b$g$x = while$b$g$(step$b$g$x)"
apply (rule_tac s = "while$b$g$ (iterate (Suc 0) $ (step$b$g) $x) " in trans)
apply (rule while_unfold2 [THEN spec])
apply simp
done

(* ------------------------------------------------------------------------- *)
(* properties of while and iterations                                        *)
(* ------------------------------------------------------------------------- *)

lemma loop_lemma1: "[| EX y. b$y=FF; iterate k$(step$b$g)$x = UU |]
     ==>iterate(Suc k)$(step$b$g)$x=UU"
apply (simp (no_asm))
apply (rule trans)
apply (rule step_def2)
apply simp
apply (erule exE)
apply (erule flat_codom [THEN disjE])
apply simp_all
done

lemma loop_lemma2: "[|EX y. b$y=FF;iterate (Suc k)$(step$b$g)$x ~=UU |]==>
      iterate k$(step$b$g)$x ~=UU"
apply (blast intro: loop_lemma1)
done

lemma loop_lemma3 [rule_format (no_asm)]:
  "[| ALL x. INV x & b$x=TT & g$x~=UU --> INV (g$x);
         EX y. b$y=FF; INV x |]
      ==> iterate k$(step$b$g)$x ~=UU --> INV (iterate k$(step$b$g)$x)"
apply (induct_tac "k")
apply (simp (no_asm_simp))
apply (intro strip)
apply (simp (no_asm) add: step_def2)
apply (rule_tac p = "b$ (iterate n$ (step$b$g) $x) " in trE)
apply (erule notE)
apply (simp add: step_def2)
apply (simp (no_asm_simp))
apply (rule mp)
apply (erule spec)
apply (simp (no_asm_simp) del: iterate_Suc add: loop_lemma2)
apply (rule_tac s = "iterate (Suc n) $ (step$b$g) $x"
  and t = "g$ (iterate n$ (step$b$g) $x) " in ssubst)
prefer 2 apply (assumption)
apply (simp add: step_def2)
apply (drule (1) loop_lemma2, simp)
done

lemma loop_lemma4 [rule_format]:
  "ALL x. b$(iterate k$(step$b$g)$x)=FF --> while$b$g$x= iterate k$(step$b$g)$x"
apply (induct_tac k)
apply (simp (no_asm))
apply (intro strip)
apply (simplesubst while_unfold)
apply simp
apply (rule allI)
apply (simplesubst iterate_Suc2)
apply (intro strip)
apply (rule trans)
apply (rule while_unfold3)
apply simp
done

lemma loop_lemma5 [rule_format (no_asm)]:
  "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==>
    ALL m. while$b$g$(iterate m$(step$b$g)$x)=UU"
apply (simplesubst while_def2)
apply (rule fix_ind)
apply simp
apply simp
apply (rule allI)
apply (simp (no_asm))
apply (rule_tac p = "b$ (iterate m$ (step$b$g) $x) " in trE)
apply (simp (no_asm_simp))
apply (simp (no_asm_simp))
apply (rule_tac s = "xa$ (iterate (Suc m) $ (step$b$g) $x) " in trans)
apply (erule_tac [2] spec)
apply (rule cfun_arg_cong)
apply (rule trans)
apply (rule_tac [2] iterate_Suc [symmetric])
apply (simp add: step_def2)
apply blast
done

lemma loop_lemma6: "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==> while$b$g$x=UU"
apply (rule_tac t = "x" in iterate_0 [THEN subst])
apply (erule loop_lemma5)
done

lemma loop_lemma7: "while$b$g$x ~= UU ==> EX k. b$(iterate k$(step$b$g)$x) = FF"
apply (blast intro: loop_lemma6)
done

(* ------------------------------------------------------------------------- *)
(* an invariant rule for loops                                               *)
(* ------------------------------------------------------------------------- *)

lemma loop_inv2:
"[| (ALL y. INV y & b$y=TT & g$y ~= UU --> INV (g$y));
    (ALL y. INV y & b$y=FF --> Q y);
    INV x; while$b$g$x~=UU |] ==> Q (while$b$g$x)"
apply (rule_tac P = "%k. b$ (iterate k$ (step$b$g) $x) =FF" in exE)
apply (erule loop_lemma7)
apply (simplesubst loop_lemma4)
apply assumption
apply (drule spec, erule mp)
apply (rule conjI)
prefer 2 apply (assumption)
apply (rule loop_lemma3)
apply assumption
apply (blast intro: loop_lemma6)
apply assumption
apply (rotate_tac -1)
apply (simp add: loop_lemma4)
done

lemma loop_inv:
  assumes premP: "P(x)"
    and premI: "!!y. P y ==> INV y"
    and premTT: "!!y. [| INV y; b$y=TT; g$y~=UU|] ==> INV (g$y)"
    and premFF: "!!y. [| INV y; b$y=FF|] ==> Q y"
    and premW: "while$b$g$x ~= UU"
  shows "Q (while$b$g$x)"
apply (rule loop_inv2)
apply (rule_tac [3] premP [THEN premI])
apply (rule_tac [3] premW)
apply (blast intro: premTT)
apply (blast intro: premFF)
done

end


section\<open>Some Classes of Pseudo-Hoops\<close>

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 "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(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 "(\<squnion>2)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(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: "(\<squnion>1) = (\<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"  "(l\<rightarrow>)"  "(r\<rightarrow>)"  "(\<le>)" "(<)" "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 (l\<rightarrow>) (\<le>) (<) 1 (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 "(\<sqinter>)" "(\<le>)" "(<)" "(\<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 "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(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 "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  by (simp add: sup1_assoc)

sublocale sup_assoc_pseudo_hoop_algebra <  sup2_lattice: pseudo_hoop_lattice "(\<squnion>2)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(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  "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(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 (\<le>) (<) 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 "(*)" "0"  "(\<sqinter>)" "(\<squnion>1)" "(l\<rightarrow>)" "(r\<rightarrow>)" "(\<le>)" "(<)"
  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" "(\<le>)" "(<)" "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 DirProds
  imports Finprod Group_Hom Finite_Cyclic
begin

(* Indexed direct outer product of groups (possibly infinite). Basically an
   indexed version of DirProd. Probably pretty ugly to use. *)
definition DirProds :: "('a \<Rightarrow> ('b, 'c) monoid_scheme) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) monoid" where
  "DirProds G I = \<lparr> carrier = Pi\<^sub>E I (carrier \<circ> G),
                   monoid.mult = (\<lambda>x y. restrict (\<lambda>i. x i \<otimes>\<^bsub>G i\<^esub> y i) I),
                   one = restrict (\<lambda>i. \<one>\<^bsub>G i\<^esub>) I \<rparr>"

lemma DirProds_empty:
  "carrier (DirProds f {}) = {\<one>\<^bsub>DirProds f {}\<^esub>}"
  unfolding DirProds_def by auto

lemma DirProds_order:
  assumes "finite I"
  shows "order (DirProds G I) = prod (order \<circ> G) I"
  unfolding order_def DirProds_def using assms by (simp add: card_PiE)

lemma DirProds_in_carrI:
  assumes "\<And>i. i \<in> I \<Longrightarrow> x i \<in> carrier (G i)" "\<And>i. i \<notin> I \<Longrightarrow> x i = undefined"
  shows "x \<in> carrier (DirProds G I)"
  unfolding DirProds_def using assms by auto

lemma comp_in_carr:
  assumes "x \<in> carrier (DirProds G I)" "i \<in> I"
  shows "x i \<in> carrier (G i)"
  using assms unfolding DirProds_def by auto

lemma comp_mult:
  assumes "i \<in> I"
  shows "(x \<otimes>\<^bsub>DirProds G I\<^esub> y) i = (x i \<otimes>\<^bsub>G i\<^esub> y i)"
  using assms unfolding DirProds_def by simp

lemma comp_exp_nat:
  fixes k::nat
  assumes "i \<in> I"
  shows "(x [^]\<^bsub>DirProds G I\<^esub> k) i = x i [^]\<^bsub>G i\<^esub> k"
proof (induction k)
  case 0
  then show ?case using assms unfolding DirProds_def by simp
next
  case i: (Suc k)
  have "(x [^]\<^bsub>DirProds G I\<^esub> k \<otimes>\<^bsub>DirProds G I\<^esub> x) i = (x [^]\<^bsub>DirProds G I\<^esub> k) i \<otimes>\<^bsub>G i\<^esub> x i"
    by(rule comp_mult[OF assms])
  also from i have "\<dots> = x i [^]\<^bsub>G i\<^esub> k \<otimes>\<^bsub>G i\<^esub> x i" by simp
  also have "\<dots> = x i [^]\<^bsub>G i\<^esub> Suc k" by simp
  finally show ?case by simp
qed

lemma DirProds_m_closed:
  assumes "x \<in> carrier (DirProds G I)" "y \<in> carrier (DirProds G I)" "\<And>i. i \<in> I \<Longrightarrow> group (G i)"
  shows "x \<otimes>\<^bsub>DirProds G I\<^esub> y \<in> carrier (DirProds G I)"
  using assms monoid.m_closed[OF group.is_monoid[OF assms(3)]] unfolding DirProds_def by fastforce

lemma partial_restr:
  assumes "a \<in> carrier (DirProds G I)" "J \<subseteq> I"
  shows "restrict a J \<in> carrier (DirProds G J)"
  using assms unfolding DirProds_def by auto

lemma eq_parts_imp_eq:
  assumes "a \<in> carrier (DirProds G I)" "b \<in> carrier (DirProds G I)" "\<And>i. i \<in> I \<Longrightarrow> a i = b i"
  shows "a = b"
  using assms unfolding DirProds_def by fastforce

lemma mult_restr:
  assumes "a \<in> carrier (DirProds G I)" "b \<in> carrier (DirProds G I)" "J \<subseteq> I"
  shows "a \<otimes>\<^bsub>DirProds G J\<^esub> b = restrict (a \<otimes>\<^bsub>DirProds G I\<^esub> b) J"
  using assms unfolding DirProds_def by force

lemma DirProds_one:
  assumes "x \<in> carrier (DirProds G I)"
  shows "(\<forall>i \<in> I. x i = \<one>\<^bsub>G i\<^esub>) \<longleftrightarrow> x = \<one>\<^bsub>DirProds G I\<^esub>"
  using assms unfolding DirProds_def by fastforce

lemma DirProds_one':
  "i\<in>I \<Longrightarrow> \<one>\<^bsub>DirProds G I\<^esub> i = \<one>\<^bsub>G i\<^esub>"
  unfolding DirProds_def by simp

lemma DirProds_one'':
  "\<one>\<^bsub>DirProds G I\<^esub> = restrict (\<lambda>i. \<one>\<^bsub>G i\<^esub>) I"
  by (unfold DirProds_def, simp)

lemma DirProds_mult:
  "(\<otimes>\<^bsub>DirProds G I\<^esub>) = (\<lambda>x y. restrict (\<lambda>i. x i \<otimes>\<^bsub>G i\<^esub> y i) I)"
  unfolding DirProds_def by simp

lemma DirProds_is_group:
  assumes "\<And>i. i \<in> I \<Longrightarrow> group (G i)"
  shows "group (DirProds G I)"
proof(rule groupI)
  show one_closed: "\<one>\<^bsub>DirProds G I\<^esub> \<in> carrier (DirProds G I)" unfolding DirProds_def
    by (simp add: assms group.is_monoid)
  fix x
  assume x: "x \<in> carrier (DirProds G I)"
  have one_: "\<And>i. i \<in> I \<Longrightarrow> \<one>\<^bsub>G i\<^esub> = \<one>\<^bsub>DirProds G I\<^esub> i" unfolding DirProds_def by simp
  have "\<And>i. i \<in> I \<Longrightarrow> \<one>\<^bsub>DirProds G I\<^esub> i \<otimes>\<^bsub>G i\<^esub> x i = x i"
  proof -
    fix i
    assume i: "i \<in> I"
    interpret group "G i" using assms[OF i] .
    have "x i \<in> carrier (G i)" using x i comp_in_carr by fast
    thus "\<one>\<^bsub>DirProds G I\<^esub> i \<otimes>\<^bsub>G i\<^esub> x i = x i" by(subst one_[OF i, symmetric]; simp)
  qed
  with one_ x show "\<one>\<^bsub>DirProds G I\<^esub> \<otimes>\<^bsub>DirProds G I\<^esub> x = x" unfolding DirProds_def by force
  have "restrict (\<lambda>i. inv\<^bsub>G i\<^esub> (x i)) I \<in> carrier (DirProds G I)" using x group.inv_closed[OF assms]
    unfolding DirProds_def by fastforce
  moreover have "restrict (\<lambda>i. inv\<^bsub>G i\<^esub> (x i)) I \<otimes>\<^bsub>DirProds G I\<^esub> x = \<one>\<^bsub>DirProds G I\<^esub>"
    using x group.l_inv[OF assms] unfolding DirProds_def by fastforce
  ultimately show "\<exists>y\<in>carrier (DirProds G I). y \<otimes>\<^bsub>DirProds G I\<^esub> x = \<one>\<^bsub>DirProds G I\<^esub>" by blast
  fix y
  assume y: "y \<in> carrier (DirProds G I)"
  from DirProds_m_closed[OF x y assms] show m_closed: "x \<otimes>\<^bsub>DirProds G I\<^esub> y \<in> carrier (DirProds G I)" by blast
  fix z
  assume z: "z \<in> carrier (DirProds G I)"
  have "\<And>i. i \<in> I \<Longrightarrow> (x \<otimes>\<^bsub>DirProds G I\<^esub> y \<otimes>\<^bsub>DirProds G I\<^esub> z) i = (x \<otimes>\<^bsub>DirProds G I\<^esub> (y \<otimes>\<^bsub>DirProds G I\<^esub> z)) i"
  proof -
    fix i
    assume i: "i \<in> I"
    have "(x \<otimes>\<^bsub>DirProds G I\<^esub> y \<otimes>\<^bsub>DirProds G I\<^esub> z) i = (x \<otimes>\<^bsub>DirProds G I\<^esub> y) i \<otimes>\<^bsub>G i\<^esub> z i"
      using assms by (simp add: comp_mult i m_closed z)
    also have "\<dots> = x i \<otimes>\<^bsub>G i\<^esub> y i \<otimes>\<^bsub>G i\<^esub> z i" by (simp add: assms comp_mult i x y)
    also have "\<dots> = x i \<otimes>\<^bsub>G i\<^esub> (y i \<otimes>\<^bsub>G i\<^esub> z i)" using i assms x y z
      by (meson Group.group_def comp_in_carr monoid.m_assoc)
    also have "\<dots> = (x \<otimes>\<^bsub>DirProds G I\<^esub> (y \<otimes>\<^bsub>DirProds G I\<^esub> z)) i" by (simp add: DirProds_def i)
    finally show "(x \<otimes>\<^bsub>DirProds G I\<^esub> y \<otimes>\<^bsub>DirProds G I\<^esub> z) i = (x \<otimes>\<^bsub>DirProds G I\<^esub> (y \<otimes>\<^bsub>DirProds G I\<^esub> z)) i" .
  qed
  thus "x \<otimes>\<^bsub>DirProds G I\<^esub> y \<otimes>\<^bsub>DirProds G I\<^esub> z = x \<otimes>\<^bsub>DirProds G I\<^esub> (y \<otimes>\<^bsub>DirProds G I\<^esub> z)" unfolding DirProds_def by auto
qed

lemma DirProds_obtain_elem_carr:
  assumes "group (DirProds G I)" "i \<in> I" "x \<in> carrier (G i)"
  obtains k where "k \<in> carrier (DirProds G I)" "k i = x"
proof -
  interpret DP: group "DirProds G I" by fact
  from comp_in_carr[OF DP.one_closed] DirProds_one' have ao: "\<forall>j\<in>I. \<one>\<^bsub>G j\<^esub> \<in> carrier (G j)" by metis
  let ?r = "restrict ((\<lambda>j. \<one>\<^bsub>G j\<^esub>)(i := x)) I"
  have "?r \<in> carrier (DirProds G I)" unfolding DirProds_def PiE_def Pi_def using assms(2, 3) ao by auto
  moreover have "?r i = x" using assms(2) by simp
  ultimately show "(\<And>k. \<lbrakk>k \<in> carrier (DirProds G I); k i = x\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis" by blast
qed

lemma DirProds_group_imp_groups:
  assumes "group (DirProds G I)" and i: "i \<in> I"
  shows "group (G i)"
proof (intro groupI)
  let ?DP = "DirProds G I"
  interpret DP: group ?DP by fact
  show "\<one>\<^bsub>G i\<^esub> \<in> carrier (G i)" using DirProds_one' comp_in_carr[OF DP.one_closed i] i by metis
  show "x \<otimes>\<^bsub>G i\<^esub> y \<in> carrier (G i)" if "x \<in> carrier (G i)" "y \<in> carrier (G i)" for x y
  proof -
    from DirProds_obtain_elem_carr[OF assms that(1)] obtain k where k: "k \<in> carrier ?DP" "k i = x" .
    from DirProds_obtain_elem_carr[OF assms that(2)] obtain l where l: "l \<in> carrier ?DP" "l i = y" .
    have "k \<otimes>\<^bsub>?DP\<^esub> l \<in> carrier ?DP" using k l by fast
    from comp_in_carr[OF this i] comp_mult[OF i] show ?thesis using k l by metis
  qed
  show "x \<otimes>\<^bsub>G i\<^esub> y \<otimes>\<^bsub>G i\<^esub> z = x \<otimes>\<^bsub>G i\<^esub> (y \<otimes>\<^bsub>G i\<^esub> z)"
    if x: "x \<in> carrier (G i)" and y: "y \<in> carrier (G i)" and z: "z \<in> carrier (G i)" for x y z
  proof -
    from DirProds_obtain_elem_carr[OF assms x] obtain k where k: "k \<in> carrier ?DP" "k i = x" .
    from DirProds_obtain_elem_carr[OF assms y] obtain l where l: "l \<in> carrier ?DP" "l i = y" .
    from DirProds_obtain_elem_carr[OF assms z] obtain m where m: "m \<in> carrier ?DP" "m i = z" .
    have "x \<otimes>\<^bsub>G i\<^esub> y \<otimes>\<^bsub>G i\<^esub> z = (k i) \<otimes>\<^bsub>G i\<^esub> (l i) \<otimes>\<^bsub>G i\<^esub> (m i)" using k l m by argo
    also have "\<dots> = (k \<otimes>\<^bsub>?DP\<^esub> l \<otimes>\<^bsub>?DP\<^esub> m) i" using comp_mult[OF i] k l m by metis
    also have "\<dots> = (k \<otimes>\<^bsub>?DP\<^esub> (l \<otimes>\<^bsub>?DP\<^esub> m)) i"
    proof -
      have "k \<otimes>\<^bsub>?DP\<^esub> l \<otimes>\<^bsub>?DP\<^esub> m = k \<otimes>\<^bsub>?DP\<^esub> (l \<otimes>\<^bsub>?DP\<^esub> m)" using DP.m_assoc[OF k(1) l(1) m(1)] .
      thus ?thesis by simp
    qed
    also have "\<dots> = (k i) \<otimes>\<^bsub>G i\<^esub> ((l i) \<otimes>\<^bsub>G i\<^esub> (m i))" using comp_mult[OF i] k l m by metis
    finally show ?thesis using k l m by blast
  qed
  show "\<one>\<^bsub>G i\<^esub> \<otimes>\<^bsub>G i\<^esub> x = x" if "x \<in> carrier (G i)" for x
  proof -
    from DirProds_obtain_elem_carr[OF assms that(1)] obtain k where k: "k \<in> carrier ?DP" "k i = x" .
    hence "\<one>\<^bsub>?DP\<^esub> \<otimes>\<^bsub>?DP\<^esub> k = k" by simp
    with comp_mult k DirProds_one[OF DP.one_closed] that i show ?thesis by metis
  qed
  show "\<exists>y\<in>carrier (G i). y \<otimes>\<^bsub>G i\<^esub> x = \<one>\<^bsub>G i\<^esub>" if "x \<in> carrier (G i)" for x
  proof -
    from DirProds_obtain_elem_carr[OF assms that(1)] obtain k where k: "k \<in> carrier ?DP" "k i = x" .
    hence ic: "inv\<^bsub>?DP\<^esub> k \<in> carrier ?DP" by simp
    have "inv\<^bsub>?DP\<^esub> k \<otimes>\<^bsub>?DP\<^esub> k = \<one>\<^bsub>?DP\<^esub>" using k by simp
    hence "(inv\<^bsub>?DP\<^esub> k) i \<otimes>\<^bsub>G i\<^esub> k i= \<one>\<^bsub>G i\<^esub>" using comp_mult[OF i] DirProds_one'[OF i] by metis
    with k(2) comp_in_carr[OF ic i] show ?thesis by blast
  qed
qed

lemma DirProds_group_iff: "group (DirProds G I) \<longleftrightarrow> (\<forall>i\<in>I. group (G i))"
  using DirProds_is_group DirProds_group_imp_groups by metis

lemma comp_inv:
  assumes "group (DirProds G I)" and x: "x \<in> carrier (DirProds G I)" and i: "i \<in> I"
  shows "(inv\<^bsub>(DirProds G I)\<^esub> x) i = inv\<^bsub>(G i)\<^esub> (x i)"
proof -
  interpret DP: group "DirProds G I" by fact
  interpret Gi: group "G i" using DirProds_group_imp_groups[OF DP.is_group i] .
  have ixc: "inv\<^bsub>(DirProds G I)\<^esub> x \<in> carrier (DirProds G I)" using x by blast
  hence "inv\<^bsub>(DirProds G I)\<^esub> x \<otimes>\<^bsub>DirProds G I\<^esub> x = \<one>\<^bsub>DirProds G I\<^esub>" using x by simp
  hence "(inv\<^bsub>(DirProds G I)\<^esub> x \<otimes>\<^bsub>DirProds G I\<^esub> x) i = \<one>\<^bsub>G i\<^esub>" by (simp add: DirProds_one' i)
  moreover with comp_mult[OF i] have "(inv\<^bsub>(DirProds G I)\<^esub> x \<otimes>\<^bsub>DirProds G I\<^esub> x) i = ((inv\<^bsub>(DirProds G I)\<^esub> x) i) \<otimes>\<^bsub>G i\<^esub> (x i)" by blast
  ultimately show ?thesis using x ixc by (simp add: comp_in_carr[OF _ i] group.inv_equality)
qed

lemma DirProds_is_comm_group:
  assumes "\<And>i. i \<in> I \<Longrightarrow> comm_group (G i)"
  shows "comm_group (DirProds G I)" (is "comm_group ?DP")
proof
  interpret group ?DP using assms DirProds_is_group unfolding comm_group_def by metis
  show "carrier ?DP \<subseteq> Units ?DP" "\<one>\<^bsub>?DP\<^esub> \<in> carrier ?DP" by simp_all
  fix x
  assume x[simp]: "x \<in> carrier ?DP"
  show "\<one>\<^bsub>?DP\<^esub> \<otimes>\<^bsub>?DP\<^esub> x = x" "x \<otimes>\<^bsub>?DP\<^esub> \<one>\<^bsub>?DP\<^esub> = x" by simp_all
  fix y
  assume y[simp]: "y \<in> carrier ?DP"
  show "x \<otimes>\<^bsub>?DP\<^esub> y \<in> carrier ?DP" by simp
  show "x \<otimes>\<^bsub>DirProds G I\<^esub> y = y \<otimes>\<^bsub>DirProds G I\<^esub> x"
  proof (rule eq_parts_imp_eq[of _ G I])
    show "x \<otimes>\<^bsub>?DP\<^esub> y \<in> carrier ?DP" by simp
    show "y \<otimes>\<^bsub>?DP\<^esub> x \<in> carrier ?DP" by simp
    show "\<And>i. i\<in>I \<Longrightarrow> (x \<otimes>\<^bsub>DirProds G I\<^esub> y) i = (y \<otimes>\<^bsub>DirProds G I\<^esub> x) i"
    proof -
      fix i
      assume i: "i \<in> I"
      interpret gi: comm_group "(G i)" using assms(1)[OF i] .
      have "(x \<otimes>\<^bsub>?DP\<^esub> y) i = x i \<otimes>\<^bsub>G i\<^esub> y i"
        by (intro comp_mult[OF i])
      also have "\<dots> = y i \<otimes>\<^bsub>G i\<^esub> x i" using comp_in_carr[OF _ i] x y gi.m_comm by metis
      also have "\<dots> = (y \<otimes>\<^bsub>?DP\<^esub> x) i" by (intro comp_mult[symmetric, OF i])
      finally show "(x \<otimes>\<^bsub>DirProds G I\<^esub> y) i = (y \<otimes>\<^bsub>DirProds G I\<^esub> x) i" .
    qed
  qed
  fix z
  assume z[simp]: "z \<in> carrier ?DP"
  show "x \<otimes>\<^bsub>?DP\<^esub> y \<otimes>\<^bsub>?DP\<^esub> z = x \<otimes>\<^bsub>?DP\<^esub> (y \<otimes>\<^bsub>?DP\<^esub> z)" using m_assoc by simp
qed

lemma DirProds_comm_group_imp_comm_groups:
  assumes "comm_group (DirProds G I)" and i: "i \<in> I"
  shows "comm_group (G i)"
proof -
  interpret DP: comm_group "DirProds G I" by fact
  interpret Gi: group "G i" using DirProds_group_imp_groups[OF DP.is_group i] .
  show "comm_group (G i)"
  proof
    show "x \<otimes>\<^bsub>G i\<^esub> y = y \<otimes>\<^bsub>G i\<^esub> x" if x: "x \<in> carrier (G i)" and y: "y \<in> carrier (G i)" for x y
    proof -
      obtain a where a[simp]: "a \<in> carrier (DirProds G I)" "a i = x" using DirProds_obtain_elem_carr[OF DP.is_group i x] .
      obtain b where b[simp]: "b \<in> carrier (DirProds G I)" "b i = y" using DirProds_obtain_elem_carr[OF DP.is_group i y] .
      have "a \<otimes>\<^bsub>DirProds G I\<^esub> b = b \<otimes>\<^bsub>DirProds G I\<^esub> a" using DP.m_comm by simp
      hence "(a \<otimes>\<^bsub>DirProds G I\<^esub> b) i = (b \<otimes>\<^bsub>DirProds G I\<^esub> a) i" by argo
      with comp_mult[OF i] have "a i \<otimes>\<^bsub>G i\<^esub> b i = b i \<otimes>\<^bsub>G i\<^esub> a i" by metis
      with a b show "x \<otimes>\<^bsub>G i\<^esub> y = y \<otimes>\<^bsub>G i\<^esub> x" by blast
    qed
  qed
qed

lemma DirProds_comm_group_iff: "comm_group (DirProds G I) \<longleftrightarrow> (\<forall>i\<in>I. comm_group (G i))"
  using DirProds_is_comm_group DirProds_comm_group_imp_comm_groups by metis

lemma DirProds_is_finite_group:
  assumes "\<And>i. i\<in>I \<Longrightarrow> finite_group (G i)" "finite I"
  shows "finite_group (DirProds G I)"
proof -
  have "group (G i)" if "i\<in>I" for i using assms(1)[OF that] unfolding finite_group_def by blast
  from DirProds_is_group[OF this] interpret DP: group "DirProds G I" by fast
  show ?thesis
  proof(unfold_locales)
    have "order (DirProds G I) \<noteq> 0"
    proof(unfold DirProds_order[OF assms(2)])
      have "(order \<circ> G) i \<noteq> 0" if "i\<in>I" for i using assms(1)[OF that] by (simp add: finite_group.order_gt_0)
      thus "prod (order \<circ> G) I \<noteq> 0" by (simp add: assms(2))
    qed
    thus "finite (carrier (DirProds G I))" unfolding order_def by (meson card.infinite)
  qed
qed

lemma DirProds_finite_imp_finite_groups:
  assumes "finite_group (DirProds G I)" "finite I"
  shows "\<And>i. i\<in>I \<Longrightarrow> finite_group (G i)"
proof -
  fix i assume i: "i \<in> I"
  interpret DP: finite_group "DirProds G I" by fact
  interpret group "G i" by (rule DirProds_group_imp_groups[OF DP.is_group i])
  show "finite_group (G i)"
  proof(unfold_locales)
    have oDP: "order (DirProds G I) \<noteq> 0" by blast
    with DirProds_order[OF assms(2), of G] have "order (G i) \<noteq> 0" using i assms(2) by force
    thus "finite (carrier (G i))" unfolding order_def by (meson card_eq_0_iff)
  qed
qed

lemma DirProds_finite_group_iff:
  assumes "finite I"
  shows "finite_group (DirProds G I) \<longleftrightarrow> (\<forall>i\<in>I. finite_group (G i))"
  using DirProds_is_finite_group DirProds_finite_imp_finite_groups assms by metis

lemma DirProds_finite_comm_group_iff:
  assumes "finite I"
  shows "finite_comm_group (DirProds G I) \<longleftrightarrow> (\<forall>i\<in>I. finite_comm_group (G i))"
  using DirProds_finite_group_iff[OF assms] DirProds_comm_group_iff unfolding finite_comm_group_def by fast

lemma (in comm_group) DirProds_two_iso:
  assumes "subgroup A G" "subgroup B G" "A \<noteq> B" "group.complementary_family G {A, B}" "carrier G = IDirProds G {A, B}"
  shows "(\<lambda>x. x A \<otimes> x B) \<in> iso (DirProds (\<lambda>H. G\<lparr>carrier := H\<rparr>) {A, B}) G" (is "?f \<in> iso ?H G")
proof -
  have "?f \<in> hom (DirProds (\<lambda>H. G\<lparr>carrier := H\<rparr>) {A, B}) G"
  proof (rule homI)
    fix x
    assume x: "x \<in> carrier ?H"
    then have xc: "x A \<in> carrier G" "x B \<in> carrier G" using comp_in_carr[OF x] assms(1, 2) subgroup.subset by(force)+
    thus "?f x \<in> carrier G" by blast
    fix y
    assume y: "y \<in> carrier ?H"
    then have yc: "y A \<in> carrier G" "y B \<in> carrier G" using comp_in_carr[OF y] assms(1, 2) subgroup.subset by(force)+
    have "(x \<otimes>\<^bsub>?H\<^esub> y) A \<otimes> (x \<otimes>\<^bsub>?H\<^esub> y) B = x A \<otimes> y A \<otimes> (x B \<otimes> y B)" by(auto simp: comp_mult)
    also have "\<dots> = x A \<otimes> x B \<otimes> (y A \<otimes> y B)" using m_assoc m_comm xc yc by simp
    finally show "?f (x \<otimes>\<^bsub>?H\<^esub> y) = ?f x \<otimes> ?f y" by blast
  qed
  then interpret f: group_hom ?H G ?f unfolding group_hom_def group_hom_axioms_def
  proof (safe)
    show "group ?H" by(intro DirProds_is_group; use assms(1, 2) subgroup.subgroup_is_group in blast)
  qed
  have "carrier G \<subseteq> ?f ` carrier ?H"
  proof -
    have "carrier G = A <#> B" using assms(5) unfolding IDirProds_def using generate_subgroup_eq_set_mult[OF assms(1, 2)] by simp
    also have "\<dots> \<subseteq> ?f ` carrier ?H"
    proof
      fix x
      assume "x \<in> A <#> B"
      then obtain a b where ab: "a \<in> A" "b \<in> B" "x = a \<otimes> b" unfolding set_mult_def by blast
      let ?y = "(\<lambda>H. undefined)(A := a, B := b)"
      have "?y \<in> carrier ?H"
        unfolding DirProds_def PiE_def Pi_def extensional_def using ab by simp
      moreover have "(\<lambda>x. x A \<otimes> x B) ?y = x" using ab assms(3) by simp
      ultimately show "x \<in> ?f ` carrier ?H" by blast
    qed
    finally show ?thesis .
  qed
  moreover have "\<forall>x\<in>carrier ?H. ?f x = \<one> \<longrightarrow> x = \<one>\<^bsub>?H\<^esub>"
  proof (rule, rule)
    fix x
    assume x: "x \<in> carrier ?H" "x A \<otimes> x B = \<one>"
    then have xs: "x A \<in> A" "x B \<in> B" using comp_in_carr[OF x(1)] by simp_all
    then have "x A \<in> carrier G" "x B \<in> carrier G" using assms(1,2) subgroup.subset by blast+
    from comm_inv_char[OF this x(2)] have "inv x A = x B" .
    then have "x B \<in> A" using subgroup.m_inv_closed[OF assms(1) xs(1)] by simp
    then have "x B \<in> (A \<inter> B)" using xs(2) by blast
    moreover have "A \<inter> B = {\<one>}" using assms(1-4)
      unfolding complementary_family_def complementary_def IDirProds_def
      using generate_subgroup_id by simp
    ultimately have "x B = \<one>" by simp
    moreover then have "x A = \<one>" using x \<open>x A \<in> carrier G\<close> by simp
    ultimately show "x = \<one>\<^bsub>?H\<^esub>" using DirProds_one[OF x(1)] assms(1, 2) subgroup.subgroup_is_group by auto
  qed
  ultimately show "?f \<in> iso ?H G" using f.iso_iff by blast
qed

lemma (in comm_group) subgroup_iso_DirProds_IDirProds:
  assumes "subgroup J G" "J = IDirProds G Hs"
  and "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H (G\<lparr>carrier := J\<rparr>)" "complementary_family Hs"
  shows "(\<lambda>x. \<Otimes>\<^bsub>G\<^esub>H\<in>Hs. x H) \<in> iso (DirProds (\<lambda>H. G\<lparr>carrier := H\<rparr>) Hs) (G\<lparr>carrier := J\<rparr>)" (is "?fp \<in> iso ?DP ?J")
proof -
  interpret J: comm_group ?J using subgroup_is_comm_group[OF assms(1)] .
  interpret DP: comm_group ?DP
    by(intro DirProds_is_comm_group; use J.subgroup_is_comm_group[OF assms(4)] in simp)
  have inJ: "H \<subseteq> J" if "H \<in> Hs" for H using subgroup.subset[OF assms(4)[OF that]] by simp
  have hom: "?fp \<in> hom ?DP ?J"
  proof (rule homI)
    fix x
    assume x[simp]: "x \<in> carrier ?DP"
    show "finprod G x Hs \<in> carrier ?J"
    proof(subst finprod_subgroup[OF _ assms(1)])
      show "x \<in> Hs \<rightarrow> J" using inJ comp_in_carr[OF x] by auto
      thus "finprod ?J x Hs \<in> carrier ?J" by(intro J.finprod_closed; simp)
    qed
    fix y
    assume y[simp]: "y \<in> carrier ?DP"
    show "finprod G (x \<otimes>\<^bsub>?DP\<^esub> y) Hs = finprod G x Hs \<otimes>\<^bsub>?J\<^esub> finprod G y Hs"
    proof(subst (1 2 3) finprod_subgroup[of _ _ J])
      show xyJ: "x \<in> Hs \<rightarrow> J" "y \<in> Hs \<rightarrow> J" using x y inJ comp_in_carr[OF x] comp_in_carr[OF y] by auto
      show xyJ1: "x \<otimes>\<^bsub>?DP\<^esub> y \<in> Hs \<rightarrow> J" using inJ x y comp_in_carr[of "x \<otimes>\<^bsub>?DP\<^esub> y"] by fastforce
      show "subgroup J G" using assms(1) .
      show "finprod ?J (x \<otimes>\<^bsub>?DP\<^esub> y) Hs = finprod ?J x Hs \<otimes>\<^bsub>?J\<^esub> finprod ?J y Hs"
      proof (rule J.finprod_eq)
        show "x \<in> Hs \<rightarrow> carrier ?J" "y \<in> Hs \<rightarrow> carrier ?J" using xyJ by simp_all
        show "x \<otimes>\<^bsub>?DP\<^esub> y \<in> Hs \<rightarrow> carrier ?J" using xyJ1 by simp
        fix H
        assume H: "H \<in> Hs"
        then have "x H \<otimes>\<^bsub>G\<lparr>carrier := H \<rparr>\<^esub> y H = (x \<otimes>\<^bsub>?DP\<^esub> y) H"
          by(intro comp_mult[symmetric])
        thus "x H \<otimes>\<^bsub>?J\<^esub> y H = (x \<otimes>\<^bsub>?DP\<^esub> y) H" by simp
      qed
    qed
  qed
  then interpret fp: group_hom ?DP ?J ?fp unfolding group_hom_def group_hom_axioms_def by blast
  have s: "subgroup H G" if "H \<in> Hs" for H using incl_subgroup[OF assms(1) assms(4)[OF that]] .
  have "kernel ?DP ?J ?fp = {\<one>\<^bsub>?DP\<^esub>}"
  proof -
    have "a = \<one>\<^bsub>?DP\<^esub>" if "a \<in> kernel ?DP ?J ?fp" for a
    proof -
      from that have a: "finprod G a Hs = \<one>" "a \<in> carrier ?DP" unfolding kernel_def by simp_all
      from comp_fam_imp_triv_finprod[OF assms(5, 3) s a(1)] comp_in_carr[OF a(2)] have "\<forall>H\<in>Hs. a H = \<one>" by simp
      then show ?thesis using DirProds_one[OF a(2)] by fastforce
    qed
    thus ?thesis using fp.one_in_kernel by blast
  qed
  moreover have "J \<subseteq> ?fp ` carrier ?DP"
    using assms(2) IDirProds_eq_finprod_PiE[OF assms(3) incl_subgroup[OF assms(1) assms(4)]]
    unfolding DirProds_def PiE_def Pi_def by simp
  ultimately show ?thesis using hom fp.iso_iff unfolding kernel_def by auto
qed

lemma (in comm_group) iso_DirProds_IDirProds:
  assumes "is_idirprod (carrier G) Hs" "finite Hs"
  shows "(\<lambda>x. \<Otimes>\<^bsub>G\<^esub>H\<in>Hs. x H) \<in> iso (DirProds (\<lambda>H. G\<lparr>carrier := H\<rparr>) Hs) G"
proof -
  from assms(1) is_idirprod.simps[of "carrier G" Hs]
  have "carrier G = IDirProds G Hs" "\<And>x. x \<in> Hs \<Longrightarrow> x \<lhd> G" "complementary_family Hs" by blast+
  from subgroup_iso_DirProds_IDirProds[OF subgroup_self this(1) assms(2) normal_imp_subgroup this(3)] this(2)
  show ?thesis by auto
qed

lemma (in comm_group) cong_DirProds_IDirProds:
  assumes "is_idirprod (carrier G) Hs" "finite Hs"
  shows "DirProds (\<lambda>H. G\<lparr>carrier := H\<rparr>) Hs \<cong> G"
  by (intro is_isoI, use iso_DirProds_IDirProds[OF assms] in blast)

lemma DirProds_one_iso: "(\<lambda>x. x G) \<in> iso (DirProds f {G}) (f G)"
proof (intro isoI homI)
  show "bij_betw (\<lambda>x. x G) (carrier (DirProds f {G})) (carrier (f G))"
  proof (unfold bij_betw_def, rule)
    show "inj_on (\<lambda>x. x G) (carrier (DirProds f {G}))" by(intro inj_onI, unfold DirProds_def PiE_def Pi_def extensional_def, fastforce)
    show "(\<lambda>x. x G) ` carrier (DirProds f {G}) = carrier (f G)"
    proof(intro equalityI subsetI)
      show "x \<in> carrier (f G)" if "x \<in> (\<lambda>x. x G) ` carrier (DirProds f {G})" for x using that unfolding DirProds_def by auto
      show "x \<in> (\<lambda>x. x G) ` carrier (DirProds f {G})" if xc: "x \<in> carrier (f G)" for x
      proof
        show "(\<lambda>k\<in>{G}. x) \<in> carrier (DirProds f {G})" unfolding DirProds_def using xc by auto
        moreover show "x = (\<lambda>k\<in>{G}. x) G" by simp
      qed
    qed
  qed
qed (unfold DirProds_def PiE_def Pi_def extensional_def, auto)

lemma DirProds_one_cong: "(DirProds f {G}) \<cong> (f G)"
  using DirProds_one_iso is_isoI by fast

lemma DirProds_one_iso_sym: "(\<lambda>x. (\<lambda>_\<in>{G}. x)) \<in> iso (f G) (DirProds f {G})"
proof (intro isoI homI)
  show "bij_betw (\<lambda>x. \<lambda>_\<in>{G}. x) (carrier (f G)) (carrier (DirProds f {G}))"
  proof (unfold bij_betw_def, rule)
    show "inj_on (\<lambda>x. (\<lambda>_\<in>{G}. x)) (carrier (f G))" by(intro inj_onI, metis imageI image_constant image_restrict_eq member_remove remove_def)
    show "(\<lambda>x. (\<lambda>_\<in>{G}. x)) ` carrier (f G) = carrier (DirProds f {G})" unfolding DirProds_def by fastforce
  qed
qed (unfold DirProds_def, auto)

lemma DirProds_one_cong_sym: "(f G) \<cong> (DirProds f {G})"
  using DirProds_one_iso_sym is_isoI by fast

lemma DirProds_iso:
  assumes "bij_betw f I J" "\<And>i. i\<in>I \<Longrightarrow> Gs i \<cong> Hs (f i)" "\<And>i. i\<in>I \<Longrightarrow> group (Gs i)" "\<And>j. j\<in>J \<Longrightarrow> group (Hs j)"
  shows "DirProds Gs I \<cong> DirProds Hs J"
proof -
  interpret DG: group "DirProds Gs I" using DirProds_is_group assms(3) by blast
  interpret DH: group "DirProds Hs J" using DirProds_is_group assms(4) by blast
  from assms(1) obtain g where g: "g = inv_into I f" "bij_betw g J I" by (meson bij_betw_inv_into)
  hence fgi: "\<And>i. i \<in> I \<Longrightarrow> g (f i) = i" "\<And>j. j \<in> J \<Longrightarrow> f (g j) = j"
    using assms(1) bij_betw_inv_into_left[OF assms(1)] bij_betw_inv_into_right[OF assms(1)] by auto
  from assms(2) have "\<And>i. i \<in> I \<Longrightarrow> (\<exists>h. h \<in> iso (Gs i) (Hs (f i)))" unfolding is_iso_def by blast
  then obtain h where h: "\<And>i. i \<in> I \<Longrightarrow> h i \<in> iso (Gs i) (Hs (f i))" by metis
  let ?h = "(\<lambda>x. (\<lambda>j. if j\<in>J then (h (g j)) (x (g j)) else undefined))"
  have hc: "?h x \<in> carrier (DirProds Hs J)" if "x \<in> carrier (DirProds Gs I)" for x
  proof -
    have xc: "x \<in> carrier (DirProds Gs I)" by fact
    have "h (g j) (x (g j)) \<in> carrier (Hs j)" if "j \<in> J" for j
    proof(intro iso_in_carr[OF _ comp_in_carr[OF xc], of "h (g j)" "g j" "Hs j"])
      show "g j \<in> I" using g(2)[unfolded bij_betw_def] that by blast
      from h[OF this] show "h (g j) \<in> Group.iso (Gs (g j)) (Hs j)" using fgi(2)[OF that] by simp
    qed
    thus ?thesis using xc unfolding DirProds_def PiE_def extensional_def by auto
  qed
  moreover have "?h (x \<otimes>\<^bsub>DirProds Gs I\<^esub> y)= ?h x \<otimes>\<^bsub>DirProds Hs J\<^esub> ?h y"
    if "x \<in> carrier (DirProds Gs I)" "y \<in> carrier (DirProds Gs I)" for x y
  proof(intro eq_parts_imp_eq[OF hc[OF DG.m_closed[OF that]] DH.m_closed[OF hc[OF that(1)] hc[OF that(2)]]])
    fix j
    assume j: "j \<in> J"
    hence gj: "g j \<in> I" using g unfolding bij_betw_def by blast
    from assms(3)[OF gj] assms(4)[OF j] have g: "group (Gs (g j))" "Group.group (Hs j)" .
    from iso_imp_homomorphism[OF h[OF gj]] fgi(2)[OF j] g
    interpret hjh: group_hom "Gs (g j)" "Hs j" "h (g j)"
      unfolding group_hom_def group_hom_axioms_def by simp
    show "(?h (x \<otimes>\<^bsub>DirProds Gs I\<^esub> y)) j = (?h x \<otimes>\<^bsub>DirProds Hs J\<^esub> ?h y) j"
    proof(subst comp_mult)
      show "(if j \<in> J then h (g j) (x (g j) \<otimes>\<^bsub>Gs (g j)\<^esub> y (g j)) else undefined) = (?h x \<otimes>\<^bsub>DirProds Hs J\<^esub> ?h y) j"
      proof(subst comp_mult)
        have "h (g j) (x (g j) \<otimes>\<^bsub>Gs (g j)\<^esub> y (g j)) = h (g j) (x (g j)) \<otimes>\<^bsub>Hs j\<^esub> h (g j) (y (g j))"
          using comp_in_carr[OF that(1) gj] comp_in_carr[OF that(2) gj] by simp
        thus "(if j \<in> J then h (g j) (x (g j) \<otimes>\<^bsub>Gs (g j)\<^esub> y (g j)) else undefined) =
              (if j \<in> J then h (g j) (x (g j)) else undefined) \<otimes>\<^bsub>Hs j\<^esub> (if j \<in> J then h (g j) (y (g j)) else undefined)"
          using j by simp
      qed (use j g that hc in auto)
    qed (use gj g that in auto)
  qed
  ultimately interpret hgh: group_hom "DirProds Gs I" "DirProds Hs J" ?h
    unfolding group_hom_def group_hom_axioms_def by (auto intro: homI)
  have "carrier (DirProds Hs J) \<subseteq> ?h ` carrier (DirProds Gs I)"
  proof
    show "x \<in> ?h ` carrier (DirProds Gs I)" if xc: "x \<in> carrier (DirProds Hs J)" for x
    proof -
      from h obtain k where k: "\<And>i. i\<in>I \<Longrightarrow> k i = inv_into (carrier (Gs i)) (h i)" by fast
      hence kiso: "\<And>i. i\<in>I \<Longrightarrow> k i \<in> iso (Hs (f i)) (Gs i)" using h by (simp add: assms(3) group.iso_set_sym)
      hence hk: "y = (h (g j) \<circ> (k (g j))) y" if "j \<in> J" "y \<in> carrier (Hs j)" for j y
      proof -
        have gj: "g j \<in> I" using that g[unfolded bij_betw_def] by blast
        thus ?thesis using h[OF gj, unfolded iso_def] k[OF gj] that fgi(2)[OF that(1)] bij_betw_inv_into_right
          unfolding comp_def by fastforce
      qed
      let ?k = "(\<lambda>i. if i\<in>I then k i else (\<lambda>_. undefined))"
      let ?y = "(\<lambda>i. (?k i) (x (f i)))"
      have "x j = (\<lambda>j. if j \<in> J then h (g j) (?y (g j)) else undefined) j" for j
      proof (cases "j \<in> J")
        case True
        thus ?thesis using hk[OF True comp_in_carr[OF that True]] fgi(2)[OF True] g[unfolded bij_betw_def] by auto
      next
        case False
        thus ?thesis using that[unfolded DirProds_def] by auto
      qed
      moreover have "?y \<in> carrier (DirProds Gs I)"
      proof -
        have "?y i \<in> carrier (Gs i)" if i: "i \<in> I" for i
          using k[OF i] h[OF i] comp_in_carr[OF xc] assms(1) bij_betwE iso_in_carr kiso that by fastforce
        moreover have "?y i = undefined" if i: "i \<notin> I" for i using i by simp
        ultimately show ?thesis unfolding DirProds_def PiE_def Pi_def extensional_def by simp
      qed
      ultimately show ?thesis by fast
    qed
  qed
  moreover have "x = \<one>\<^bsub>DirProds Gs I\<^esub>" if "x \<in> carrier (DirProds Gs I)" "?h x = \<one>\<^bsub>DirProds Hs J\<^esub>" for x
  proof -
    have "\<forall>i\<in>I. x i = \<one>\<^bsub>Gs i\<^esub>"
    proof
      fix i
      assume i: "i \<in> I"
      interpret gi: group "Gs i" using assms(3)[OF i] .
      interpret hfi: group "Hs (f i)" using assms(4) i assms(1)[unfolded bij_betw_def] by blast
      from h[OF i] interpret hi: group_hom "(Gs i)" "Hs (f i)" "h i"
        unfolding group_hom_def group_hom_axioms_def iso_def by blast
      from that have hx: "?h x \<in> carrier (DirProds Hs J)" by simp
      from DirProds_one[OF this] that(2) have "(if j \<in> J then h (g j) (x (g j)) else undefined) = \<one>\<^bsub>Hs j\<^esub>" if "j \<in> J" for j
        using that by blast
      hence "h (g (f i)) (x (g (f i))) = \<one>\<^bsub>Hs (f i)\<^esub>" using i assms(1)[unfolded bij_betw_def] by auto
      hence "h i (x i) = \<one>\<^bsub>Hs (f i)\<^esub>" using fgi(1)[OF i] by simp
      with hi.iso_iff h[OF i] comp_in_carr[OF that(1) i] show "x i = \<one>\<^bsub>Gs i\<^esub>" by fast
    qed
    with DirProds_one that show ?thesis using assms(3) by blast
  qed
  ultimately show ?thesis unfolding is_iso_def using hgh.iso_iff by blast
qed

lemma DirProds_iso1:
  assumes "\<And>i. i\<in>I \<Longrightarrow> Gs i \<cong> (f \<circ> Gs) i" "\<And>i. i\<in>I \<Longrightarrow> group (Gs i)" "\<And>i. i\<in>I \<Longrightarrow> group ((f \<circ> Gs) i)"
  shows "DirProds Gs I \<cong> DirProds (f \<circ> Gs) I"
proof -
  interpret DP: group "DirProds Gs I" using DirProds_is_group assms by metis
  interpret fDP: group "DirProds (f \<circ> Gs) I" using DirProds_is_group assms by metis
  from assms have "\<forall>i\<in>I. (\<exists>g. g \<in> iso (Gs i) ((f \<circ> Gs) i))" unfolding is_iso_def by blast
  then obtain J where J: "\<forall>i\<in>I. J i \<in> iso (Gs i) ((f \<circ> Gs) i)" by metis
  let ?J = "(\<lambda>i. if i\<in>I then J i else (\<lambda>_. undefined))"
  from J obtain K where K: "\<forall>i\<in>I. K i = inv_into (carrier (Gs i)) (J i)" by fast
  hence K_iso: "\<forall>i\<in>I. K i \<in> iso ((f \<circ> Gs) i) (Gs i)" using group.iso_set_sym assms J by metis
  let ?K = "(\<lambda>i. if i\<in>I then K i else (\<lambda>_. undefined))"
  have JKi: "(?J i) ((?K i) (x i)) = x i" if "x \<in> carrier (DirProds (f \<circ> Gs) I)" for i x
  proof -
    have "(J i) ((K i) (x i)) = x i" if "x \<in> carrier (DirProds (f \<circ> Gs) I)" "i \<in> I" for i x
    proof -
      from J that have "(J i) ` (carrier (Gs i)) = carrier ((f \<circ> Gs) i)" unfolding iso_def bij_betw_def by blast
      hence "\<exists>y. y \<in> carrier (Gs i) \<and> (J i) y = x i" using that by (metis comp_in_carr imageE)
      with someI_ex[OF this] that show "(J i) ((K i) (x i)) = x i" using K J K_iso unfolding inv_into_def by auto
    qed
    moreover have "(?J i) ((K i) (x i)) = x i" if "x \<in> carrier (DirProds (f \<circ> Gs) I)" "i \<notin> I" for i x
      using that unfolding DirProds_def PiE_def extensional_def by force
    ultimately show ?thesis using that by simp
  qed
  let ?r = "(\<lambda>e. restrict (\<lambda>i. ?J i (e i)) I)"
  have hom: "?r \<in> hom (DirProds Gs I) (DirProds (f \<circ> Gs) I)"
  proof (intro homI)
    show "?r x \<in> carrier (DirProds (f \<circ> Gs) I)" if "x \<in> carrier (DirProds Gs I)" for x
      using that J comp_in_carr[OF that] unfolding DirProds_def iso_def bij_betw_def by fastforce
    show "?r (x \<otimes>\<^bsub>DirProds Gs I\<^esub> y) = ?r x \<otimes>\<^bsub>DirProds (f \<circ> Gs) I\<^esub> ?r y" if "x \<in> carrier (DirProds Gs I)" "y \<in> carrier (DirProds Gs I)" for x y
      using that J comp_in_carr[OF that(1)] comp_in_carr[OF that(2)] unfolding DirProds_def iso_def hom_def by force
  qed
  then interpret r: group_hom "(DirProds Gs I)" "(DirProds (f \<circ> Gs) I)" ?r
    unfolding group_hom_def group_hom_axioms_def by blast
  have "carrier (DirProds (f \<circ> Gs) I) \<subseteq> ?r ` carrier (DirProds Gs I)"
  proof
    show "x \<in> ?r ` carrier (DirProds Gs I)" if "x \<in> carrier (DirProds (f \<circ> Gs) I)" for x
    proof
      show "x = (\<lambda>i\<in>I. ?J i ((?K i) (x i)))"
        using JKi[OF that] that unfolding DirProds_def PiE_def by (simp add: extensional_restrict)
      show "(\<lambda>i. ?K i (x i)) \<in> carrier (DirProds Gs I)" using K_iso iso_in_carr that
        unfolding DirProds_def PiE_def Pi_def extensional_def by fastforce
    qed
  qed
  moreover have "x = \<one>\<^bsub>DirProds Gs I\<^esub>" if "x \<in> carrier (DirProds Gs I)" "?r x = \<one>\<^bsub>DirProds (f \<circ> Gs) I\<^esub>" for x
  proof -
    have "\<forall>i\<in>I. x i = \<one>\<^bsub>Gs i\<^esub>"
    proof
      fix i
      assume i: "i \<in> I"
      with J assms interpret Ji: group_hom "(Gs i)" "(f \<circ> Gs) i" "J i" unfolding group_hom_def group_hom_axioms_def iso_def by blast
      from that have rx: "?r x \<in> carrier (DirProds (f \<circ> Gs) I)" by simp
      from i DirProds_one[OF this] that have "(\<lambda>i\<in>I. (if i \<in> I then J i else (\<lambda>_. undefined)) (x i)) i = \<one>\<^bsub>(f \<circ> Gs) i\<^esub>" by blast
      hence "(J i) (x i) = \<one>\<^bsub>(f \<circ> Gs) i\<^esub>" using i by simp
      with Ji.iso_iff mp[OF spec[OF J[unfolded Ball_def]] i] comp_in_carr[OF that(1) i] show "x i = \<one>\<^bsub>Gs i\<^esub>" by fast
    qed
    with DirProds_one[OF that(1)] show ?thesis by blast
  qed
  ultimately show ?thesis unfolding is_iso_def using r.iso_iff by blast
qed

lemma DirProds_iso2:
  assumes "inj_on f A" "group (DirProds g (f ` A))"
  shows "DirProds (g \<circ> f) A \<cong> DirProds g (f ` A)"
proof (intro DirProds_iso[of f])
  show "bij_betw f A (f ` A)" using assms(1) unfolding bij_betw_def by blast
  show "\<And>i. i \<in> A \<Longrightarrow> (g \<circ> f) i \<cong> g (f i)" unfolding comp_def using iso_refl by simp
  from assms(2) show "\<And>i. i \<in> (f ` A) \<Longrightarrow> group (g i)" using DirProds_group_imp_groups by fast
  with assms(1) show "\<And>i. i \<in> A \<Longrightarrow> group ((g \<circ> f) i)" by auto
qed

lemma DirProds_Sigma:
  "DirProds (\<lambda>i. DirProds (G i) (J i)) I \<cong> DirProds (\<lambda>(i,j). G i j) (Sigma I J)" (is "?L \<cong> ?R")
proof (intro is_isoI isoI)
  let ?f = "\<lambda>x. restrict (case_prod x) (Sigma I J)"
  show hom: "?f \<in> hom ?L ?R"
  proof(intro homI)
    show "?f a \<in> carrier ?R" if "a \<in> carrier ?L" for a using that unfolding DirProds_def PiE_def Pi_def extensional_def by auto
    show "?f (a \<otimes>\<^bsub>?L\<^esub> b) = ?f a \<otimes>\<^bsub>?R\<^esub> ?f b" if "a \<in> carrier ?L" and "b \<in> carrier ?L" for a b
      using that unfolding DirProds_def PiE_def Pi_def extensional_def by auto
  qed
  show "bij_betw ?f (carrier ?L) (carrier ?R)"
  proof (intro bij_betwI)
    let ?g = "\<lambda>x. (\<lambda>i. if i\<in>I then (\<lambda>j. if j\<in>(J i) then x(i, j) else undefined) else undefined)"
    show "?f \<in> carrier ?L \<rightarrow> carrier ?R" unfolding DirProds_def by fastforce
    show "?g \<in> carrier ?R \<rightarrow> carrier ?L" unfolding DirProds_def by fastforce
    show "?f (?g x) = x" if "x \<in> carrier ?R" for x using that unfolding DirProds_def PiE_def Pi_def extensional_def by auto
    show "?g (?f x) = x" if "x \<in> carrier ?L" for x using that unfolding DirProds_def PiE_def Pi_def extensional_def by force
  qed
qed

lemma Zn_iso_DirProds_prime_powers:
  assumes "n \<noteq> 0"
  shows "Z n \<cong> DirProds (\<lambda>p. Z (p ^ multiplicity p n)) (prime_factors n)" (is "Z n \<cong> ?DP")
proof (cases "n = 1")
  case True
  show ?thesis by (intro triv_iso[OF group_integer_mod_group DirProds_is_group], use DirProds_empty carrier_integer_mod_group True in auto)
next
  case nno: False
  interpret DP: group ?DP by (intro DirProds_is_group, use group_integer_mod_group in blast)
  have "order ?DP = prod (order \<circ> (\<lambda>p. Z (p ^ multiplicity p n))) (prime_factors n)" by (intro DirProds_order, blast)
  also have "\<dots> = prod (\<lambda>p. p ^ multiplicity p n) (prime_factors n)" using Zn_order by simp
  also have n: "\<dots> = n" using prod_prime_factors[OF assms] by simp
  finally have oDP: "order ?DP = n" .
  then interpret DP: finite_group ?DP by (unfold_locales, unfold order_def, metis assms card.infinite)
  let ?f = "\<lambda>p\<in>(prime_factors n). 1"
  have fc: "?f \<in> carrier ?DP"
  proof -
    have p: "0 < multiplicity p n" if "p \<in> prime_factors n" for p using prime_factors_multiplicity that by auto
    have pk: "1 < p ^ k" if "Factorial_Ring.prime p" "0 < k" for p k::nat
      using that one_less_power prime_gt_1_nat by blast
    show ?thesis unfolding DirProds_def PiE_def
      by(use carrier_integer_mod_group assms nno pk p in auto,
         metis in_prime_factors_iff nat_int of_nat_power one_less_nat_eq)
  qed
  have of: "DP.ord ?f = n"
  proof -
    have "n dvd j" if j: "?f [^]\<^bsub>?DP\<^esub> j = \<one>\<^bsub>?DP\<^esub>" for j
    proof (intro pairwise_coprime_dvd'[OF _ _ n[symmetric]])
      show "finite (prime_factors n)" by simp
      show "\<forall>a\<in>#prime_factorization n. a ^ multiplicity a n dvd j"
      proof
        show "p ^ multiplicity p n dvd j" if "p \<in> prime_factors n" for p
        proof -
          from j have "(?f [^]\<^bsub>?DP\<^esub> j) p = 0" using that unfolding DirProds_def one_integer_mod_group by auto
          hence "?f p [^]\<^bsub>Z (p ^ multiplicity p n)\<^esub> j = 0" using comp_exp_nat[OF that] by metis
          hence "group.ord (Z (p ^ multiplicity p n)) (?f p) dvd j" using comp_in_carr[OF fc that]
            by (metis group.pow_eq_id group_integer_mod_group one_integer_mod_group)
          moreover have "group.ord (Z (p ^ multiplicity p n)) (?f p) = p ^ multiplicity p n"
            by (metis (no_types, lifting) Zn_neq1_cyclic_group Zn_order comp_in_carr cyclic_group.ord_gen_is_group_order fc integer_mod_group_1 restrict_apply' that)
          ultimately show ?thesis by simp
        qed
      qed
      show "coprime (i ^ multiplicity i n) (j ^ multiplicity j n)"
        if "i \<in># prime_factorization n" "j \<in># prime_factorization n" "i \<noteq> j" for i j
        using that diff_prime_power_imp_coprime by blast
    qed
    thus ?thesis using fc DP.ord_dvd_group_order gcd_nat.asym oDP by force
  qed
  interpret DP: cyclic_group ?DP ?f by (intro DP.element_ord_generates_cyclic, use of oDP fc in auto)
  show ?thesis using DP.iso_sym[OF DP.Zn_iso[OF oDP]] .
qed

lemma Zn_iso_DirProds_prime_powers':
  assumes "n \<noteq> 0"
  shows "Z n \<cong> DirProds (\<lambda>p. Z p) ((\<lambda>p. p ^ multiplicity p n) ` (prime_factors n))" (is "Z n \<cong> ?DP")
proof -
  have cp: "(\<lambda>p. Z (p ^ multiplicity p n)) = (\<lambda>p. Z p) \<circ> (\<lambda>p. p ^ multiplicity p n)" by auto
  have "DirProds (\<lambda>p. Z (p ^ multiplicity p n)) (prime_factors n) \<cong> ?DP"
  proof(subst cp, intro DirProds_iso2)
    show "inj_on (\<lambda>p. p ^ multiplicity p n) (prime_factors n)" by (intro inj_onI; simp add: prime_factors_multiplicity prime_power_inj'')
    show "group (DirProds Z ((\<lambda>p. p ^ multiplicity p n) ` prime_factors n))" by (intro DirProds_is_group, use group_integer_mod_group in auto)
  qed
  with Zn_iso_DirProds_prime_powers[OF assms] show ?thesis using Group.iso_trans by blast
qed

end


theory Injectivity
imports Main
begin

lemma test:
  assumes auth_eq: "\<And> r x y. auth x r = auth y r \<Longrightarrow> x = y"
  and     auth_ex: "\<And> i. i \<in> I \<Longrightarrow> \<exists> r. auth i r"
  shows "\<exists> f. inj_on f I \<and> (\<forall> i \<in> I. auth i (f i))"
  apply(rule_tac x="\<lambda> i. SOME r. auth i r" in exI)
  apply(safe)
  apply(simp add: inj_on_def)
  apply(safe)
  apply(rule_tac r="(SOME r. auth x r)" in auth_eq)
  apply(drule auth_ex)+
  apply(clarify)
  apply(rule iffI)
  apply(simp)
  apply(rule someI, assumption)+
  apply(drule auth_ex)+
  apply(clarify)
  apply(rule someI, assumption)+
  done

lemma iagree_to_niagree:
  assumes niagree: "\<forall> i. prem i \<longrightarrow> (\<exists> j. conc i j)"
  and     conc_inj: "\<forall> i1 i2 j. conc i1 j = conc i2 j \<longrightarrow> i1 = i2"
  shows "let prems = prem;
             concs = conc
         in \<exists>f. inj_on f prems \<and> (\<forall>i. prems i \<longrightarrow> concs i (f i))"
proof -
  have "\<exists> f. inj_on f prem \<and> (\<forall> i \<in> prem. conc i (f i))"
    by(rule test, auto simp: conc_inj[rule_format] niagree[rule_format] mem_def)
  thus ?thesis
    by(force simp: Let_def mem_def)
qed

definition smaller (* :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool" *)
where "smaller A B = (\<exists> f. inj_on f A \<and> (\<forall> x \<in> A. f(x) \<in> B \<and> (f(x) \<in> A \<longrightarrow>  x \<in> B)))"

lemma smaller_refl [iff]: "smaller A A"
  apply(clarsimp simp: smaller_def inj_on_def)
  apply(auto)
  done

lemma smaller_mono: "\<lbrakk> smaller A B; B \<subseteq> C \<rbrakk> \<Longrightarrow> smaller A C"
  apply(clarsimp simp: smaller_def)
  apply(auto)
  done

lemma smaller_compl: "smaller (- A) (- B) \<Longrightarrow> smaller B A"
  apply(clarsimp simp: smaller_def)
  apply(rule_tac x="\<lambda> x. if x \<in> A then x else f(x)" in exI)
  apply(auto)
  apply(auto simp: inj_on_def)
  done

lemma smaller_image: "inj_on f A \<Longrightarrow> smaller A (f ` A)"
  apply(clarsimp simp: smaller_def image_def)
  apply(rule_tac x="f" in exI)
  apply(safe)
  apply(force)
  apply(erule contrapos_pp)
  apply(clarsimp simp: inj_on_def)
(* hmm that doesn't really work. let's call it a day and use the restricted version of
   niagree_to_iagree, which is actually just fine in practice.
*)

  apply(
  apply(auto)
  apply(rule_tac x="inv_into A f x" in bexI)
  apply(rule sym)
  apply(rule f_inv_into_f)
  apply(simp add: image_def)
  apply(subst f_inv_into_f)
  apply(force)
  apply(auto simp: image_def inj_on_def)
  done

lemma inj_on_extend: "inj_on (f :: 'a \<Rightarrow> 'a) A \<Longrightarrow> \<exists> g. inj g \<and> (\<forall> x \<in> A. g x = f x)"

lemma blah: "SOME f. False"
  apply(rule someI) back
ML_prf{*
  case @{term X} of
    Free (_,ty) => Term.dest_Type ty |> snd |> hd |> dest_Type
*}
ML_prf{* dest_fun *}
  apply(rule someI)
thm someI

lemma test3:
  "(\<exists> f. inj_on f A \<and> (\<forall> a \<in> A. P a (f a))) \<Longrightarrow>
   (\<exists> f. X f \<and> (\<forall> a \<in> A. P a (f a)))"

apply(clarsimp)
apply(rule_tac x="(SOME g. X g)" in exI)
thm someI
apply(rule conjI)
apply(rule someI) back
apply(assumption)

apply(rule_tac x="(SOME g. inj g \<and> (\<forall> a \<in> A. g a = f a))" in exI)

apply(clarsimp)
apply(clarsimp simp: inj_on_def)

apply(rule_tac x="\<lambda> x. if x \<in> A then f x else
                       (SOME y. h

lemma test2:
  assumes auth_eq: "\<And> r x y. auth r x = auth r y \<Longrightarrow> x = y"
  and     inj_ex: "\<exists> f. inj_on f I \<and> (\<forall> i \<in> I. auth (f i) i)"
  and     in_I: "i \<in> I"
  shows "\<exists> r. auth r i"
using inj_ex in_I
apply(clarsimp simp: inj_on_def)
apply(rule_tac x="f i" in exI)
apply(fast)
done

lemma test:
  " (\<forall> i \<in> I.
              (\<exists> r. auth i r \<and> (\<forall> j \<in> I. auth j r \<longrightarrow> j = i)))
   \<Longrightarrow> (\<exists> f. inj_on f I \<and> (\<forall> i \<in> I. auth i (f i))) "
  apply(rule_tac x="\<lambda> i. THE r. auth i r" in exI)
  apply(simp add: inj_on_def)
  apply(rule conjI)
  apply(clarsimp) prefer 2
  apply(clarsimp)
  apply(drule bspec, assumption)
  apply(clarify)
  apply(rule theI, assumption)
  apply(drule bspec, assumption)
  apply(frule bspec, assumption)
  apply(drule bspec, assumption) back
  apply(clarify)
  apply(force)