(*  Title:      AlgebraSandbox.thy
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
*)

theory AlgebraSandbox
imports
  "~~/src/HOL/Algebra/Ideal"
  "~~/src/HOL/Algebra/Group"
  "~~/src/HOL/Algebra/IntRing"
  "~~/src/HOL/Algebra/Bij"
  "~~/src/HOL/Algebra/Sylow"
  "~~/src/HOL/Algebra/Coset"
  "~~/src/HOL/Hilbert_Choice"
  "SndSylow"
begin

(*Zero is contained in every ideal*)
lemma (in ideal) zero_in_ideal:
  shows "\<zero> \<in> I"
by (metis additive_subgroup.zero_closed is_additive_subgroup)

(*An Ideal is an additive subgroup*)
lemma (in ideal) ideal_additive_subgroup:
  shows "additive_subgroup I R"
by (rule local.is_additive_subgroup)

(*The preimage of an ideal is an ideal*)
lemma (in ring_hom_cring) ideal_preimage:
  assumes idealJ:"ideal J S"
  shows "ideal {r \<in> carrier R. h r \<in> J} R"
apply(rule idealI)
  apply (rule R.is_ring)
  apply (rule group.subgroupI)
  apply (rule R.add.is_group)
  apply auto
proof -
  have "\<zero> \<in> carrier R" by (rule R.zero_closed)
  moreover have "h \<zero> = \<zero>\<^bsub>S\<^esub>" by (rule hom_zero)
  with idealJ have "h \<zero> \<in> J" by (metis ideal.zero_in_ideal)
  ultimately show "\<exists>x. x \<in> carrier R \<and> h x \<in> J" by auto
next
  fix a
  assume a:"a \<in> carrier R"
  assume haJ:"h a \<in> J"
  have "h (inv\<^bsub>\<lparr>carrier = carrier R, mult = op \<oplus>, one = \<zero>\<rparr>\<^esub> a)
    = inv\<^bsub>\<lparr>carrier = carrier S, mult = op \<oplus>\<^bsub>S\<^esub>, one = \<zero>\<^bsub>S\<^esub>\<rparr>\<^esub>(h a)" by (metis a a_inv_def hom_a_inv)
  moreover from idealJ have "additive_subgroup J S" by (rule ideal.ideal_additive_subgroup)
  with haJ have "inv\<^bsub>\<lparr>carrier = carrier S, mult = op \<oplus>\<^bsub>S\<^esub>, one = \<zero>\<^bsub>S\<^esub>\<rparr>\<^esub> (h a) \<in> J"
    by (metis a_inv_def additive_subgroup.a_inv_closed additive_subgroupI)
  ultimately show "h (inv\<^bsub>\<lparr>carrier = carrier R, mult = op \<oplus>, one = \<zero>\<rparr>\<^esub> a) \<in> J" by simp
next
  fix a b
  assume assm:"h a \<in> J" "h b \<in> J"
  thus "h a \<oplus>\<^bsub>S\<^esub> h b \<in> J"
    by (metis additive_subgroup.a_closed ideal.ideal_additive_subgroup idealJ)
next
  fix a x
  assume "h a \<in> J" "x \<in> carrier R"
  thus "h x \<otimes>\<^bsub>S\<^esub> h a \<in> J" by (metis hom_closed ideal.I_l_closed idealJ)
next
  fix a x
  assume "h a \<in> J" "x \<in> carrier R"
  thus "h a \<otimes>\<^bsub>S\<^esub> h x \<in> J" by (metis hom_closed ideal.I_r_closed idealJ)
qed

subsection {*The actual exercise*}

(*The preimage of a primeideal is a primeideal*)
lemma (in ring_hom_cring) primeideal_preimage:
  assumes primeJ:"primeideal J S"
  shows "primeideal {r \<in> carrier R. h r \<in> J} R"
proof(rule primeidealI)
  from primeJ have "ideal J S" unfolding primeideal_def..
  thus "ideal {r \<in> carrier R. h r \<in> J} R" by (rule ideal_preimage)
next
  show "cring R" by (rule R.is_cring)
next
  show "carrier R \<noteq> {r \<in> carrier R. h r \<in> J}"
  proof(rule ccontr)
    assume "\<not> carrier R \<noteq> {r \<in> carrier R. h r \<in> J}"
    hence "carrier R = {r \<in> carrier R. h r \<in> J}" by simp
    hence "\<one> \<in> {r \<in> carrier R. h r \<in> J}" by (simp add:R.one_closed)
    hence "h \<one> \<in> J" by simp
    hence "J = carrier S" by (metis primeideal_def hom_one ideal.one_imp_carrier primeJ)
    thus "False" by (metis primeJ primeideal.I_notcarr)
  qed
next
  fix a b
  assume a:"a \<in> carrier R"
  assume b:"b \<in> carrier R"
  assume ab:"a \<otimes> b \<in> {r \<in> carrier R. h r \<in> J}"
  hence "h (a \<otimes> b) \<in> J" by simp
  hence "(h a) \<otimes>\<^bsub>S\<^esub> (h b) \<in> J" by (metis a b hom_mult)
  hence "h a \<in> J \<or> h b \<in> J" by (metis a assms b hom_closed primeideal.I_prime)
  thus "a \<in> {r \<in> carrier R. h r \<in> J} \<or> b \<in> {r \<in> carrier R. h r \<in> J}" by (metis a b mem_Collect_eq)
qed

section {*Aufgabe 2b*}

(*The definition of the direct product of two rings*)

definition ringProd :: "_ \<Rightarrow> _ \<Rightarrow> ('a \<times> 'b) ring"
  where "ringProd R S = \<lparr> carrier = carrier R \<times> carrier S,
    mult = (\<lambda>(r,s) (r',s'). (r \<otimes>\<^bsub>R\<^esub> r', s \<otimes>\<^bsub>S\<^esub> s')),
    one = (\<one>\<^bsub>R\<^esub>, \<one>\<^bsub>S\<^esub>),
    zero = (\<zero>\<^bsub>R\<^esub>, \<zero>\<^bsub>S\<^esub>),
    add = (\<lambda>(r,s) (r',s'). (r \<oplus>\<^bsub>R\<^esub> r', s \<oplus>\<^bsub>S\<^esub> s')) \<rparr>"

(* The direct product of two abelian groups is an abelian group *)

lemma dirProd_preserves_comm:
  assumes "comm_group G" "comm_group H"
  shows "comm_group (G \<times>\<times> H)"
proof (rule group.group_comm_groupI)
  from assms have "group G" "group H" unfolding comm_group_def by simp_all
  thus "group (G \<times>\<times> H)" by (rule DirProd_group)
next
  fix x y
  assume a:"x \<in> carrier (G \<times>\<times> H)" "y \<in> carrier (G \<times>\<times> H)"
  hence "x \<otimes>\<^bsub>G \<times>\<times> H\<^esub> y = ((fst x) \<otimes>\<^bsub>G\<^esub> (fst y), (snd x) \<otimes>\<^bsub>H\<^esub> (snd y))"
  unfolding DirProd_def by auto
  also  have "... = ((fst y) \<otimes>\<^bsub>G\<^esub> (fst x), (snd y) \<otimes>\<^bsub>H\<^esub> (snd x))"
  proof(rule prod_eqI)
    from a have "fst x \<in> carrier G" "fst y \<in> carrier G" by auto
    with `comm_group G` have "(fst x) \<otimes>\<^bsub>G\<^esub> (fst y) = (fst y) \<otimes>\<^bsub>G\<^esub> (fst x)"
      unfolding comm_group_def by (metis comm_monoid.m_comm)
    thus "fst (fst x \<otimes>\<^bsub>G\<^esub> fst y, snd x \<otimes>\<^bsub>H\<^esub> snd y) =
    fst (fst y \<otimes>\<^bsub>G\<^esub> fst x, snd y \<otimes>\<^bsub>H\<^esub> snd x)" by simp
  next
    from a have "snd x \<in> carrier H" "snd y \<in> carrier H" by auto
    with `comm_group H` have "(snd x) \<otimes>\<^bsub>H\<^esub> (snd y) = (snd y) \<otimes>\<^bsub>H\<^esub> (snd x)"
      unfolding comm_group_def by (metis comm_monoid.m_comm)
    thus "snd (fst x \<otimes>\<^bsub>G\<^esub> fst y, snd x \<otimes>\<^bsub>H\<^esub> snd y) =
    snd (fst y \<otimes>\<^bsub>G\<^esub> fst x, snd y \<otimes>\<^bsub>H\<^esub> snd x)" by simp
  qed
  also with a have "... = y \<otimes>\<^bsub>G \<times>\<times> H\<^esub> x" unfolding DirProd_def by auto
  ultimately show "x \<otimes>\<^bsub>G \<times>\<times> H\<^esub> y = y \<otimes>\<^bsub>G \<times>\<times> H\<^esub> x" by simp
qed

lemma ringProd_ring:
  assumes "ring R" "ring S"
  shows "ring (RingProd R S)"

sorry

(* The components of map between two rings make up a ring homomorphism if they are themselves
  ring homomorphisms. *)

lemma ring_prod_hom_from_hom:
  assumes fst:"(fst \<circ> h) \<in> ring_hom R S"
  assumes snd:" (snd \<circ> h) \<in> ring_hom R S'"
  shows "h \<in> ring_hom R (ringProd S S')"
unfolding ring_hom_def
apply(simp)
apply(rule conjI)
apply(rule funcsetI)
unfolding ringProd_def
apply(auto)
proof -
  fix x
  assume "x \<in> carrier R"
  with fst snd have "fst (h x) \<in> carrier S"  "snd (h x) \<in> carrier S'"
    by (metis o_eq_dest_lhs ring_hom_closed)+
  hence "h x \<in> {(s,s'). s \<in> carrier S \<and> s' \<in> carrier S'}" by (metis (lifting) mem_Collect_eq prod_case_unfold)
  thus "h x \<in> carrier S \<times> carrier S'" by (metis Collect_mem_eq Collect_split)
