(*  Title:      HOL/Types_To_Sets/Examples/Linear_Algebra_On.thy
    Author:     Fabian Immler, TU München
*)
theory Linear_Algebra_On
  imports
    "Prerequisites"
    "../Types_To_Sets"
    Linear_Algebra_On_With
begin

subsection \<open>Rewrite rules to make \<open>ab_group_add\<close> operations implicit.\<close>

named_theorems implicit_ab_group_add

lemmas [implicit_ab_group_add] = sum_with[symmetric]

lemma semigroup_add_on_with_eq[implicit_ab_group_add]:
  "semigroup_add_on_with S ((+)::_::semigroup_add \<Rightarrow> _) \<longleftrightarrow> (\<forall>a\<in>S. \<forall>b\<in>S. a + b \<in> S)"
  by (simp add: semigroup_add_on_with_Ball_def ac_simps)

lemma ab_semigroup_add_on_with_eq[implicit_ab_group_add]:
  "ab_semigroup_add_on_with S ((+)::_::ab_semigroup_add \<Rightarrow> _) = semigroup_add_on_with S (+)"
  unfolding ab_semigroup_add_on_with_Ball_def
  by (simp add: semigroup_add_on_with_eq ac_simps)

lemma comm_monoid_add_on_with_eq[implicit_ab_group_add]:
  "comm_monoid_add_on_with S ((+)::_::comm_monoid_add \<Rightarrow> _) 0 \<longleftrightarrow> semigroup_add_on_with S (+) \<and> 0 \<in> S"
  unfolding comm_monoid_add_on_with_Ball_def
  by (simp add: ab_semigroup_add_on_with_eq ac_simps)

lemma ab_group_add_on_with[implicit_ab_group_add]:
  "ab_group_add_on_with S ((+)::_::ab_group_add \<Rightarrow> _) 0 (-) uminus \<longleftrightarrow>
    comm_monoid_add_on_with S (+) 0 \<and> (\<forall>a\<in>S. -a\<in>S)"
  unfolding ab_group_add_on_with_Ball_def
  by simp

subsection \<open>Definitions \<^emph>\<open>on\<close> carrier set\<close>

locale module_on =
  fixes S and scale :: "'a::comm_ring_1 \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b" (infixr "*s" 75)
  assumes scale_right_distrib_on [algebra_simps]: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> a *s (x + y) = a *s x + a *s y"
    and scale_left_distrib_on [algebra_simps]: "x \<in> S \<Longrightarrow> (a + b) *s x = a *s x + b *s x"
    and scale_scale_on [simp]: "x \<in> S \<Longrightarrow> a *s (b *s x) = (a * b) *s x"
    and scale_one_on [simp]: "x \<in> S \<Longrightarrow> 1 *s x = x"
    and mem_add: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x + y \<in> S"
    and mem_zero: "0 \<in> S"
    and mem_scale: "x \<in> S \<Longrightarrow> a *s x \<in> S"
begin

lemma S_ne: "S \<noteq> {}" using mem_zero by auto

lemma scale_minus_left_on: "scale (- a) x = - scale a x" if "x \<in> S"
  by (metis add_cancel_right_right scale_left_distrib_on neg_eq_iff_add_eq_0 that)

lemma mem_uminus: "x \<in> S \<Longrightarrow> -x \<in> S"
  by (metis mem_scale scale_minus_left_on scale_one_on)

definition subspace :: "'b set \<Rightarrow> bool"
  where subspace_on_def: "subspace T \<longleftrightarrow> 0 \<in> T \<and> (\<forall>x\<in>T. \<forall>y\<in>T. x + y \<in> T) \<and> (\<forall>c. \<forall>x\<in>T. c *s x \<in> T)"

definition span :: "'b set \<Rightarrow> 'b set"
  where span_on_def: "span b = {sum (\<lambda>a. r a *s  a) t | t r. finite t \<and> t \<subseteq> b}"

definition dependent :: "'b set \<Rightarrow> bool"
  where dependent_on_def: "dependent s \<longleftrightarrow> (\<exists>t u. finite t \<and> t \<subseteq> s \<and> (sum (\<lambda>v. u v *s v) t = 0 \<and> (\<exists>v\<in>t. u v \<noteq> 0)))"

lemma implicit_subspace_with[implicit_ab_group_add]: "subspace_with (+) 0 (*s) = subspace"
  unfolding subspace_on_def subspace_with_def ..

lemma implicit_dependent_with[implicit_ab_group_add]: "dependent_with (+) 0 (*s) = dependent"
  unfolding dependent_on_def dependent_with_def sum_with ..

lemma implicit_span_with[implicit_ab_group_add]: "span_with (+) 0 (*s) = span"
  unfolding span_on_def span_with_def sum_with ..

end

lemma implicit_module_on_with[implicit_ab_group_add]:
  "module_on_with S (+) (-) uminus 0 = module_on S"
proof (intro ext iffI)
  fix s::"'a\<Rightarrow>'b\<Rightarrow>'b" assume "module_on S s"
  then interpret module_on S s .
  show "module_on_with S (+) (-) uminus 0 s"
    by (auto simp: module_on_with_def implicit_ab_group_add
        mem_add mem_zero mem_uminus scale_right_distrib_on scale_left_distrib_on mem_scale)
qed (auto simp: module_on_with_def module_on_def implicit_ab_group_add)

locale module_pair_on = m1: module_on S1 scale1 +
                        m2: module_on S2 scale2
                        for S1:: "'b::ab_group_add set" and S2::"'c::ab_group_add set"
                          and scale1::"'a::comm_ring_1 \<Rightarrow> _" and scale2::"'a \<Rightarrow> _"

lemma implicit_module_pair_on_with[implicit_ab_group_add]:
  "module_pair_on_with S1 S2 (+) (-) uminus 0 s1 (+) (-) uminus 0 s2 = module_pair_on S1 S2 s1 s2"
  unfolding module_pair_on_with_def implicit_module_on_with module_pair_on_def ..

locale module_hom_on = m1: module_on S1 s1 + m2: module_on S2 s2
  for S1 :: "'b::ab_group_add set" and S2 :: "'c::ab_group_add set"
    and s1 :: "'a::comm_ring_1 \<Rightarrow> 'b \<Rightarrow> 'b" (infixr "*a" 75)
    and s2 :: "'a::comm_ring_1 \<Rightarrow> 'c \<Rightarrow> 'c" (infixr "*b" 75) +
  fixes f :: "'b \<Rightarrow> 'c"
  assumes add: "\<And>b1 b2. b1 \<in> S1 \<Longrightarrow> b2 \<in> S1 \<Longrightarrow> f (b1 + b2) = f b1 + f b2"
    and scale: "\<And>b. b \<in> S1 \<Longrightarrow> f (r *a b) = r *b f b"

lemma implicit_module_hom_on_with[implicit_ab_group_add]:
  "module_hom_on_with S1 S2 (+) (-) uminus 0 s1 (+) (-) uminus 0 s2 = module_hom_on S1 S2 s1 s2"
  unfolding module_hom_on_with_def implicit_module_pair_on_with module_hom_on_def module_pair_on_def
    module_hom_on_axioms_def
  by (auto intro!: ext)

locale vector_space_on = module_on S scale
  for S and scale :: "'a::field \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b" (infixr "*s" 75)
begin

definition dim :: "'b set \<Rightarrow> nat"
  where "dim V = (if \<exists>b\<subseteq>S. \<not> dependent b \<and> span b = span V
    then card (SOME b. b \<subseteq> S \<and> \<not> dependent b \<and> span b = span V)
    else 0)"

lemma implicit_dim_with[implicit_ab_group_add]: "dim_on_with S (+) 0 (*s) = dim"
  unfolding dim_on_with_def dim_def implicit_ab_group_add ..

end

lemma vector_space_on_alt_def: "vector_space_on S = module_on S"
  unfolding vector_space_on_def module_on_def
  by auto

lemma implicit_vector_space_on_with[implicit_ab_group_add]:
  "vector_space_on_with S (+) (-) uminus 0 = vector_space_on S"
  unfolding vector_space_on_alt_def vector_space_on_def vector_space_on_with_def implicit_module_on_with ..

locale linear_on = module_hom_on S1 S2 s1 s2 f
  for S1 S2 and s1::"'a::field \<Rightarrow> 'b \<Rightarrow> 'b::ab_group_add"
    and s2::"'a::field \<Rightarrow> 'c \<Rightarrow> 'c::ab_group_add"
    and f

lemma implicit_linear_on_with[implicit_ab_group_add]:
  "linear_on_with S1 S2 (+) (-) uminus 0 s1 (+) (-) uminus 0 s2 = linear_on S1 S2 s1 s2"
  unfolding linear_on_with_def linear_on_def implicit_module_hom_on_with ..

locale finite_dimensional_vector_space_on = vector_space_on S scale for S scale +
  fixes basis :: "'a set"
  assumes finite_Basis: "finite basis"
  and independent_Basis: "\<not> dependent basis"
  and span_Basis: "span basis = S" and basis_subset: "basis \<subseteq> S"

locale vector_space_pair_on = m1: vector_space_on S1 scale1 +
  m2: vector_space_on S2 scale2
  for S1:: "'b::ab_group_add set" and S2::"'c::ab_group_add set"
    and scale1::"'a::field \<Rightarrow> _" and scale2::"'a \<Rightarrow> _"

locale finite_dimensional_vector_space_pair_1_on =
  vs1: finite_dimensional_vector_space_on S1 scale1 Basis1 +
  vs2: vector_space_on S2 scale2
  for S1 S2
    and scale1::"'a::field \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b"
    and scale2::"'a::field \<Rightarrow> 'c::ab_group_add \<Rightarrow> 'c"
    and Basis1

locale finite_dimensional_vector_space_pair_on =
  vs1: finite_dimensional_vector_space_on S1 scale1 Basis1 +
  vs2: finite_dimensional_vector_space_on S2 scale2 Basis2
  for S1 S2
    and scale1::"'a::field \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b"
    and scale2::"'a::field \<Rightarrow> 'c::ab_group_add \<Rightarrow> 'c"
    and Basis1 Basis2

subsection \<open>Local Typedef for Subspace\<close>

locale local_typedef_module_on = module_on S scale
  for S and scale::"'a::comm_ring_1\<Rightarrow>'b\<Rightarrow>'b::ab_group_add" and s::"'s itself" +
  assumes Ex_type_definition_S: "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S"
begin

lemma mem_sum: "sum f X \<in> S" if "\<And>x. x \<in> X \<Longrightarrow> f x \<in> S"
  using that
  by (induction X rule: infinite_finite_induct) (auto intro!: mem_zero mem_add)

sublocale local_typedef S "TYPE('s)"
  using Ex_type_definition_S by unfold_locales

sublocale local_typedef_ab_group_add_on_with "(+)::'b\<Rightarrow>'b\<Rightarrow>'b" "0::'b" "(-)" uminus S "TYPE('s)"
  using mem_zero mem_add mem_scale[of _ "-1"]
  by unfold_locales (auto simp: scale_minus_left_on)

context includes lifting_syntax begin

definition scale_S::"'a \<Rightarrow> 's \<Rightarrow> 's" where "scale_S = (id ---> rep ---> Abs) scale"

lemma scale_S_transfer[transfer_rule]: "((=) ===> cr_S ===> cr_S) scale scale_S"
  unfolding scale_S_def
  by (auto simp: cr_S_def mem_scale intro!: rel_funI)

end

lemma type_module_on_with: "module_on_with UNIV plus_S minus_S uminus_S (zero_S::'s) scale_S"
proof -
  have "module_on_with {x. x \<in> S} (+) (-) uminus 0 scale"
    using module_on_axioms
    by (auto simp: module_on_with_def module_on_def ab_group_add_on_with_Ball_def
        comm_monoid_add_on_with_Ball_def mem_uminus
        ab_semigroup_add_on_with_Ball_def semigroup_add_on_with_def)
  then show ?thesis
    by transfer'
qed

lemma UNIV_transfer[transfer_rule]: "(rel_set cr_S) S UNIV"
  by (auto simp: rel_set_def cr_S_def) (metis Abs_inverse)

end

context includes lifting_syntax begin

lemma Eps_unique_transfer_lemma:
  "f' (Eps (\<lambda>x. Domainp A x \<and> f x)) = g' (Eps g)"
  if [transfer_rule]: "right_total A" "(A ===> (=)) f g" "(A ===> (=)) f' g'"
    and holds: "\<exists>x. Domainp A x \<and> f x"
    and unique_g: "\<And>x y. g x \<Longrightarrow> g y \<Longrightarrow> g' x = g' y"
proof -
  define Epsg where "Epsg = Eps g"
  have "\<exists>x. g x"
    by transfer (simp add: holds)
  then have "g Epsg"
    unfolding Epsg_def
    by (rule someI_ex)
  obtain x where x[transfer_rule]: "A x Epsg"
    by (meson \<open>right_total A\<close> right_totalE)
  then have "Domainp A x" by auto
  from \<open>g Epsg\<close>[untransferred] have "f x" .
  from unique_g have unique:
    "\<And>x y. Domainp A x \<Longrightarrow> Domainp A y \<Longrightarrow> f x \<Longrightarrow> f y \<Longrightarrow> f' x = f' y"
    by transfer
  have "f' (Eps (\<lambda>x. Domainp A x \<and> f x)) = f' x"
    apply (rule unique[OF _ \<open>Domainp A x\<close> _ \<open>f x\<close>])
    apply (metis (mono_tags, lifting) local.holds someI_ex)
    apply (metis (mono_tags, lifting) local.holds someI_ex)
    done
  show "f' (SOME x. Domainp A x \<and> f x) = g' (Eps g)"
    using x \<open>f' (Eps _) = f' x\<close> Epsg_def
    using rel_funE that(3) by fastforce
qed

end

locale local_typedef_vector_space_on = local_typedef_module_on S scale s + vector_space_on S scale
  for S and scale::"'a::field\<Rightarrow>'b\<Rightarrow>'b::ab_group_add" and s::"'s itself"
begin

lemma type_vector_space_on_with: "vector_space_on_with UNIV plus_S minus_S uminus_S (zero_S::'s) scale_S"
  using type_module_on_with
  by (auto simp: vector_space_on_with_def)

context includes lifting_syntax begin

definition dim_S::"'s set \<Rightarrow> nat" where "dim_S = dim_on_with UNIV plus_S zero_S scale_S"

lemma transfer_dim[transfer_rule]: "(rel_set cr_S ===> (=)) dim dim_S"
proof (rule rel_funI)
  fix V V'
  assume [transfer_rule]: "rel_set cr_S V V'"
  then have subset: "V \<subseteq> S"
    by (auto simp: rel_set_def cr_S_def)
  then have "span V \<subseteq> S"
    by (auto simp: span_on_def intro!: mem_sum mem_scale)
  note type_dim_eq_card =
    vector_space.dim_eq_card[var_simplified explicit_ab_group_add, unoverload_type 'd,
      OF type.ab_group_add_axioms type_vector_space_on_with]
  have *: "(\<exists>b\<subseteq>UNIV. \<not> dependent_with plus_S zero_S scale_S b \<and> span_with plus_S zero_S scale_S b = span_with plus_S zero_S scale_S V') \<longleftrightarrow>
    (\<exists>b\<subseteq>S. \<not> local.dependent b \<and> local.span b = local.span V)"
    unfolding subset_iff
    by transfer (simp add: implicit_ab_group_add Ball_def)
  have **[symmetric]:
    "card (SOME b. Domainp (rel_set cr_S) b \<and> (\<not> dependent_with (+) 0 scale b \<and> span_with (+) 0 scale b = span_with (+) 0 scale V)) =
      card (SOME b. \<not> dependent_with plus_S zero_S scale_S b \<and> span_with plus_S zero_S scale_S b = span_with plus_S zero_S scale_S V')"
    if "b \<subseteq> S" "\<not>dependent b" "span b = span V" for b
    apply (rule Eps_unique_transfer_lemma[where f'=card and g'=card])
    subgoal by (rule right_total_rel_set) (rule transfer_raw)
    subgoal by transfer_prover
    subgoal by transfer_prover
    subgoal using that by (auto simp: implicit_ab_group_add Domainp_set Domainp_cr_S)
    subgoal premises prems for b c
    proof -
      from type_dim_eq_card[of b V'] type_dim_eq_card[of c V'] prems
      show ?thesis by simp
    qed
    done
  show "local.dim V = dim_S V'"
    unfolding dim_def dim_S_def * dim_on_with_def
    by (auto simp: ** Domainp_set Domainp_cr_S implicit_ab_group_add subset_eq)
qed

end

end

locale local_typedef_finite_dimensional_vector_space_on = local_typedef_vector_space_on S scale s +
  finite_dimensional_vector_space_on S scale Basis
  for S and scale::"'a::field\<Rightarrow>'b\<Rightarrow>'b::ab_group_add" and Basis and s::"'s itself"
begin

definition "Basis_S = Abs ` Basis"

lemma Basis_S_transfer[transfer_rule]: "rel_set cr_S Basis Basis_S"
  using Abs_inverse rep_inverse basis_subset
  by (force simp: rel_set_def Basis_S_def cr_S_def)

lemma type_finite_dimensional_vector_space_on_with:
  "finite_dimensional_vector_space_on_with UNIV plus_S minus_S uminus_S zero_S scale_S Basis_S"
proof -
  have "finite Basis_S" by transfer (rule finite_Basis)
  moreover have "\<not> dependent_with plus_S zero_S scale_S Basis_S"
    by transfer (simp add: implicit_dependent_with independent_Basis)
  moreover have "span_with plus_S zero_S scale_S Basis_S = UNIV"
    by transfer (simp add: implicit_span_with span_Basis)
  ultimately show ?thesis
    using type_vector_space_on_with
    by (auto simp: finite_dimensional_vector_space_on_with_def)
qed

end

locale local_typedef_module_pair =
  lt1: local_typedef_module_on S1 scale1 s +
  lt2: local_typedef_module_on S2 scale2 t
  for S1::"'b::ab_group_add set" and scale1::"'a::comm_ring_1 \<Rightarrow> 'b \<Rightarrow> 'b" and s::"'s itself"
    and S2::"'c::ab_group_add set" and scale2::"'a \<Rightarrow> 'c \<Rightarrow> 'c" and t::"'t itself"
begin

lemma type_module_pair_on_with:
  "module_pair_on_with UNIV UNIV lt1.plus_S lt1.minus_S lt1.uminus_S (lt1.zero_S::'s) lt1.scale_S
  lt2.plus_S lt2.minus_S lt2.uminus_S (lt2.zero_S::'t) lt2.scale_S"
  by (simp add: lt1.type_module_on_with lt2.type_module_on_with module_pair_on_with_def)

end

locale local_typedef_vector_space_pair =
  local_typedef_module_pair S1 scale1 s S2 scale2 t
  for S1::"'b::ab_group_add set" and scale1::"'a::field \<Rightarrow> 'b \<Rightarrow> 'b" and s::"'s itself"
    and S2::"'c::ab_group_add set" and scale2::"'a \<Rightarrow> 'c \<Rightarrow> 'c" and t::"'t itself"
begin

lemma type_vector_space_pair_on_with:
  "vector_space_pair_on_with UNIV UNIV lt1.plus_S lt1.minus_S lt1.uminus_S (lt1.zero_S::'s) lt1.scale_S
  lt2.plus_S lt2.minus_S lt2.uminus_S (lt2.zero_S::'t) lt2.scale_S"
  by (simp add: type_module_pair_on_with vector_space_pair_on_with_def)

sublocale lt1: local_typedef_vector_space_on S1 scale1 s by unfold_locales
sublocale lt2: local_typedef_vector_space_on S2 scale2 t by unfold_locales

end

locale local_typedef_finite_dimensional_vector_space_pair_1 =
  lt1: local_typedef_finite_dimensional_vector_space_on S1 scale1 Basis1 s +
  lt2: local_typedef_vector_space_on S2 scale2 t
  for S1::"'b::ab_group_add set" and scale1::"'a::field \<Rightarrow> 'b \<Rightarrow> 'b" and Basis1 and s::"'s itself"
    and S2::"'c::ab_group_add set" and scale2::"'a \<Rightarrow> 'c \<Rightarrow> 'c" and t::"'t itself"
begin

lemma type_finite_dimensional_vector_space_pair_1_on_with:
  "finite_dimensional_vector_space_pair_1_on_with UNIV UNIV lt1.plus_S lt1.minus_S lt1.uminus_S (lt1.zero_S::'s) lt1.scale_S lt1.Basis_S
  lt2.plus_S lt2.minus_S lt2.uminus_S (lt2.zero_S::'t) lt2.scale_S"
  by (simp add: finite_dimensional_vector_space_pair_1_on_with_def
      lt1.type_finite_dimensional_vector_space_on_with lt2.type_vector_space_on_with)

end

locale local_typedef_finite_dimensional_vector_space_pair =
  lt1: local_typedef_finite_dimensional_vector_space_on S1 scale1 Basis1 s +
  lt2: local_typedef_finite_dimensional_vector_space_on S2 scale2 Basis2 t
  for S1::"'b::ab_group_add set" and scale1::"'a::field \<Rightarrow> 'b \<Rightarrow> 'b" and Basis1 and s::"'s itself"
    and S2::"'c::ab_group_add set" and scale2::"'a \<Rightarrow> 'c \<Rightarrow> 'c" and Basis2 and t::"'t itself"
begin

lemma type_finite_dimensional_vector_space_pair_on_with:
  "finite_dimensional_vector_space_pair_on_with UNIV UNIV lt1.plus_S lt1.minus_S lt1.uminus_S (lt1.zero_S::'s) lt1.scale_S lt1.Basis_S
  lt2.plus_S lt2.minus_S lt2.uminus_S (lt2.zero_S::'t) lt2.scale_S lt2.Basis_S"
  by (simp add: finite_dimensional_vector_space_pair_on_with_def
      lt1.type_finite_dimensional_vector_space_on_with
      lt2.type_finite_dimensional_vector_space_on_with)

end

subsection \<open>Transfer from type-based \<^theory>\<open>HOL.Modules\<close> and \<^theory>\<open>HOL.Vector_Spaces\<close>\<close>

lemmas [transfer_rule] = right_total_fun_eq_transfer
  and [transfer_rule del] = vimage_parametric

subsubsection \<open>Modules\<close>

context module_on begin

context includes lifting_syntax assumes ltd: "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S" begin

interpretation local_typedef_module_on S scale "TYPE('s)" by unfold_locales fact

text\<open>Get theorem names:\<close>
print_locale! module
text\<open>Then replace:
\<^verbatim>\<open>notes[^"]*"([^"]*).*\<close>
with
\<^verbatim>\<open>$1 = module.$1\<close>
\<close>
text \<open>TODO: automate systematic naming!\<close>
lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'd,
    OF type.ab_group_add_axioms type_module_on_with,
    untransferred,
    var_simplified implicit_ab_group_add]:
    lt_scale_left_commute = module.scale_left_commute
  and lt_scale_zero_left = module.scale_zero_left
  and lt_scale_minus_left = module.scale_minus_left
  and lt_scale_left_diff_distrib = module.scale_left_diff_distrib
  and lt_scale_sum_left = module.scale_sum_left
  and lt_scale_zero_right = module.scale_zero_right
  and lt_scale_minus_right = module.scale_minus_right
  and lt_scale_right_diff_distrib = module.scale_right_diff_distrib
  and lt_scale_sum_right = module.scale_sum_right
  and lt_sum_constant_scale = module.sum_constant_scale
  and lt_subspace_def = module.subspace_def
  and lt_subspaceI = module.subspaceI
  and lt_subspace_single_0 = module.subspace_single_0
  and lt_subspace_0 = module.subspace_0
  and lt_subspace_add = module.subspace_add
  and lt_subspace_scale = module.subspace_scale
  and lt_subspace_neg = module.subspace_neg
  and lt_subspace_diff = module.subspace_diff
  and lt_subspace_sum = module.subspace_sum
  and lt_subspace_inter = module.subspace_inter
  and lt_span_explicit = module.span_explicit
  and lt_span_explicit' = module.span_explicit'
  and lt_span_finite = module.span_finite
  and lt_span_induct_alt = module.span_induct_alt
  and lt_span_mono = module.span_mono
  and lt_span_base = module.span_base
  and lt_span_superset = module.span_superset
  and lt_span_zero = module.span_zero
  and lt_span_add = module.span_add
  and lt_span_scale = module.span_scale
  and lt_subspace_span = module.subspace_span
  and lt_span_neg = module.span_neg
  and lt_span_diff = module.span_diff
  and lt_span_sum = module.span_sum
  and lt_span_minimal = module.span_minimal
  and lt_span_unique = module.span_unique
  and lt_span_subspace_induct = module.span_subspace_induct
  and lt_span_induct = module.span_induct
  and lt_span_empty = module.span_empty
  and lt_span_subspace = module.span_subspace
  and lt_span_span = module.span_span
  and lt_span_add_eq = module.span_add_eq
  and lt_span_add_eq2 = module.span_add_eq2
  and lt_span_singleton = module.span_singleton
  and lt_span_Un = module.span_Un
  and lt_span_insert = module.span_insert
  and lt_span_breakdown = module.span_breakdown
  and lt_span_breakdown_eq = module.span_breakdown_eq
  and lt_span_clauses = module.span_clauses
  and lt_span_eq_iff = module.span_eq_iff
  and lt_span_eq = module.span_eq
  and lt_eq_span_insert_eq = module.eq_span_insert_eq
  and lt_dependent_explicit = module.dependent_explicit
  and lt_dependent_mono = module.dependent_mono
  and lt_independent_mono = module.independent_mono
  and lt_dependent_zero = module.dependent_zero
  and lt_independent_empty = module.independent_empty
  and lt_independent_explicit_module = module.independent_explicit_module
  and lt_independentD = module.independentD
  and lt_independent_Union_directed = module.independent_Union_directed
  and lt_dependent_finite = module.dependent_finite
  and lt_independentD_alt = module.independentD_alt
  and lt_independentD_unique = module.independentD_unique
  and lt_spanning_subset_independent = module.spanning_subset_independent
  and lt_module_hom_scale_self = module.module_hom_scale_self
  and lt_module_hom_scale_left = module.module_hom_scale_left
  and lt_module_hom_id = module.module_hom_id
  and lt_module_hom_ident = module.module_hom_ident
  and lt_module_hom_uminus = module.module_hom_uminus
  and lt_subspace_UNIV = module.subspace_UNIV
(* should work but don't:
  and span_def = module.span_def
  and span_UNIV = module.span_UNIV
  and lt_span_alt = module.span_alt
  and dependent_alt = module.dependent_alt
  and independent_alt = module.independent_alt
  and unique_representation = module.unique_representation
  and subspace_Int = module.subspace_Int
  and subspace_Inter = module.subspace_Inter
*)
(* not expected to work:
and representation_ne_zero = module.representation_ne_zero
and representation_ne_zero = module.representation_ne_zero
and finite_representation = module.finite_representation
and sum_nonzero_representation_eq = module.sum_nonzero_representation_eq
and sum_representation_eq = module.sum_representation_eq
and representation_eqI = module.representation_eqI
and representation_basis = module.representation_basis
and representation_zero = module.representation_zero
and representation_diff = module.representation_diff
and representation_neg = module.representation_neg
and representation_add = module.representation_add
and representation_sum = module.representation_sum
and representation_scale = module.representation_scale
and representation_extend = module.representation_extend
end
*)

end

lemmas_with [cancel_type_definition,
    OF S_ne,
    folded subset_iff',
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
      scale_left_commute = lt_scale_left_commute
  and scale_zero_left = lt_scale_zero_left
  and scale_minus_left = lt_scale_minus_left
  and scale_left_diff_distrib = lt_scale_left_diff_distrib
  and scale_sum_left = lt_scale_sum_left
  and scale_zero_right = lt_scale_zero_right
  and scale_minus_right = lt_scale_minus_right
  and scale_right_diff_distrib = lt_scale_right_diff_distrib
  and scale_sum_right = lt_scale_sum_right
  and sum_constant_scale = lt_sum_constant_scale
  and subspace_def = lt_subspace_def
  and subspaceI = lt_subspaceI
  and subspace_single_0 = lt_subspace_single_0
  and subspace_0 = lt_subspace_0
  and subspace_add = lt_subspace_add
  and subspace_scale = lt_subspace_scale
  and subspace_neg = lt_subspace_neg
  and subspace_diff = lt_subspace_diff
  and subspace_sum = lt_subspace_sum
  and subspace_inter = lt_subspace_inter
  and span_explicit = lt_span_explicit
  and span_explicit' = lt_span_explicit'
  and span_finite = lt_span_finite
  and span_induct_alt[consumes 1, case_names base step, induct set : span] = lt_span_induct_alt
  and span_mono = lt_span_mono
  and span_base = lt_span_base
  and span_superset = lt_span_superset
  and span_zero = lt_span_zero
  and span_add = lt_span_add
  and span_scale = lt_span_scale
  and subspace_span = lt_subspace_span
  and span_neg = lt_span_neg
  and span_diff = lt_span_diff
  and span_sum = lt_span_sum
  and span_minimal = lt_span_minimal
  and span_unique = lt_span_unique
  and span_subspace_induct[consumes 2] = lt_span_subspace_induct
  and span_induct[consumes 1, case_names base step, induct set : span] = lt_span_induct
  and span_empty = lt_span_empty
  and span_subspace = lt_span_subspace
  and span_span = lt_span_span
  and span_add_eq = lt_span_add_eq
  and span_add_eq2 = lt_span_add_eq2
  and span_singleton = lt_span_singleton
  and span_Un = lt_span_Un
  and span_insert = lt_span_insert
  and span_breakdown = lt_span_breakdown
  and span_breakdown_eq = lt_span_breakdown_eq
  and span_clauses = lt_span_clauses
  and span_eq_iff = lt_span_eq_iff
  and span_eq = lt_span_eq
  and eq_span_insert_eq = lt_eq_span_insert_eq
  and dependent_explicit = lt_dependent_explicit
  and dependent_mono = lt_dependent_mono
  and independent_mono = lt_independent_mono
  and dependent_zero = lt_dependent_zero
  and independent_empty = lt_independent_empty
  and independent_explicit_module = lt_independent_explicit_module
  and independentD = lt_independentD
  and independent_Union_directed = lt_independent_Union_directed
  and dependent_finite = lt_dependent_finite
  and independentD_alt = lt_independentD_alt
  and independentD_unique = lt_independentD_unique
  and spanning_subset_independent = lt_spanning_subset_independent
  and module_hom_scale_self = lt_module_hom_scale_self
  and module_hom_scale_left = lt_module_hom_scale_left
  and module_hom_id = lt_module_hom_id
  and module_hom_ident = lt_module_hom_ident
  and module_hom_uminus = lt_module_hom_uminus
  and subspace_UNIV = lt_subspace_UNIV
end

subsubsection \<open>Vector Spaces\<close>

context vector_space_on begin

context includes lifting_syntax assumes "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S" begin

interpretation local_typedef_vector_space_on S scale "TYPE('s)" by unfold_locales fact

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'd,
    OF type.ab_group_add_axioms type_vector_space_on_with,
    folded dim_S_def,
    untransferred,
    var_simplified implicit_ab_group_add]:
    lt_linear_id = vector_space.linear_id
and lt_linear_ident = vector_space.linear_ident
and lt_linear_scale_self = vector_space.linear_scale_self
and lt_linear_scale_left = vector_space.linear_scale_left
and lt_linear_uminus = vector_space.linear_uminus
and lt_linear_imp_scale["consumes" - 1, "case_names" "1"] = vector_space.linear_imp_scale
and lt_scale_eq_0_iff = vector_space.scale_eq_0_iff
and lt_scale_left_imp_eq = vector_space.scale_left_imp_eq
and lt_scale_right_imp_eq = vector_space.scale_right_imp_eq
and lt_scale_cancel_left = vector_space.scale_cancel_left
and lt_scale_cancel_right = vector_space.scale_cancel_right
and lt_injective_scale = vector_space.injective_scale
and lt_dependent_def = vector_space.dependent_def
and lt_dependent_single = vector_space.dependent_single
and lt_in_span_insert = vector_space.in_span_insert
and lt_dependent_insertD = vector_space.dependent_insertD
and lt_independent_insertI = vector_space.independent_insertI
and lt_independent_insert = vector_space.independent_insert
and lt_maximal_independent_subset_extend["consumes" - 1, "case_names" "1"] = vector_space.maximal_independent_subset_extend
and lt_maximal_independent_subset["consumes" - 1, "case_names" "1"] = vector_space.maximal_independent_subset
and lt_in_span_delete = vector_space.in_span_delete
and lt_span_redundant = vector_space.span_redundant
and lt_span_trans = vector_space.span_trans
and lt_span_insert_0 = vector_space.span_insert_0
and lt_span_delete_0 = vector_space.span_delete_0
and lt_span_image_scale = vector_space.span_image_scale
and lt_exchange_lemma = vector_space.exchange_lemma
and lt_independent_span_bound = vector_space.independent_span_bound
and lt_independent_explicit_finite_subsets = vector_space.independent_explicit_finite_subsets
and lt_independent_if_scalars_zero = vector_space.independent_if_scalars_zero
and lt_subspace_sums = vector_space.subspace_sums
and lt_dim_unique = vector_space.dim_unique
and lt_dim_eq_card = vector_space.dim_eq_card
and lt_basis_card_eq_dim = vector_space.basis_card_eq_dim
and lt_basis_exists = vector_space.basis_exists
and lt_dim_eq_card_independent = vector_space.dim_eq_card_independent
and lt_dim_span = vector_space.dim_span
and lt_dim_span_eq_card_independent = vector_space.dim_span_eq_card_independent
and lt_dim_le_card = vector_space.dim_le_card
and lt_span_eq_dim = vector_space.span_eq_dim
and lt_dim_le_card' = vector_space.dim_le_card'
and lt_span_card_ge_dim = vector_space.span_card_ge_dim
and lt_dim_with = vector_space.dim_with
(* should work but don't:v

and lt_bij_if_span_eq_span_bases = vector_space.bij_if_span_eq_span_bases
*)
(* not expected to work:
and lt_dim_def = vector_space.dim_def
and lt_extend_basis_superset = vector_space.extend_basis_superset
and lt_independent_extend_basis = vector_space.independent_extend_basis
and lt_span_extend_basis = vector_space.span_extend_basis
*)

end

lemmas_with [cancel_type_definition,
    OF S_ne,
    folded subset_iff',
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
    linear_id = lt_linear_id
and linear_ident = lt_linear_ident
and linear_scale_self = lt_linear_scale_self
and linear_scale_left = lt_linear_scale_left
and linear_uminus = lt_linear_uminus
and linear_imp_scale["consumes" - 1, "case_names" "1"] = lt_linear_imp_scale
and scale_eq_0_iff = lt_scale_eq_0_iff
and scale_left_imp_eq = lt_scale_left_imp_eq
and scale_right_imp_eq = lt_scale_right_imp_eq
and scale_cancel_left = lt_scale_cancel_left
and scale_cancel_right = lt_scale_cancel_right
and dependent_def = lt_dependent_def
and dependent_single = lt_dependent_single
and in_span_insert = lt_in_span_insert
and dependent_insertD = lt_dependent_insertD
and independent_insertI = lt_independent_insertI
and independent_insert = lt_independent_insert
and maximal_independent_subset_extend["consumes" - 1, "case_names" "1"] = lt_maximal_independent_subset_extend
and maximal_independent_subset["consumes" - 1, "case_names" "1"] = lt_maximal_independent_subset
and in_span_delete = lt_in_span_delete
and span_redundant = lt_span_redundant
and span_trans = lt_span_trans
and span_insert_0 = lt_span_insert_0
and span_delete_0 = lt_span_delete_0
and span_image_scale = lt_span_image_scale
and exchange_lemma = lt_exchange_lemma
and independent_span_bound = lt_independent_span_bound
and independent_explicit_finite_subsets = lt_independent_explicit_finite_subsets
and independent_if_scalars_zero = lt_independent_if_scalars_zero
and subspace_sums = lt_subspace_sums
and dim_unique = lt_dim_unique
and dim_eq_card = lt_dim_eq_card
and basis_card_eq_dim = lt_basis_card_eq_dim
and basis_exists["consumes" - 1, "case_names" "1"] = lt_basis_exists
and dim_eq_card_independent = lt_dim_eq_card_independent
and dim_span = lt_dim_span
and dim_span_eq_card_independent = lt_dim_span_eq_card_independent
and dim_le_card = lt_dim_le_card
and span_eq_dim = lt_span_eq_dim
and dim_le_card' = lt_dim_le_card'
and span_card_ge_dim = lt_span_card_ge_dim
and dim_with = lt_dim_with

end

subsubsection \<open>Finite Dimensional Vector Spaces\<close>

context finite_dimensional_vector_space_on begin

context includes lifting_syntax assumes "\<exists>(Rep::'s \<Rightarrow> 'a) (Abs::'a \<Rightarrow> 's). type_definition Rep Abs S" begin

interpretation local_typedef_finite_dimensional_vector_space_on S scale basis "TYPE('s)" by unfold_locales fact

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'd,
    OF type.ab_group_add_axioms type_finite_dimensional_vector_space_on_with,
    folded dim_S_def,
    untransferred,
    var_simplified implicit_ab_group_add]:
     lt_finiteI_independent = finite_dimensional_vector_space.finiteI_independent
and  lt_dim_empty = finite_dimensional_vector_space.dim_empty
and  lt_dim_insert = finite_dimensional_vector_space.dim_insert
and  lt_dim_singleton = finite_dimensional_vector_space.dim_singleton
and  lt_choose_subspace_of_subspace["consumes" - 1, "case_names" "1"] = finite_dimensional_vector_space.choose_subspace_of_subspace
and  lt_basis_subspace_exists["consumes" - 1, "case_names" "1"] = finite_dimensional_vector_space.basis_subspace_exists
and  lt_dim_mono = finite_dimensional_vector_space.dim_mono
and  lt_dim_subset = finite_dimensional_vector_space.dim_subset
and  lt_dim_eq_0 = finite_dimensional_vector_space.dim_eq_0
and  lt_dim_UNIV = finite_dimensional_vector_space.dim_UNIV
and  lt_independent_card_le_dim = finite_dimensional_vector_space.independent_card_le_dim
and  lt_card_ge_dim_independent = finite_dimensional_vector_space.card_ge_dim_independent
and  lt_card_le_dim_spanning = finite_dimensional_vector_space.card_le_dim_spanning
and  lt_card_eq_dim = finite_dimensional_vector_space.card_eq_dim
and  lt_subspace_dim_equal = finite_dimensional_vector_space.subspace_dim_equal
and  lt_dim_eq_span = finite_dimensional_vector_space.dim_eq_span
and  lt_dim_psubset = finite_dimensional_vector_space.dim_psubset
and  lt_indep_card_eq_dim_span = finite_dimensional_vector_space.indep_card_eq_dim_span
and  lt_independent_bound_general = finite_dimensional_vector_space.independent_bound_general
and  lt_independent_explicit = finite_dimensional_vector_space.independent_explicit
and  lt_dim_sums_Int = finite_dimensional_vector_space.dim_sums_Int
and  lt_dependent_biggerset_general = finite_dimensional_vector_space.dependent_biggerset_general
and  lt_subset_le_dim = finite_dimensional_vector_space.subset_le_dim
and  lt_linear_inj_imp_surj = finite_dimensional_vector_space.linear_inj_imp_surj
and  lt_linear_surj_imp_inj = finite_dimensional_vector_space.linear_surj_imp_inj
and  lt_linear_inverse_left = finite_dimensional_vector_space.linear_inverse_left
and  lt_left_inverse_linear = finite_dimensional_vector_space.left_inverse_linear
and  lt_right_inverse_linear = finite_dimensional_vector_space.right_inverse_linear
(* not expected to work:
     lt_dimension_def = finite_dimensional_vector_space.dimension_def
and  lt_dim_subset_UNIV = finite_dimensional_vector_space.dim_subset_UNIV
and  lt_dim_eq_full = finite_dimensional_vector_space.dim_eq_full
and  lt_inj_linear_imp_inv_linear = finite_dimensional_vector_space.inj_linear_imp_inv_linear
*)

end

lemmas_with [cancel_type_definition,
    OF S_ne,
    folded subset_iff',
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
     finiteI_independent = lt_finiteI_independent
and  dim_empty = lt_dim_empty
and  dim_insert = lt_dim_insert
and  dim_singleton = lt_dim_singleton
and  choose_subspace_of_subspace["consumes" - 1, "case_names" "1"] = lt_choose_subspace_of_subspace
and  basis_subspace_exists["consumes" - 1, "case_names" "1"] = lt_basis_subspace_exists
and  dim_mono = lt_dim_mono
and  dim_subset = lt_dim_subset
and  dim_eq_0 = lt_dim_eq_0
and  dim_UNIV = lt_dim_UNIV
and  independent_card_le_dim = lt_independent_card_le_dim
and  card_ge_dim_independent = lt_card_ge_dim_independent
and  card_le_dim_spanning = lt_card_le_dim_spanning
and  card_eq_dim = lt_card_eq_dim
and  subspace_dim_equal = lt_subspace_dim_equal
and  dim_eq_span = lt_dim_eq_span
and  dim_psubset = lt_dim_psubset
and  indep_card_eq_dim_span = lt_indep_card_eq_dim_span
and  independent_bound_general = lt_independent_bound_general
and  independent_explicit = lt_independent_explicit
and  dim_sums_Int = lt_dim_sums_Int
and  dependent_biggerset_general = lt_dependent_biggerset_general
and  subset_le_dim = lt_subset_le_dim
and  linear_inj_imp_surj = lt_linear_inj_imp_surj
and  linear_surj_imp_inj = lt_linear_surj_imp_inj
and  linear_inverse_left = lt_linear_inverse_left
and  left_inverse_linear = lt_left_inverse_linear
and  right_inverse_linear = lt_right_inverse_linear

end

context module_pair_on begin

context includes lifting_syntax
  assumes
    "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S1"
    "\<exists>(Rep::'t \<Rightarrow> 'c) (Abs::'c \<Rightarrow> 't). type_definition Rep Abs S2" begin

interpretation local_typedef_module_pair S1 scale1 "TYPE('s)" S2 scale2 "TYPE('t)" by unfold_locales fact+

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'e 'f,
  OF lt2.type.ab_group_add_axioms lt1.type.ab_group_add_axioms type_module_pair_on_with,
  untransferred,
  var_simplified implicit_ab_group_add]:
  lt_module_hom_zero = module_pair.module_hom_zero
and lt_module_hom_add = module_pair.module_hom_add
and lt_module_hom_sub = module_pair.module_hom_sub
and lt_module_hom_neg = module_pair.module_hom_neg
and lt_module_hom_scale = module_pair.module_hom_scale
and lt_module_hom_compose_scale = module_pair.module_hom_compose_scale
and lt_module_hom_sum = module_pair.module_hom_sum
and lt_module_hom_eq_on_span = module_pair.module_hom_eq_on_span
(* should work, but doesnt
and lt_bij_module_hom_imp_inv_module_hom = module_pair.bij_module_hom_imp_inv_module_hom[of scale1 scale2]
*)

end

lemmas_with [cancel_type_definition, OF m1.S_ne,
  cancel_type_definition, OF m2.S_ne,
    folded subset_iff' top_set_def,
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
  module_hom_zero = lt_module_hom_zero
and module_hom_add = lt_module_hom_add
and module_hom_sub = lt_module_hom_sub
and module_hom_neg = lt_module_hom_neg
and module_hom_scale = lt_module_hom_scale
and module_hom_compose_scale = lt_module_hom_compose_scale
and module_hom_sum = lt_module_hom_sum
and module_hom_eq_on_span = lt_module_hom_eq_on_span

end

context vector_space_pair_on begin

context includes lifting_syntax
  notes [transfer_rule del] = Collect_transfer
  assumes
    "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S1"
    "\<exists>(Rep::'t \<Rightarrow> 'c) (Abs::'c \<Rightarrow> 't). type_definition Rep Abs S2" begin

interpretation local_typedef_vector_space_pair S1 scale1 "TYPE('s)" S2 scale2 "TYPE('t)" by unfold_locales fact+

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'e 'f,
  OF lt2.type.ab_group_add_axioms lt1.type.ab_group_add_axioms type_vector_space_pair_on_with,
  folded lt1.dim_S_def lt2.dim_S_def,
  untransferred,
  var_simplified implicit_ab_group_add]:
  lt_linear_0 = vector_space_pair.linear_0
and lt_linear_add = vector_space_pair.linear_add
and lt_linear_scale = vector_space_pair.linear_scale
and lt_linear_neg = vector_space_pair.linear_neg
and lt_linear_diff = vector_space_pair.linear_diff
and lt_linear_sum = vector_space_pair.linear_sum
and lt_linear_inj_on_iff_eq_0 = vector_space_pair.linear_inj_on_iff_eq_0
and lt_linear_inj_iff_eq_0 = vector_space_pair.linear_inj_iff_eq_0
and lt_linear_subspace_image = vector_space_pair.linear_subspace_image
and lt_linear_subspace_vimage = vector_space_pair.linear_subspace_vimage
and lt_linear_subspace_kernel = vector_space_pair.linear_subspace_kernel
and lt_linear_span_image = vector_space_pair.linear_span_image
and lt_linear_dependent_inj_imageD = vector_space_pair.linear_dependent_inj_imageD
and lt_linear_eq_0_on_span = vector_space_pair.linear_eq_0_on_span
and lt_linear_independent_injective_image = vector_space_pair.linear_independent_injective_image
and lt_linear_inj_on_span_independent_image = vector_space_pair.linear_inj_on_span_independent_image
and lt_linear_inj_on_span_iff_independent_image = vector_space_pair.linear_inj_on_span_iff_independent_image
and lt_linear_subspace_linear_preimage = vector_space_pair.linear_subspace_linear_preimage
and lt_linear_spans_image = vector_space_pair.linear_spans_image
and lt_linear_spanning_surjective_image = vector_space_pair.linear_spanning_surjective_image
and lt_linear_eq_on_span = vector_space_pair.linear_eq_on_span
and lt_linear_compose_scale_right = vector_space_pair.linear_compose_scale_right
and lt_linear_compose_add = vector_space_pair.linear_compose_add
and lt_linear_zero = vector_space_pair.linear_zero
and lt_linear_compose_sub = vector_space_pair.linear_compose_sub
and lt_linear_compose_neg = vector_space_pair.linear_compose_neg
and lt_linear_compose_scale = vector_space_pair.linear_compose_scale
and lt_linear_indep_image_lemma = vector_space_pair.linear_indep_image_lemma
and lt_linear_eq_on = vector_space_pair.linear_eq_on
and lt_linear_compose_sum = vector_space_pair.linear_compose_sum
and lt_linear_independent_extend_subspace = vector_space_pair.linear_independent_extend_subspace
and lt_linear_independent_extend = vector_space_pair.linear_independent_extend
and lt_linear_exists_left_inverse_on = vector_space_pair.linear_exists_left_inverse_on
and lt_linear_exists_right_inverse_on = vector_space_pair.linear_exists_right_inverse_on
and lt_linear_inj_on_left_inverse = vector_space_pair.linear_inj_on_left_inverse
and lt_linear_injective_left_inverse = vector_space_pair.linear_injective_left_inverse
and lt_linear_surj_right_inverse = vector_space_pair.linear_surj_right_inverse
and lt_linear_surjective_right_inverse = vector_space_pair.linear_surjective_right_inverse
and lt_finite_basis_to_basis_subspace_isomorphism = vector_space_pair.finite_basis_to_basis_subspace_isomorphism
(* should work, but doesnt
*)
(* not expected to work:
  lt_construct_def = vector_space_pair.construct_def
  lt_construct_cong = vector_space_pair.construct_cong
  lt_linear_construct = vector_space_pair.linear_construct
  lt_construct_basis = vector_space_pair.construct_basis
  lt_construct_outside = vector_space_pair.construct_outside
  lt_construct_add = vector_space_pair.construct_add
  lt_construct_scale = vector_space_pair.construct_scale
  lt_construct_in_span = vector_space_pair.construct_in_span
  lt_in_span_in_range_construct = vector_space_pair.in_span_in_range_construct
  lt_range_construct_eq_span = vector_space_pair.range_construct_eq_span
*)
end

lemmas_with [cancel_type_definition, OF m1.S_ne,
    cancel_type_definition, OF m2.S_ne,
    folded subset_iff' top_set_def,
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
  linear_0 = lt_linear_0
  and linear_add = lt_linear_add
  and linear_scale = lt_linear_scale
  and linear_neg = lt_linear_neg
  and linear_diff = lt_linear_diff
  and linear_sum = lt_linear_sum
  and linear_inj_on_iff_eq_0 = lt_linear_inj_on_iff_eq_0
  and linear_inj_iff_eq_0 = lt_linear_inj_iff_eq_0
  and linear_subspace_image = lt_linear_subspace_image
  and linear_subspace_vimage = lt_linear_subspace_vimage
  and linear_subspace_kernel = lt_linear_subspace_kernel
  and linear_span_image = lt_linear_span_image
  and linear_dependent_inj_imageD = lt_linear_dependent_inj_imageD
  and linear_eq_0_on_span = lt_linear_eq_0_on_span
  and linear_independent_injective_image = lt_linear_independent_injective_image
  and linear_inj_on_span_independent_image = lt_linear_inj_on_span_independent_image
  and linear_inj_on_span_iff_independent_image = lt_linear_inj_on_span_iff_independent_image
  and linear_subspace_linear_preimage = lt_linear_subspace_linear_preimage
  and linear_spans_image = lt_linear_spans_image
  and linear_spanning_surjective_image = lt_linear_spanning_surjective_image
  and linear_eq_on_span = lt_linear_eq_on_span
  and linear_compose_scale_right = lt_linear_compose_scale_right
  and linear_compose_add = lt_linear_compose_add
  and linear_zero = lt_linear_zero
  and linear_compose_sub = lt_linear_compose_sub
  and linear_compose_neg = lt_linear_compose_neg
  and linear_compose_scale = lt_linear_compose_scale
  and linear_indep_image_lemma = lt_linear_indep_image_lemma
  and linear_eq_on = lt_linear_eq_on
  and linear_compose_sum = lt_linear_compose_sum
  and linear_independent_extend_subspace = lt_linear_independent_extend_subspace
  and linear_independent_extend = lt_linear_independent_extend
  and linear_exists_left_inverse_on = lt_linear_exists_left_inverse_on
  and linear_exists_right_inverse_on = lt_linear_exists_right_inverse_on
  and linear_inj_on_left_inverse = lt_linear_inj_on_left_inverse
  and linear_injective_left_inverse = lt_linear_injective_left_inverse
  and linear_surj_right_inverse = lt_linear_surj_right_inverse
  and linear_surjective_right_inverse = lt_linear_surjective_right_inverse
  and finite_basis_to_basis_subspace_isomorphism = lt_finite_basis_to_basis_subspace_isomorphism

end

context finite_dimensional_vector_space_pair_1_on begin

context includes lifting_syntax
  notes [transfer_rule del] = Collect_transfer
  assumes
    "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S1"
    "\<exists>(Rep::'t \<Rightarrow> 'c) (Abs::'c \<Rightarrow> 't). type_definition Rep Abs S2" begin

interpretation local_typedef_finite_dimensional_vector_space_pair_1 S1 scale1 Basis1 "TYPE('s)" S2 scale2 "TYPE('t)" by unfold_locales fact+

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'e 'f,
  OF lt2.type.ab_group_add_axioms lt1.type.ab_group_add_axioms type_finite_dimensional_vector_space_pair_1_on_with,
  folded lt1.dim_S_def lt2.dim_S_def,
  untransferred,
  var_simplified implicit_ab_group_add]:
   lt_dim_image_eq = finite_dimensional_vector_space_pair_1.dim_image_eq
and lt_dim_image_le = finite_dimensional_vector_space_pair_1.dim_image_le

end

lemmas_with [cancel_type_definition, OF vs1.S_ne,
    cancel_type_definition, OF vs2.S_ne,
    folded subset_iff' top_set_def,
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
  dim_image_eq = lt_dim_image_eq
and dim_image_le = lt_dim_image_le

end

context finite_dimensional_vector_space_pair_on begin

context includes lifting_syntax
  notes [transfer_rule del] = Collect_transfer
  assumes
    "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S1"
    "\<exists>(Rep::'t \<Rightarrow> 'c) (Abs::'c \<Rightarrow> 't). type_definition Rep Abs S2" begin

interpretation local_typedef_finite_dimensional_vector_space_pair S1 scale1 Basis1 "TYPE('s)" S2 scale2 Basis2 "TYPE('t)" by unfold_locales fact+

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'e 'f,
  OF lt2.type.ab_group_add_axioms lt1.type.ab_group_add_axioms type_finite_dimensional_vector_space_pair_on_with,
  folded lt1.dim_S_def lt2.dim_S_def,
  untransferred,
  var_simplified implicit_ab_group_add]:
lt_linear_surjective_imp_injective = finite_dimensional_vector_space_pair.linear_surjective_imp_injective
and lt_linear_injective_imp_surjective = finite_dimensional_vector_space_pair.linear_injective_imp_surjective
and lt_linear_injective_isomorphism = finite_dimensional_vector_space_pair.linear_injective_isomorphism
and lt_linear_surjective_isomorphism = finite_dimensional_vector_space_pair.linear_surjective_isomorphism
and lt_basis_to_basis_subspace_isomorphism = finite_dimensional_vector_space_pair.basis_to_basis_subspace_isomorphism
and lt_subspace_isomorphism = finite_dimensional_vector_space_pair.subspace_isomorphism

end

lemmas_with [cancel_type_definition, OF vs1.S_ne,
    cancel_type_definition, OF vs2.S_ne,
    folded subset_iff' top_set_def,
    simplified pred_fun_def,
    simplified\<comment>\<open>too much?\<close>]:
linear_surjective_imp_injective = lt_linear_surjective_imp_injective
and linear_injective_imp_surjective = lt_linear_injective_imp_surjective
and linear_injective_isomorphism = lt_linear_injective_isomorphism
and linear_surjective_isomorphism = lt_linear_surjective_isomorphism
and basis_to_basis_subspace_isomorphism = lt_basis_to_basis_subspace_isomorphism
and subspace_isomorphism = lt_subspace_isomorphism

end

end


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

section \<open>Periodic Functions\<close>

theory Periodic_Fun
imports Complex_MainRLT
begin

text \<open>
  A locale for periodic functions. The idea is that one proves $f(x + p) = f(x)$
  for some period $p$ and gets derived results like $f(x - p) = f(x)$ and $f(x + 2p) = f(x)$
  for free.

  \<^term>\<open>g\<close> and \<^term>\<open>gm\<close> are ``plus/minus k periods'' functions.
  \<^term>\<open>g1\<close> and \<^term>\<open>gn1\<close> are ``plus/minus one period'' functions.
  This is useful e.g. if the period is one; the lemmas one gets are then
  \<^term>\<open>f (x + 1) = f x\<close> instead of \<^term>\<open>f (x + 1 * 1) = f x\<close> etc.
\<close>
locale periodic_fun =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b" and g gm :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" and g1 gn1 :: "'a \<Rightarrow> 'a"
  assumes plus_1: "f (g1 x) = f x"
  assumes periodic_arg_plus_0: "g x 0 = x"
  assumes periodic_arg_plus_distrib: "g x (of_int (m + n)) = g (g x (of_int n)) (of_int m)"
  assumes plus_1_eq: "g x 1 = g1 x" and minus_1_eq: "g x (-1) = gn1 x"
          and minus_eq: "g x (-y) = gm x y"
begin

lemma plus_of_nat: "f (g x (of_nat n)) = f x"
  by (induction n) (insert periodic_arg_plus_distrib[of _ 1 "int n" for n],
                    simp_all add: plus_1 periodic_arg_plus_0 plus_1_eq)

lemma minus_of_nat: "f (gm x (of_nat n)) = f x"
proof -
  have "f (g x (- of_nat n)) = f (g (g x (- of_nat n)) (of_nat n))"
    by (rule plus_of_nat[symmetric])
  also have "\<dots> = f (g (g x (of_int (- of_nat n))) (of_int (of_nat n)))" by simp
  also have "\<dots> = f x"
    by (subst periodic_arg_plus_distrib [symmetric]) (simp add: periodic_arg_plus_0)
  finally show ?thesis by (simp add: minus_eq)
qed

lemma plus_of_int: "f (g x (of_int n)) = f x"
  by (induction n) (simp_all add: plus_of_nat minus_of_nat minus_eq del: of_nat_Suc)

lemma minus_of_int: "f (gm x (of_int n)) = f x"
  using plus_of_int[of x "of_int (-n)"] by (simp add: minus_eq)

lemma plus_numeral: "f (g x (numeral n)) = f x"
  by (subst of_nat_numeral[symmetric], subst plus_of_nat) (rule refl)

lemma minus_numeral: "f (gm x (numeral n)) = f x"
  by (subst of_nat_numeral[symmetric], subst minus_of_nat) (rule refl)

lemma minus_1: "f (gn1 x) = f x"
  using minus_of_nat[of x 1] by (simp flip: minus_1_eq minus_eq)

lemmas periodic_simps = plus_of_nat minus_of_nat plus_of_int minus_of_int
                        plus_numeral minus_numeral plus_1 minus_1

end

text \<open>
  Specialised case of the \<^term>\<open>periodic_fun\<close> locale for periods that are not 1.
  Gives lemmas \<^term>\<open>f (x - period) = f x\<close> etc.
\<close>
locale periodic_fun_simple =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b" and period :: 'a
  assumes plus_period: "f (x + period) = f x"
begin
sublocale periodic_fun f "\<lambda>z x. z + x * period" "\<lambda>z x. z - x * period"
  "\<lambda>z. z + period" "\<lambda>z. z - period"
  by standard (simp_all add: ring_distribs plus_period)
end

text \<open>
  Specialised case of the \<^term>\<open>periodic_fun\<close> locale for period 1.
  Gives lemmas \<^term>\<open>f (x - 1) = f x\<close> etc.
\<close>
locale periodic_fun_simple' =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b"
  assumes plus_period: "f (x + 1) = f x"
begin
sublocale periodic_fun f "\<lambda>z x. z + x" "\<lambda>z x. z - x" "\<lambda>z. z + 1" "\<lambda>z. z - 1"
  by standard (simp_all add: ring_distribs plus_period)

lemma of_nat: "f (of_nat n) = f 0" using plus_of_nat[of 0 n] by simp
lemma uminus_of_nat: "f (-of_nat n) = f 0" using minus_of_nat[of 0 n] by simp
lemma of_int: "f (of_int n) = f 0" using plus_of_int[of 0 n] by simp
lemma uminus_of_int: "f (-of_int n) = f 0" using minus_of_int[of 0 n] by simp
lemma of_numeral: "f (numeral n) = f 0" using plus_numeral[of 0 n] by simp
lemma of_neg_numeral: "f (-numeral n) = f 0" using minus_numeral[of 0 n] by simp
lemma of_1: "f 1 = f 0" using plus_of_nat[of 0 1] by simp
lemma of_neg_1: "f (-1) = f 0" using minus_of_nat[of 0 1] by simp

lemmas periodic_simps' =
  of_nat uminus_of_nat of_int uminus_of_int of_numeral of_neg_numeral of_1 of_neg_1

end

lemma sin_plus_pi: "sin ((z :: 'a :: {real_normed_field,banach}) + of_real pi) = - sin z"
  by (simp add: sin_add)

lemma cos_plus_pi: "cos ((z :: 'a :: {real_normed_field,banach}) + of_real pi) = - cos z"
  by (simp add: cos_add)

interpretation sin: periodic_fun_simple sin "2 * of_real pi :: 'a :: {real_normed_field,banach}"
proof
  fix z :: 'a
  have "sin (z + 2 * of_real pi) = sin (z + of_real pi + of_real pi)" by (simp add: ac_simps)
  also have "\<dots> = sin z" by (simp only: sin_plus_pi) simp
  finally show "sin (z + 2 * of_real pi) = sin z" .
qed

interpretation cos: periodic_fun_simple cos "2 * of_real pi :: 'a :: {real_normed_field,banach}"
proof
  fix z :: 'a
  have "cos (z + 2 * of_real pi) = cos (z + of_real pi + of_real pi)" by (simp add: ac_simps)
  also have "\<dots> = cos z" by (simp only: cos_plus_pi) simp
  finally show "cos (z + 2 * of_real pi) = cos z" .
qed

interpretation tan: periodic_fun_simple tan "2 * of_real pi :: 'a :: {real_normed_field,banach}"
  by standard (simp only: tan_def [abs_def] sin.plus_1 cos.plus_1)

interpretation cot: periodic_fun_simple cot "2 * of_real pi :: 'a :: {real_normed_field,banach}"
  by standard (simp only: cot_def [abs_def] sin.plus_1 cos.plus_1)

end


theory ConcreteSemantics10_4_Live_True
  imports Main "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Vars" "~~/src/HOL/Library/While_Combinator"
begin

subsection "True Liveness Analysis"

subsubsection "Analysis"

fun L :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"L SKIP X = X" |
"L (x ::= a) X = (if x \<in> X then vars a \<union> (X - {x}) else X)" |
"L (c\<^sub>1;; c\<^sub>2) X = L c\<^sub>1 (L c\<^sub>2 X)" |
"L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> L c\<^sub>1 X \<union> L c\<^sub>2 X" |
"L (WHILE b DO c) X = lfp(\<lambda>Y. vars b \<union> X \<union> L c Y)"

(*Lemma 10.30.*)
lemma L_mono: "mono(L c)"
proof-
  have "X \<subseteq> Y \<Longrightarrow> L c X \<subseteq> L c Y" for X Y
  proof (induction c arbitrary: X Y)
  case SKIP
    then show ?case
      by (simp add: monoI)
  next
    case (Assign x1 x2)
    then show ?case by auto
  next
    case (Seq c1 c2)
    then show ?case
      by simp
  next
    case (If x1 c1 c2)
    then show ?case by (simp add: subset_iff)
  next
    case (While x1 c)
    show ?case
    proof(simp, rule lfp_mono)
      fix Z show "vars x1 \<union> X \<union> L c Z \<subseteq> vars x1 \<union> Y \<union> L c Z"
        using While.prems by auto
    qed
  qed
  thus ?thesis
    by (simp add: monoI)
qed

lemma mono_union_L:
  "mono (\<lambda>Y. X \<union> L c Y)"
  by (smt L_mono le_iff_sup le_sup_iff monoI mono_Un sup.idem sup.mono)

lemma L_While_unfold: "L (WHILE b DO c) X = vars b \<union> X \<union> L c (L (WHILE b DO c) X)"
  apply(metis lfp_unfold[OF mono_union_L] L.simps(5))
  done
(*
 1. lfp (\<lambda>Y. vars b \<union> X \<union> L c Y) = vars b \<union> X \<union> L c (lfp (\<lambda>Y. vars b \<union> X \<union> L c Y))
*)

lemma L_While_pfp: "L c (L (WHILE b DO c) X) \<subseteq> L (WHILE b DO c) X"
  using L_While_unfold by blast

lemma L_While_vars: "vars b \<subseteq> L (WHILE b DO c) X"
  using L_While_unfold by auto

lemma L_While_X: "X \<subseteq> L (WHILE b DO c) X"
  using L_While_unfold by auto

subsubsection "Correctness"
(*Lemma 10.31 (Correctness of L).*)
theorem L_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  then show ?case by (auto simp add: ball_Un)
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq.IH(1) Seq.prems obtain t2 where "(c\<^sub>1, t) \<Rightarrow> t2" and "s\<^sub>2 = t2 on L c\<^sub>2 X"
    by simp blast
  obtain t3 where "(c\<^sub>2, t2) \<Rightarrow> t3" and "s\<^sub>3 = t3 on X"
    using Seq.IH(2) \<open>s\<^sub>2 = t2 on L c\<^sub>2 X\<close> by blast
  then show ?case
    using \<open>(c\<^sub>1, t) \<Rightarrow> t2\<close> by blast
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  then have "s = t on vars b" and "s = t on L c\<^sub>1 X " by auto
  have "bval b t"
    using IfTrue.hyps(1) \<open>s = t on vars b\<close> bval_eq_if_eq_on_vars by blast
 from IfTrue.IH[OF \<open>s = t on L c\<^sub>1 X\<close>] obtain t' where "s' = t' on X"  "(c\<^sub>1, t) \<Rightarrow> t'" by auto
  then show ?case
    using \<open>bval b t\<close> by blast
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  then have "s = t on vars b" and "s = t on L c\<^sub>2 X " by auto
  have "\<not> bval b t"
    using IfFalse.hyps(1) \<open>s = t on vars b\<close> bval_eq_if_eq_on_vars by blast
 from IfFalse.IH[OF \<open>s = t on L c\<^sub>2 X\<close>] obtain t' where "s' = t' on X"  "(c\<^sub>2, t) \<Rightarrow> t'" by auto
  then show ?case using \<open>\<not> bval b t\<close> by blast
next
  case (WhileFalse b s c)
  then have "~ bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  thus ?case
    using L_While_X WhileFalse.prems by blast
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?w = "WHILE b DO c"
  have "bval b t"
    by (metis L_While_vars WhileTrue.hyps(1) WhileTrue.prems bval_eq_if_eq_on_vars subsetD)
  then have "s\<^sub>1 = t on L c (L ?w X)"
    using L_While_pfp WhileTrue.prems by blast
  obtain t2 where "(c, t) \<Rightarrow> t2" "s\<^sub>2 = t2 on L ?w X"
    using WhileTrue.IH(1) \<open>s\<^sub>1 = t on L c (L (WHILE b DO c) X)\<close> by blast
  obtain t3 where "(?w, t2) \<Rightarrow> t3" "s\<^sub>3 = t3 on X"
    using WhileTrue.IH(2) \<open>s\<^sub>2 = t2 on L (WHILE b DO c) X\<close> by blast
  then show ?case
    using \<open>(c, t) \<Rightarrow> t2\<close> \<open>bval b t\<close> by blast
qed

subsubsection "Executability"

lemma L_subset_vars: "L c X \<subseteq> rvars c \<union> X"
proof (induction c arbitrary: X)
case SKIP
  then show ?case by auto
next
  case (Assign x1 x2)
  then show ?case by auto
next
  case (Seq c1 c2)
  then show ?case by auto
next
  case (If x1 c1 c2)
  then show ?case by auto
next
  case (While x1 c)
(*
1. \<And>x1 c X. (\<And>X. L c X \<subseteq> rvars c \<union> X) \<Longrightarrow> L (WHILE x1 DO c) X \<subseteq> rvars (WHILE x1 DO c) \<union> X
*)
  then have "lfp (\<lambda>Y. vars x1 \<union> X \<union> L c Y) \<subseteq> vars x1 \<union> rvars c \<union> X"
    by (metis Un_subset_iff lfp_lowerbound sup.cobounded2 sup.left_idem sup_assoc sup_left_commute)
  show ?case
    by (simp add: \<open>lfp (\<lambda>Y. vars x1 \<union> X \<union> L c Y) \<subseteq> vars x1 \<union> rvars c \<union> X\<close>)
qed

(* Lemma 10.34. *)
lemma L_While: fixes b c X
assumes "finite X" defines "f == \<lambda>Y. vars b \<union> X \<union> L c Y"
shows "L (WHILE b DO c) X = while (\<lambda>Y. f Y \<noteq> Y) f {}" (is "_ = ?r")
proof -
  let ?V = "vars b \<union> rvars c \<union> X"
  have "lfp f = ?r"
  proof(rule lfp_while[where C = ?V])
(* 1. mono f
 2. \<And>Xa. Xa \<subseteq> vars b \<union> rvars c \<union> X \<Longrightarrow> f Xa \<subseteq> vars b \<union> rvars c \<union> X
 3. finite (vars b \<union> rvars c \<union> X)*)
    show "mono f"
      by (metis (no_types, lifting) L_mono Un_mono f_def le_iff_sup mono_def sup.idem)
  next
    fix Xa show " Xa \<subseteq> vars b \<union> rvars c \<union> X \<Longrightarrow> f Xa \<subseteq> vars b \<union> rvars c \<union> X"
      using L_subset_vars f_def by auto
  next
    show "finite (vars b \<union> rvars c \<union> X)"
      by (simp add: assms(1))
  qed
  thus ?thesis  by (simp add: f_def)
qed

lemma L_While_set: "L (WHILE b DO c) (set xs) =
  (let f = (\<lambda>Y. vars b \<union> set xs \<union> L c Y)
   in while (\<lambda>Y. f Y \<noteq> Y) f {})"
  using L_While by auto

text\<open>Replace the equation for \<open>L (WHILE \<dots>)\<close> by the executable @{thm[source] L_While_set}:\<close>
lemmas [code] = L.simps(1-4) L_While_set
text\<open>Sorry, this syntax is odd.\<close>

text\<open>A test:\<close>
lemma "(let b = Less (N 0) (V ''y''); c = ''y'' ::= V ''x'';; ''x'' ::= V ''z''
  in L (WHILE b DO c) {''y''}) = {''x'', ''y'', ''z''}"
  by eval

subsubsection "Limiting the number of iterations"

text\<open>The final parameter is the default value:\<close>

fun iter :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter f 0 p d = d" |
"iter f (Suc n) p d = (if f p = p then p else iter f n (f p) d)"

(*Lemma 10.32.*)
lemma lfp_subset_iter:
  "\<lbrakk> mono f; !!X. f X \<subseteq> f' X; lfp f \<subseteq> D \<rbrakk> \<Longrightarrow> lfp f \<subseteq> iter f' n A D"
proof(induction n arbitrary: A)
case 0
  then show ?case
    by simp
next
  case (Suc n)
  then show ?case
    by (metis ConcreteSemantics10_4_Live_True.iter.simps(2) lfp_lowerbound)
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Generic Lemmas used in the Word Library"

theory HOL_Lemmas
imports Main
begin

definition
  strict_part_mono :: "'a set \<Rightarrow> ('a :: order \<Rightarrow> 'b :: order) \<Rightarrow> bool" where
 "strict_part_mono S f \<equiv> \<forall>A\<in>S. \<forall>B\<in>S. A < B \<longrightarrow> f A < f B"

lemma strict_part_mono_by_steps:
  "strict_part_mono {..n :: nat} f = (n \<noteq> 0 \<longrightarrow> f (n - 1) < f n \<and> strict_part_mono {.. n - 1} f)"
  apply (cases n; simp add: strict_part_mono_def)
  apply (safe; clarsimp)
  apply (case_tac "B = Suc nat"; simp)
  apply (case_tac "A = nat"; clarsimp)
  apply (erule order_less_trans [rotated])
  apply simp
  done

lemma strict_part_mono_singleton[simp]:
  "strict_part_mono {x} f"
  by (simp add: strict_part_mono_def)

lemma strict_part_mono_lt:
  "\<lbrakk> x < f 0; strict_part_mono {.. n :: nat} f \<rbrakk> \<Longrightarrow> \<forall>m \<le> n. x < f m"
  by (metis atMost_iff le_0_eq le_cases neq0_conv order.strict_trans strict_part_mono_def)

lemma strict_part_mono_reverseE:
  "\<lbrakk> f n \<le> f m; strict_part_mono {.. N :: nat} f; n \<le> N \<rbrakk> \<Longrightarrow> n \<le> m"
  by (rule ccontr) (fastforce simp: linorder_not_le strict_part_mono_def)

lemma takeWhile_take_has_property:
  "n \<le> length (takeWhile P xs) \<Longrightarrow> \<forall>x \<in> set (take n xs). P x"
  by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)

lemma takeWhile_take_has_property_nth:
  "\<lbrakk> n < length (takeWhile P xs) \<rbrakk> \<Longrightarrow> P (xs ! n)"
  by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)

lemma takeWhile_replicate:
  "takeWhile f (replicate len x) = (if f x then replicate len x else [])"
  by (induct_tac len) auto

lemma takeWhile_replicate_id:
  "f x \<Longrightarrow> takeWhile f (replicate len x) = replicate len x"
  by (simp add: takeWhile_replicate)

lemma le_imp_diff_le:
  "(j::nat) \<le> k \<Longrightarrow> j - n \<le> k"
  by simp

lemma power_sub:
  fixes a :: nat
  assumes lt: "n \<le> m"
  and     av: "0 < a"
  shows "a ^ (m - n) = a ^ m div a ^ n"
proof (subst nat_mult_eq_cancel1 [symmetric])
  show "(0::nat) < a ^ n" using av by simp
next
  from lt obtain q where mv: "n + q = m"
    by (auto simp: le_iff_add)

  have "a ^ n * (a ^ m div a ^ n) = a ^ m"
  proof (subst mult.commute)
    have "a ^ m = (a ^ m div a ^ n) * a ^ n + a ^ m mod a ^ n"
      by (rule  div_mult_mod_eq [symmetric])

    moreover have "a ^ m mod a ^ n = 0"
      by (subst mod_eq_0_iff, rule exI [where x = "a ^ q"],
      (subst power_add [symmetric] mv)+, rule refl)

    ultimately show "(a ^ m div a ^ n) * a ^ n = a ^ m" by simp
  qed

  then show "a ^ n * a ^ (m - n) = a ^ n * (a ^ m div a ^ n)" using lt
    by (simp add: power_add [symmetric])
qed

lemma union_sub:
  "\<lbrakk>B \<subseteq> A; C \<subseteq> B\<rbrakk> \<Longrightarrow> (A - B) \<union> (B - C) = (A - C)"
  by fastforce

lemma insert_sub:
  "x \<in> xs \<Longrightarrow> (insert x (xs - ys)) = (xs - (ys - {x}))"
  by blast

lemma ran_upd:
  "\<lbrakk> inj_on f (dom f); f y = Some z \<rbrakk> \<Longrightarrow> ran (\<lambda>x. if x = y then None else f x) = ran f - {z}"
  unfolding ran_def
  apply (rule set_eqI)
  apply simp
  by (metis domI inj_on_eq_iff option.sel)

lemma nat_less_power_trans:
  fixes n :: nat
  assumes nv: "n < 2 ^ (m - k)"
  and     kv: "k \<le> m"
  shows "2 ^ k * n < 2 ^ m"
proof (rule order_less_le_trans)
  show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
    by (rule mult_less_mono2 [OF nv zero_less_power]) simp

  show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
    by (subst power_add [symmetric]) simp
qed

lemma nat_le_power_trans:
  fixes n :: nat
  shows "\<lbrakk>n \<le> 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> 2 ^ k * n \<le> 2 ^ m"
  by (metis le_imp_less_or_eq less_imp_le nat_less_power_trans power_sub split_div_lemma
            zero_less_numeral zero_less_power)

lemma x_power_minus_1:
  fixes x :: "'a :: {ab_group_add, power, numeral, one}"
  shows "x + (2::'a) ^ n - (1::'a) = x + (2 ^ n - 1)" by simp

lemma nat_diff_add:
  fixes i :: nat
  shows "\<lbrakk> i + j = k \<rbrakk> \<Longrightarrow> i = k - j"
  by arith

lemma pow_2_gt: "n \<ge> 2 \<Longrightarrow> (2::int) < 2 ^ n"
  by (induct n) auto

lemma if_apply_def2:
  "(if P then F else G) = (\<lambda>x. (P \<longrightarrow> F x) \<and> (\<not> P \<longrightarrow> G x))"
  by simp

lemma case_bool_If:
  "case_bool P Q b = (if b then P else Q)"
  by simp

lemma sum_to_zero:
  "(a :: 'a :: ring) + b = 0 \<Longrightarrow> a = (- b)"
  by (drule arg_cong[where f="\<lambda> x. x - a"], simp)

lemma arith_is_1:
  "\<lbrakk> x \<le> Suc 0; x > 0 \<rbrakk> \<Longrightarrow> x = 1"
  by arith

lemma if_f:
  "(if a then f b else f c) = f (if a then b else c)"
  by simp

lemma upt_add_eq_append':
  assumes "i \<le> j" and "j \<le> k"
  shows "[i..<k] = [i..<j] @ [j..<k]"
  using assms le_Suc_ex upt_add_eq_append by blast

lemma split_upt_on_n:
  "n < m \<Longrightarrow> [0 ..< m] = [0 ..< n] @ [n] @ [Suc n ..< m]"
  by (metis append_Cons append_Nil less_Suc_eq_le less_imp_le_nat upt_add_eq_append'
            upt_rec zero_less_Suc)

lemma drop_Suc_nth:
  "n < length xs \<Longrightarrow> drop n xs = xs!n # drop (Suc n) xs"
  by (simp add: Cons_nth_drop_Suc)

lemma n_less_equal_power_2 [simp]:
  "n < 2 ^ n"
  by (induct n; simp)

lemma nat_min_simps [simp]:
  "(a::nat) \<le> b \<Longrightarrow> min b a = a"
  "a \<le> b \<Longrightarrow> min a b = a"
  by auto

lemma power_sub_int:
  "\<lbrakk> m \<le> n; 0 < b \<rbrakk> \<Longrightarrow> b ^ n div b ^ m = (b ^ (n - m) :: int)"
  apply (subgoal_tac "\<exists>n'. n = m + n'")
   apply (clarsimp simp: power_add)
  apply (rule exI[where x="n - m"])
  apply simp
  done

end


(*  Title:      HOL/Lattice/Orders.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Orders\<close>

theory Orders imports Main begin

subsection \<open>Ordered structures\<close>

text \<open>
  We define several classes of ordered structures over some type \<^typ>\<open>'a\<close> with relation \<open>\<sqsubseteq> :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>.  For a
  \emph{quasi-order} that relation is required to be reflexive and
  transitive, for a \emph{partial order} it also has to be
  anti-symmetric, while for a \emph{linear order} all elements are
  required to be related (in either direction).
\<close>

class leq =
  fixes leq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infixl "\<sqsubseteq>" 50)

class quasi_order = leq +
  assumes leq_refl [intro?]: "x \<sqsubseteq> x"
  assumes leq_trans [trans]: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"

class partial_order = quasi_order +
  assumes leq_antisym [trans]: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"

class linear_order = partial_order +
  assumes leq_linear: "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

lemma linear_order_cases:
    "((x::'a::linear_order) \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> (y \<sqsubseteq> x \<Longrightarrow> C) \<Longrightarrow> C"
  by (insert leq_linear) blast

subsection \<open>Duality\<close>

text \<open>
  The \emph{dual} of an ordered structure is an isomorphic copy of the
  underlying type, with the \<open>\<sqsubseteq>\<close> relation defined as the inverse
  of the original one.
\<close>

datatype 'a dual = dual 'a

primrec undual :: "'a dual \<Rightarrow> 'a" where
  undual_dual: "undual (dual x) = x"

instantiation dual :: (leq) leq
begin

definition
  leq_dual_def: "x' \<sqsubseteq> y' \<equiv> undual y' \<sqsubseteq> undual x'"

instance ..

end

lemma undual_leq [iff?]: "(undual x' \<sqsubseteq> undual y') = (y' \<sqsubseteq> x')"
  by (simp add: leq_dual_def)

lemma dual_leq [iff?]: "(dual x \<sqsubseteq> dual y) = (y \<sqsubseteq> x)"
  by (simp add: leq_dual_def)

text \<open>
  \medskip Functions \<^term>\<open>dual\<close> and \<^term>\<open>undual\<close> are inverse to
  each other; this entails the following fundamental properties.
\<close>

lemma dual_undual [simp]: "dual (undual x') = x'"
  by (cases x') simp

lemma undual_dual_id [simp]: "undual o dual = id"
  by (rule ext) simp

lemma dual_undual_id [simp]: "dual o undual = id"
  by (rule ext) simp

text \<open>
  \medskip Since \<^term>\<open>dual\<close> (and \<^term>\<open>undual\<close>) are both injective
  and surjective, the basic logical connectives (equality,
  quantification etc.) are transferred as follows.
\<close>

lemma undual_equality [iff?]: "(undual x' = undual y') = (x' = y')"
  by (cases x', cases y') simp

lemma dual_equality [iff?]: "(dual x = dual y) = (x = y)"
  by simp

lemma dual_ball [iff?]: "(\<forall>x \<in> A. P (dual x)) = (\<forall>x' \<in> dual ` A. P x')"
proof
  assume a: "\<forall>x \<in> A. P (dual x)"
  show "\<forall>x' \<in> dual ` A. P x'"
  proof
    fix x' assume x': "x' \<in> dual ` A"
    have "undual x' \<in> A"
    proof -
      from x' have "undual x' \<in> undual ` dual ` A" by simp
      thus "undual x' \<in> A" by (simp add: image_comp)
    qed
    with a have "P (dual (undual x'))" ..
    also have "\<dots> = x'" by simp
    finally show "P x'" .
  qed
next
  assume a: "\<forall>x' \<in> dual ` A. P x'"
  show "\<forall>x \<in> A. P (dual x)"
  proof
    fix x assume "x \<in> A"
    hence "dual x \<in> dual ` A" by simp
    with a show "P (dual x)" ..
  qed
qed

lemma range_dual [simp]: "surj dual"
proof -
  have "\<And>x'. dual (undual x') = x'" by simp
  thus "surj dual" by (rule surjI)
qed

lemma dual_all [iff?]: "(\<forall>x. P (dual x)) = (\<forall>x'. P x')"
proof -
  have "(\<forall>x \<in> UNIV. P (dual x)) = (\<forall>x' \<in> dual ` UNIV. P x')"
    by (rule dual_ball)
  thus ?thesis by simp
qed

lemma dual_ex: "(\<exists>x. P (dual x)) = (\<exists>x'. P x')"
proof -
  have "(\<forall>x. \<not> P (dual x)) = (\<forall>x'. \<not> P x')"
    by (rule dual_all)
  thus ?thesis by blast
qed

lemma dual_Collect: "{dual x| x. P (dual x)} = {x'. P x'}"
proof -
  have "{dual x| x. P (dual x)} = {x'. \<exists>x''. x' = x'' \<and> P x''}"
    by (simp only: dual_ex [symmetric])
  thus ?thesis by blast
qed

subsection \<open>Transforming orders\<close>

subsubsection \<open>Duals\<close>

text \<open>
  The classes of quasi, partial, and linear orders are all closed
  under formation of dual structures.
\<close>

instance dual :: (quasi_order) quasi_order
proof
  fix x' y' z' :: "'a::quasi_order dual"
  have "undual x' \<sqsubseteq> undual x'" .. thus "x' \<sqsubseteq> x'" ..
  assume "y' \<sqsubseteq> z'" hence "undual z' \<sqsubseteq> undual y'" ..
  also assume "x' \<sqsubseteq> y'" hence "undual y' \<sqsubseteq> undual x'" ..
  finally show "x' \<sqsubseteq> z'" ..
qed

instance dual :: (partial_order) partial_order
proof
  fix x' y' :: "'a::partial_order dual"
  assume "y' \<sqsubseteq> x'" hence "undual x' \<sqsubseteq> undual y'" ..
  also assume "x' \<sqsubseteq> y'" hence "undual y' \<sqsubseteq> undual x'" ..
  finally show "x' = y'" ..
qed

instance dual :: (linear_order) linear_order
proof
  fix x' y' :: "'a::linear_order dual"
  show "x' \<sqsubseteq> y' \<or> y' \<sqsubseteq> x'"
  proof (rule linear_order_cases)
    assume "undual y' \<sqsubseteq> undual x'"
    hence "x' \<sqsubseteq> y'" .. thus ?thesis ..
  next
    assume "undual x' \<sqsubseteq> undual y'"
    hence "y' \<sqsubseteq> x'" .. thus ?thesis ..
  qed
qed

subsubsection \<open>Binary products \label{sec:prod-order}\<close>

text \<open>
  The classes of quasi and partial orders are closed under binary
  products.  Note that the direct product of linear orders need
  \emph{not} be linear in general.
\<close>

instantiation prod :: (leq, leq) leq
begin

definition
  leq_prod_def: "p \<sqsubseteq> q \<equiv> fst p \<sqsubseteq> fst q \<and> snd p \<sqsubseteq> snd q"

instance ..

end

lemma leq_prodI [intro?]:
    "fst p \<sqsubseteq> fst q \<Longrightarrow> snd p \<sqsubseteq> snd q \<Longrightarrow> p \<sqsubseteq> q"
  by (unfold leq_prod_def) blast

lemma leq_prodE [elim?]:
    "p \<sqsubseteq> q \<Longrightarrow> (fst p \<sqsubseteq> fst q \<Longrightarrow> snd p \<sqsubseteq> snd q \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold leq_prod_def) blast

instance prod :: (quasi_order, quasi_order) quasi_order
proof
  fix p q r :: "'a::quasi_order \<times> 'b::quasi_order"
  show "p \<sqsubseteq> p"
  proof
    show "fst p \<sqsubseteq> fst p" ..
    show "snd p \<sqsubseteq> snd p" ..
  qed
  assume pq: "p \<sqsubseteq> q" and qr: "q \<sqsubseteq> r"
  show "p \<sqsubseteq> r"
  proof
    from pq have "fst p \<sqsubseteq> fst q" ..
    also from qr have "\<dots> \<sqsubseteq> fst r" ..
    finally show "fst p \<sqsubseteq> fst r" .
    from pq have "snd p \<sqsubseteq> snd q" ..
    also from qr have "\<dots> \<sqsubseteq> snd r" ..
    finally show "snd p \<sqsubseteq> snd r" .
  qed
qed

instance prod :: (partial_order, partial_order) partial_order
proof
  fix p q :: "'a::partial_order \<times> 'b::partial_order"
  assume pq: "p \<sqsubseteq> q" and qp: "q \<sqsubseteq> p"
  show "p = q"
  proof
    from pq have "fst p \<sqsubseteq> fst q" ..
    also from qp have "\<dots> \<sqsubseteq> fst p" ..
    finally show "fst p = fst q" .
    from pq have "snd p \<sqsubseteq> snd q" ..
    also from qp have "\<dots> \<sqsubseteq> snd p" ..
    finally show "snd p = snd q" .
  qed
qed

subsubsection \<open>General products \label{sec:fun-order}\<close>

text \<open>
  The classes of quasi and partial orders are closed under general
  products (function spaces).  Note that the direct product of linear
  orders need \emph{not} be linear in general.
\<close>

instantiation "fun" :: (type, leq) leq
begin

definition
  leq_fun_def: "f \<sqsubseteq> g \<equiv> \<forall>x. f x \<sqsubseteq> g x"

instance ..

end

lemma leq_funI [intro?]: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
  by (unfold leq_fun_def) blast

lemma leq_funD [dest?]: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
  by (unfold leq_fun_def) blast

instance "fun" :: (type, quasi_order) quasi_order
proof
  fix f g h :: "'a \<Rightarrow> 'b::quasi_order"
  show "f \<sqsubseteq> f"
  proof
    fix x show "f x \<sqsubseteq> f x" ..
  qed
  assume fg: "f \<sqsubseteq> g" and gh: "g \<sqsubseteq> h"
  show "f \<sqsubseteq> h"
  proof
    fix x from fg have "f x \<sqsubseteq> g x" ..
    also from gh have "\<dots> \<sqsubseteq> h x" ..
    finally show "f x \<sqsubseteq> h x" .
  qed
qed

instance "fun" :: (type, partial_order) partial_order
proof
  fix f g :: "'a \<Rightarrow> 'b::partial_order"
  assume fg: "f \<sqsubseteq> g" and gf: "g \<sqsubseteq> f"
  show "f = g"
  proof
    fix x from fg have "f x \<sqsubseteq> g x" ..
    also from gf have "\<dots> \<sqsubseteq> f x" ..
    finally show "f x = g x" .
  qed
qed

end


(*
  Title: Sup-Lattices and Other Simplifications
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Sup-Lattices and Other Simplifications\<close>

theory Sup_Lattice
  imports  Main
           "HOL-Library.Lattice_Syntax"

begin

text \<open>Some definitions for orderings and lattices in Isabelle could be simpler. The strict order in
in ord could be defined instead of being axiomatised. The function mono could have been defined on ord
and not on order---even on a general (di)graph it serves as a morphism. In complete lattices, the
supremum---and dually the infimum---suffices to define the other operations (in the Isabelle/HOL-definition
infimum, binary supremum and infimum, bottom and top element are axiomatised). This not only increases
the number of proof obligations in subclass or sublocale statements, instantiations or interpretations,
it also complicates situations where suprema are presented faithfully, e.g. mapped onto suprema in
some subalgebra, whereas infima in the subalgebra are different from those in the super-structure.\<close>

text \<open>It would be even nicer to use a class less-eq which dispenses with the strict order symbol
in ord. Then one would not have to redefine this symbol in all instantiations or interpretations.
At least, it does not carry any proof obligations.\<close>

context ord
begin

text \<open>ub-set yields the set of all upper bounds of a set; lb-set the set of all lower bounds.\<close>

definition ub_set :: "'a set \<Rightarrow> 'a set" where
  "ub_set X = {y. \<forall>x \<in> X. x \<le> y}"

definition lb_set :: "'a set \<Rightarrow> 'a set" where
  "lb_set X = {y. \<forall>x \<in> X. y \<le> x}"

end

definition ord_pres :: "('a::ord \<Rightarrow> 'b::ord) \<Rightarrow> bool" where
 "ord_pres f = (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"

lemma ord_pres_mono:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "mono f = ord_pres f"
  by (simp add: mono_def ord_pres_def)

class preorder_lean = ord +
  assumes preorder_refl: "x \<le> x"
  and preorder_trans: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"

begin

definition le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "le x y = (x \<le> y \<and> \<not> (x \<ge> y))"

end

sublocale preorder_lean \<subseteq> prel: preorder "(\<le>)" le
  by (unfold_locales, auto simp add: le_def preorder_refl preorder_trans)

class order_lean = preorder_lean +
  assumes order_antisym: "x \<le> y \<Longrightarrow> x \<ge> y \<Longrightarrow> x = y"

sublocale order_lean \<subseteq> posl: order "(\<le>)" le
  by (unfold_locales, simp add: order_antisym)

class Sup_lattice = order_lean + Sup +
  assumes Sups_upper: "x \<in> X \<Longrightarrow> x \<le> \<Squnion>X"
  and Sups_least: "(\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Squnion>X \<le> z"

begin

definition Infs :: "'a set \<Rightarrow> 'a" where
  "Infs X =  \<Squnion>{y. \<forall>x \<in> X. y \<le> x}"

definition sups :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "sups x y = \<Squnion>{x,y}"

definition infs :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "infs x y = Infs{x,y}"

definition bots :: 'a where
  "bots = \<Squnion>{}"

definition tops :: 'a where
  "tops = Infs{}"

lemma Infs_prop: "Infs = Sup \<circ> lb_set"
  unfolding fun_eq_iff by (simp add: Infs_def prel.lb_set_def)

end

class Inf_lattice = order_lean + Inf +
  assumes Infi_lower: "x \<in> X \<Longrightarrow> \<Sqinter>X \<le> x"
  and Infi_greatest: "(\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> \<Sqinter>X"

begin

definition Supi :: "'a set \<Rightarrow> 'a" where
  "Supi X = \<Sqinter>{y. \<forall>x \<in> X. x \<le> y}"

definition supi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "supi x y = Supi{x,y}"

definition infi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "infi x y = \<Sqinter>{x,y}"

definition boti :: 'a where
  "boti = Supi{}"

definition topi :: 'a where
  "topi = \<Sqinter>{}"

lemma Supi_prop: "Supi = Inf \<circ> ub_set"
  unfolding fun_eq_iff by (simp add: Supi_def prel.ub_set_def)

end

sublocale Inf_lattice \<subseteq> ldual: Sup_lattice Inf "(\<ge>)"
  rewrites "ldual.Infs = Supi"
  and "ldual.infs = supi"
  and "ldual.sups = infi"
  and "ldual.tops = boti"
  and "ldual.bots = topi"
proof-
  show "class.Sup_lattice Inf (\<ge>)"
    by (unfold_locales, simp_all add: Infi_lower Infi_greatest preorder_trans)
  then interpret ldual: Sup_lattice Inf "(\<ge>)".
  show a: "ldual.Infs = Supi"
    unfolding fun_eq_iff by (simp add: ldual.Infs_def Supi_def)
  show "ldual.infs = supi"
    unfolding fun_eq_iff by (simp add: a ldual.infs_def supi_def)
  show "ldual.sups = infi"
    unfolding fun_eq_iff by (simp add: ldual.sups_def infi_def)
  show "ldual.tops = boti"
    by (simp add: a ldual.tops_def boti_def)
  show "ldual.bots = topi"
    by (simp add: ldual.bots_def topi_def)
qed

sublocale Sup_lattice \<subseteq> supclat: complete_lattice Infs Sup_class.Sup infs "(\<le>)" le sups bots tops
  apply unfold_locales
  unfolding Infs_def infs_def sups_def bots_def tops_def
  by (simp_all, auto intro: Sups_least, simp_all add: Sups_upper)

 sublocale Inf_lattice \<subseteq> infclat: complete_lattice Inf_class.Inf Supi infi "(\<le>)" le supi boti topi
  by (unfold_locales, simp_all add: ldual.Sups_upper ldual.Sups_least ldual.supclat.Inf_lower ldual.supclat.Inf_greatest)

end


section \<open>Quicksort with function package\<close>

theory Quicksort
imports "HOL-Library.Multiset"
begin

context linorder
begin

fun quicksort :: "'a list \<Rightarrow> 'a list" where
  "quicksort []     = []"
| "quicksort (x#xs) = quicksort [y\<leftarrow>xs. \<not> x\<le>y]
                        @ [x] @
                      quicksort [y\<leftarrow>xs. x\<le>y]"

lemma mset_quicksort [simp]:
  "mset (quicksort xs) = mset xs"
apply(induct xs rule: quicksort.induct)
  apply simp
  by (simp add: add.commute)

lemma "[y\<leftarrow>xs . \<not> x \<le> y] = (filter ((>) x) xs)"
  by (meson local.leD local.leI)

lemma set_quicksort [simp]: "set (quicksort xs) = set xs"
proof -
  have "set_mset (mset (quicksort xs)) = set_mset (mset xs)"
    by simp
  then show ?thesis by (simp only: set_mset_mset)
qed

lemma sorted_quicksort: "sorted (quicksort xs)"
apply(induct xs rule: quicksort.induct)
  apply simp
  by (auto simp add: sorted_append not_le less_imp_le)

theorem sort_quicksort:
  "sort = quicksort"
  by (rule ext, rule properties_for_sort)
      (fact mset_quicksort sorted_quicksort)+

end

end


theory ExF011
  imports Main
begin

lemma "(\<not> (\<exists>x. \<forall>y. P x y)) \<longrightarrow> \<not>(\<exists>x. \<exists>y .  \<not>P x y) \<longrightarrow> False "
proof -
  {
    assume a:"(\<not> (\<exists>x. \<forall>y. P x y))"
    {
      fix aa
      assume b:"\<not>(\<exists>x. \<exists>y .  \<not>P x y)"
      {
        fix bb
        {
          assume "\<not>P aa bb"
          hence "\<exists>y. \<not>P aa y" by (rule exI)
          hence "\<exists>x. \<exists>y. \<not>P x y" by (rule exI)
          with b have False by contradiction
        }
        hence "\<not>\<not>P aa bb" by (rule notI)
        hence "P aa bb" by (rule notnotD)
      }
      hence "\<forall>y. P aa y" by (rule allI)
      hence "\<exists>x. \<forall>y. P x y" by (rule exI)
      with a have False by contradiction
    }
    hence "\<not>(\<exists>x. \<exists>y .  \<not>P x y) \<longrightarrow> False " by (rule impI)
  }
  thus ?thesis by (rule impI)
qed


theory BCIgen imports Main
begin

section \<open>A toy background theory\<close> (*skip on first read*)

(*Sets are encoded as characteristic functions/predicates (i.e. functions with a 'bool' codomain)*)
type_synonym 'a \<sigma> = \<open>'a \<Rightarrow> bool\<close>

(*Standard subset relation*)
definition subset::"'a \<sigma> \<Rightarrow> 'a \<sigma> \<Rightarrow> bool" (infixr "\<^bold>\<subseteq>" 51)
  where "A \<^bold>\<subseteq> B \<equiv> \<forall>x. A x \<longrightarrow> B x"

(*The infimum (i.e. big-intersection) of a set of sets*)
definition Infimum:: "('a \<sigma>)\<sigma> \<Rightarrow> 'a \<sigma>" ("\<^bold>\<Inter>")
  where "\<^bold>\<Inter>S \<equiv> \<lambda>z. (\<forall>X. S X \<longrightarrow> X z)"

(*A set S can be closed under a zero-ary, unary, or binary operation (\<chi>/0, \<phi>/1, or \<xi>/2 resp.)*)
abbreviation (input) op0_closed::"'a  \<Rightarrow> 'a \<sigma>  \<Rightarrow> bool" ("_-closed\<^sub>0")
  where "\<chi>-closed\<^sub>0 \<equiv> \<lambda>S. S \<chi>" (*just for illustration, not really useful as a definition *)
definition op1_closed::"('a \<Rightarrow> 'a) \<Rightarrow> 'a \<sigma> \<Rightarrow> bool" ("_-closed\<^sub>1")
  where "\<phi>-closed\<^sub>1 \<equiv> \<lambda>S. \<forall>x. S x \<longrightarrow> S(\<phi> x)"
definition op2_closed::"('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<sigma> \<Rightarrow> bool" ("_-closed\<^sub>2")
  where "\<xi>-closed\<^sub>2 \<equiv> \<lambda>S. \<forall>x y. S x \<and> S y \<longrightarrow> S(\<xi> x y)"

(*Closure under a binary operation can be reduced to closure under a unary operation via partial application*)
lemma op2_closed_def2: "\<xi>-closed\<^sub>2 = (\<lambda>S. (\<forall>x. S x \<longrightarrow> (\<xi> x)-closed\<^sub>1 S))"
  unfolding op1_closed_def op2_closed_def by blast

(*Convenient abbreviation to say that the set S is a (sub)algebra wrt. to the operations \<chi>/0, \<phi>/1*)
definition "subAlg \<chi> \<phi> \<equiv> \<lambda>S. (\<chi>-closed\<^sub>0 S) \<and> (\<phi>-closed\<^sub>1 S)" (*i.e. (\<chi>-closed\<^sub>0 S) \<and> (\<phi>-closed\<^sub>1 S)*)

(*The set of elements denoted by terms of the form \<phi>\<^sup>n\<chi>. Let's call them 'inductive(ly generated) sets'*)
definition "indAlg \<chi> \<phi> \<equiv> \<^bold>\<Inter>(subAlg \<chi> \<phi>)"

(*Convenient shorthand for composing unary with binary functions*)
abbreviation (input) fcomp12::"('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c)" (infixr "\<circ>\<^sub>1\<^sub>2" 75)
  where "\<phi> \<circ>\<^sub>1\<^sub>2 \<xi> \<equiv> \<lambda>x y. \<phi>(\<xi> x y)"

section \<open>Encoding BCI problem\<close>

(*For each model, the semantic domain \<D>\<^sup>i can be seen as the carrier of an algebra \<A> = <\<D>\<^sup>i,e/0,s/1>*)
typedecl i
consts e :: "i"  (*zero-ary operation*)
       s :: "i\<Rightarrow>i"  (*unary operation*)

(*The first three axioms axiomatize (via equations!) a binary operation 'f' in terms of 'e' and 's'*)
abbreviation (input) "A1 f \<equiv> \<forall>x. f x e = s e"
abbreviation (input) "A2 f \<equiv> \<forall>y. f e (s y) = s (s (f e y))"
abbreviation (input) "A3 f \<equiv> \<forall>x y. f (s x) (s y) = f x (f (s x) y)"

(*The final two axioms constrain a given set 'd' as a subuniverse (subalgebra) of \<A> (= <\<D>\<^sup>i,e/0,s/1>)*)
abbreviation (input) "A4 d \<equiv> d e"
abbreviation (input) "A5 d \<equiv> \<forall>x. d x \<longrightarrow> d (s x)"

(*Observe that the last two axioms correspond to the definition of a <e,s>-subalgebra of \<A>*)
lemma "(A4 d \<and> A5 d) = (subAlg e s) d"  unfolding  op1_closed_def subAlg_def ..

(*Boolos original problem basically asks whether, for an arbitrary <e,s>-subalgebra 'd', the image under 'f'
 (as axiomatized with A1-A3) of two particular elements (denoted by the terms of the form 's\<^sup>ne') is in 'd'*)
theorem BCI: "A1 f \<Longrightarrow> A2 f \<Longrightarrow> A3 f \<Longrightarrow> \<forall>d. (A4 d \<and> A5 d) \<longrightarrow> d (f (s(s(s(s e)))) (s(s(s(s e)))))"
  (*sledgehammer*) oops (*not solvable automatically yet*)

section \<open>A generalized BCI problem\<close>

(*Let us introduce a convenient shorthand notation for the (inductively generated) set N of all elements
 that are denoted by terms of the form s\<^sup>ne (for some arbitrary n). This is the smallest <e,s>-subalgebra.*)
abbreviation "N \<equiv> indAlg e s"

(*A natural generalization of Boolos' problem asks whether the image under 'f' of any two elements
 belonging to N (i.e. denoted by terms of the form 's\<^sup>ne') belongs again to N. In other words, we want
 to find out whether axioms A1-A3 constrain 'f' in such a way that N is closed under 'f'.*)
lemma BCIgen: "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> f-closed\<^sub>2 N" oops (*no automatic proof...yet*)

(*First of all, note that the axioms A1-A3 don't guarantee that N is closed under the unary
  operation (f x) for any arbitrary x in the domain...*)
lemma "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> (\<forall>x. (f x)-closed\<^sub>1 N)" nitpick oops (*countermodel found*)
(*...but only for those x that belong in fact to the (inductive) set N...*)
lemma "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> (\<forall>x. N x \<longrightarrow> (f x)-closed\<^sub>1 N)" oops
(*...or equivalently*)
lemma "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> N  \<^bold>\<subseteq> (\<lambda>x. (f x)-closed\<^sub>1 N)" oops (*still difficult to prove automatically*)

(*Recall that when we want to show that a set contains an inductively generated set it suffices to show
  that it is a (sub)algebra wrt. the corresponding signature (the other direction does not hold though!)*)
lemma "(subAlg \<chi> \<phi>) S \<longrightarrow> (indAlg \<chi> \<phi>) \<^bold>\<subseteq> S" by (metis (full_types) Infimum_def indAlg_def subset_def)
lemma "(indAlg \<chi> \<phi>) \<^bold>\<subseteq> S \<longrightarrow> (subAlg \<chi> \<phi>) S" nitpick oops (*countermodel*)

(*Thus we see that our result holds if we manage to prove the following (slightly more general) statement:*)
lemma BCIgen: "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> (subAlg e s) (\<lambda>x. (f x)-closed\<^sub>1 N)"
  unfolding subAlg_def apply auto oops (*unfolds definition of subalgebra and obtains subgoals*)

(*which, after unfolding definitions, divides into two subgoals (using minimal sets of assumptions)*)
lemma BCIgen_base: "A1 f \<and> A2 f \<longrightarrow> (f e)-closed\<^sub>1 N" oops (*still not proven automatically*)
lemma BCIgen_induct: "A1 f \<and> A3 f \<longrightarrow> s-closed\<^sub>1 (\<lambda>x. (f x)-closed\<^sub>1 N)" oops (*still not proven automatically*)

(*As it happens, proving the two lemmata above requires the following (monomorphic!) definition:*)
definition p:: "(i \<Rightarrow> i \<Rightarrow> i) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool" (*we need to enforce the type for the definition to be useful*)
  where "p f \<equiv> N \<circ>\<^sub>1\<^sub>2 f" (*\<lambda>x y. N (f x y)*)

(*We can now prove the 'base' case...*)
lemma BCIgen_base: "A1 f \<and> A2 f \<longrightarrow> (f e)-closed\<^sub>1 N"
  by (smt (verit) Infimum_def indAlg_def op1_closed_def p_def subAlg_def)
(*...as well as the 'inductive' case*)
lemma BCIgen_induct: "A1 f \<and> A3 f \<longrightarrow> s-closed\<^sub>1 (\<lambda>x. (f x)-closed\<^sub>1 N)"
  by (smt (verit, best) Infimum_def indAlg_def op1_closed_def p_def subAlg_def)

(*So we can now finally prove what we set out to*)
lemma BCIgen: "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> f-closed\<^sub>2 N"
  by (metis (mono_tags, lifting) Infimum_def BCIgen_base indAlg_def BCIgen_induct op2_closed_def2 subAlg_def)

(*Interestingly, ATPs can automatically detect that BCI follows from the (cut) lemma above!*)
theorem BCI: "A1 f \<and> A2 f \<and> A3 f \<longrightarrow> (\<forall>d. (A4 d \<and> A5 d) \<longrightarrow> d (f (s(s(s(s e)))) (s(s(s(s e))))))"
  by (smt (z3) BCIgen Infimum_def indAlg_def op1_closed_def op2_closed_def2 subAlg_def)

(*The main benefit of proving Boolos problem automatically via a suitable cut-lemma (BCIgen) is that
 we are now in a position to repeat the previous experiment using other axiom sets (e.g. axiomatizing
 other Ackermann-style functions or hyper-operators). *)

end