next
  (*Note: This should actually proven via the ring homomorphism "product" being the "product"
    of monoid morphisms. *)
  fix x y
  assume a:"x \<in> carrier R" "y \<in> carrier R"
  with fst snd have homImp:"(fst \<circ> h) x \<otimes>\<^bsub>S\<^esub> (fst \<circ> h) y = (fst \<circ> h) (x \<otimes>\<^bsub>R\<^esub> y)"
    "(snd \<circ> h) x \<otimes>\<^bsub>S'\<^esub> (snd \<circ> h) y = (snd \<circ> h) (x \<otimes>\<^bsub>R\<^esub> y)" by (auto dest:ring_hom_mult)
  have "(\<lambda>(r, s) (r', s'). (r \<otimes>\<^bsub>S\<^esub> r', s \<otimes>\<^bsub>S'\<^esub> s')) (h x) (h y)
    = (fst (h x) \<otimes>\<^bsub>S\<^esub> fst (h y), snd (h x) \<otimes>\<^bsub>S'\<^esub> snd (h y))" by (metis (lifting) prod_case_unfold)
  also from homImp have "... = ((fst \<circ> h) (x \<otimes>\<^bsub>R\<^esub> y), (snd \<circ> h) (x \<otimes>\<^bsub>R\<^esub> y))" by simp
  also have "... = h (x \<otimes>\<^bsub>R\<^esub> y)" by (metis comp_apply pair_collapse)
  finally show "h (x \<otimes>\<^bsub>R\<^esub> y) = (\<lambda>(r, s) (r', s'). (r \<otimes>\<^bsub>S\<^esub> r', s \<otimes>\<^bsub>S'\<^esub> s')) (h x) (h y)"..
next
  fix x y
  assume a:"x \<in> carrier R" "y \<in> carrier R"
  with fst snd have homImp:"(fst \<circ> h) x \<oplus>\<^bsub>S\<^esub> (fst \<circ> h) y = (fst \<circ> h) (x \<oplus>\<^bsub>R\<^esub> y)"
    "(snd \<circ> h) x \<oplus>\<^bsub>S'\<^esub> (snd \<circ> h) y = (snd \<circ> h) (x \<oplus>\<^bsub>R\<^esub> y)" by (auto dest:ring_hom_add)
  have "(\<lambda>(r, s) (r', s'). (r \<oplus>\<^bsub>S\<^esub> r', s \<oplus>\<^bsub>S'\<^esub> s')) (h x) (h y)
    = (fst (h x) \<oplus>\<^bsub>S\<^esub> fst (h y), snd (h x) \<oplus>\<^bsub>S'\<^esub> snd (h y))" by (metis (lifting) prod_case_unfold)
  also from homImp have "... = ((fst \<circ> h) (x \<oplus>\<^bsub>R\<^esub> y), (snd \<circ> h) (x \<oplus>\<^bsub>R\<^esub> y))" by simp
  also have "... = h (x \<oplus>\<^bsub>R\<^esub> y)" by (metis comp_apply pair_collapse)
  finally show "h (x \<oplus>\<^bsub>R\<^esub> y) = (\<lambda>(r, s) (r', s'). (r \<oplus>\<^bsub>S\<^esub> r', s \<oplus>\<^bsub>S'\<^esub> s')) (h x) (h y)"..
next
  from fst snd show "h \<one>\<^bsub>R\<^esub> = (\<one>\<^bsub>S\<^esub>, \<one>\<^bsub>S'\<^esub>)" by (metis comp_apply pair_collapse ring_hom_one)
qed

(* Interpret a commutative ring as a (general) ring *)

lemma (in cring) is_ring:
  assumes "cring R"
  shows "ring R"
by (metis is_ring)

(* The direct product of two commutative rings is commutative. *)

lemma cringProd_cring:
  assumes cringR:"cring R"
  assumes cringS:"cring S"
  shows "cring (ringProd R S)"
proof -
  from assms have isRing:"ring (ringProd R S)" by (metis cring.is_ring ringProd_ring)
  have "comm_monoid (ringProd R S)"
  proof (rule monoid.monoid_comm_monoidI)
    from isRing show monoid:"monoid (ringProd R S)" by (rule ring.is_monoid)
  next
    fix x y
    assume xyassms:"x \<in> carrier (ringProd R S)" "y \<in> carrier (ringProd R S)"
    then obtain r s r' s' where rsassms:"(r,s) = x" "(r',s') = y" by (metis surj_pair)
    hence "x \<otimes>\<^bsub>ringProd R S\<^esub> y = (r \<otimes>\<^bsub>R\<^esub> r', s \<otimes>\<^bsub>S\<^esub> s')" unfolding ringProd_def by (metis monoid.select_convs(1) split_conv)
    also from xyassms rsassms have rassms:"r \<in> carrier R" "r' \<in> carrier R" unfolding ringProd_def by auto
    with cringR have "(r \<otimes>\<^bsub>R\<^esub> r', s \<otimes>\<^bsub>S\<^esub> s') = (r' \<otimes>\<^bsub>R\<^esub> r, s \<otimes>\<^bsub>S\<^esub> s')" by (metis cring.cring_simprules(14))
    also from xyassms rsassms have sassms:"s \<in> carrier S" "s' \<in> carrier S" unfolding ringProd_def by auto
    with cringS have "(r' \<otimes>\<^bsub>R\<^esub> r, s \<otimes>\<^bsub>S\<^esub> s') = (r' \<otimes>\<^bsub>R\<^esub> r, s' \<otimes>\<^bsub>S\<^esub> s)" by (metis cring.cring_simprules(14))
    also from rsassms have "(r' \<otimes>\<^bsub>R\<^esub> r, s' \<otimes>\<^bsub>S\<^esub> s) = y \<otimes>\<^bsub>ringProd R S\<^esub> x" unfolding ringProd_def by (metis monoid.select_convs(1) split_conv)
    ultimately show "x \<otimes>\<^bsub>ringProd R S\<^esub> y = y \<otimes>\<^bsub>ringProd R S\<^esub> x" unfolding ringProd_def by simp
  qed
  with isRing show ?thesis unfolding cring_def..
qed

(*The image of an ideal is not neccessarily an ideal*)

lemma ideal_image:
  obtains I R S h
  where "ideal I (R::(int set) ring)" "h \<in> ring_hom R (S::(int set \<times> int set) ring)" "\<not> ideal (h ` I) S"
proof -
  def Z2 \<equiv> "ZFact 2"
  def Z2Z2 \<equiv> "ringProd Z2 Z2"
  have c:"cring Z2" by (metis Z2_def ZFact_is_cring)
  hence r:"ring Z2" by (metis cring.is_ring)
  hence r2:"ring Z2Z2" by (metis Z2Z2_def ringProd_ring)
  def h \<equiv> "\<lambda>x::(int set).(x,x)"
  have a:"h \<in> ring_hom Z2 Z2Z2"
    unfolding Z2Z2_def
  proof(rule ring_prod_hom_from_hom)
    from h_def have "fst \<circ> h = id" by auto
    thus "fst \<circ> h \<in> ring_hom Z2 Z2" by simp
  next
    from h_def have "snd \<circ> h = id" by auto
    thus "snd \<circ> h \<in> ring_hom Z2 Z2" by simp
  qed
  from r have b:"ideal (carrier Z2) Z2" by (metis ring.oneideal)
  have "\<not> ideal (h ` (carrier Z2)) Z2Z2"
  proof -
    from a have "\<one>\<^bsub>Z2Z2\<^esub> \<in> h ` (carrier Z2)" unfolding h_def Z2Z2_def ringProd_def by (metis (mono_tags) image_eqI monoid.select_convs(2) r ring.ring_simprules(6))
    moreover from c have "(\<one>\<^bsub>Z2\<^esub>, \<zero>\<^bsub>Z2\<^esub>) \<in> carrier Z2Z2" unfolding Z2Z2_def ringProd_def by (metis cring.cring_simprules(2) cring.cring_simprules(6) mem_Sigma_iff partial_object.select_convs(1))
    moreover with r2 have Z2Z2simp:"(\<one>\<^bsub>Z2\<^esub>, \<zero>\<^bsub>Z2\<^esub>) \<otimes>\<^bsub>Z2Z2\<^esub> \<one>\<^bsub>Z2Z2\<^esub> = (\<one>\<^bsub>Z2\<^esub>, \<zero>\<^bsub>Z2\<^esub>)" by (metis monoid.r_one ring.is_monoid)
    have "domain Z2" unfolding Z2_def by (metis ZFact_prime_is_domain nat_numeral two_is_prime)
    hence one_not_zero:"\<one>\<^bsub>Z2\<^esub> \<noteq> \<zero>\<^bsub>Z2\<^esub>" by (metis domain.zero_not_one)
    hence "(\<one>\<^bsub>Z2\<^esub>, \<zero>\<^bsub>Z2\<^esub>) \<otimes>\<^bsub>Z2Z2\<^esub> \<one>\<^bsub>Z2Z2\<^esub> \<notin> h ` (carrier Z2)" by (metis Z2Z2simp h_def imageE prod.inject)
    ultimately show ?thesis by (metis r2 a ideal.one_imp_carrier ring.ring_simprules(5) ring_hom_one)
  qed
  with b a show thesis by (rule that)
qed

(*Simple Groups*)

lemma (in subgroup) subgroup_of_restricted_group:
  assumes "subgroup U (G\<lparr> carrier := H\<rparr>)"
  shows "U \<subseteq> H"
using assms subgroup_imp_subset by force

lemma (in subgroup) subgroup_of_subgroup:
  assumes "group G"
  assumes "subgroup U (G\<lparr> carrier := H\<rparr>)"
  shows "subgroup U G"
proof
  from assms(2) have "U \<subseteq> H" by (rule subgroup_of_restricted_group)
  thus "U \<subseteq> carrier G" by (auto simp:subset)
next
  fix x y
  have a:"x \<otimes> y = x \<otimes>\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> y" by simp
  assume "x \<in> U" "y \<in> U"
  with assms a show " x \<otimes> y \<in> U" by (metis subgroup.m_closed)
next
  have "\<one>\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> = \<one>" by simp
  with assms show "\<one> \<in> U" by (metis subgroup.one_closed)
next
  have "subgroup H G"..
  fix x
  assume "x \<in> U"
  with assms(2) have "inv\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> x \<in> U" by (rule subgroup.m_inv_closed)
  moreover from assms `x \<in> U` have "x \<in> H" by (metis in_mono subgroup_of_restricted_group)
  with assms(1) `subgroup H G` have "inv\<^bsub>G\<lparr> carrier := H\<rparr>\<^esub> x = inv x" by (rule group.subgroup_inv_equality)
  ultimately show "inv x \<in> U" by simp
qed

(*Symmetric Group*)

definition symmetric_group :: "nat \<Rightarrow> _"
  where "symmetric_group n = BijGroup {1 .. n}"

end


(*  Title:      HOL/Library/Z2.thy
    Author:     Brian Huffman
*)

section \<open>The Field of Integers mod 2\<close>

theory Z2
imports Main "HOL-Library.Bit_Operations"
begin

text \<open>
  Note that in most cases \<^typ>\<open>bool\<close> is appropriate hen a binary type is needed; the
  type provided here, for historical reasons named \<^text>\<open>bit\<close>, is only needed if proper
  field operations are required.
\<close>

typedef bit = \<open>UNIV :: bool set\<close> ..

instantiation bit :: zero_neq_one
begin

definition zero_bit :: bit
  where \<open>0 = Abs_bit False\<close>

definition one_bit :: bit
  where \<open>1 = Abs_bit True\<close>

instance
  by standard (simp add: zero_bit_def one_bit_def Abs_bit_inject)

end

free_constructors case_bit for \<open>0::bit\<close> | \<open>1::bit\<close>
proof -
  fix P :: bool
  fix a :: bit
  assume \<open>a = 0 \<Longrightarrow> P\<close> and \<open>a = 1 \<Longrightarrow> P\<close>
  then show P
    by (cases a) (auto simp add: zero_bit_def one_bit_def Abs_bit_inject)
qed simp

lemma bit_not_zero_iff [simp]:
  \<open>a \<noteq> 0 \<longleftrightarrow> a = 1\<close> for a :: bit
  by (cases a) simp_all

lemma bit_not_one_imp [simp]:
  \<open>a \<noteq> 1 \<longleftrightarrow> a = 0\<close> for a :: bit
  by (cases a) simp_all

instantiation bit :: semidom_modulo
begin

definition plus_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a + b = Abs_bit (Rep_bit a \<noteq> Rep_bit b)\<close>

definition minus_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>minus_bit = plus\<close>

definition times_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a * b = Abs_bit (Rep_bit a \<and> Rep_bit b)\<close>

definition divide_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>divide_bit = times\<close>

definition modulo_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a mod b = Abs_bit (Rep_bit a \<and> \<not> Rep_bit b)\<close>

instance
  by standard
    (auto simp flip: Rep_bit_inject
    simp add: zero_bit_def one_bit_def plus_bit_def times_bit_def modulo_bit_def Abs_bit_inverse Rep_bit_inverse)

end

lemma bit_2_eq_0 [simp]:
  \<open>2 = (0::bit)\<close>
  by (simp flip: one_add_one add: zero_bit_def plus_bit_def)

instance bit :: semiring_parity
  apply standard
    apply (auto simp flip: Rep_bit_inject simp add: modulo_bit_def Abs_bit_inverse Rep_bit_inverse)
         apply (auto simp add: zero_bit_def one_bit_def Abs_bit_inverse Rep_bit_inverse)
  done

lemma Abs_bit_eq_of_bool [code_abbrev]:
  \<open>Abs_bit = of_bool\<close>
  by (simp add: fun_eq_iff zero_bit_def one_bit_def)

lemma Rep_bit_eq_odd:
  \<open>Rep_bit = odd\<close>
proof -
  have \<open>\<not> Rep_bit 0\<close>
    by (simp only: zero_bit_def) (subst Abs_bit_inverse, auto)
  then show ?thesis
    by (auto simp flip: Rep_bit_inject simp add: fun_eq_iff)
qed

lemma Rep_bit_iff_odd [code_abbrev]:
  \<open>Rep_bit b \<longleftrightarrow> odd b\<close>
  by (simp add: Rep_bit_eq_odd)

lemma Not_Rep_bit_iff_even [code_abbrev]:
  \<open>\<not> Rep_bit b \<longleftrightarrow> even b\<close>
  by (simp add: Rep_bit_eq_odd)

lemma Not_Not_Rep_bit [code_unfold]:
  \<open>\<not> \<not> Rep_bit b \<longleftrightarrow> Rep_bit b\<close>
  by simp

code_datatype \<open>0::bit\<close> \<open>1::bit\<close>

lemma Abs_bit_code [code]:
  \<open>Abs_bit False = 0\<close>
  \<open>Abs_bit True = 1\<close>
  by (simp_all add: Abs_bit_eq_of_bool)

lemma Rep_bit_code [code]:
  \<open>Rep_bit 0 \<longleftrightarrow> False\<close>
  \<open>Rep_bit 1 \<longleftrightarrow> True\<close>
  by (simp_all add: Rep_bit_eq_odd)

context zero_neq_one
begin

abbreviation of_bit :: \<open>bit \<Rightarrow> 'a\<close>
  where \<open>of_bit b \<equiv> of_bool (odd b)\<close>

end

context
begin

qualified lemma bit_eq_iff:
  \<open>a = b \<longleftrightarrow> (even a \<longleftrightarrow> even b)\<close> for a b :: bit
  by (cases a; cases b) simp_all

end

lemma modulo_bit_unfold [simp, code]:
  \<open>a mod b = of_bool (odd a \<and> even b)\<close> for a b :: bit
  by (simp add: modulo_bit_def Abs_bit_eq_of_bool Rep_bit_eq_odd)

lemma power_bit_unfold [simp, code]:
  \<open>a ^ n = of_bool (odd a \<or> n = 0)\<close> for a :: bit
  by (cases a) simp_all

instantiation bit :: semiring_bits
begin

definition bit_bit :: \<open>bit \<Rightarrow> nat \<Rightarrow> bool\<close>
  where [simp]: \<open>bit_bit b n \<longleftrightarrow> odd b \<and> n = 0\<close>

instance
  apply standard
              apply auto
  apply (metis bit.exhaust of_bool_eq(2))
  done

end

instantiation bit :: semiring_bit_shifts
begin

definition push_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>push_bit n b = of_bool (odd b \<and> n = 0)\<close> for b :: bit

definition drop_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>drop_bit_bit = push_bit\<close>

definition take_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>take_bit n b = of_bool (odd b \<and> n > 0)\<close> for b :: bit

instance
  by standard simp_all

end

instantiation bit :: semiring_bit_operations
begin

definition and_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b AND c = of_bool (odd b \<and> odd c)\<close> for b c :: bit

definition or_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b OR c = of_bool (odd b \<or> odd c)\<close> for b c :: bit

definition xor_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b XOR c = of_bool (odd b \<noteq> odd c)\<close> for b c :: bit

definition mask_bit :: \<open>nat \<Rightarrow> bit\<close>
  where [simp]: \<open>mask_bit n = of_bool (n > 0)\<close>

instance
  by standard auto

end

lemma add_bit_eq_xor [simp, code]:
  \<open>(+) = ((XOR) :: bit \<Rightarrow> _)\<close>
  by (auto simp add: fun_eq_iff)

lemma mult_bit_eq_and [simp, code]:
  \<open>(*) = ((AND) :: bit \<Rightarrow> _)\<close>
  by (simp add: fun_eq_iff)

instantiation bit :: field
begin

definition uminus_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>uminus_bit = id\<close>

definition inverse_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>inverse_bit = id\<close>

instance
  by standard simp_all

end

instantiation bit :: ring_bit_operations
begin

definition not_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>NOT b = of_bool (even b)\<close> for b :: bit

instance
  by standard simp_all

end

lemma bit_numeral_even [simp]: "numeral (Num.Bit0 w) = (0 :: bit)"
  by (simp only: Z2.bit_eq_iff even_numeral) simp

lemma bit_numeral_odd [simp]: "numeral (Num.Bit1 w) = (1 :: bit)"
  by (simp only: Z2.bit_eq_iff odd_numeral)  simp

end


section \<open>Sums in monoids\<close>

theory MonoidSums

imports Main
  "HOL-Algebra.Module"
  RingModuleFacts
  FunctionLemmas
begin

text \<open>We build on the finite product simplifications in FiniteProduct.thy and the analogous ones
for finite sums (see "lemmas" in Ring.thy).\<close>

lemma (in comm_monoid) extend_prod:
  fixes a A S
  assumes fin: "finite S" and subset: "A\<subseteq>S" and a: "a\<in>A\<rightarrow>carrier G"
  shows "(\<Otimes>\<^bsub>G\<^esub> x\<in>S. (if x\<in>A then a x else \<one>\<^bsub>G\<^esub>)) = (\<Otimes>\<^bsub>G\<^esub> x\<in>A. a x)"
  (is "(\<Otimes>\<^bsub>G\<^esub> x\<in>S. ?b x) = (\<Otimes>\<^bsub>G\<^esub> x\<in>A. a x)")
proof -
  from subset have uni:"S = A \<union> (S-A)" by auto
  from assms subset show ?thesis
    apply (subst uni)
    apply (subst finprod_Un_disjoint, auto)
    by (auto cong: finprod_cong if_cong elim: finite_subset simp add:Pi_def finite_subset)
(*Pi_def is key for automation here*)
qed

text \<open>Scalar multiplication distributes over scalar multiplication (on left).\<close>(*Add to module.*)
lemma (in module) finsum_smult:
  "[| c\<in> carrier R; g \<in> A \<rightarrow> carrier M |] ==>
   (c \<odot>\<^bsub>M\<^esub> finsum M g A) = finsum M (%x. c \<odot>\<^bsub>M\<^esub> g x) A "
proof (induct A rule: infinite_finite_induct)
  case (insert a A)
  from insert.hyps insert.prems have 1: "finsum M g (insert a A) = g a \<oplus>\<^bsub>M\<^esub> finsum M g A"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems have 2: "(\<Oplus>\<^bsub>M\<^esub>x\<in>insert a A. c \<odot>\<^bsub>M\<^esub> g x) = c \<odot>\<^bsub>M\<^esub> g a \<oplus>\<^bsub>M\<^esub>(\<Oplus>\<^bsub>M\<^esub>x\<in>A. c \<odot>\<^bsub>M\<^esub> g x)"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems show ?case
    by (auto simp add:1 2 smult_r_distr)
qed auto

text \<open>Scalar multiplication distributes over scalar multiplication (on right).\<close>(*Add to module.*)
lemma (in module) finsum_smult_r:
  "[| v\<in> carrier M; f \<in> A \<rightarrow> carrier R |] ==>
   (finsum R f A \<odot>\<^bsub>M\<^esub> v) = finsum M (%x. f x \<odot>\<^bsub>M\<^esub> v) A "
proof (induct A rule: infinite_finite_induct)
  case (insert a A)
  from insert.hyps insert.prems have 1: "finsum R f (insert a A) = f a \<oplus>\<^bsub>R\<^esub> finsum R f A"
    by (intro R.finsum_insert, auto)
  from insert.hyps insert.prems have 2: "(\<Oplus>\<^bsub>M\<^esub>x\<in>insert a A. f x \<odot>\<^bsub>M\<^esub> v) = f a \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub>(\<Oplus>\<^bsub>M\<^esub>x\<in>A. f x \<odot>\<^bsub>M\<^esub> v)"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems show ?case
    by (auto simp add:1 2 smult_l_distr)
qed auto

text \<open>A sequence of lemmas that shows that the product does not depend on the ambient group.
Note I had to dig back into the definitions of foldSet to show this.\<close>
(*Add the following 2 lemmas to Group.*)

lemma foldD_not_depend:
  fixes D E B f e A
  assumes h1: "LCD B D f" and h2: "LCD B E f" and h3: "D\<subseteq>E" and h4: "e\<in>D" and h5: "A\<subseteq>B" and h6: "finite B"
  shows "foldD D f e A = foldD E f e A"
proof -
  from assms have 1: "\<exists>y. (A,y)\<in>foldSetD D f e"
    apply (intro finite_imp_foldSetD, auto)
     apply (metis finite_subset)
    by (unfold LCD_def, auto)
  from 1 obtain y where 2: "(A,y)\<in>foldSetD D f e" by auto
  from assms 2 have 3: "foldD D f e A = y" by (intro LCD.foldD_equality[of B], auto)
  from h3 have 4: "foldSetD D f e \<subseteq> foldSetD E f e" by (rule foldSet_not_depend)
  from 2 4 have 5: "(A,y)\<in>foldSetD E f e" by auto
  from assms 5 have 6: "foldD E f e A = y" by (intro LCD.foldD_equality[of B], auto)
(*(A,y)\<in>f*)
  from 3 6 show ?thesis by auto
qed

lemmas (in comm_monoid) [simp] = finprod_one_eqI

context abelian_monoid
begin
lemmas extend_sum = add.extend_prod
lemmas finsum_all0 = add.finprod_one_eqI
end

end


header {* Many-Typed (Many-Sorted) First-Order Logic *}
theory Sig imports Preliminaries
begin

text{* In this formalization, we call ``types" what the first-order logic community usually calls ``sorts".  *}

subsection{* Signatures *}

locale Signature =
fixes
    wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf :: "'fsym \<Rightarrow> 'tp"
and parOf :: "'psym \<Rightarrow> 'tp list"
assumes
    countable_tp: "countable (UNIV :: 'tp set)"
and countable_wtFsym: "countable {f::'fsym. wtFsym f}"
and countable_wtPsym: "countable {p::'psym. wtPsym p}"
begin

text{* Partitioning of the variables in countable sets for each type: *}

definition tpOfV_pred :: "(var \<Rightarrow> 'tp) \<Rightarrow> bool" where
"tpOfV_pred f \<equiv> \<forall> \<sigma>. infinite (f -` {\<sigma>})"

definition "tpOfV \<equiv> SOME f. tpOfV_pred f"

lemma infinite_fst_vimage:
"infinite ((fst :: 'a \<times> nat \<Rightarrow> 'a) -` {a})" (is "infinite (?f -` {a})")
proof-
  have "?f -` {a} = {(a,n::nat) | n . True}" (is "_ = ?A") by auto
  moreover
  {have 0: "?A = range (Pair a)" by auto
   have "infinite ?A" unfolding 0 apply(rule range_inj_infinite)
   unfolding inj_on_def by auto
  }
  ultimately show ?thesis by auto
qed

lemma tpOfV_pred: "\<exists> f. tpOfV_pred f"
proof-
  def Ut \<equiv> "UNIV :: 'tp set" def Uv \<equiv> "UNIV :: var set"
  def Unt \<equiv> "UNIV :: nat set"
  def U2 \<equiv> "UNIV :: ('tp \<times> nat) set"
  have U2: "U2 \<equiv> Ut \<times> Unt" unfolding Ut_def Unt_def U2_def UNIV_Times_UNIV .
  have "|U2| =o |Unt \<times> Ut|" unfolding U2 by (metis card_of_Times_commute)
  also have "|Unt \<times> Ut| =o |Unt|"
  apply(rule card_of_Times_infinite_simps(1)) unfolding Ut_def Unt_def
  apply (metis nat_not_finite)
  apply (metis UNIV_not_empty)
  by (metis countable_card_of_nat countable_tp)
  also have "|Unt| =o |Uv|" apply(rule ordIso_symmetric)
  unfolding Unt_def Uv_def using card_of_var card_of_nat[THEN ordIso_symmetric]
  by(rule ordIso_transitive)
  finally have "|U2| =o |Uv|" .
  hence "|Uv| =o |U2|" by(rule ordIso_symmetric)
  then obtain g where g: "bij_betw g Uv U2" unfolding card_of_ordIso[symmetric] by blast
  show ?thesis apply(rule exI[of _ "fst o g"]) unfolding tpOfV_pred_def apply safe
  unfolding vimage_comp [symmetric] apply (drule finite_vimageD)
  using g unfolding bij_betw_def Uv_def U2_def by (auto simp: infinite_fst_vimage)
qed

lemma tpOfV_pred_tpOfV: "tpOfV_pred tpOfV"
using tpOfV_pred unfolding tpOfV_def by (rule someI_ex)

lemma tpOfV: "infinite (tpOfV -` {\<sigma>})"
using tpOfV_pred_tpOfV unfolding tpOfV_pred_def by auto

definition "tpart1 V \<equiv> \<Union> \<sigma>. part1 (V \<inter> tpOfV -` {\<sigma>})"
definition "tpart2 V \<equiv> \<Union> \<sigma>. part2 (V \<inter> tpOfV -` {\<sigma>})"
definition "tinfinite V \<equiv> \<forall> \<sigma>. infinite (V \<inter> tpOfV -` {\<sigma>})"

lemma tinfinite_var[simp,intro]: "tinfinite (UNIV :: var set)"
unfolding tinfinite_def using tpOfV by auto

lemma tinifnite_singl[simp]:
assumes "tinfinite V"  shows "tinfinite (V - {x})"
unfolding tinfinite_def proof safe
  fix \<sigma> assume 0: "finite ((V - {x}) \<inter> tpOfV -` {\<sigma>})"
  have "finite ((V \<inter> tpOfV -` {\<sigma>}) - {x})" apply(rule finite_subset[OF _ 0]) by auto
  thus False using assms unfolding tinfinite_def by auto
qed

lemma tpart1_Un_tpart2[simp]:
assumes "tinfinite V" shows "tpart1 V \<union> tpart2 V = V"
using assms part1_Un_part2 unfolding tinfinite_def tpart1_def tpart2_def
unfolding UN_Un_distrib[symmetric] by blast

lemma tpart1_Int_tpart2[simp]:
assumes "tinfinite V" shows "tpart1 V \<inter> tpart2 V = {}"
using assms part1_Int_part2 unfolding tinfinite_def tpart1_def tpart2_def
unfolding Int_UN_distrib2 apply auto apply (case_tac "xa = xb", auto)
using part1_su part2_su by blast (* fixme: clean proof *)

lemma tpart1_su:
assumes "tinfinite V"  shows "tpart1 V \<subseteq> V"
using assms unfolding tinfinite_def tpart1_def
using part1_su by (auto intro: UN_least)

lemma tpart1_in:
assumes "tinfinite V" and "x \<in> tpart1 V" shows "x \<in> V"
using assms tpart1_su by auto

lemma tinfinite_tpart1[simp]:
assumes "tinfinite V"
shows "tinfinite (tpart1 V)"
unfolding tinfinite_def tpart1_def proof safe
  fix \<sigma> assume
  "finite ((\<Union>\<sigma>'. part1 (V \<inter> tpOfV -` {\<sigma>'})) \<inter> tpOfV -` {\<sigma>})" (is "finite ?A")
  moreover have "?A = part1 (V \<inter> tpOfV -` {\<sigma>})"
  using assms part1_su unfolding tinfinite_def by auto
  moreover have "infinite ..."
  using assms infinite_part1 unfolding tinfinite_def by auto
  ultimately show False by auto
qed

lemma tinfinite_tpart2[simp]:
assumes "tinfinite V"
shows "tinfinite (tpart2 V)"
unfolding tinfinite_def tpart2_def proof safe
  fix \<sigma> assume
  "finite ((\<Union>\<sigma>'. part2 (V \<inter> tpOfV -` {\<sigma>'})) \<inter> tpOfV -` {\<sigma>})" (is "finite ?A")
  moreover have "?A = part2 (V \<inter> tpOfV -` {\<sigma>})"
  using assms part2_su unfolding tinfinite_def by auto
  moreover have "infinite ..."
  using assms infinite_part2 unfolding tinfinite_def by auto
  ultimately show False by auto
qed

lemma tpart2_su:
assumes "tinfinite V"  shows "tpart2 V \<subseteq> V"
using assms unfolding tinfinite_def tpart2_def
using part2_su by (auto intro: UN_least)

lemma tpart2_in:
assumes "tinfinite V" and "x \<in> tpart2 V" shows "x \<in> V"
using assms tpart2_su by auto

text{* Typed-pick: picking a variable of a given type *}

definition "tpick \<sigma> V \<equiv> pick (V \<inter> tpOfV -` {\<sigma>})"

lemma tinfinite_ex: "tinfinite V \<Longrightarrow> \<exists> x \<in> V. tpOfV x = \<sigma>"
unfolding tinfinite_def using infinite_imp_nonempty by auto

lemma tpick: assumes "tinfinite V" shows "tpick \<sigma> V \<in> V \<inter> tpOfV -` {\<sigma>}"
proof-
  obtain x where "x \<in> V \<and> tpOfV x = \<sigma>"
  using tinfinite_ex[OF assms] by auto
  hence "x \<in> V \<inter> tpOfV -` {\<sigma>}" by blast
  thus ?thesis unfolding tpick_def by (rule pick)
qed

lemma tpick_in[simp]: "tinfinite V \<Longrightarrow> tpick \<sigma> V \<in> V"
and tpOfV_tpick[simp]: "tinfinite V \<Longrightarrow> tpOfV (tpick \<sigma> V) = \<sigma>"
using tpick by auto

lemma finite_tinfinite:
assumes "finite V"
shows "tinfinite (UNIV - V)"
using assms infinite_var unfolding tinfinite_def
by (metis Diff_Int2 Diff_Int_distrib2 Int_UNIV_left finite_Diff2 tpOfV)

(* get variable terms for the given types: *)
fun getVars where
"getVars [] = []"
|
"getVars (\<sigma> # \<sigma>l) =
 (let xl = getVars \<sigma>l in (tpick \<sigma> (UNIV - set xl)) # xl)"

lemma distinct_getVars: "distinct (getVars \<sigma>l)"
using tpick_in[OF finite_tinfinite] by (induct \<sigma>l, auto simp: Let_def)

lemma length_getVars[simp]: "length (getVars \<sigma>l) = length \<sigma>l"
by(induct \<sigma>l, auto simp: Let_def)

lemma map_tpOfV_getVars[simp]: "map tpOfV (getVars \<sigma>l) = \<sigma>l"
using tpOfV_tpick[OF finite_tinfinite] by (induct \<sigma>l, auto simp: Let_def)

lemma tpOfV_getVars_nth[simp]:
assumes "i < length \<sigma>l"  shows "tpOfV (getVars \<sigma>l ! i) = \<sigma>l ! i"
using assms using map_tpOfV_getVars by (metis length_getVars nth_map)

end (* context Signature *)

end


(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section \<open>The Cauchy--Binet formula in HOL Analysis\<close>

theory Cauchy_Binet_HOL_Analysis
  imports
    Cauchy_Binet
    Perron_Frobenius.HMA_Connect
begin

subsection \<open>Definition of submatrices in HOL Analysis\<close>

definition submatrix_hma :: "'a^'nc^'nr\<Rightarrow>nat set\<Rightarrow>nat set\<Rightarrow>('a^'nc2^'nr2)"
  where "submatrix_hma A I J = (\<chi> a b. A $h (from_nat (pick I (to_nat a))) $h (from_nat (pick J (to_nat b))))"

context includes lifting_syntax
begin

context
  fixes I::"nat set" and J::"nat set"
  assumes I: "card {i. i < CARD('nr::finite) \<and> i \<in> I} = CARD('nr2::finite)"
  assumes J: "card {i. i < CARD('nc::finite) \<and> i \<in> J} = CARD('nc2::finite)"
begin

lemma HMA_submatrix[transfer_rule]: "(HMA_M ===> HMA_M) (\<lambda>A. submatrix A I J)
  ((\<lambda>A. submatrix_hma A I J):: 'a^ 'nc ^ 'nr \<Rightarrow> 'a ^ 'nc2 ^ 'nr2)"
proof (intro rel_funI, goal_cases)
  case (1 A B)
  note relAB[transfer_rule] = this
  show ?case unfolding  HMA_M_def
  proof (rule eq_matI, auto)
    show "dim_row (submatrix A I J) = CARD('nr2)"
      unfolding submatrix_def
      using I dim_row_transfer_rule relAB by force
    show "dim_col (submatrix A I J) = CARD('nc2)"
      unfolding submatrix_def
      using J dim_col_transfer_rule relAB by force
    let ?B="(submatrix_hma B I J)::'a ^ 'nc2 ^ 'nr2"
    fix i j assume i: "i < CARD('nr2)" and
           j: "j < CARD('nc2)"
    have i2: "i < card {i. i < dim_row A \<and> i \<in> I}"
      using I dim_row_transfer_rule i relAB by fastforce
    have j2: "j < card {j. j < dim_col A \<and> j \<in> J}"
      using J dim_col_transfer_rule j relAB by fastforce
    let ?i = "(from_nat (pick I i))::'nr"
    let ?j = "(from_nat (pick J j))::'nc"
    let ?i' = "Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2)"
    let ?j' = "Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)"
    have i': "?i' = i" by (rule to_nat_from_nat_id[OF i])
    have j': "?j' = j" by (rule to_nat_from_nat_id[OF j])
    let ?f = "(\<lambda>(i, j).
         B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h
         Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2))))"
    have [transfer_rule]: "HMA_I (pick I i) ?i"
      by (simp add: Bij_Nat.to_nat_from_nat_id I i pick_le HMA_I_def)
    have [transfer_rule]: "HMA_I (pick J j) ?j"
      by (simp add: Bij_Nat.to_nat_from_nat_id J j pick_le HMA_I_def)
    have "submatrix A I J $$ (i, j) = A $$ (pick I i, pick J j)" by (rule submatrix_index[OF i2 j2])
    also have "... = index_hma B ?i ?j" by (transfer, simp)
    also have "... =  B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h
         Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)))"
      unfolding i' j' index_hma_def by auto
    also have "... = ?f (i,j)" by auto
    also have "... = Matrix.mat CARD('nr2) CARD('nc2) ?f $$ (i, j)"
      by (rule index_mat[symmetric, OF i j])
    also have "... = from_hma\<^sub>m ?B $$ (i, j)"
      unfolding from_hma\<^sub>m_def submatrix_hma_def by auto
    finally show "submatrix A I J $$ (i, j) = from_hma\<^sub>m ?B $$ (i, j)" .
  qed
qed

end
end

subsection \<open>Transferring the proof from JNF to HOL Analysis\<close>

lemma Cauchy_Binet_HOL_Analysis:
  fixes A::"'a::comm_ring_1^'m^'n" and B::"'a^'n^'m"
  shows "Determinants.det (A**B) = (\<Sum>I\<in>{I. I\<subseteq>{0..<ncols A} \<and> card I=nrows A}.
         Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) *
         Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n))"
proof -
  let ?A = "(from_hma\<^sub>m A)"
  let ?B = "(from_hma\<^sub>m B)"
  have relA[transfer_rule]: "HMA_M ?A A" unfolding HMA_M_def by simp
  have relB[transfer_rule]: "HMA_M ?B B" unfolding HMA_M_def by simp
  have "(\<Sum>I\<in>{I. I\<subseteq>{0..<ncols A} \<and> card I = nrows A}.
         Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) *
         Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n)) =
          (\<Sum>I\<in>{I. I\<subseteq>{0..<ncols A} \<and> card I=nrows A}. det (submatrix ?A UNIV I)
        * det (submatrix ?B I UNIV))"
  proof (rule sum.cong)
    fix I assume I: "I \<in>{I. I\<subseteq>{0..<ncols A} \<and> card I=nrows A}"
    let ?sub_A= "((submatrix_hma A UNIV I)::'a^'n^'n)"
    let ?sub_B= "((submatrix_hma B I UNIV)::'a^'n^'n)"
    have c1: "card {i. i < CARD('n) \<and> i \<in> UNIV} = CARD('n)" using I by auto
    have c2: "card {i. i < CARD('m) \<and> i \<in> I} = CARD('n)"
    proof -
      have "I = {i. i < CARD('m) \<and> i \<in> I}" using I unfolding nrows_def ncols_def by auto
      thus ?thesis using I nrows_def by auto
    qed
    have [transfer_rule]: "HMA_M (submatrix ?A UNIV I) ?sub_A"
      using HMA_submatrix[OF c1 c2] relA unfolding rel_fun_def by auto
    have [transfer_rule]: "HMA_M (submatrix ?B I UNIV) ?sub_B"
      using HMA_submatrix[OF c2 c1] relB unfolding rel_fun_def by auto
    show "Determinants.det ?sub_A * Determinants.det ?sub_B
      = det (submatrix ?A UNIV I) * det (submatrix ?B I UNIV)" by (transfer', auto)
  qed (auto)
  also have "... = det (?A*?B)"
    by (rule Cauchy_Binet[symmetric], unfold nrows_def ncols_def, auto)
  also have "... = Determinants.det (A**B)" by (transfer', auto)
  finally show ?thesis ..
qed

end


theory HOModel
imports Main
begin

declare if_split_asm [split] \<comment> \<open>perform default perform case splitting on conditionals\<close>

section \<open>Heard-Of Algorithms\<close>

subsection \<open>The Consensus Problem\<close>

text \<open>
  We are interested in the verification of fault-tolerant distributed algorithms.
  The Consensus problem is paradigmatic in this area. Stated
  informally, it assumes that all processes participating in the algorithm
  initially propose some value, and that they may at some point decide some value.
  It is required that every process eventually decides, and that all processes
  must decide the same value.

  More formally, we represent runs of algorithms as \<open>\<omega>\<close>-sequences of
  configurations (vectors of process states). Hence, a run is modeled as
  a function of type \<open>nat \<Rightarrow> 'proc \<Rightarrow> 'pst\<close> where type variables
  \<open>'proc\<close> and \<open>'pst\<close> represent types of processes and process
  states, respectively. The Consensus property is expressed with respect
  to a collection \<open>vals\<close> of initially proposed values (one per process)
  and an observer function \<open>dec::'pst \<Rightarrow> val option\<close> that retrieves the decision
  (if any) from a process state. The Consensus problem is stated as the conjunction
  of the following properties:
  \begin{description}
  \item[Integrity.] Processes can only decide initially proposed values.
  \item[Agreement.] Whenever processes \<open>p\<close> and \<open>q\<close> decide,
    their decision values must be the same. (In particular, process \<open>p\<close>
    may never change the value it decides, which is referred to as Irrevocability.)
  \item[Termination.] Every process decides eventually.
  \end{description}

  The above properties are sometimes only required of non-faulty processes, since
  nothing can be required of a faulty process.
  The Heard-Of model does not attribute faults to processes, and therefore the
  above formulation is appropriate in this framework.
\<close>

type_synonym
  ('proc,'pst) run = "nat \<Rightarrow> 'proc \<Rightarrow> 'pst"

definition
  consensus :: "('proc \<Rightarrow> 'val) \<Rightarrow> ('pst \<Rightarrow> 'val option) \<Rightarrow> ('proc,'pst) run \<Rightarrow> bool"
where
  "consensus vals dec rho \<equiv>
     (\<forall>n p v. dec (rho n p) = Some v \<longrightarrow> v \<in> range vals)
   \<and> (\<forall>m n p q v w. dec (rho m p) = Some v \<and> dec (rho n q) = Some w
         \<longrightarrow> v = w)
   \<and> (\<forall>p. \<exists>n. dec (rho n p) \<noteq> None)"

text \<open>
  A variant of the Consensus problem replaces the Integrity requirement by
  \begin{description}
  \item[Validity.] If all processes initially propose the same value \<open>v\<close>
    then every process may only decide \<open>v\<close>.
  \end{description}
\<close>

definition weak_consensus where
  "weak_consensus vals dec rho \<equiv>
     (\<forall>v. (\<forall>p. vals p = v) \<longrightarrow> (\<forall>n p w. dec (rho n p) = Some w \<longrightarrow> w = v))
   \<and> (\<forall>m n p q v w. dec (rho m p) = Some v \<and> dec (rho n q) = Some w
         \<longrightarrow> v = w)
   \<and> (\<forall>p. \<exists>n. dec (rho n p) \<noteq> None)"

text \<open>
  Clearly, \<open>consensus\<close> implies \<open>weak_consensus\<close>.
\<close>

lemma consensus_then_weak_consensus:
  assumes "consensus vals dec rho"
  shows "weak_consensus vals dec rho"
  using assms by (auto simp: consensus_def weak_consensus_def image_def)

text \<open>
  Over Boolean values (``binary Consensus''), \<open>weak_consensus\<close>
  implies \<open>consensus\<close>, hence the two problems are equivalent.
  In fact, this theorem holds more generally whenever at most two
  different values are proposed initially (i.e., \<open>card (range vals) \<le> 2\<close>).
\<close>

lemma binary_weak_consensus_then_consensus:
  assumes bc: "weak_consensus (vals::'proc \<Rightarrow> bool) dec rho"
  shows "consensus vals dec rho"
proof -
  { \<comment> \<open>Show the Integrity property, the other conjuncts are the same.\<close>
    fix n p v
    assume dec: "dec (rho n p) = Some v"
    have "v \<in> range vals"
    proof (cases "\<exists>w. \<forall>p. vals p = w")
      case True
      then obtain w where w: "\<forall>p. vals p = w" ..
      with bc have "dec (rho n p) \<in> {Some w, None}" by (auto simp: weak_consensus_def)
      with dec w show ?thesis by (auto simp: image_def)
    next
      case False
      \<comment> \<open>In this case both possible values occur in @{text "vals"}, and the result is trivial.\<close>
      thus ?thesis by (auto simp: image_def)
    qed
  } note integrity = this
  from bc show ?thesis
    unfolding consensus_def weak_consensus_def by (auto elim!: integrity)
qed

text \<open>
  The algorithms that we are going to verify solve the Consensus or weak Consensus
  problem, under different hypotheses about the kinds and number of faults.
\<close>

subsection \<open>A Generic Representation of Heard-Of Algorithms\<close>

text \<open>
  Charron-Bost and Schiper~\cite{charron:heardof} introduce
  the Heard-Of (HO) model for representing fault-tolerant
  distributed algorithms. In this model, algorithms execute in communication-closed
  rounds: at any round~$r$, processes only receive messages that were sent for
  that round. For every process~$p$ and round~$r$, the ``heard-of set'' $HO(p,r)$
  denotes the set of processes from which~$p$ receives a message in round~$r$.
  Since every process is assumed to send a message to all processes in each round,
  the complement of $HO(p,r)$ represents the set of faults that may affect~$p$ in
  round~$r$ (messages that were not received, e.g. because the sender crashed,
  because of a network problem etc.).

  The HO model expresses hypotheses on the faults tolerated by an algorithm
  through ``communication predicates'' that constrain the sets $HO(p,r)$
  that may occur during an execution. Charron-Bost and Schiper show that
  standard fault models can be represented in this form.

  The original HO model is sufficient for representing algorithms
  tolerating benign failures such as process crashes or message loss. A later
  extension for algorithms tolerating Byzantine (or value) failures~\cite{biely:tolerating}
  adds a second collection of sets $SHO(p,r) \subseteq HO(p,r)$ that contain those
  processes $q$ from which process $p$ receives the message that $q$ was indeed
  supposed to send for round $r$ according to the algorithm. In other words,
  messages from processes in $HO(p,r) \setminus SHO(p,r)$ were corrupted, be it
  due to errors during message transmission or because of the sender was faulty or
  lied deliberately. For both benign and Byzantine errors, the HO model registers
  the fault but does not try to identify the faulty component (i.e., designate the
  sending or receiving process, or the communication channel as the ``culprit'').

  Executions of HO algorithms are defined with respect to collections
  $HO(p,r)$ and $SHO(p,r)$. However, the code of a process does not have
  access to these sets. In particular, process $p$ has no way of determining
  if a message it received from another process $q$ corresponds to what $q$
  should have sent or if it has been corrupted.

  Certain algorithms rely on the assignment of ``coordinator'' processes for
  each round. Just as the collections $HO(p,r)$, the definitions assume an
  external coordinator assignment such that $coord(p,r)$ denotes the coordinator
  of process $p$ and round $r$. Again, the correctness of algorithms may depend
  on hypotheses about coordinator assignments -- e.g., it may be assumed that
  processes agree sufficiently often on who the current coordinator is.

  The following definitions provide a generic representation of HO and SHO algorithms
  in Isabelle/HOL. A (coordinated) HO algorithm is described by the following parameters:
  \begin{itemize}
  \item a finite type \<open>'proc\<close> of processes,
  \item a type \<open>'pst\<close> of local process states,
  \item a type \<open>'msg\<close> of messages sent in the course of the algorithm,
  \item a predicate \<open>CinitState\<close> such that \<open>CinitState p st crd\<close> is
    true precisely of the initial states \<open>st\<close> of process \<open>p\<close>, assuming
    that \<open>crd\<close> is the initial coordinator of \<open>p\<close>,
  \item a function \<open>sendMsg\<close> where \<open>sendMsg r p q st\<close> yields
    the message that process \<open>p\<close> sends to process \<open>q\<close> at round
    \<open>r\<close>, given its local state \<open>st\<close>, and
  \item a predicate \<open>CnextState\<close> where \<open>CnextState r p st msgs crd st'\<close>
    characterizes the successor states \<open>st'\<close> of process \<open>p\<close> at round
    \<open>r\<close>, given current state \<open>st\<close>, the vector
    \<open>msgs :: 'proc \<Rightarrow> 'msg option\<close> of messages that \<open>p\<close> received at
    round \<open>r\<close> (\<open>msgs q = None\<close> indicates that no message has been
    received from process \<open>q\<close>),
    and process \<open>crd\<close> as the coordinator for the following round.
  \end{itemize}
  Note that every process can store the coordinator for the current round in its
  local state, and it is therefore not necessary to make the coordinator a parameter
  of the message sending function \<open>sendMsg\<close>.

  We represent an algorithm by a record as follows.
\<close>

record ('proc, 'pst, 'msg) CHOAlgorithm =
  CinitState ::  "'proc \<Rightarrow> 'pst \<Rightarrow> 'proc \<Rightarrow> bool"
  sendMsg ::   "nat \<Rightarrow> 'proc \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> 'msg"
  CnextState :: "nat \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> ('proc \<Rightarrow> 'msg option) \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> bool"

text \<open>
  For non-coordinated HO algorithms, the coordinator argument of functions
  \<open>CinitState\<close> and \<open>CnextState\<close> is irrelevant, and we
  define utility functions that omit that argument.
\<close>

definition isNCAlgorithm where
  "isNCAlgorithm alg \<equiv>
      (\<forall>p st crd crd'. CinitState alg p st crd = CinitState alg p st crd')
   \<and> (\<forall>r p st msgs crd crd' st'. CnextState alg r p st msgs crd st'
                               = CnextState alg r p st msgs crd' st')"

definition initState where
  "initState alg p st \<equiv> CinitState alg p st undefined"

definition nextState where
  "nextState alg r p st msgs st' \<equiv> CnextState alg r p st msgs undefined st'"

text \<open>
  A \emph{heard-of assignment} associates a set of processes with each
  process. The following type is used to represent the collections $HO(p,r)$
  and $SHO(p,r)$ for fixed round $r$.
%
  Similarly, a \emph{coordinator assignment} associates a process (its coordinator)
  to each process.
\<close>

type_synonym
  'proc HO = "'proc \<Rightarrow> 'proc set"

type_synonym
  'proc coord = "'proc \<Rightarrow> 'proc"

text \<open>
  An execution of an HO algorithm is defined with respect to HO and SHO
  assignments that indicate, for every round \<open>r\<close> and every process \<open>p\<close>,
  from which sender processes \<open>p\<close> receives messages (resp., uncorrupted
  messages) at round \<open>r\<close>.

%% That's the intention, but we don't enforce this in the definitions.
%  Obviously, SHO sets are always included in HO sets, for the same process and round.

  The following definitions formalize this idea. We define ``coarse-grained''
  executions whose unit of atomicity is the round of execution. At each round,
  the entire collection of processes performs a transition according to the
  \<open>CnextState\<close> function of the algorithm. Consequently, a system state is
  simply described by a configuration, i.e. a function assigning a process state
  to every process. This definition of executions may appear surprising for an
  asynchronous distributed system, but it simplifies system verification,
  compared to a ``fine-grained'' execution model that records individual events
  such as message sending and reception or local transitions. We will justify
  later why the ``coarse-grained'' model is sufficient for verifying interesting
  correctness properties of HO algorithms.

  The predicate \<open>CSHOinitConfig\<close> describes the possible initial configurations
  for algorithm \<open>A\<close> (remember that a configuration is a function that assigns
  local states to every process).
\<close>

definition CHOinitConfig where
  "CHOinitConfig A cfg (coord::'proc coord) \<equiv> \<forall>p. CinitState A p (cfg p) (coord p)"

text \<open>
  Given the current configuration \<open>cfg\<close> and the HO and SHO sets \<open>HOp\<close>
  and \<open>SHOp\<close> for process \<open>p\<close> at round \<open>r\<close>, the function
  \<open>SHOmsgVectors\<close> computes the set of possible vectors of messages that
  process \<open>p\<close> may receive. For processes \<open>q \<notin> HOp\<close>, \<open>p\<close>
  receives no message (represented as value \<open>None\<close>). For processes
  \<open>q \<in> SHOp\<close>, \<open>p\<close> receives the message that \<open>q\<close> computed
  according to the \<open>sendMsg\<close> function of the algorithm. For the remaining
  processes \<open>q \<in> HOp - SHOp\<close>, \<open>p\<close> may receive some arbitrary value.
\<close>

definition SHOmsgVectors where
  "SHOmsgVectors A r p cfg HOp SHOp \<equiv>
   {\<mu>. (\<forall>q. q \<in> HOp \<longleftrightarrow> \<mu> q \<noteq> None)
     \<and> (\<forall>q. q \<in> SHOp \<inter> HOp \<longrightarrow> \<mu> q = Some (sendMsg A r q p (cfg q)))}"

text \<open>
  Predicate \<open>CSHOnextConfig\<close> uses the preceding function and the algorithm's
  \<open>CnextState\<close> function to characterize the possible successor configurations
  in a coarse-grained step, and predicate \<open>CSHORun\<close> defines (coarse-grained)
  executions \<open>rho\<close> of an HO algorithm.
\<close>

definition CSHOnextConfig where
  "CSHOnextConfig A r cfg HO SHO coord cfg' \<equiv>
   \<forall>p. \<exists>\<mu> \<in> SHOmsgVectors A r p cfg (HO p) (SHO p).
          CnextState A r p (cfg p) \<mu> (coord p) (cfg' p)"

definition CSHORun where
  "CSHORun A rho HOs SHOs coords \<equiv>
     CHOinitConfig A (rho 0) (coords 0)
   \<and> (\<forall>r. CSHOnextConfig A r (rho r) (HOs r) (SHOs r) (coords (Suc r))
                             (rho (Suc r)))"

text \<open>
  For non-coordinated algorithms. the \<open>coord\<close> arguments of the above functions
  are irrelevant. We define similar functions that omit that argument, and relate
  them to the above utility functions for these algorithms.
\<close>

definition HOinitConfig where
  "HOinitConfig A cfg \<equiv> CHOinitConfig A cfg (\<lambda>q. undefined)"

definition SHOnextConfig where
  "SHOnextConfig A r cfg HO SHO cfg' \<equiv>
   CSHOnextConfig A r cfg HO SHO (\<lambda>q. undefined) cfg'"

lemma SHOnextConfig_eq:
  "SHOnextConfig A r cfg HO SHO cfg' =
   (\<forall>p. \<exists>\<mu> \<in> SHOmsgVectors A r p cfg (HO p) (SHO p).
             nextState A r p (cfg p) \<mu> (cfg' p))"
  by (auto simp: SHOnextConfig_def CSHOnextConfig_def SHOmsgVectors_def nextState_def)

definition SHORun where
  "SHORun A rho HOs SHOs \<equiv>
   CSHORun A rho HOs SHOs (\<lambda>r q. undefined)"

lemma SHORun_eq:
  "SHORun A rho HOs SHOs =
     (HOinitConfig A (rho 0)
   \<and> (\<forall>r. SHOnextConfig A r (rho r) (HOs r) (SHOs r) (rho (Suc r))))"
  by (auto simp: SHORun_def CSHORun_def HOinitConfig_def SHOnextConfig_def)

text \<open>
  Algorithms designed to tolerate benign failures are not subject to
  message corruption, and therefore the SHO sets are irrelevant (more formally,
  each SHO set equals the corresponding HO set). We define corresponding
  special cases of the definitions of successor configurations and of runs,
  and prove that these are equivalent to simpler definitions that will be more
  useful in proofs. In particular, the vector of messages received by a process
  in a benign execution is uniquely determined from the current configuration
  and the HO sets.
\<close>

definition HOrcvdMsgs where
  "HOrcvdMsgs A r p HO cfg \<equiv>
   \<lambda>q. if q \<in> HO then Some (sendMsg A r q p (cfg q)) else None"

lemma SHOmsgVectors_HO:
  "SHOmsgVectors A r p cfg HO HO = {HOrcvdMsgs A r p HO cfg}"
  unfolding SHOmsgVectors_def HOrcvdMsgs_def by auto

text \<open>With coordinators\<close>

definition CHOnextConfig where
  "CHOnextConfig A r cfg HO coord cfg' \<equiv>
   CSHOnextConfig A r cfg HO HO coord cfg'"

lemma CHOnextConfig_eq:
  "CHOnextConfig A r cfg HO coord cfg' =
   (\<forall>p. CnextState A r p (cfg p) (HOrcvdMsgs A r p (HO p) cfg)
                   (coord p) (cfg' p))"
  by (auto simp: CHOnextConfig_def CSHOnextConfig_def SHOmsgVectors_HO)

definition CHORun where
  "CHORun A rho HOs coords \<equiv> CSHORun A rho HOs HOs coords"

lemma CHORun_eq:
  "CHORun A rho HOs coords =
     (CHOinitConfig A (rho 0) (coords 0)
      \<and> (\<forall>r. CHOnextConfig A r (rho r) (HOs r) (coords (Suc r)) (rho (Suc r))))"
  by (auto simp: CHORun_def CSHORun_def CHOinitConfig_def CHOnextConfig_def)

text \<open>Without coordinators\<close>
definition HOnextConfig where
  "HOnextConfig A r cfg HO cfg' \<equiv> SHOnextConfig A r cfg HO HO cfg'"

lemma HOnextConfig_eq:
  "HOnextConfig A r cfg HO cfg' =
   (\<forall>p. nextState A r p (cfg p) (HOrcvdMsgs A r p (HO p) cfg) (cfg' p))"
  by (auto simp: HOnextConfig_def SHOnextConfig_eq SHOmsgVectors_HO)

definition HORun where
  "HORun A rho HOs \<equiv> SHORun A rho HOs HOs"

lemma HORun_eq:
  "HORun A rho HOs =
   (  HOinitConfig A (rho 0)
    \<and> (\<forall>r. HOnextConfig A r (rho r) (HOs r) (rho (Suc r))))"
  by (auto simp: HORun_def SHORun_eq HOnextConfig_def)

text \<open>
  The following derived proof rules are immediate consequences of
  the definition of \<open>CHORun\<close>; they simplify automatic reasoning.
\<close>

lemma CHORun_0:
  assumes "CHORun A rho HOs coords"
      and "\<And>cfg. CHOinitConfig A cfg (coords 0) \<Longrightarrow> P cfg"
  shows "P (rho 0)"
using assms unfolding CHORun_eq by blast

lemma CHORun_Suc:
  assumes "CHORun A rho HOs coords"
  and "\<And>r. CHOnextConfig A r (rho r) (HOs r) (coords (Suc r)) (rho (Suc r))
            \<Longrightarrow> P r"
  shows "P n"
using assms unfolding CHORun_eq by blast

lemma CHORun_induct:
  assumes run: "CHORun A rho HOs coords"
  and init: "CHOinitConfig A (rho 0) (coords 0) \<Longrightarrow> P 0"
  and step: "\<And>r. \<lbrakk> P r; CHOnextConfig A r (rho r) (HOs r) (coords (Suc r))
                                      (rho (Suc r)) \<rbrakk> \<Longrightarrow> P (Suc r)"
  shows "P n"
using run unfolding CHORun_eq by (induct n, auto elim: init step)

text \<open>
  Because algorithms will not operate for arbitrary HO, SHO, and coordinator
  assignments, these are constrained by a \emph{communication predicate}.
  For convenience, we split this predicate into a \emph{per Round} part that
  is expected to hold at every round and a \emph{global} part that must hold
  of the sequence of (S)HO assignments and may thus express liveness assumptions.

  In the parlance of~\cite{charron:heardof}, a \emph{HO machine} is an HO algorithm
  augmented with a communication predicate. We therefore define (C)(S)HO machines as
  the corresponding extensions of the record defining an HO algorithm.
\<close>

record ('proc, 'pst, 'msg) HOMachine = "('proc, 'pst, 'msg) CHOAlgorithm" +
  HOcommPerRd::"'proc HO \<Rightarrow> bool"
  HOcommGlobal::"(nat \<Rightarrow> 'proc HO) \<Rightarrow> bool"

record ('proc, 'pst, 'msg) CHOMachine = "('proc, 'pst, 'msg) CHOAlgorithm" +
  CHOcommPerRd::"nat \<Rightarrow> 'proc HO \<Rightarrow> 'proc coord \<Rightarrow> bool"
  CHOcommGlobal::"(nat \<Rightarrow> 'proc HO) \<Rightarrow> (nat \<Rightarrow> 'proc coord) \<Rightarrow> bool"

record ('proc, 'pst, 'msg) SHOMachine = "('proc, 'pst, 'msg) CHOAlgorithm" +
  SHOcommPerRd::"('proc HO) \<Rightarrow> ('proc HO) \<Rightarrow> bool"
  SHOcommGlobal::"(nat \<Rightarrow> 'proc HO) \<Rightarrow> (nat \<Rightarrow> 'proc HO) \<Rightarrow> bool"

record ('proc, 'pst, 'msg) CSHOMachine = "('proc, 'pst, 'msg) CHOAlgorithm" +
  CSHOcommPerRd::"('proc HO) \<Rightarrow> ('proc HO) \<Rightarrow> 'proc coord \<Rightarrow> bool"
  CSHOcommGlobal::"(nat \<Rightarrow> 'proc HO) \<Rightarrow> (nat \<Rightarrow> 'proc HO)
                                     \<Rightarrow> (nat \<Rightarrow> 'proc coord) \<Rightarrow> bool"

end \<comment> \<open>theory HOModel\<close>


(*<*)theory Axioms imports Overloading Setup begin(*>*)

subsection \<open>Axioms\<close>

text \<open>Attaching axioms to our classes lets us reason on the level of
classes.  The results will be applicable to all types in a class, just
as in axiomatic mathematics.

\begin{warn}
Proofs in this section use structured \emph{Isar} proofs, which are not
covered in this tutorial; but see @{cite "Nipkow-TYPES02"}.%
\end{warn}\<close>

subsubsection \<open>Semigroups\<close>

text\<open>We specify \emph{semigroups} as subclass of \<^class>\<open>plus\<close>:\<close>

class semigroup = plus +
  assumes assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"

text \<open>\noindent This @{command class} specification requires that
all instances of \<^class>\<open>semigroup\<close> obey @{fact "assoc:"}~@{prop
[source] "\<And>x y z :: 'a::semigroup. (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"}.

We can use this class axiom to derive further abstract theorems
relative to class \<^class>\<open>semigroup\<close>:\<close>

lemma assoc_left:
  fixes x y z :: "'a::semigroup"
  shows "x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
  using assoc by (rule sym)

text \<open>\noindent The \<^class>\<open>semigroup\<close> constraint on type \<^typ>\<open>'a\<close> restricts instantiations of \<^typ>\<open>'a\<close> to types of class
\<^class>\<open>semigroup\<close> and during the proof enables us to use the fact
@{fact assoc} whose type parameter is itself constrained to class
\<^class>\<open>semigroup\<close>.  The main advantage of classes is that theorems
can be proved in the abstract and freely reused for each instance.

On instantiation, we have to give a proof that the given operations
obey the class axioms:\<close>

instantiation nat :: semigroup
begin

instance proof

txt \<open>\noindent The proof opens with a default proof step, which for
instance judgements invokes method @{method intro_classes}.\<close>

  fix m n q :: nat
  show "(m \<oplus> n) \<oplus> q = m \<oplus> (n \<oplus> q)"
    by (induct m) simp_all
qed

end

text \<open>\noindent Again, the interesting things enter the stage with
parametric types:\<close>

instantiation prod :: (semigroup, semigroup) semigroup
begin

instance proof
  fix p\<^sub>1 p\<^sub>2 p\<^sub>3 :: "'a::semigroup \<times> 'b::semigroup"
  show "p\<^sub>1 \<oplus> p\<^sub>2 \<oplus> p\<^sub>3 = p\<^sub>1 \<oplus> (p\<^sub>2 \<oplus> p\<^sub>3)"
    by (cases p\<^sub>1, cases p\<^sub>2, cases p\<^sub>3) (simp add: assoc)

txt \<open>\noindent Associativity of product semigroups is established
using the hypothetical associativity @{fact assoc} of the type
components, which holds due to the \<^class>\<open>semigroup\<close> constraints
imposed on the type components by the @{command instance} proposition.
Indeed, this pattern often occurs with parametric types and type
classes.\<close>

qed

end

subsubsection \<open>Monoids\<close>

text \<open>We define a subclass \<open>monoidl\<close> (a semigroup with a
left-hand neutral) by extending \<^class>\<open>semigroup\<close> with one additional
parameter \<open>neutral\<close> together with its property:\<close>

class monoidl = semigroup +
  fixes neutral :: "'a" ("\<zero>")
  assumes neutl: "\<zero> \<oplus> x = x"

text \<open>\noindent Again, we prove some instances, by providing
suitable parameter definitions and proofs for the additional
specifications.\<close>

instantiation nat :: monoidl
begin

definition
  neutral_nat_def: "\<zero> = (0::nat)"

instance proof
  fix n :: nat
  show "\<zero> \<oplus> n = n"
    unfolding neutral_nat_def by simp
qed

end

text \<open>\noindent In contrast to the examples above, we here have both
specification of class operations and a non-trivial instance proof.

This covers products as well:
\<close>

instantiation prod :: (monoidl, monoidl) monoidl
begin

definition
  neutral_prod_def: "\<zero> = (\<zero>, \<zero>)"

instance proof
  fix p :: "'a::monoidl \<times> 'b::monoidl"
  show "\<zero> \<oplus> p = p"
    by (cases p) (simp add: neutral_prod_def neutl)
qed

end

text \<open>\noindent Fully-fledged monoids are modelled by another
subclass which does not add new parameters but tightens the
specification:\<close>

class monoid = monoidl +
  assumes neutr: "x \<oplus> \<zero> = x"

text \<open>\noindent Corresponding instances for \<^typ>\<open>nat\<close> and products
are left as an exercise to the reader.\<close>

subsubsection \<open>Groups\<close>

text \<open>\noindent To finish our small algebra example, we add a \<open>group\<close> class:\<close>

class group = monoidl +
  fixes inv :: "'a \<Rightarrow> 'a" ("\<div> _" [81] 80)
  assumes invl: "\<div> x \<oplus> x = \<zero>"

text \<open>\noindent We continue with a further example for abstract
proofs relative to type classes:\<close>

lemma left_cancel:
  fixes x y z :: "'a::group"
  shows "x \<oplus> y = x \<oplus> z \<longleftrightarrow> y = z"
proof
  assume "x \<oplus> y = x \<oplus> z"
  then have "\<div> x \<oplus> (x \<oplus> y) = \<div> x \<oplus> (x \<oplus> z)" by simp
  then have "(\<div> x \<oplus> x) \<oplus> y = (\<div> x \<oplus> x) \<oplus> z" by (simp add: assoc)
  then show "y = z" by (simp add: invl neutl)
next
  assume "y = z"
  then show "x \<oplus> y = x \<oplus> z" by simp
qed

text \<open>\noindent Any \<open>group\<close> is also a \<open>monoid\<close>; this
can be made explicit by claiming an additional subclass relation,
together with a proof of the logical difference:\<close>

instance group \<subseteq> monoid
proof
  fix x
  from invl have "\<div> x \<oplus> x = \<zero>" .
  then have "\<div> x \<oplus> (x \<oplus> \<zero>) = \<div> x \<oplus> x"
    by (simp add: neutl invl assoc [symmetric])
  then show "x \<oplus> \<zero> = x" by (simp add: left_cancel)
qed

text \<open>\noindent The proof result is propagated to the type system,
making \<open>group\<close> an instance of \<open>monoid\<close> by adding an
additional edge to the graph of subclass relation; see also
Figure~\ref{fig:subclass}.

\begin{figure}[htbp]
 \begin{center}
   \small
   \unitlength 0.6mm
   \begin{picture}(40,60)(0,0)
     \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
     \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
     \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
     \put(40,00){\makebox(0,0){\<open>group\<close>}}
     \put(20,55){\vector(0,-1){10}}
     \put(15,35){\vector(-1,-1){10}}
     \put(25,35){\vector(1,-3){10}}
   \end{picture}
   \hspace{8em}
   \begin{picture}(40,60)(0,0)
     \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
     \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
     \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
     \put(40,00){\makebox(0,0){\<open>group\<close>}}
     \put(20,55){\vector(0,-1){10}}
     \put(15,35){\vector(-1,-1){10}}
     \put(05,15){\vector(3,-1){30}}
   \end{picture}
   \caption{Subclass relationship of monoids and groups:
      before and after establishing the relationship
      \<open>group \<subseteq> monoid\<close>;  transitive edges are left out.}
   \label{fig:subclass}
 \end{center}
\end{figure}
\<close>

subsubsection \<open>Inconsistencies\<close>

text \<open>The reader may be wondering what happens if we attach an
inconsistent set of axioms to a class. So far we have always avoided
to add new axioms to HOL for fear of inconsistencies and suddenly it
seems that we are throwing all caution to the wind. So why is there no
problem?

The point is that by construction, all type variables in the axioms of
a \isacommand{class} are automatically constrained with the class
being defined (as shown for axiom @{thm[source]refl} above). These
constraints are always carried around and Isabelle takes care that
they are never lost, unless the type variable is instantiated with a
type that has been shown to belong to that class. Thus you may be able
to prove \<^prop>\<open>False\<close> from your axioms, but Isabelle will remind you
that this theorem has the hidden hypothesis that the class is
non-empty.

Even if each individual class is consistent, intersections of
(unrelated) classes readily become inconsistent in practice. Now we
know this need not worry us.\<close>

subsubsection\<open>Syntactic Classes and Predefined Overloading\<close>

text \<open>In our algebra example, we have started with a \emph{syntactic
class} \<^class>\<open>plus\<close> which only specifies operations but no axioms; it
would have been also possible to start immediately with class \<^class>\<open>semigroup\<close>, specifying the \<open>\<oplus>\<close> operation and associativity at
the same time.

Which approach is more appropriate depends.  Usually it is more
convenient to introduce operations and axioms in the same class: then
the type checker will automatically insert the corresponding class
constraints whenever the operations occur, reducing the need of manual
annotations.  However, when operations are decorated with popular
syntax, syntactic classes can be an option to re-use the syntax in
different contexts; this is indeed the way most overloaded constants
in HOL are introduced, of which the most important are listed in
Table~\ref{tab:overloading} in the appendix.  Section
\ref{sec:numeric-classes} covers a range of corresponding classes
\emph{with} axioms.

Further note that classes may contain axioms but \emph{no} operations.
An example is class \<^class>\<open>finite\<close> from theory \<^theory>\<open>HOL.Finite_Set\<close>
which specifies a type to be finite: @{lemma [source] "finite (UNIV :: 'a::finite
set)" by (fact finite_UNIV)}.\<close>

(*<*)end(*>*)


(*  Title:      HOL/Old_Number_Theory/Factorization.thy
    Author:     Thomas Marthedal Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Fundamental Theorem of Arithmetic (unique factorization into primes) *}

theory Factorization
imports Primes "~~/src/HOL/Library/Permutation"
begin

subsection {* Definitions *}

definition primel :: "nat list => bool"
  where "primel xs = (\<forall>p \<in> set xs. prime p)"

primrec nondec :: "nat list => bool"
where
  "nondec [] = True"
| "nondec (x # xs) = (case xs of [] => True | y # ys => x \<le> y \<and> nondec xs)"

primrec prod :: "nat list => nat"
where
  "prod [] = Suc 0"
| "prod (x # xs) = x * prod xs"

primrec oinsert :: "nat => nat list => nat list"
where
  "oinsert x [] = [x]"
| "oinsert x (y # ys) = (if x \<le> y then x # y # ys else y # oinsert x ys)"

primrec sort :: "nat list => nat list"
where
  "sort [] = []"
| "sort (x # xs) = oinsert x (sort xs)"

subsection {* Arithmetic *}

lemma one_less_m: "(m::nat) \<noteq> m * k ==> m \<noteq> Suc 0 ==> Suc 0 < m"
  apply (cases m)
   apply auto
  done

lemma one_less_k: "(m::nat) \<noteq> m * k ==> Suc 0 < m * k ==> Suc 0 < k"
  apply (cases k)
   apply auto
  done

lemma mult_left_cancel: "(0::nat) < k ==> k * n = k * m ==> n = m"
  apply auto
  done

lemma mn_eq_m_one: "(0::nat) < m ==> m * n = m ==> n = Suc 0"
  apply (cases n)
   apply auto
  done

lemma prod_mn_less_k:
    "(0::nat) < n ==> 0 < k ==> Suc 0 < m ==> m * n = k ==> n < k"
  apply (induct m)
   apply auto
  done

subsection {* Prime list and product *}

lemma prod_append: "prod (xs @ ys) = prod xs * prod ys"
  apply (induct xs)
   apply (simp_all add: mult.assoc)
  done

lemma prod_xy_prod:
    "prod (x # xs) = prod (y # ys) ==> x * prod xs = y * prod ys"
  apply auto
  done

lemma primel_append: "primel (xs @ ys) = (primel xs \<and> primel ys)"
  apply (unfold primel_def)
  apply auto
  done

lemma prime_primel: "prime n ==> primel [n] \<and> prod [n] = n"
  apply (unfold primel_def)
  apply auto
  done

lemma prime_nd_one: "prime p ==> \<not> p dvd Suc 0"
  apply (unfold prime_def dvd_def)
  apply auto
  done

lemma hd_dvd_prod: "prod (x # xs) = prod ys ==> x dvd (prod ys)"
  by (metis dvd_mult_left dvd_refl prod.simps(2))

lemma primel_tl: "primel (x # xs) ==> primel xs"
  apply (unfold primel_def)
  apply auto
  done

lemma primel_hd_tl: "(primel (x # xs)) = (prime x \<and> primel xs)"
  apply (unfold primel_def)
  apply auto
  done

lemma primes_eq: "prime p ==> prime q ==> p dvd q ==> p = q"
  apply (unfold prime_def)
  apply auto
  done

lemma primel_one_empty: "primel xs ==> prod xs = Suc 0 ==> xs = []"
  apply (cases xs)
   apply (simp_all add: primel_def prime_def)
  done

lemma prime_g_one: "prime p ==> Suc 0 < p"
  apply (unfold prime_def)
  apply auto
  done

lemma prime_g_zero: "prime p ==> 0 < p"
  apply (unfold prime_def)
  apply auto
  done

lemma primel_nempty_g_one:
    "primel xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> Suc 0 < prod xs"
  apply (induct xs)
   apply simp
  apply (fastforce simp: primel_def prime_def elim: one_less_mult)
  done

lemma primel_prod_gz: "primel xs ==> 0 < prod xs"
  apply (induct xs)
   apply (auto simp: primel_def prime_def)
  done

subsection {* Sorting *}

lemma nondec_oinsert: "nondec xs \<Longrightarrow> nondec (oinsert x xs)"
  apply (induct xs)
   apply simp
   apply (case_tac xs)
    apply (simp_all cong del: list.case_cong_weak)
  done

lemma nondec_sort: "nondec (sort xs)"
  apply (induct xs)
   apply simp_all
  apply (erule nondec_oinsert)
  done

lemma x_less_y_oinsert: "x \<le> y ==> l = y # ys ==> x # l = oinsert x l"
  apply simp_all
  done

lemma nondec_sort_eq [rule_format]: "nondec xs \<longrightarrow> xs = sort xs"
  apply (induct xs)
   apply safe
    apply simp_all
   apply (case_tac xs)
    apply simp_all
  apply (case_tac xs)
   apply simp
  apply (rule_tac y = aa and ys = list in x_less_y_oinsert)
   apply simp_all
  done

lemma oinsert_x_y: "oinsert x (oinsert y l) = oinsert y (oinsert x l)"
  apply (induct l)
  apply auto
  done

subsection {* Permutation *}

lemma perm_primel [rule_format]: "xs <~~> ys ==> primel xs --> primel ys"
  apply (unfold primel_def)
  apply (induct set: perm)
     apply simp
    apply simp
   apply (simp (no_asm))
   apply blast
  apply blast
  done

lemma perm_prod: "xs <~~> ys ==> prod xs = prod ys"
  apply (induct set: perm)
     apply (simp_all add: ac_simps)
  done

lemma perm_subst_oinsert: "xs <~~> ys ==> oinsert a xs <~~> oinsert a ys"
  apply (induct set: perm)
     apply auto
  done

lemma perm_oinsert: "x # xs <~~> oinsert x xs"
  apply (induct xs)
   apply auto
  done

lemma perm_sort: "xs <~~> sort xs"
  apply (induct xs)
  apply (auto intro: perm_oinsert elim: perm_subst_oinsert)
  done

lemma perm_sort_eq: "xs <~~> ys ==> sort xs = sort ys"
  apply (induct set: perm)
     apply (simp_all add: oinsert_x_y)
  done

subsection {* Existence *}

lemma ex_nondec_lemma:
    "primel xs ==> \<exists>ys. primel ys \<and> nondec ys \<and> prod ys = prod xs"
  apply (blast intro: nondec_sort perm_prod perm_primel perm_sort perm_sym)
  done

lemma not_prime_ex_mk:
  "Suc 0 < n \<and> \<not> prime n ==>
    \<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k"
  apply (unfold prime_def dvd_def)
  apply (auto intro: n_less_m_mult_n n_less_n_mult_m one_less_m one_less_k)
  done

lemma split_primel:
  "primel xs \<Longrightarrow> primel ys \<Longrightarrow> \<exists>l. primel l \<and> prod l = prod xs * prod ys"
  apply (rule exI)
  apply safe
   apply (rule_tac [2] prod_append)
  apply (simp add: primel_append)
  done

lemma factor_exists [rule_format]: "Suc 0 < n --> (\<exists>l. primel l \<and> prod l = n)"
  apply (induct n rule: nat_less_induct)
  apply (rule impI)
  apply (case_tac "prime n")
   apply (rule exI)
   apply (erule prime_primel)
  apply (cut_tac n = n in not_prime_ex_mk)
   apply (auto intro!: split_primel)
  done

lemma nondec_factor_exists: "Suc 0 < n ==> \<exists>l. primel l \<and> nondec l \<and> prod l = n"
  apply (erule factor_exists [THEN exE])
  apply (blast intro!: ex_nondec_lemma)
  done

subsection {* Uniqueness *}

lemma prime_dvd_mult_list [rule_format]:
    "prime p ==> p dvd (prod xs) --> (\<exists>m. m:set xs \<and> p dvd m)"
  apply (induct xs)
   apply (force simp add: prime_def)
   apply (force dest: prime_dvd_mult)
  done

lemma hd_xs_dvd_prod:
  "primel (x # xs) ==> primel ys ==> prod (x # xs) = prod ys
    ==> \<exists>m. m \<in> set ys \<and> x dvd m"
  apply (rule prime_dvd_mult_list)
   apply (simp add: primel_hd_tl)
  apply (erule hd_dvd_prod)
  done

lemma prime_dvd_eq: "primel (x # xs) ==> primel ys ==> m \<in> set ys ==> x dvd m ==> x = m"
  apply (rule primes_eq)
    apply (auto simp add: primel_def primel_hd_tl)
  done

lemma hd_xs_eq_prod:
  "primel (x # xs) ==>
    primel ys ==> prod (x # xs) = prod ys ==> x \<in> set ys"
  apply (frule hd_xs_dvd_prod)
    apply auto
  apply (drule prime_dvd_eq)
     apply auto
  done

lemma perm_primel_ex:
  "primel (x # xs) ==>
    primel ys ==> prod (x # xs) = prod ys ==> \<exists>l. ys <~~> (x # l)"
  apply (rule exI)
  apply (rule perm_remove)
  apply (erule hd_xs_eq_prod)
   apply simp_all
  done

lemma primel_prod_less:
  "primel (x # xs) ==>
    primel ys ==> prod (x # xs) = prod ys ==> prod xs < prod ys"
  by (metis less_asym linorder_neqE_nat mult_less_cancel2 nat_0_less_mult_iff
    nat_less_le nat_mult_1 prime_def primel_hd_tl primel_prod_gz prod.simps(2))

lemma prod_one_empty:
    "primel xs ==> p * prod xs = p ==> prime p ==> xs = []"
  apply (auto intro: primel_one_empty simp add: prime_def)
  done

lemma uniq_ex_aux:
  "\<forall>m. m < prod ys --> (\<forall>xs ys. primel xs \<and> primel ys \<and>
      prod xs = prod ys \<and> prod xs = m --> xs <~~> ys) ==>
    primel list ==> primel x ==> prod list = prod x ==> prod x < prod ys
    ==> x <~~> list"
  apply simp
  done

lemma factor_unique [rule_format]:
  "\<forall>xs ys. primel xs \<and> primel ys \<and> prod xs = prod ys \<and> prod xs = n
    --> xs <~~> ys"
  apply (induct n rule: nat_less_induct)
  apply safe
  apply (case_tac xs)
   apply (force intro: primel_one_empty)
  apply (rule perm_primel_ex [THEN exE])
     apply simp_all
  apply (rule perm.trans [THEN perm_sym])
  apply assumption
  apply (rule perm.Cons)
  apply (case_tac "x = []")
   apply (metis perm_prod perm_refl prime_primel primel_hd_tl primel_tl prod_one_empty)
  apply (metis nat_0_less_mult_iff nat_mult_eq_cancel1 perm_primel perm_prod primel_prod_gz primel_prod_less primel_tl prod.simps(2))
  done

lemma perm_nondec_unique:
    "xs <~~> ys ==> nondec xs ==> nondec ys ==> xs = ys"
  by (metis nondec_sort_eq perm_sort_eq)

theorem unique_prime_factorization [rule_format]:
    "\<forall>n. Suc 0 < n --> (\<exists>!l. primel l \<and> nondec l \<and> prod l = n)"
  by (metis factor_unique nondec_factor_exists perm_nondec_unique)

end


theory T106
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory int_add_ident_right
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Zero | Succ "Nat"

datatype Z = P "Nat" | N "Nat"

fun zero :: "Z" where
"zero = P Zero"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Zero) y = y"
| "plus2 (Succ n) y = Succ (plus2 n y)"

fun minus :: "Nat => Nat => Z" where
"minus (Zero) (Zero) = P Zero"
| "minus (Zero) (Succ n) = N n"
| "minus (Succ m) (Zero) = P (Succ m)"
| "minus (Succ m) (Succ o) = minus m o"

fun plus :: "Z => Z => Z" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o) = minus m (Succ o)"
| "plus (N m2) (P n2) = minus n2 (Succ m2)"
| "plus (N m2) (N n3) = N (Succ (plus2 m2 n3))"

(*hipster zero plus2 minus plus *)

theorem x0 :
  "!! (x :: Z) . x = (plus x zero)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Nameless_Representation_Of_Terms
imports Main
begin
(*>*)

section {* Nameless Representation of Terms *}
text {* \label{sec:nameless-rep-of-terms} *}

text {*
In the background section on $\lambda$-calculus (Section~\ref{sec:background-lambda-calculus}), we
presented the problem of name clashes that can arise when performing $\beta$-reduction. In its
definitions and proofs, the book only works up to $\alpha$-equivalence: assuming that the variables
would be implicitly renamed if such a name clash occurred. In a separate chapter, a different
representation of terms that avoids such problem is presented. It is described as one possible
encoding that can be used when implementing an compiler for the $\lambda$-calculus.

Even though we are not building a compiler, our computer-verified formalization requires us to
explicitly handle this problem. We chose to use this representation and, thus must also formalize
this chapter.

The idea behind this representation, known as de Bruijn indices, is to make variables reference
directly their corresponding binder, rather than referring to them by name. This is accomplished by
using an index that count the number of enclosing $\lambda$-abstractions between a variable and its
binder. Following is an example of de Bruijn indices representation for the function composition
combinator:
\begin{displaymath}
  \lambda f. \ \lambda g. \ \lambda x. \ f \ (g \ x)
    \equiv \lambda \ \lambda \ \lambda \ 2 \ (1 \ 0)
\end{displaymath}

This representation releases us from having to consider the case of variable name clashes at the
expense of being harder to read and having to maintain the correct indices when adding and removing
$\lambda$-abstractions. Using this representation, we define the syntax of the untyped lambda
calculus as follow:\footnote{The prefix \emph{ul} stands for \emph{untyped lambda-calculus}.}
*}

datatype ulterm =
  ULVar nat |
  ULAbs ulterm |
  ULApp ulterm ulterm

text {*
Using this syntax, the same example of the function composition combinator looks like this:

\begin{center}
  \small
  @{term "ULAbs (ULAbs (ULAbs (ULApp (ULVar 2) (ULApp (ULVar 1) (ULVar 0)))))"}
\end{center}
*}
(*<*)
(* Definition 6.1.2 *)

inductive n_term :: "nat \<Rightarrow> ulterm \<Rightarrow> bool" where
  n_term_ULVar: "0 \<le> k \<Longrightarrow> k < n \<Longrightarrow> n_term n (ULVar k)" |
  n_term_ULAbs: "n_term n t \<Longrightarrow> n > 0 \<Longrightarrow> n_term (n - 1) (ULAbs t)" |
  n_term_ULApp: "n_term n t1 \<Longrightarrow> n_term n t2 \<Longrightarrow> n_term n (ULApp t1 t2)"

(* Definition 6.2.1 *)
(*>*)
text {*
We define a shift function serving to increase or decrease, by a fix amount @{term d}, all indices
larger than @{term c} in a term:
*}

primrec shift_UL :: "int \<Rightarrow> nat \<Rightarrow> ulterm \<Rightarrow> ulterm" where
  "shift_UL d c (ULVar k) = ULVar (if k < c then k else nat (int k + d))" |
  "shift_UL d c (ULAbs t) = ULAbs (shift_UL d (Suc c) t)" |
  "shift_UL d c (ULApp t1 t2) = ULApp (shift_UL d c t1) (shift_UL d c t2)"

text {*
In this definition, there is a possible information loss. The variables use a
natural number as index but the function allows to shift both up and down, thus the use of an
integer for the shift increment. When a variable is encountered, we first convert the index from
natural number to integer, which is always safe, perform the integer addition, which correspond to a
subtraction if @{term d} is negative, and convert the result back to natural numbers to serve as the
new index. This last operation converts negative numbers to zero. We know that this loss of
information is safe, since it makes no sense to speak of negative indices. Our @{const shift_UL}
function thus has an implicit assumption that it should not be called with a negative number larger
than the smallest free variable in the term. Following is an example of shifting up every free
variable by 2:
*}

(* Exercise 6.2.2 *)

lemma "shift_UL 2 0
  (ULAbs (ULAbs (ULApp (ULVar 1) (ULApp (ULVar 0) (ULVar 2))))) =
   ULAbs (ULAbs (ULApp (ULVar 1) (ULApp (ULVar 0) (ULVar 4))))"
  by simp

text {*
On a first reading, the previous example may seems broken: the variables @{term "ULVar 0"} and
@{term "ULVar 1"} are not incremented. This is because the shift function operates on free
variables, i.e. variables whose index refers to a non-existing $\lambda$-abstraction. Since the
binding referred by @{term "ULVar 1"} is in the term, it is not a free variable: it is bound.
*}
(*<*)

lemma "shift_UL 2 0
  (ULAbs (ULApp (ULVar 0) (ULApp (ULVar 1) (ULAbs (ULApp (ULVar 0) (ULApp (ULVar 1) (ULVar 2))))))) =
   ULAbs (ULApp (ULVar 0) (ULApp (ULVar 3) (ULAbs (ULApp (ULVar 0) (ULApp (ULVar 1) (ULVar 4))))))"
  by simp

(* Exercise 6.2.3 *)

lemma "n_term n t \<Longrightarrow> n_term (n + nat d) (shift_UL d c t)"
proof (induction n t arbitrary: d c rule: n_term.induct)
  case (n_term_ULVar k n)
  thus ?case by (auto intro: n_term.intros)
next
  case (n_term_ULAbs n t)
  thus ?case
    using n_term.n_term_ULAbs by (auto)
next
  case (n_term_ULApp n t1 t2)
  thus ?case by (auto intro: n_term.intros)
qed

(*>*)
text {*
We now define a substitution function that replaces every free variable with index @{term j} by
the term @{term s}:
\newpage
*}
(* Definition 6.2.4 *)

primrec subst_UL :: "nat \<Rightarrow> ulterm \<Rightarrow> ulterm \<Rightarrow> ulterm" where
  "subst_UL j s (ULVar k) = (if k = j then s else ULVar k)" |
  "subst_UL j s (ULAbs t) = ULAbs (subst_UL (Suc j) (shift_UL 1 0 s) t)" |
  "subst_UL j s (ULApp t1 t2) = ULApp (subst_UL j s t1) (subst_UL j s t2)"

(* Exercise 6.2.5 *)

text {*
Here is an example of substituting the variable 0 by the variable 1:
*}

lemma "subst_UL 0 (ULVar 1)
  (ULApp (ULVar 0) (ULAbs (ULAbs (ULVar 2)))) =
   ULApp (ULVar 1) (ULAbs (ULAbs (ULVar 3)))"
  by simp

text {*
Note that the indices are relative to their position in the term. This is why @{term "ULVar 2"} is
also substituted in the previous example: counting the number of enclosing $\lambda$-abstractions
shows us that this variable is, indeed, the same as @{term "ULVar 0"} outside the
$\lambda$-abstractions. Of course, we must maintain this invariant by incrementing variables in our
substituting term accordingly.
*}

(*<*)
lemma "subst_UL 0 (ULApp (ULVar 1) (ULAbs (ULVar 2)))
  (ULApp (ULVar 0) (ULAbs (ULVar 1))) =
   ULApp (ULApp (ULVar 1) (ULAbs (ULVar 2))) (ULAbs (ULApp (ULVar 2) (ULAbs (ULVar 3))))"
  by simp

lemma "subst_UL 0 (ULVar 1)
  (ULAbs (ULApp (ULVar 0) (ULVar 2))) =
   ULAbs (ULApp (ULVar 0) (ULVar 2))"
  by simp

lemma "subst_UL 0 (ULVar 1)
  (ULAbs (ULApp (ULVar 1) (ULVar 0))) =
   ULAbs (ULApp (ULVar 2) (ULVar 0))"
  by simp

(* Exercise 6.2.6 *)

lemma n_term_shift_UL: "n_term n t \<Longrightarrow> n_term (n + nat j) (shift_UL j i t)"
  by (induction n t arbitrary: j i rule: n_term.induct)
    (auto intro: n_term.intros n_term_ULAbs[unfolded One_nat_def])

(* updated
   changes: only Abstraction case left, other cases follow by auto
*)
lemma "n_term n t \<Longrightarrow> n_term n s \<Longrightarrow> j \<le> n \<Longrightarrow> n_term n (subst_UL j s t)"
proof (induction n t arbitrary: s j rule: n_term.induct)
  case (n_term_ULAbs n t)
  thus ?case
   (*
      other proof (possible with ver. 2016)
      by (smt Groups.add_ac(2) Nat.le_diff_conv2 One_nat_def Suc_leI add.right_neutral add_Suc_right
        add_diff_inverse_nat linorder_not_less n_term.intros(2) n_term_shift_UL
        subst_UL.simps(2) transfer_nat_int_numerals(2))
   *)
      using n_term.intros n_term_shift_UL[OF n_term_ULAbs.prems(1), where j = 1]
      by (auto
        intro: n_term_ULAbs.IH
        intro!: n_term.n_term_ULAbs[unfolded One_nat_def]
        simp: n_term_shift_UL[OF n_term_ULAbs.prems(1), where j = 1])

qed (auto intro: n_term.intros)

end
(*>*)