theory SINVAR_Dependability
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Dependability *}

type_synonym dependability_level = nat

definition default_node_properties :: "dependability_level"
  where  "default_node_properties \<equiv> 0"

text {* Less-equal other nodes depend on the output of a node than its dependability level. *}
fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (num_reachable G e1) \<le> (nP e1))"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

text{* It does not matter whether we iterate over all edges or all nodes. We chose all edges because it is in line with the other models.  *}
  fun sinvar_nodes :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
    "sinvar_nodes G nP = (\<forall> v \<in> nodes G. (num_reachable G v) \<le> (nP v))"

  theorem sinvar_edges_nodes_iff: "wf_graph G \<Longrightarrow>
    sinvar_nodes G nP = sinvar G nP"
  proof(unfold sinvar_nodes.simps sinvar.simps, rule iffI)
    assume a1: "wf_graph G"
      and  a2: "\<forall>v\<in>nodes G. num_reachable G v \<le> nP v"

      from a1[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
      from f1 a2 have "\<forall>v \<in> (fst ` edges G). num_reachable G v \<le> nP v" by auto

      thus "\<forall>(e1, _) \<in> edges G. num_reachable G e1 \<le> nP e1" by auto
    next
    assume a1: "wf_graph G"
      and  a2: "\<forall>(e1, _)\<in>edges G. num_reachable G e1 \<le> nP e1"

      from a2 have g1: "\<forall> v \<in> (fst ` edges G). num_reachable G v \<le> nP v" by auto

      from FiniteGraph.succ_tran_empty[OF a1] num_reachable_zero_iff[OF a1, symmetric]
      have g2: "\<forall> v. v \<notin> (fst ` edges G) \<longrightarrow> num_reachable G v \<le> nP v" by (metis le0)

      from g1 g2 show "\<forall>v\<in>nodes G. num_reachable G v \<le> nP v" by metis
  qed

  lemma num_reachable_le_nodes: "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow> num_reachable G v \<le> card (nodes G)"
    unfolding num_reachable_def
    using succ_tran_subseteq_nodes card_seteq nat_le_linear wf_graph.finiteV by metis

  text{* nP is valid if all dependability level are greater equal the total number of nodes in the graph *}
  lemma "\<lbrakk> wf_graph G; \<forall>v \<in> nodes G. nP v \<ge> card (nodes G) \<rbrakk> \<Longrightarrow> sinvar G nP"
    apply(subst sinvar_edges_nodes_iff[symmetric], simp)
    apply(simp add:)
    using num_reachable_le_nodes by (metis le_trans)

  text{* Generate a valid configuration to start from: *}
   text{* Takes arbitrary configuration, returns a valid one *}
   fun dependability_fix_nP :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<Rightarrow> dependability_level)" where
      "dependability_fix_nP G nP = (\<lambda>v. if num_reachable G v \<le> (nP v) then (nP v) else num_reachable G v)"

   text{* @{const dependability_fix_nP} always gives you a valid solution *}
   lemma dependability_fix_nP_valid: "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow> sinvar G (dependability_fix_nP G nP)"
      by(subst sinvar_edges_nodes_iff[symmetric], simp_all)

   text{* furthermore, it gives you a minimal solution, i.e. if someone supplies a configuration with a value lower than
          calculated by @{const dependability_fix_nP}, this is invalid! *}
   lemma dependability_fix_nP_minimal_solution: "\<lbrakk> wf_graph G; \<exists> v \<in> nodes G. (nP v) < (dependability_fix_nP G (\<lambda>_. 0)) v \<rbrakk> \<Longrightarrow> \<not> sinvar G nP"
      apply(subst sinvar_edges_nodes_iff[symmetric], simp)
      apply(simp)
      apply(clarify)
      apply(rule_tac x="v" in bexI)
       apply(simp_all)
      done

(*
lemma card_less_equal_trancl: "finite A \<Longrightarrow> card {e2. (aa, e2) \<in> (A - X)\<^sup>+} \<le> card {e2. (aa, e2) \<in> (A)\<^sup>+}"
apply(subgoal_tac "{e2. (aa, e2) \<in> (A - X)\<^sup>+} \<subseteq> {e2. (aa, e2) \<in> (A)\<^sup>+}")
apply(rule card_mono)
defer
apply(simp)
apply (metis (lifting) Collect_mono Diff_subset trancl_mono)
by (metis (lifting) Range_iff finite_Range mem_Collect_eq rev_finite_subset subsetI trancl_range)
*)

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
done

interpretation Dependability: SecurityInvariant_ACS
where default_node_properties = SINVAR_Dependability.default_node_properties
and sinvar = SINVAR_Dependability.sinvar
  unfolding SINVAR_Dependability.default_node_properties_def
  proof
    fix G::"'a graph" and f nP
    assume "wf_graph G" and "f \<in> set_offending_flows G nP"
    thus "\<forall>i\<in>fst ` f. \<not> sinvar G (nP(i := 0))"
     apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
     apply (simp split: prod.split_asm prod.split)
     apply (simp add:graph_ops)
     apply(clarify)
     apply (metis gr0I le0)
     done
  next
   fix otherbot
   assume assm: "\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst ` f \<longrightarrow> \<not> sinvar G (nP(i := otherbot))"
   have unique_default_example_succ_tran:
    "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
    using unique_default_example1 by blast
   from assm show "otherbot = 0"
    apply -
    apply(elim default_uniqueness_by_counterexample_ACS)
    apply(simp)
    apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
        SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
        SecurityInvariant_withOffendingFlows.is_offending_flows_def)
    apply (simp add:graph_ops)
    apply (simp split: prod.split_asm prod.split)
    apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
    apply(rule conjI)
     apply(simp add: wf_graph_def)
    apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 0, vertex_2 := 0)" in exI, simp)
    apply(rule conjI)
     apply(simp add: unique_default_example_succ_tran num_reachable_def)
    apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
    apply(simp add: unique_default_example_succ_tran num_reachable_def)
    apply(simp add: succ_tran_def unique_default_example_simp1 unique_default_example_simp2)
    done
  qed

  lemma TopoS_Dependability: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation default_node_properties

end


(*  Title:      The Jordan-Hölder Theorem
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory JordanHolder
imports
  CompositionSeries
  MaximalNormalSubgroups
  "HOL-Library.Multiset"
  GroupIsoClasses
begin

section \<open>The Jordan-H\"older Theorem\<close>

locale jordan_hoelder = group
  + comp\<HH>?: composition_series G \<HH>
  + comp\<GG>?: composition_series G \<GG> for \<HH> and \<GG>
  + assumes finite: "finite (carrier G)"

text \<open>Before we finally start the actual proof of the theorem, one last lemma: Cancelling
  the last entry of a normal series results in a normal series with quotients being all but the last
  of the original ones.\<close>

lemma (in normal_series) quotients_butlast:
  assumes "length \<GG> > 1"
  shows "butlast quotients = normal_series.quotients (G\<lparr>carrier := \<GG> ! (length \<GG> - 1 - 1)\<rparr>) (take (length \<GG> - 1) \<GG>)"
proof (rule nth_equalityI )
  define n where "n = length \<GG> - 1"
  hence "n = length (take n \<GG>)" "n > 0" "n < length \<GG>" using assms notempty by auto
  interpret normal\<GG>butlast: normal_series "(G\<lparr>carrier := \<GG> ! (n - 1)\<rparr>)" "take n \<GG>"
    using normal_series_prefix_closed \<open>n > 0\<close> \<open>n < length \<GG>\<close> by auto
  have "length (butlast quotients) = length quotients - 1" by (metis length_butlast)
  also have "\<dots> = length \<GG> - 1 - 1" by (metis add_diff_cancel_right' quotients_length)
  also have "\<dots> = length (take n \<GG>) - 1" by (metis \<open>n = length (take n \<GG>)\<close> n_def)
  also have "\<dots> = length normal\<GG>butlast.quotients" by (metis normal\<GG>butlast.quotients_length diff_add_inverse2)
  finally show "length (butlast quotients) = length normal\<GG>butlast.quotients" .
  have "\<forall>i<length (butlast quotients). butlast quotients ! i = normal\<GG>butlast.quotients ! i"
  proof auto
    fix i
    assume i: "i < length quotients - Suc 0"
    hence i': "i < length \<GG> - 1" "i < n" "i + 1 < n" unfolding n_def using quotients_length by auto
    from i have "butlast quotients ! i = quotients ! i" by (metis One_nat_def length_butlast nth_butlast)
    also have "\<dots> = G\<lparr>carrier := \<GG> ! (i + 1)\<rparr> Mod \<GG> ! i" unfolding quotients_def using i'(1) by auto
    also have "\<dots> = G\<lparr>carrier := (take n \<GG>) ! (i + 1)\<rparr> Mod (take n \<GG>) ! i" using i'(2,3) nth_take by metis
    also have "\<dots> = normal\<GG>butlast.quotients ! i" unfolding normal\<GG>butlast.quotients_def using i' by fastforce
    finally show "butlast (normal_series.quotients G \<GG>) ! i = normal_series.quotients (G\<lparr>carrier := \<GG> ! (n - Suc 0)\<rparr>) (take n \<GG>) ! i" by auto
  qed
  thus "\<And>i. i < length (butlast quotients)
            \<Longrightarrow> butlast quotients ! i
              = normal_series.quotients (G\<lparr>carrier := \<GG> ! (length \<GG> - 1 - 1)\<rparr>)  (take (length \<GG> - 1) \<GG>) ! i"
    unfolding n_def by auto
qed

text \<open>The main part of the Jordan Hölder theorem is its statement about the uniqueness of
  a composition series. Here, uniqueness up to reordering and isomorphism is modelled by stating
  that the multisets of isomorphism classes of all quotients are equal.\<close>

theorem jordan_hoelder_multisets:
  assumes "group G"
  assumes "finite (carrier G)"
  assumes "composition_series G \<GG>"
  assumes "composition_series G \<HH>"
  shows "mset (map group.iso_class (normal_series.quotients G \<GG>))
    = mset (map group.iso_class (normal_series.quotients G \<HH>))"
using assms
proof (induction "length \<GG>" arbitrary: \<GG> \<HH> G rule: full_nat_induct)
  case (1 \<GG> \<HH> G)
  then interpret comp\<GG>: composition_series G \<GG> by simp
  from 1 interpret comp\<HH>: composition_series G \<HH> by simp
  from 1 interpret grpG: group G by simp
  show ?case
  proof (cases "length \<GG> \<le> 2")
  next
    case True
    hence  "length \<GG> = 0 \<or> length \<GG> = 1 \<or> length \<GG> = 2" by arith
    with comp\<GG>.notempty have  "length \<GG> = 1 \<or> length \<GG> = 2" by simp
    thus ?thesis
    proof (auto simp del: mset_map)
      \<comment> \<open>First trivial case: @{text \<GG>} is the trivial group.\<close>
      assume "length \<GG> = Suc 0"
      hence length: "length \<GG> = 1" by simp
      hence "length [] + 1 = length \<GG>" by auto
      moreover from length have char\<GG>: "\<GG> = [{\<one>\<^bsub>G\<^esub>}]" by (metis comp\<GG>.composition_series_length_one)
      hence "carrier G = {\<one>\<^bsub>G\<^esub>}" by (metis comp\<GG>.composition_series_triv_group)
      with length char\<GG> have "\<GG> = \<HH>" using comp\<HH>.composition_series_triv_group by simp
      thus ?thesis by simp
    next
      \<comment> \<open>Second trivial case: @{text \<GG>} is simple.\<close>
      assume "length \<GG> = 2"
      hence \<GG>char: "\<GG> = [{\<one>\<^bsub>G\<^esub>}, carrier G]" by (metis comp\<GG>.length_two_unique)
      hence simple: "simple_group G" by (metis comp\<GG>.composition_series_simple_group)
      hence "\<HH> = [{\<one>\<^bsub>G\<^esub>}, carrier G]" using comp\<HH>.composition_series_simple_group by auto
      with \<GG>char have "\<GG> = \<HH>" by simp
      thus ?thesis by simp
    qed
  next
    case False
    \<comment> \<open>Non-trivial case: @{text \<GG>} has length at least 3.\<close>
    hence length: "length \<GG> \<ge> 3" by simp
    \<comment> \<open>First we show that @{text \<HH>} must have a length of at least 3.\<close>
    hence "\<not> simple_group G" using comp\<GG>.composition_series_simple_group by auto
    hence "\<HH> \<noteq> [{\<one>\<^bsub>G\<^esub>}, carrier G]" using comp\<HH>.composition_series_simple_group by auto
    hence "length \<HH> \<noteq> 2" using comp\<HH>.length_two_unique by auto
    moreover from length have "carrier G \<noteq> {\<one>\<^bsub>G\<^esub>}" using comp\<GG>.composition_series_length_one comp\<GG>.composition_series_triv_group by auto
    hence "length \<HH> \<noteq> 1" using comp\<HH>.composition_series_length_one comp\<HH>.composition_series_triv_group by auto
    moreover from comp\<HH>.notempty have "length \<HH> \<noteq> 0" by simp
    ultimately have length\<HH>big: "length \<HH> \<ge> 3" using comp\<HH>.notempty by arith
    define m where "m = length \<HH> - 1"
    define n where "n = length \<GG> - 1"
    from length\<HH>big have m': "m > 0" "m < length \<HH>" "(m - 1) + 1 < length \<HH>" "m - 1 = length \<HH> - 2" "m - 1 + 1 = length \<HH> - 1" "m - 1 < length \<HH>"
      unfolding m_def by auto
    from length have n': "n > 0" "n < length \<GG>" "(n - 1) + 1 < length \<GG>" "n - 1 < length \<GG>" "Suc n \<le> length \<GG>"
     "n - 1 = length \<GG> - 2" "n - 1 + 1 = length \<GG> - 1"  unfolding n_def by auto
    define \<GG>Pn where "\<GG>Pn = G\<lparr>carrier := \<GG> ! (n - 1)\<rparr>"
    define \<HH>Pm where "\<HH>Pm = G\<lparr>carrier := \<HH> ! (m - 1)\<rparr>"
    then interpret grp\<GG>Pn: group \<GG>Pn unfolding \<GG>Pn_def using n' by (metis comp\<GG>.normal_series_subgroups comp\<GG>.subgroup_imp_group)
    interpret grp\<HH>Pm: group \<HH>Pm unfolding \<HH>Pm_def using m' comp\<HH>.normal_series_subgroups 1(2) group.subgroup_imp_group by force
    have finGbl: "finite (carrier \<GG>Pn)" using \<open>n - 1 < length \<GG>\<close> 1(3) unfolding \<GG>Pn_def using comp\<GG>.normal_series_subgroups comp\<GG>.subgroup_finite by auto
    have finHbl: "finite (carrier \<HH>Pm)" using \<open>m - 1 < length \<HH>\<close> 1(3) unfolding \<HH>Pm_def using comp\<HH>.normal_series_subgroups comp\<GG>.subgroup_finite by auto
    have quots\<GG>notempty: "comp\<GG>.quotients \<noteq> []" using comp\<GG>.quotients_length length by auto
    have quots\<HH>notempty: "comp\<HH>.quotients \<noteq> []" using comp\<HH>.quotients_length length\<HH>big by auto

    \<comment> \<open>Instantiate truncated composition series since they are used for both cases\<close>
    interpret \<HH>butlast: composition_series \<HH>Pm "take m \<HH>" using comp\<HH>.composition_series_prefix_closed m'(1,2) \<HH>Pm_def by auto
    interpret \<GG>butlast: composition_series \<GG>Pn "take n \<GG>" using comp\<GG>.composition_series_prefix_closed n'(1,2) \<GG>Pn_def by auto
    have ltaken: "n = length (take n \<GG>)" using length_take n'(2) by auto
    have ltakem: "m = length (take m \<HH>)" using length_take m'(2) by auto
    show ?thesis
    proof (cases "\<HH> ! (m - 1)  = \<GG> ! (n - 1)")
      \<comment> \<open>If @{term "\<HH> ! (l - 1) = \<GG> ! 1"}, everything is simple...\<close>
      case True
      \<comment> \<open>The last quotients of @{term \<GG>} and @{term \<HH>} are equal.\<close>
      have lasteq: "last comp\<GG>.quotients = last comp\<HH>.quotients"
      proof -
        from length have lg: "length \<GG> - 1 - 1 + 1 = length \<GG> - 1" by (metis Suc_diff_1 Suc_eq_plus1 n'(1) n_def)
        from length\<HH>big have lh: "length \<HH> - 1 - 1 + 1 = length \<HH> - 1" by (metis Suc_diff_1 Suc_eq_plus1 \<open>0 < m\<close> m_def)
        have "last comp\<GG>.quotients =  G Mod \<GG> ! (n - 1)" using length comp\<GG>.last_quotient unfolding n_def by auto
        also have "\<dots> = G Mod \<HH> ! (m - 1)" using True by simp
        also have "\<dots> = last comp\<HH>.quotients" using length\<HH>big comp\<HH>.last_quotient unfolding m_def by auto
        finally show ?thesis .
      qed
      from ltaken have ind: "mset (map group.iso_class \<GG>butlast.quotients) = mset (map group.iso_class \<HH>butlast.quotients)"
        using 1(1) True n'(5) grp\<GG>Pn.is_group finGbl \<GG>butlast.is_composition_series \<HH>butlast.is_composition_series unfolding \<GG>Pn_def \<HH>Pm_def by metis
      have "mset (map group.iso_class comp\<GG>.quotients)
                    = mset (map group.iso_class (butlast comp\<GG>.quotients @ [last comp\<GG>.quotients]))" by (simp add: quots\<GG>notempty)
      also have "\<dots> = mset (map group.iso_class (\<GG>butlast.quotients @ [last (comp\<GG>.quotients)]))" using comp\<GG>.quotients_butlast length unfolding n_def \<GG>Pn_def by auto
      also have "\<dots> = mset ((map group.iso_class \<GG>butlast.quotients) @ [group.iso_class (last (comp\<GG>.quotients))])" by auto
      also have "\<dots> = mset (map group.iso_class \<GG>butlast.quotients) + {# group.iso_class (last (comp\<GG>.quotients)) #}" by auto
      also have "\<dots> = mset (map group.iso_class \<HH>butlast.quotients) + {# group.iso_class (last (comp\<GG>.quotients)) #}" using ind by simp
      also have "\<dots> = mset (map group.iso_class \<HH>butlast.quotients) + {# group.iso_class (last (comp\<HH>.quotients)) #}" using lasteq by simp
      also have "\<dots> = mset ((map group.iso_class \<HH>butlast.quotients) @ [group.iso_class (last (comp\<HH>.quotients))])" by auto
      also have "\<dots> = mset (map group.iso_class (\<HH>butlast.quotients @ [last (comp\<HH>.quotients)]))" by auto
      also have "\<dots> = mset (map group.iso_class (butlast comp\<HH>.quotients @ [last comp\<HH>.quotients]))" using length\<HH>big comp\<HH>.quotients_butlast unfolding m_def \<HH>Pm_def by auto
      also have "\<dots> = mset (map group.iso_class comp\<HH>.quotients)" using append_butlast_last_id quots\<HH>notempty by simp
      finally show ?thesis .
    next
      case False
      define \<HH>PmInt\<GG>Pn where "\<HH>PmInt\<GG>Pn = G\<lparr>carrier := \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)\<rparr>"
      interpret \<GG>Pnmax: max_normal_subgroup "\<GG> ! (n - 1)" G unfolding n_def
        by (metis add_lessD1 diff_diff_add n'(3) add.commute one_add_one 1(3) comp\<GG>.snd_to_last_max_normal)
      interpret \<HH>Pmmax: max_normal_subgroup "\<HH> ! (m - 1)" G unfolding m_def
        by (metis add_lessD1 diff_diff_add m'(3) add.commute one_add_one 1(3) comp\<HH>.snd_to_last_max_normal)
      have \<HH>PmnormG: "\<HH> ! (m - 1) \<lhd> G" using comp\<HH>.normal_series_snd_to_last m'(4) unfolding m_def by auto
      have \<GG>PnnormG: "\<GG> ! (n - 1) \<lhd> G" using comp\<GG>.normal_series_snd_to_last n'(6) unfolding n_def by auto
      have \<HH>Pmint\<GG>PnnormG: "\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) \<lhd> G" using \<HH>PmnormG \<GG>PnnormG by (rule comp\<GG>.normal_subgroup_intersect)
      have Intnorm\<GG>Pn: "\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) \<lhd> \<GG>Pn" using \<GG>PnnormG \<HH>PmnormG Int_lower2 unfolding \<GG>Pn_def
        by (metis comp\<GG>.normal_restrict_supergroup comp\<GG>.normal_series_subgroups comp\<GG>.normal_subgroup_intersect n'(4))
      then interpret grp\<GG>PnMod\<HH>Pmint\<GG>Pn: group "\<GG>Pn Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)" by (rule normal.factorgroup_is_group)
      have Intnorm\<HH>Pm: "\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) \<lhd> \<HH>Pm" using \<HH>PmnormG \<GG>PnnormG Int_lower2 Int_commute unfolding \<HH>Pm_def
        by (metis comp\<GG>.normal_restrict_supergroup comp\<GG>.normal_subgroup_intersect comp\<HH>.normal_series_subgroups m'(6))
      then interpret grp\<HH>PmMod\<HH>Pmint\<GG>Pn: group "\<HH>Pm Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)" by (rule normal.factorgroup_is_group)

      \<comment> \<open>Show that the second to last entries are not contained in each other.\<close>
      have not\<HH>PmSub\<GG>Pn: "\<not> (\<HH> ! (m - 1) \<subseteq> \<GG> ! (n - 1))" using \<HH>Pmmax.max_normal \<GG>PnnormG False[symmetric] \<GG>Pnmax.proper by simp
      have not\<GG>PnSub\<HH>Pm: "\<not> (\<GG> ! (n - 1) \<subseteq> \<HH> ! (m - 1))" using \<GG>Pnmax.max_normal \<HH>PmnormG False \<HH>Pmmax.proper by simp

      \<comment> \<open>Show that @{term "G Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1))"} is a simple group.\<close>
      have \<HH>PmSubSetmult: "\<HH> ! (m - 1) \<subseteq> \<HH> ! (m - 1) <#>\<^bsub>G\<^esub> \<GG> ! (n - 1)"
        using \<GG>Pnmax.subgroup_axioms \<HH>PmnormG second_isomorphism_grp.H_contained_in_set_mult
          second_isomorphism_grp_axioms_def second_isomorphism_grp_def by blast
      have \<GG>PnSubSetmult: "\<GG> ! (n - 1) \<subseteq> \<HH> ! (m - 1) <#>\<^bsub>G\<^esub> \<GG> ! (n - 1)"
        by (metis \<GG>Pnmax.subset \<GG>PnnormG \<HH>PmSubSetmult \<HH>Pmmax.max_normal \<HH>Pmmax.subgroup_axioms \<HH>PmnormG
            comp\<GG>.normal_subgroup_set_mult_closed comp\<GG>.set_mult_inclusion)
      have "\<GG> ! (n - 1) \<noteq> (\<HH> ! (m - 1)) <#>\<^bsub>G\<^esub> (\<GG> ! (n - 1))" using \<HH>PmSubSetmult not\<HH>PmSub\<GG>Pn by auto
      hence set_multG: "(\<HH> ! (m - 1)) <#>\<^bsub>G\<^esub> (\<GG> ! (n - 1)) = carrier G"
        by (metis \<GG>PnSubSetmult \<GG>Pnmax.max_normal \<GG>PnnormG \<HH>PmnormG comp\<GG>.normal_subgroup_set_mult_closed)
      then obtain \<phi> where "\<phi> \<in> iso (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1))) (G\<lparr>carrier := carrier G\<rparr> Mod \<HH> ! (m - 1))"
        by (metis second_isomorphism_grp.normal_intersection_quotient_isom \<HH>PmnormG
            \<GG>Pn_def \<GG>Pnmax.subgroup_axioms second_isomorphism_grp_axioms_def second_isomorphism_grp_def)
      hence \<phi>: "\<phi> \<in> iso (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1))) (G Mod \<HH> ! (m - 1))" by auto
      then obtain \<phi>2 where \<phi>2: "\<phi>2 \<in> iso (G Mod \<HH> ! (m - 1)) (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using group.iso_set_sym grp\<GG>PnMod\<HH>Pmint\<GG>Pn.is_group by auto
      moreover have "simple_group (G\<lparr>carrier := \<HH> ! (m - 1 + 1)\<rparr> Mod \<HH> ! (m - 1))" using comp\<HH>.simplefact m'(3) by simp
      hence "simple_group (G Mod \<HH> ! (m - 1))" using comp\<HH>.last last_conv_nth comp\<HH>.notempty m'(5) by fastforce
      ultimately have simple\<GG>PnModInt: "simple_group (\<GG>Pn Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using simple_group.iso_simple grp\<GG>PnMod\<HH>Pmint\<GG>Pn.is_group by auto
      interpret grpGMod\<HH>Pm: group "(G Mod \<HH> ! (m - 1))" by (metis \<HH>PmnormG normal.factorgroup_is_group)

      \<comment> \<open>Show analogues of the previous statements for @{term "\<HH> ! (m - 1)"} instead of @{term "\<GG> ! (n - 1)"}.\<close>
      have \<HH>PmSubSetmult': "\<HH> ! (m - 1) \<subseteq> \<GG> ! (n - 1) <#>\<^bsub>G\<^esub> \<HH> ! (m - 1)"
        by (metis \<GG>PnnormG \<HH>PmSubSetmult comp\<GG>.commut_normal \<HH>PmnormG normal_imp_subgroup)
      have \<GG>PnSubSetmult': "\<GG> ! (n - 1) \<subseteq> \<GG> ! (n - 1) <#>\<^bsub>G\<^esub> \<HH> ! (m - 1)"
        by (metis \<HH>PmnormG normal_imp_subgroup \<GG>PnSubSetmult \<GG>PnnormG comp\<GG>.commut_normal)
      have "\<HH> ! (m - 1) \<noteq> (\<GG> ! (n - 1)) <#>\<^bsub>G\<^esub> (\<HH> ! (m - 1))" using \<GG>PnSubSetmult' not\<GG>PnSub\<HH>Pm by auto
      hence set_multG: "(\<GG> ! (n - 1)) <#>\<^bsub>G\<^esub> (\<HH> ! (m - 1)) = carrier G"
        using \<HH>Pmmax.max_normal \<GG>PnnormG comp\<GG>.normal_subgroup_set_mult_closed \<HH>PmSubSetmult' \<HH>PmnormG by blast
      from set_multG obtain \<psi> where
            "\<psi> \<in> iso (\<HH>Pm Mod (\<GG> ! (n - 1) \<inter> \<HH> ! (m - 1))) (G\<lparr>carrier := carrier G\<rparr> Mod \<GG> ! (n - 1))"
        by (metis \<HH>Pm_def \<HH>PmnormG second_isomorphism_grp_axioms_def second_isomorphism_grp_def
            second_isomorphism_grp.normal_intersection_quotient_isom \<GG>PnnormG normal_imp_subgroup)

      hence \<psi>: "\<psi> \<in> iso (\<HH>Pm Mod (\<HH> ! (m - 1) \<inter> (\<GG> ! (n - 1)))) (G\<lparr>carrier := carrier G\<rparr> Mod \<GG> ! (n - 1))" using Int_commute by metis
      then obtain \<psi>2 where
             \<psi>2: "\<psi>2 \<in> iso (G Mod \<GG> ! (n - 1)) (\<HH>Pm Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using group.iso_set_sym grp\<HH>PmMod\<HH>Pmint\<GG>Pn.is_group by auto
      moreover have "simple_group (G\<lparr>carrier := \<GG> ! (n - 1 + 1)\<rparr> Mod \<GG> ! (n - 1))" using comp\<GG>.simplefact n'(3) by simp
      hence "simple_group (G Mod \<GG> ! (n - 1))" using comp\<GG>.last last_conv_nth comp\<GG>.notempty n'(7) by fastforce
      ultimately have simple\<HH>PmModInt: "simple_group (\<HH>Pm Mod (\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)))"
        using simple_group.iso_simple grp\<HH>PmMod\<HH>Pmint\<GG>Pn.is_group by auto
      interpret grpGMod\<GG>Pn: group "(G Mod \<GG> ! (n - 1))" by (metis \<GG>PnnormG normal.factorgroup_is_group)

      \<comment> \<open>Instantiate several composition series used to build up the equality of quotient multisets.\<close>
      define \<KK> where "\<KK> = remdups_adj (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>)"
      define \<LL> where "\<LL> = remdups_adj (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>)"
      interpret \<KK>: composition_series \<HH>Pm \<KK> using comp\<GG>.intersect_normal 1(3) \<HH>PmnormG unfolding \<KK>_def \<HH>Pm_def by auto
      interpret \<LL>: composition_series \<GG>Pn \<LL> using comp\<HH>.intersect_normal 1(3) \<GG>PnnormG unfolding \<LL>_def \<GG>Pn_def by auto

      \<comment> \<open>Apply the induction hypothesis on @{text \<GG>butlast} and @{text \<LL>}\<close>
      from n'(2) have "Suc (length (take n \<GG>)) \<le> length \<GG>" by auto
      hence multisets\<GG>butlast\<LL>: "mset (map group.iso_class \<GG>butlast.quotients) = mset (map group.iso_class \<LL>.quotients)"
        using  "1.hyps" grp\<GG>Pn.is_group finGbl \<GG>butlast.is_composition_series \<LL>.is_composition_series by metis
      hence length\<LL>: "n = length \<LL>" using \<GG>butlast.quotients_length \<LL>.quotients_length length_map size_mset ltaken by metis
      hence length\<LL>': "length \<LL> > 1" "length \<LL> - 1 > 0" "length \<LL> - 1 \<le> length \<LL>" using n'(6) length by auto
      have Inteq\<LL>sndlast: "\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) = \<LL> ! (length \<LL> - 1 - 1)"
      proof -
        have "length \<LL> - 1 - 1 + 1 < length \<LL>" using length\<LL>' by auto
        moreover have KGnotempty: "(map ((\<inter>) (\<GG> ! (n - 1))) \<HH>) \<noteq> []" using comp\<HH>.notempty by (metis Nil_is_map_conv)
        ultimately obtain i where i: "i + 1 < length (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>)"
          "\<LL> ! (length \<LL> - 1 - 1) = (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>) ! i" "\<LL> ! (length \<LL> - 1 - 1 + 1) = (map ((\<inter>) (\<GG> ! (n - 1))) \<HH>) ! (i + 1)"
          using remdups_adj_obtain_adjacency unfolding \<LL>_def by force
        hence "\<LL> ! (length \<LL> - 1 - 1) = \<HH> ! i \<inter> \<GG> ! (n - 1)" "\<LL> ! (length \<LL> - 1 - 1 + 1) = \<HH> ! (i + 1) \<inter> \<GG> ! (n - 1)" by auto
        hence "\<LL> ! (length \<LL> - 1) = \<HH> ! (i + 1) \<inter> \<GG> ! (n - 1)" using length\<LL>'(2) by (metis Suc_diff_1 Suc_eq_plus1)
        hence \<GG>Pnsub\<HH>Pm: "\<GG> ! (n - 1) \<subseteq> \<HH> ! (i + 1)" using \<LL>.last \<LL>.notempty last_conv_nth unfolding \<GG>Pn_def by auto
        from i(1) have "i + 1 < m + 1" unfolding m_def by auto
        moreover have "\<not> (i + 1 \<le> m - 1)" using comp\<HH>.entries_mono m'(6) not\<GG>PnSub\<HH>Pm \<GG>Pnsub\<HH>Pm by fastforce
        ultimately have "m - 1 = i" by auto
        with i show ?thesis by auto
      qed
      hence \<LL>sndlast: "\<HH>PmInt\<GG>Pn = (\<GG>Pn\<lparr>carrier := \<LL> ! (length \<LL> - 1 - 1)\<rparr>)" unfolding \<HH>PmInt\<GG>Pn_def \<GG>Pn_def by auto
      then interpret \<LL>butlast: composition_series \<HH>PmInt\<GG>Pn "take (length \<LL> - 1) \<LL>" using length\<LL>' \<LL>.composition_series_prefix_closed by metis
      from \<open>length \<LL> > 1\<close> have quots\<LL>notemtpy: "\<LL>.quotients \<noteq> []" unfolding \<LL>.quotients_def by auto

      \<comment> \<open>Apply the induction hypothesis on @{text \<LL>butlast} and @{text \<KK>butlast}\<close>
      have "length \<KK> > 1"
      proof (rule ccontr)
        assume "\<not> length \<KK> > 1"
        with \<KK>.notempty have "length \<KK> = 1" by (metis One_nat_def Suc_lessI length_greater_0_conv)
        hence "carrier \<HH>Pm = {\<one>\<^bsub>\<HH>Pm\<^esub>}" using \<KK>.composition_series_length_one \<KK>.composition_series_triv_group by auto
        hence "carrier \<HH>Pm = {\<one>\<^bsub>G\<^esub>}" unfolding \<HH>Pm_def by auto
        hence "carrier \<HH>Pm \<subseteq> \<GG> ! (n - 1)" using \<GG>Pnmax.is_subgroup subgroup.one_closed by auto
        with not\<HH>PmSub\<GG>Pn show False unfolding \<HH>Pm_def by auto
      qed
      hence length\<KK>': "length \<KK> - 1 > 0" "length \<KK> - 1 \<le> length \<KK>" by auto
      have Inteq\<KK>sndlast: "\<HH> ! (m - 1) \<inter> \<GG> ! (n - 1) = \<KK> ! (length \<KK> - 1 - 1)"
      proof -
        have "length \<KK> - 1 - 1 + 1 < length \<KK>" using length\<KK>' by auto
        moreover have KGnotempty: "(map ((\<inter>) (\<HH> ! (m - 1))) \<GG>) \<noteq> []" using comp\<GG>.notempty by (metis Nil_is_map_conv)
        ultimately obtain i where i: "i + 1 < length (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>)"
          "\<KK> ! (length \<KK> - 1 - 1) = (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>) ! i" "\<KK> ! (length \<KK> - 1 - 1 + 1) = (map ((\<inter>) (\<HH> ! (m - 1))) \<GG>) ! (i + 1)"
          using remdups_adj_obtain_adjacency unfolding \<KK>_def by force
        hence "\<KK> ! (length \<KK> - 1 - 1) = \<GG> ! i \<inter> \<HH> ! (m - 1)" "\<KK> ! (length \<KK> - 1 - 1 + 1) = \<GG> ! (i + 1) \<inter> \<HH> ! (m - 1)" by auto
        hence "\<KK> ! (length \<KK> - 1) = \<GG> ! (i + 1) \<inter> \<HH> ! (m - 1)" using length\<KK>'(1) by (metis Suc_diff_1 Suc_eq_plus1)
        hence \<HH>Pmsub\<GG>Pn: "\<HH> ! (m - 1) \<subseteq> \<GG> ! (i + 1)" using \<KK>.last \<KK>.notempty last_conv_nth unfolding \<HH>Pm_def by auto
        from i(1) have "i + 1 < n + 1" unfolding n_def by auto
        moreover have "\<not> (i + 1 \<le> n - 1)" using comp\<GG>.entries_mono n'(2) not\<HH>PmSub\<GG>Pn \<HH>Pmsub\<GG>Pn by fastforce
        ultimately have "n - 1 = i" by auto
        with i show ?thesis by auto
      qed
      have "composition_series (G\<lparr>carrier := \<KK> ! (length \<KK> - 1 - 1)\<rparr>) (take (length \<KK> - 1) \<KK>)"
        using length\<KK>' \<KK>.composition_series_prefix_closed unfolding \<HH>PmInt\<GG>Pn_def \<HH>Pm_def by fastforce
      then interpret \<KK>butlast: composition_series \<HH>PmInt\<GG>Pn "(take (length \<KK> - 1) \<KK>)" using Inteq\<KK>sndlast unfolding \<HH>PmInt\<GG>Pn_def by auto
      from finGbl have finInt: "finite (carrier \<HH>PmInt\<GG>Pn)" unfolding \<HH>PmInt\<GG>Pn_def \<GG>Pn_def by simp
      moreover have "Suc (length (take (length \<LL> - 1) \<LL>)) \<le> length \<GG>" using length\<LL> unfolding n_def using n'(2) by auto
      ultimately have multisets\<KK>\<LL>butlast: "mset (map group.iso_class \<LL>butlast.quotients) = mset (map group.iso_class \<KK>butlast.quotients)"
         using "1.hyps" \<LL>butlast.is_group \<KK>butlast.is_composition_series \<LL>butlast.is_composition_series by auto
      hence "length (take (length \<KK> - 1) \<KK>) = length (take (length \<LL> - 1) \<LL>)"
        using \<KK>butlast.quotients_length \<LL>butlast.quotients_length length_map size_mset by metis
      hence "length (take (length \<KK> - 1) \<KK>) = n - 1" using length\<LL> n'(1) by auto
      hence length\<KK>: "length \<KK> = n" by (metis Suc_diff_1 \<KK>.notempty butlast_conv_take length_butlast length_greater_0_conv n'(1))

      \<comment> \<open>Apply the induction hypothesis on @{text \<KK>} and @{text \<HH>butlast}\<close>
      from Inteq\<KK>sndlast have \<KK>sndlast: "\<HH>PmInt\<GG>Pn = (\<HH>Pm\<lparr>carrier := \<KK> ! (length \<KK> - 1 - 1)\<rparr>)" unfolding \<HH>PmInt\<GG>Pn_def \<HH>Pm_def \<KK>_def by auto
      from length\<KK> have "Suc (length \<KK>) \<le> length \<GG>" using n'(2) by auto
      hence multisets\<HH>butlast\<KK>: "mset (map group.iso_class \<HH>butlast.quotients) = mset (map group.iso_class \<KK>.quotients)"
        using  "1.hyps" grp\<HH>Pm.is_group finHbl \<HH>butlast.is_composition_series \<KK>.is_composition_series by metis
      hence length\<KK>: "m = length \<KK>" using \<HH>butlast.quotients_length \<KK>.quotients_length length_map size_mset ltakem by metis
      hence  "length \<KK> > 1" "length \<KK> - 1 > 0" "length \<KK> - 1 \<le> length \<KK>" using m'(4) length\<HH>big by auto
      hence quots\<KK>notemtpy: "\<KK>.quotients \<noteq> []" unfolding \<KK>.quotients_def by auto

      interpret \<KK>butlastadd\<GG>Pn: composition_series \<GG>Pn "(take (length \<KK> - 1) \<KK>) @ [\<GG> ! (n - 1)]"
        using grp\<GG>Pn.composition_series_extend \<KK>butlast.is_composition_series simple\<GG>PnModInt Intnorm\<GG>Pn
        unfolding \<GG>Pn_def \<HH>PmInt\<GG>Pn_def by auto
      interpret \<LL>butlastadd\<HH>Pm: composition_series \<HH>Pm "(take (length \<LL> - 1) \<LL>) @ [\<HH> ! (m - 1)]"
        using grp\<HH>Pm.composition_series_extend \<LL>butlast.is_composition_series simple\<HH>PmModInt Intnorm\<HH>Pm
        unfolding \<HH>Pm_def \<HH>PmInt\<GG>Pn_def by auto

      \<comment> \<open>Prove equality of those composition series.\<close>
      have "mset (map group.iso_class comp\<GG>.quotients)
                    = mset (map group.iso_class ((butlast comp\<GG>.quotients) @ [last comp\<GG>.quotients]))" using quots\<GG>notempty by simp
      also have "\<dots> = mset (map group.iso_class (\<GG>butlast.quotients @ [G Mod \<GG> ! (n - 1)]))"
        using comp\<GG>.quotients_butlast comp\<GG>.last_quotient length unfolding n_def \<GG>Pn_def by auto
      also have "\<dots> = mset (map group.iso_class ((butlast \<LL>.quotients) @ [last \<LL>.quotients])) + {# group.iso_class (G Mod \<GG> ! (n - 1)) #}"
        using multisets\<GG>butlast\<LL> quots\<LL>notemtpy by simp
      also have "\<dots> = mset (map group.iso_class (\<LL>butlast.quotients @ [\<GG>Pn Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)])) + {# group.iso_class (G Mod \<GG> ! (n - 1)) #}"
        using \<LL>.quotients_butlast \<LL>.last_quotient \<open>length \<LL> > 1\<close> \<LL>sndlast Inteq\<LL>sndlast unfolding n_def by auto
      also have "\<dots> = mset (map group.iso_class \<KK>butlast.quotients) + {# group.iso_class (\<GG>Pn Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)) #} + {# group.iso_class (G Mod \<GG> ! (n - 1)) #}"
        using multisets\<KK>\<LL>butlast by simp
      also have "\<dots> = mset (map group.iso_class \<KK>butlast.quotients) + {# group.iso_class (G Mod \<HH> ! (m - 1)) #} + {# group.iso_class (\<HH>Pm Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)) #}"
        using \<phi> \<psi>2 iso_classes_iff grp\<GG>PnMod\<HH>Pmint\<GG>Pn.is_group grpGMod\<HH>Pm.is_group grpGMod\<GG>Pn.is_group grp\<HH>PmMod\<HH>Pmint\<GG>Pn.is_group
        by metis
      also have "\<dots> = mset (map group.iso_class \<KK>butlast.quotients) + {# group.iso_class (\<HH>Pm Mod \<HH> ! (m - 1) \<inter> \<GG> ! (n - 1)) #} + {# group.iso_class (G Mod \<HH> ! (m - 1)) #}"
        by simp
      also have "\<dots> = mset (map group.iso_class ((butlast \<KK>.quotients) @ [last \<KK>.quotients])) + {# group.iso_class (G Mod \<HH> ! (m - 1)) #}"
        using \<KK>.quotients_butlast \<KK>.last_quotient \<open>length \<KK> > 1\<close> \<KK>sndlast Inteq\<KK>sndlast unfolding m_def by auto
      also have "\<dots> = mset (map group.iso_class \<HH>butlast.quotients) + {# group.iso_class (G Mod \<HH> ! (m - 1)) #}"
        using multisets\<HH>butlast\<KK> quots\<KK>notemtpy by simp
      also have "\<dots> = mset (map group.iso_class ((butlast comp\<HH>.quotients) @ [last comp\<HH>.quotients]))"
        using comp\<HH>.quotients_butlast comp\<HH>.last_quotient length\<HH>big unfolding m_def \<HH>Pm_def by auto
      also have "\<dots> = mset (map group.iso_class comp\<HH>.quotients)" using quots\<HH>notempty by simp
      finally show ?thesis .
    qed
  qed
qed

text \<open>As a corollary, we see that the composition series of a fixed group all have the same length.\<close>

corollary (in jordan_hoelder) jordan_hoelder_size:
  shows "length \<GG> = length \<HH>"
proof -
  have "length \<GG> = length comp\<GG>.quotients + 1" by (metis comp\<GG>.quotients_length)
  also have "\<dots> = size (mset (map group.iso_class comp\<GG>.quotients)) + 1" by (metis length_map size_mset)
  also have "\<dots> = size (mset (map group.iso_class comp\<HH>.quotients)) + 1"
    using jordan_hoelder_multisets is_group finite is_composition_series comp\<HH>.is_composition_series by metis
  also have "\<dots> = length comp\<HH>.quotients + 1" by (metis size_mset length_map)
  also have "\<dots> = length \<HH>" by (metis comp\<HH>.quotients_length)
  finally show ?thesis.
qed

end


section \<open>Multiset\<close>

text \<open>
  \file{Multiset} contains a minimal multiset structure.
\<close>

theory Multiset
imports Main
begin

subsection \<open>A minimal multiset theory\<close>

text \<open>
  Völzer, p. 84, does specify that messages in transit are modelled using
  multisets.

  We decided to implement a tiny structure for multisets, just fitting our needs.
  These multisets allow to add new values to them, to check for elements existing
  in a certain multiset, filter elements according to boolean predicates, remove
  elements and to create a new multiset from a single element.
\<close>

text \<open>
  A multiset for a type is a mapping from the elements of the type to natural
  numbers. So, we record how often a message has to be processed in the future.
\<close>

type_synonym 'a multiset = "'a \<Rightarrow> nat"

abbreviation mElem ::
  "'a \<Rightarrow> 'a multiset \<Rightarrow> bool" ("_ \<in># _" 60)
where
  "mElem a ms \<equiv> 0 < ms a"

text \<open>
  Hence the union of two multisets is the addition of the number of the
  elements and therefore the associative and the commutative laws holds for
  the union.
\<close>

abbreviation mUnion ::
  "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" ("_ \<union># _" 70)
where
  "mUnion msA msB v \<equiv> msA v + msB v"

text \<open>
  Correspondingly the subtraction is defined and the commutative law holds.
\<close>
abbreviation mRm ::
  "'a multiset \<Rightarrow> 'a \<Rightarrow> 'a multiset" ("_ -# _" 65)
where
  "mRm ms rm v \<equiv> if v = rm then ms v - 1 else ms v"

abbreviation mSingleton ::
  "'a \<Rightarrow> 'a multiset"          ("{# _ }")
where
  "mSingleton a v \<equiv> if a = v then 1 else 0"

text \<open>
  The lemma \isb{AXc} adds just the fact we need for our proofs about
  the commutativity of the union of multisets while elements are removed.
\<close>
lemma AXc:
assumes
  "c1 \<noteq> c2" and
  "c1 \<in># X" and
  "c2 \<in># X"
shows "(A1 \<union># ((A2 \<union># (X -# c2)) -# c1))
      = (A2 \<union># ((A1 \<union># (X -# c1)) -# c2))"
proof-
  have
    "(A2 \<union># ((A1 \<union># (X -# c1)) -# c2))
         = (A2 \<union># (A1 \<union># ((X -# c1) -# c2)))"
    using assms by auto
  also have
    "... = (A1 \<union># ((A2 \<union># (X -# c2)) -# c1)) "
    using assms by auto
  finally show ?thesis by auto
qed

end


(*  Title:      HOL/Proofs/Extraction/Euclid.thy
    Author:     Markus Wenzel, TU Muenchen
    Author:     Freek Wiedijk, Radboud University Nijmegen
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Euclid's theorem\<close>

theory Euclid
imports
  "HOL-Computational_Algebra.Primes"
  Util
  "HOL-Library.Code_Target_Numeral"
  "HOL-Library.Realizers"
begin

text \<open>
  A constructive version of the proof of Euclid's theorem by
  Markus Wenzel and Freek Wiedijk \<^cite>\<open>"Wenzel-Wiedijk-JAR2002"\<close>.
\<close>

lemma factor_greater_one1: "n = m * k \<Longrightarrow> m < n \<Longrightarrow> k < n \<Longrightarrow> Suc 0 < m"
  by (induct m) auto

lemma factor_greater_one2: "n = m * k \<Longrightarrow> m < n \<Longrightarrow> k < n \<Longrightarrow> Suc 0 < k"
  by (induct k) auto

lemma prod_mn_less_k: "0 < n \<Longrightarrow> 0 < k \<Longrightarrow> Suc 0 < m \<Longrightarrow> m * n = k \<Longrightarrow> n < k"
  by (induct m) auto

lemma prime_eq: "prime (p::nat) \<longleftrightarrow> 1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> 1 < m \<longrightarrow> m = p)"
  apply (simp add: prime_nat_iff)
  apply (rule iffI)
  apply blast
  apply (erule conjE)
  apply (rule conjI)
  apply assumption
  apply (rule allI impI)+
  apply (erule allE)
  apply (erule impE)
  apply assumption
  apply (case_tac "m = 0")
  apply simp
  apply (case_tac "m = Suc 0")
  apply simp
  apply simp
  done

lemma prime_eq': "prime (p::nat) \<longleftrightarrow> 1 < p \<and> (\<forall>m k. p = m * k \<longrightarrow> 1 < m \<longrightarrow> m = p)"
  by (simp add: prime_eq dvd_def HOL.all_simps [symmetric] del: HOL.all_simps)

lemma not_prime_ex_mk:
  assumes n: "Suc 0 < n"
  shows "(\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k) \<or> prime n"
proof -
  from nat_eq_dec have "(\<exists>m<n. n = m * k) \<or> \<not> (\<exists>m<n. n = m * k)" for k
    by (rule search)
  then have "(\<exists>k<n. \<exists>m<n. n = m * k) \<or> \<not> (\<exists>k<n. \<exists>m<n. n = m * k)"
    by (rule search)
  then show ?thesis
  proof
    assume "\<exists>k<n. \<exists>m<n. n = m * k"
    then obtain k m where k: "k<n" and m: "m<n" and nmk: "n = m * k"
      by iprover
    from nmk m k have "Suc 0 < m" by (rule factor_greater_one1)
    moreover from nmk m k have "Suc 0 < k" by (rule factor_greater_one2)
    ultimately show ?thesis using k m nmk by iprover
  next
    assume "\<not> (\<exists>k<n. \<exists>m<n. n = m * k)"
    then have A: "\<forall>k<n. \<forall>m<n. n \<noteq> m * k" by iprover
    have "\<forall>m k. n = m * k \<longrightarrow> Suc 0 < m \<longrightarrow> m = n"
    proof (intro allI impI)
      fix m k
      assume nmk: "n = m * k"
      assume m: "Suc 0 < m"
      from n m nmk have k: "0 < k"
        by (cases k) auto
      moreover from n have n: "0 < n" by simp
      moreover note m
      moreover from nmk have "m * k = n" by simp
      ultimately have kn: "k < n" by (rule prod_mn_less_k)
      show "m = n"
      proof (cases "k = Suc 0")
        case True
        with nmk show ?thesis by (simp only: mult_Suc_right)
      next
        case False
        from m have "0 < m" by simp
        moreover note n
        moreover from False n nmk k have "Suc 0 < k" by auto
        moreover from nmk have "k * m = n" by (simp only: ac_simps)
        ultimately have mn: "m < n" by (rule prod_mn_less_k)
        with kn A nmk show ?thesis by iprover
      qed
    qed
    with n have "prime n"
      by (simp only: prime_eq' One_nat_def simp_thms)
    then show ?thesis ..
  qed
qed

lemma dvd_factorial: "0 < m \<Longrightarrow> m \<le> n \<Longrightarrow> m dvd fact n"
proof (induct n rule: nat_induct)
  case 0
  then show ?case by simp
next
  case (Suc n)
  from \<open>m \<le> Suc n\<close> show ?case
  proof (rule le_SucE)
    assume "m \<le> n"
    with \<open>0 < m\<close> have "m dvd fact n" by (rule Suc)
    then have "m dvd (fact n * Suc n)" by (rule dvd_mult2)
    then show ?thesis by (simp add: mult.commute)
  next
    assume "m = Suc n"
    then have "m dvd (fact n * Suc n)"
      by (auto intro: dvdI simp: ac_simps)
    then show ?thesis by (simp add: mult.commute)
  qed
qed

lemma dvd_prod [iff]: "n dvd (\<Prod>m::nat \<in># mset (n # ns). m)"
  by (simp add: prod_mset_Un)

definition all_prime :: "nat list \<Rightarrow> bool"
  where "all_prime ps \<longleftrightarrow> (\<forall>p\<in>set ps. prime p)"

lemma all_prime_simps:
  "all_prime []"
  "all_prime (p # ps) \<longleftrightarrow> prime p \<and> all_prime ps"
  by (simp_all add: all_prime_def)

lemma all_prime_append: "all_prime (ps @ qs) \<longleftrightarrow> all_prime ps \<and> all_prime qs"
  by (simp add: all_prime_def ball_Un)

lemma split_all_prime:
  assumes "all_prime ms" and "all_prime ns"
  shows "\<exists>qs. all_prime qs \<and>
    (\<Prod>m::nat \<in># mset qs. m) = (\<Prod>m::nat \<in># mset ms. m) * (\<Prod>m::nat \<in># mset ns. m)"
  (is "\<exists>qs. ?P qs \<and> ?Q qs")
proof -
  from assms have "all_prime (ms @ ns)"
    by (simp add: all_prime_append)
  moreover
  have "(\<Prod>m::nat \<in># mset (ms @ ns). m) = (\<Prod>m::nat \<in># mset ms. m) * (\<Prod>m::nat \<in># mset ns. m)"
    using assms by (simp add: prod_mset_Un)
  ultimately have "?P (ms @ ns) \<and> ?Q (ms @ ns)" ..
  then show ?thesis ..
qed

lemma all_prime_nempty_g_one:
  assumes "all_prime ps" and "ps \<noteq> []"
  shows "Suc 0 < (\<Prod>m::nat \<in># mset ps. m)"
  using \<open>ps \<noteq> []\<close> \<open>all_prime ps\<close>
  unfolding One_nat_def [symmetric]
  by (induct ps rule: list_nonempty_induct)
    (simp_all add: all_prime_simps prod_mset_Un prime_gt_1_nat less_1_mult del: One_nat_def)

lemma factor_exists: "Suc 0 < n \<Longrightarrow> (\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = n)"
proof (induct n rule: nat_wf_ind)
  case (1 n)
  from \<open>Suc 0 < n\<close>
  have "(\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k) \<or> prime n"
    by (rule not_prime_ex_mk)
  then show ?case
  proof
    assume "\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k"
    then obtain m k where m: "Suc 0 < m" and k: "Suc 0 < k" and mn: "m < n"
      and kn: "k < n" and nmk: "n = m * k"
      by iprover
    from mn and m have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = m"
      by (rule 1)
    then obtain ps1 where "all_prime ps1" and prod_ps1_m: "(\<Prod>m::nat \<in># mset ps1. m) = m"
      by iprover
    from kn and k have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = k"
      by (rule 1)
    then obtain ps2 where "all_prime ps2" and prod_ps2_k: "(\<Prod>m::nat \<in># mset ps2. m) = k"
      by iprover
    from \<open>all_prime ps1\<close> \<open>all_prime ps2\<close>
    have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) =
      (\<Prod>m::nat \<in># mset ps1. m) * (\<Prod>m::nat \<in># mset ps2. m)"
      by (rule split_all_prime)
    with prod_ps1_m prod_ps2_k nmk show ?thesis by simp
  next
    assume "prime n" then have "all_prime [n]" by (simp add: all_prime_simps)
    moreover have "(\<Prod>m::nat \<in># mset [n]. m) = n" by (simp)
    ultimately have "all_prime [n] \<and> (\<Prod>m::nat \<in># mset [n]. m) = n" ..
    then show ?thesis ..
  qed
qed

lemma prime_factor_exists:
  assumes N: "(1::nat) < n"
  shows "\<exists>p. prime p \<and> p dvd n"
proof -
  from N obtain ps where "all_prime ps" and prod_ps: "n = (\<Prod>m::nat \<in># mset ps. m)"
    using factor_exists by simp iprover
  with N have "ps \<noteq> []"
    by (auto simp add: all_prime_nempty_g_one)
  then obtain p qs where ps: "ps = p # qs"
    by (cases ps) simp
  with \<open>all_prime ps\<close> have "prime p"
    by (simp add: all_prime_simps)
  moreover from \<open>all_prime ps\<close> ps prod_ps have "p dvd n"
    by (simp only: dvd_prod)
  ultimately show ?thesis by iprover
qed

text \<open>Euclid's theorem: there are infinitely many primes.\<close>

lemma Euclid: "\<exists>p::nat. prime p \<and> n < p"
proof -
  let ?k = "fact n + (1::nat)"
  have "1 < ?k" by simp
  then obtain p where prime: "prime p" and dvd: "p dvd ?k"
    using prime_factor_exists by iprover
  have "n < p"
  proof -
    have "\<not> p \<le> n"
    proof
      assume pn: "p \<le> n"
      from \<open>prime p\<close> have "0 < p" by (rule prime_gt_0_nat)
      then have "p dvd fact n" using pn by (rule dvd_factorial)
      with dvd have "p dvd ?k - fact n" by (rule dvd_diff_nat)
      then have "p dvd 1" by simp
      with prime show False by auto
    qed
    then show ?thesis by simp
  qed
  with prime show ?thesis by iprover
qed

extract Euclid

text \<open>
  The program extracted from the proof of Euclid's theorem looks as follows.
  @{thm [display] Euclid_def}
  The program corresponding to the proof of the factorization theorem is
  @{thm [display] factor_exists_def}
\<close>

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation list :: (type) default
begin

definition "default = []"

instance ..

end

primrec iterate :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
where
  "iterate 0 f x = []"
| "iterate (Suc n) f x = (let y = f x in y # iterate n f y)"

lemma "factor_exists 1007 = [53, 19]" by eval
lemma "factor_exists 567 = [7, 3, 3, 3, 3]" by eval
lemma "factor_exists 345 = [23, 5, 3]" by eval
lemma "factor_exists 999 = [37, 3, 3, 3]" by eval
lemma "factor_exists 876 = [73, 3, 2, 2]" by eval

lemma "iterate 4 Euclid 0 = [2, 3, 7, 71]" by eval

end


(*
  Example with mixed induction and coinduction
 *)
theory Lappend_append_assoc
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

fun to_llist :: "'a list \<Rightarrow> 'a Llist" where
  "to_llist [] = LNil"
| "to_llist (Cons x xs) = LCons x (to_llist xs)"

(* hipster lappend append to_llist *)
lemma lemma_a [thy_expl]: "lappend y LNil = y"
  apply (coinduction  arbitrary: y rule: Lappend_append_assoc.Llist.coinduct_strong)
  apply simp
  done

lemma lemma_aa [thy_expl]: "lappend LNil y = y"
  apply (coinduction  arbitrary: y rule: Lappend_append_assoc.Llist.coinduct_strong)
apply simp
  done

lemma lemma_ab [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
  apply (coinduction  arbitrary: y rule: Lappend_append_assoc.Llist.coinduct_strong)
  apply (metis lappend.simps(4) lemma_a lnull_def)
  done

lemma lemma_ac [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
  apply (coinduction  arbitrary: x2 y z rule: Lappend_append_assoc.Llist.coinduct_strong)
  apply simp
  done

lemma lemma_ad [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
  apply (coinduction  arbitrary: x2 y z rule: Lappend_append_assoc.Llist.coinduct_strong)
  apply auto
  done

lemma lemma_ae [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
  apply (coinduction  arbitrary: y rule: Lappend_append_assoc.Llist.coinduct_strong)
  apply (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)
  done

(* Note that this lemma is proved by induction, and uses other lemmas that were discovered
   and proved by coinduction within the same proof loop. *)
lemma lemma_af [thy_expl]: "lappend (to_llist y) (to_llist z) = to_llist (y @ z)"
  apply (induct y arbitrary: z)
  apply simp
  apply (simp add: lemma_aa)
  apply simp
  apply (simp add: lemma_ac)
  done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Ancient_Numeral
  imports Main Reversed_Bit_Lists
begin

definition Bit :: "int \<Rightarrow> bool \<Rightarrow> int"  (infixl "BIT" 90)
  where "k BIT b = (if b then 1 else 0) + k + k"

lemma Bit_B0: "k BIT False = k + k"
   by (simp add: Bit_def)

lemma Bit_B1: "k BIT True = k + k + 1"
   by (simp add: Bit_def)

lemma Bit_B0_2t: "k BIT False = 2 * k"
  by (rule trans, rule Bit_B0) simp

lemma Bit_B1_2t: "k BIT True = 2 * k + 1"
  by (rule trans, rule Bit_B1) simp

lemma uminus_Bit_eq:
  "- k BIT b = (- k - of_bool b) BIT b"
  by (cases b) (simp_all add: Bit_def)

lemma power_BIT: "2 ^ Suc n - 1 = (2 ^ n - 1) BIT True"
  by (simp add: Bit_B1)

lemma bin_rl_simp [simp]: "bin_rest w BIT bin_last w = w"
  by (simp add: Bit_def)

lemma bin_rest_BIT [simp]: "bin_rest (x BIT b) = x"
  by (simp add: Bit_def)

lemma even_BIT [simp]: "even (x BIT b) \<longleftrightarrow> \<not> b"
  by (simp add: Bit_def)

lemma bin_last_BIT [simp]: "bin_last (x BIT b) = b"
  by simp

lemma BIT_eq_iff [iff]: "u BIT b = v BIT c \<longleftrightarrow> u = v \<and> b = c"
  by (auto simp: Bit_def) arith+

lemma BIT_bin_simps [simp]:
  "numeral k BIT False = numeral (Num.Bit0 k)"
  "numeral k BIT True = numeral (Num.Bit1 k)"
  "(- numeral k) BIT False = - numeral (Num.Bit0 k)"
  "(- numeral k) BIT True = - numeral (Num.BitM k)"
  by (simp_all only: Bit_B0 Bit_B1 numeral.simps numeral_BitM)

lemma BIT_special_simps [simp]:
  shows "0 BIT False = 0"
    and "0 BIT True = 1"
    and "1 BIT False = 2"
    and "1 BIT True = 3"
    and "(- 1) BIT False = - 2"
    and "(- 1) BIT True = - 1"
  by (simp_all add: Bit_def)

lemma Bit_eq_0_iff: "w BIT b = 0 \<longleftrightarrow> w = 0 \<and> \<not> b"
  by (auto simp: Bit_def) arith

lemma Bit_eq_m1_iff: "w BIT b = -1 \<longleftrightarrow> w = -1 \<and> b"
  by (auto simp: Bit_def) arith

lemma expand_BIT:
  "numeral (Num.Bit0 w) = numeral w BIT False"
  "numeral (Num.Bit1 w) = numeral w BIT True"
  "- numeral (Num.Bit0 w) = (- numeral w) BIT False"
  "- numeral (Num.Bit1 w) = (- numeral (w + Num.One)) BIT True"
  by (simp_all add: BitM_inc_eq add_One)

lemma less_Bits: "v BIT b < w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> \<not> b \<and> c"
  by (auto simp: Bit_def)

lemma le_Bits: "v BIT b \<le> w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> (\<not> b \<or> c)"
  by (auto simp: Bit_def)

lemma pred_BIT_simps [simp]:
  "x BIT False - 1 = (x - 1) BIT True"
  "x BIT True - 1 = x BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma succ_BIT_simps [simp]:
  "x BIT False + 1 = x BIT True"
  "x BIT True + 1 = (x + 1) BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma add_BIT_simps [simp]:
  "x BIT False + y BIT False = (x + y) BIT False"
  "x BIT False + y BIT True = (x + y) BIT True"
  "x BIT True + y BIT False = (x + y) BIT True"
  "x BIT True + y BIT True = (x + y + 1) BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma mult_BIT_simps [simp]:
  "x BIT False * y = (x * y) BIT False"
  "x * y BIT False = (x * y) BIT False"
  "x BIT True * y = (x * y) BIT False + y"
  by (simp_all add: Bit_B0_2t Bit_B1_2t algebra_simps)

lemma B_mod_2': "X = 2 \<Longrightarrow> (w BIT True) mod X = 1 \<and> (w BIT False) mod X = 0"
  by (simp add: Bit_B0 Bit_B1)

lemma bin_ex_rl: "\<exists>w b. w BIT b = bin"
  by (metis bin_rl_simp)

lemma bin_exhaust: "(\<And>x b. bin = x BIT b \<Longrightarrow> Q) \<Longrightarrow> Q"
by (metis bin_ex_rl)

lemma bin_abs_lem: "bin = (w BIT b) \<Longrightarrow> bin \<noteq> -1 \<longrightarrow> bin \<noteq> 0 \<longrightarrow> nat \<bar>w\<bar> < nat \<bar>bin\<bar>"
  apply clarsimp
  apply (unfold Bit_def)
  apply (cases b)
   apply (clarsimp, arith)
  apply (clarsimp, arith)
  done

lemma bin_induct:
  assumes PPls: "P 0"
    and PMin: "P (- 1)"
    and PBit: "\<And>bin bit. P bin \<Longrightarrow> P (bin BIT bit)"
  shows "P bin"
  apply (rule_tac P=P and a=bin and f1="nat \<circ> abs" in wf_measure [THEN wf_induct])
  apply (simp add: measure_def inv_image_def)
  apply (case_tac x rule: bin_exhaust)
  apply (frule bin_abs_lem)
  apply (auto simp add : PPls PMin PBit)
  done

lemma Bit_div2: "(w BIT b) div 2 = w"
  by (fact bin_rest_BIT)

lemma twice_conv_BIT: "2 * x = x BIT False"
  by (simp add: Bit_def)

lemma BIT_lt0 [simp]: "x BIT b < 0 \<longleftrightarrow> x < 0"
by(cases b)(auto simp add: Bit_def)

lemma BIT_ge0 [simp]: "x BIT b \<ge> 0 \<longleftrightarrow> x \<ge> 0"
by(cases b)(auto simp add: Bit_def)

lemma bin_to_bl_aux_Bit_minus_simp [simp]:
  "0 < n \<Longrightarrow> bin_to_bl_aux n (w BIT b) bl = bin_to_bl_aux (n - 1) w (b # bl)"
  by (cases n) auto

lemma bl_to_bin_BIT:
  "bl_to_bin bs BIT b = bl_to_bin (bs @ [b])"
  by (simp add: bl_to_bin_append Bit_def)

lemma bin_nth_0_BIT: "bin_nth (w BIT b) 0 \<longleftrightarrow> b"
  by simp

lemma bin_nth_Suc_BIT: "bin_nth (w BIT b) (Suc n) = bin_nth w n"
  by (simp add: bit_Suc)

lemma bin_nth_minus [simp]: "0 < n \<Longrightarrow> bin_nth (w BIT b) n = bin_nth w (n - 1)"
  by (cases n) (simp_all add: bit_Suc)

lemma bin_sign_simps [simp]:
  "bin_sign (w BIT b) = bin_sign w"
  by (simp add: bin_sign_def Bit_def)

lemma bin_nth_Bit: "bin_nth (w BIT b) n \<longleftrightarrow> n = 0 \<and> b \<or> (\<exists>m. n = Suc m \<and> bin_nth w m)"
  by (cases n) auto

lemmas sbintrunc_Suc_BIT [simp] =
  signed_take_bit_Suc [where a="w BIT b", simplified bin_last_BIT bin_rest_BIT] for w b

lemmas sbintrunc_0_BIT_B0 [simp] =
  signed_take_bit_0 [where a="w BIT False", simplified bin_last_numeral_simps bin_rest_numeral_simps]
  for w

lemmas sbintrunc_0_BIT_B1 [simp] =
  signed_take_bit_0 [where a="w BIT True", simplified bin_last_BIT bin_rest_numeral_simps]
  for w

lemma sbintrunc_Suc_minus_Is:
  \<open>0 < n \<Longrightarrow>
  sbintrunc (n - 1) w = y \<Longrightarrow>
  sbintrunc n (w BIT b) = y BIT b\<close>
  by (cases n) (simp_all add: Bit_def signed_take_bit_Suc)

lemma bin_cat_Suc_Bit: "bin_cat w (Suc n) (v BIT b) = bin_cat w n v BIT b"
  by (auto simp add: Bit_def concat_bit_Suc)

lemma int_not_BIT [simp]: "NOT (w BIT b) = (NOT w) BIT (\<not> b)"
  by (simp add: not_int_def Bit_def)

lemma int_and_Bits [simp]: "(x BIT b) AND (y BIT c) = (x AND y) BIT (b \<and> c)"
  using and_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)

lemma int_or_Bits [simp]: "(x BIT b) OR (y BIT c) = (x OR y) BIT (b \<or> c)"
  using or_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)

lemma int_xor_Bits [simp]: "(x BIT b) XOR (y BIT c) = (x XOR y) BIT ((b \<or> c) \<and> \<not> (b \<and> c))"
  using xor_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)

lemma mod_BIT:
  "bin BIT bit mod 2 ^ Suc n = (bin mod 2 ^ n) BIT bit" for bit
proof -
  have "2 * (bin mod 2 ^ n) + 1 = (2 * bin mod 2 ^ Suc n) + 1"
    by (simp add: mod_mult_mult1)
  also have "\<dots> = ((2 * bin mod 2 ^ Suc n) + 1) mod 2 ^ Suc n"
    by (simp add: ac_simps pos_zmod_mult_2)
  also have "\<dots> = (2 * bin + 1) mod 2 ^ Suc n"
    by (simp only: mod_simps)
  finally show ?thesis
    by (auto simp add: Bit_def)
qed

lemma minus_BIT_0: fixes x y :: int shows "x BIT b - y BIT False = (x - y) BIT b"
by(simp add: Bit_def)

lemma int_lsb_BIT [simp]: fixes x :: int shows
  "lsb (x BIT b) \<longleftrightarrow> b"
by(simp add: lsb_int_def)

lemma int_shiftr_BIT [simp]: fixes x :: int
  shows int_shiftr0: "x >> 0 = x"
  and int_shiftr_Suc: "x BIT b >> Suc n = x >> n"
proof -
  show "x >> 0 = x" by (simp add: shiftr_int_def)
  show "x BIT b >> Suc n = x >> n" by (cases b)
   (simp_all add: shiftr_int_def Bit_def add.commute pos_zdiv_mult_2)
qed

lemma msb_BIT [simp]: "msb (x BIT b) = msb x"
by(simp add: msb_int_def)

end


section \<open>Lens instances\<close>

theory Lens_Instances
  imports Lens_Order
  keywords "alphabet" :: "thy_decl_block"
begin

text \<open>In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.\<close>

subsection \<open>Function lens\<close>

text \<open>We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.\<close>

definition fun_lens :: "'a \<Rightarrow> ('b::two \<Longrightarrow> ('a \<Rightarrow> 'b))" where
[lens_defs]: "fun_lens x = \<lparr> lens_get = (\<lambda> f. f x), lens_put = (\<lambda> f u. f(x := u)) \<rparr>"

lemma fun_wb_lens: "wb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

lemma fun_lens_indep:
  "fun_lens x \<bowtie> fun_lens y \<longleftrightarrow> x \<noteq> y"
proof -
  obtain u v :: "'a::two" where "u \<noteq> v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

text \<open>The function range lens allows us to focus on a particular region on a functions range.\<close>

definition fun_ran_lens :: "('c \<Longrightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Longrightarrow> '\<alpha>) \<Rightarrow> (('a \<Rightarrow> 'c) \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "fun_ran_lens X Y = \<lparr> lens_get = \<lambda> s. get\<^bsub>X\<^esub> \<circ> get\<^bsub>Y\<^esub> s
                                 , lens_put = \<lambda> s v. put\<^bsub>Y\<^esub> s (\<lambda> x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \<rparr>"

lemma fun_ran_mwb_lens: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection \<open>Map lens\<close>

definition map_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a \<rightharpoonup> 'b))" where
[lens_defs]: "map_lens x = \<lparr> lens_get = (\<lambda> f. the (f x)), lens_put = (\<lambda> f u. f(x \<mapsto> u)) \<rparr>"

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

subsection \<open>List lens\<close>

definition list_pad_out :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

definition list_augment :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

definition nth' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

lemma list_update_append_lemma1: "i < length xs \<Longrightarrow> xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys \<Longrightarrow> xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = list_pad_out xs (max i j)[i := u, j := v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

lemma list_augment_commute:
  "i \<noteq> j \<Longrightarrow> list_augment (list_augment \<sigma> j v) i u = list_augment (list_augment \<sigma> i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i \<noteq> j \<Longrightarrow> nth' (list_augment \<sigma> i v) j = nth' \<sigma> j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

definition list_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a list)" where
[lens_defs]: "list_lens i = \<lparr> lens_get = (\<lambda> xs. nth' xs i)
                            , lens_put = (\<lambda> xs x. list_augment xs i x) \<rparr>"

abbreviation "hd_lens \<equiv> list_lens 0"

definition tl_lens :: "'a list \<Longrightarrow> 'a list" where
[lens_defs]: "tl_lens = \<lparr> lens_get = (\<lambda> xs. tl xs)
                        , lens_put = (\<lambda> xs xs'. hd xs # xs') \<rparr>"

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

lemma tail_lens_mwb:
  "mwb_lens tl_lens"
  by (unfold_locales, simp_all add: tl_lens_def)

lemma list_lens_indep:
  "i \<noteq> j \<Longrightarrow> list_lens i \<bowtie> list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hd_lens \<bowtie> tl_lens"
  apply (rule lens_indepI)
  apply (simp_all add: list_lens_def tl_lens_def)
  apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
  apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis Nitpick.size_list_simp(2) One_nat_def add_Suc_right append.simps(1) append_Nil2 diff_Suc_Suc diff_zero hd_Cons_tl list.inject list.size(4) list_augment_0 list_augment_def list_augment_same_twice list_pad_out_def nth_list_augment replicate.simps(1) replicate.simps(2) tl_Nil)
done

subsection \<open>Record field lenses\<close>

abbreviation (input) "fld_put f \<equiv> (\<lambda> \<sigma> u. f (\<lambda>_. u) \<sigma>)"

syntax "_FLDLENS" :: "id \<Rightarrow> ('a \<Longrightarrow> 'r)"  ("FLDLENS _")
translations "FLDLENS x" => "\<lparr> lens_get = x, lens_put = CONST fld_put (_update_name x) \<rparr>"

text {* Introduce the alphabet command that creates a record with lenses for each field *}

ML_file "Lens_Record.ML"

text {* The following theorem attribute stores splitting theorems for alphabet types *}

named_theorems alpha_splits

(*
alphabet mylens =
  x :: nat
  y :: string

lemma mylens_bij_lens:
  "bij_lens (x +\<^sub>L y +\<^sub>L mylens_child_lens)"
  by (unfold_locales, simp_all add: lens_plus_def x_def y_def mylens_child_lens_def id_lens_def sublens_def lens_comp_def prod.case_eq_if)

alphabet mylens_2 = mylens +
  z :: int
  k :: "string list"

alphabet mylens_3 = mylens_2 +
  n :: real
  h :: nat
*)

subsection {* Lens Interpretation *}

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]
end
end


(*
    Title:      Gauss_Jordan_PA.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Obtaining explicitly the invertible matrix which transforms a matrix to its reduced row echelon form\<close>

theory Gauss_Jordan_PA
imports
 Gauss_Jordan
 Rank_Nullity_Theorem.Miscellaneous
 Linear_Maps (*Really, this file is not necessary, but it contains interesting properties about linear maps.*)
begin

subsection\<open>Definitions\<close>

text\<open>The following algorithm is similar to @{term "Gauss_Jordan"},
but in this case we will also return the P matrix which makes @{term "Gauss_Jordan A = P ** A"}. If A is invertible, this matrix P will be the inverse of it.\<close>

definition Gauss_Jordan_in_ij_PA :: "(('a::{semiring_1, inverse, one, uminus}^'rows::{finite, ord}^'rows::{finite, ord}) \<times> ('a^'cols^'rows::{finite, ord})) => 'rows=>'cols
  =>(('a^'rows::{finite, ord}^'rows::{finite, ord}) \<times> ('a^'cols^'rows::{finite, ord}))"
where "Gauss_Jordan_in_ij_PA A' i j = (let P=fst A'; A=snd A';
                                        n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
                                        interchange_A = (interchange_rows A i n);
                                        interchange_P = (interchange_rows P i n);
                                        P' = mult_row interchange_P i (1/interchange_A$i$j)
                                        in
                                       (vec_lambda(% s. if s=i then P' $ s else (row_add P' s i (-(interchange_A$s$j))) $ s), Gauss_Jordan_in_ij A i j))"

definition Gauss_Jordan_column_k_PA
where "Gauss_Jordan_column_k_PA A' k =
    (let P = fst A';
         i = fst (snd A');
         A = snd (snd A');
         from_nat_i=from_nat i;
         from_nat_k=from_nat k
         in
         if (\<forall>m\<ge>from_nat_i. A $ m $ from_nat_k = 0) \<or> i = nrows A then (P, i, A)
         else (let Gauss = Gauss_Jordan_in_ij_PA (P,A) (from_nat_i) (from_nat_k) in (fst Gauss, i + 1, snd Gauss)))"

definition "Gauss_Jordan_upt_k_PA A k = (let foldl=(foldl Gauss_Jordan_column_k_PA (mat 1,0, A) [0..<Suc k]) in (fst foldl, snd (snd foldl)))"
definition "Gauss_Jordan_PA A = Gauss_Jordan_upt_k_PA A (ncols A - 1)"

subsection\<open>Proofs\<close>

subsubsection\<open>Properties about @{term "Gauss_Jordan_in_ij_PA"}\<close>

text\<open>The following lemmas are very important in order to improve the efficience of the code\<close>
text\<open>We define the following function to obtain an efficient code for @{term "Gauss_Jordan_in_ij_PA A i j"}.\<close>

definition "Gauss_Jordan_wrapper i j A B = vec_lambda(%s. if s=i then A $ s else (row_add A s i (-(B$s$j))) $ s)"

lemma Gauss_Jordan_wrapper_code[code abstract]:
  "vec_nth (Gauss_Jordan_wrapper i j A B) = (%s. if s=i then A $ s else (row_add A s i (-(B$s$j))) $ s)"
  unfolding Gauss_Jordan_wrapper_def by force

lemma Gauss_Jordan_in_ij_PA_def'[code]:
   "Gauss_Jordan_in_ij_PA A' i j = (let P=fst A'; A=snd A';
                                        n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
                                        interchange_A = (interchange_rows A i n);
                                        A' = mult_row interchange_A i (1/interchange_A$i$j);
                                        interchange_P = (interchange_rows P i n);
                                        P' = mult_row interchange_P i (1/interchange_A$i$j)
                                        in
                                       (Gauss_Jordan_wrapper i j P' interchange_A,
                                        Gauss_Jordan_wrapper i j A' interchange_A))"
unfolding Gauss_Jordan_in_ij_PA_def Gauss_Jordan_in_ij_def Let_def Gauss_Jordan_wrapper_def by auto

text\<open>The second component is equal to @{term "Gauss_Jordan_in_ij"}\<close>
lemma snd_Gauss_Jordan_in_ij_PA_eq[code_unfold]: "snd (Gauss_Jordan_in_ij_PA (P,A) i j) = Gauss_Jordan_in_ij A i j"
  unfolding Gauss_Jordan_in_ij_PA_def Let_def snd_conv ..

lemma fst_Gauss_Jordan_in_ij_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes PB_A: "P ** B = A"
shows "fst (Gauss_Jordan_in_ij_PA (P,A) i j) ** B = snd (Gauss_Jordan_in_ij_PA (P,A) i j)"
proof (unfold Gauss_Jordan_in_ij_PA_def' Gauss_Jordan_wrapper_def Let_def fst_conv snd_conv, subst (1 2 3 4 5 6 7 8 9 10) interchange_rows_mat_1[symmetric], subst vec_eq_iff, auto)
show "((\<chi> s. if s = i then mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $ s
              else row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s i
              (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ i =
              mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $ i"
proof (unfold matrix_matrix_mult_def, vector, auto)
fix ia
have "mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)
** B = mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)"
by(subst (5) PB_A[symmetric], subst (1 2) mult_row_mat_1[symmetric], unfold matrix_mul_assoc, rule refl)
thus "(\<Sum>k\<in>UNIV. mult_row (\<chi> ia ja. \<Sum>k\<in>UNIV. interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ k * P $ k $ ja) i
                     (1 / (\<Sum>k\<in>UNIV. mat 1 $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ k * A $ k $ j)) $ i $ k * B $ k $ ia) =
                     mult_row (\<chi> ia ja. \<Sum>k\<in>UNIV. interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ k * A $ k $ ja) i
                     (1 / (\<Sum>k\<in>UNIV. mat 1 $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ k * A $ k $ j)) $ i $ ia"
unfolding matrix_matrix_mult_def
unfolding vec_lambda_beta unfolding interchange_rows_i using sum.cong
by (metis (lifting, no_types) vec_lambda_beta)
qed
next
fix ia assume ia_not_i: "ia \<noteq> i"
have "((\<chi> s. if s = i then mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $
             s else row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s
             i (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ ia =
((\<chi> s. row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s
             i (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ ia"
unfolding row_matrix_matrix_mult[symmetric]
using ia_not_i by auto
also have "... = row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) ia i
     (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ ia $ j) $ ia v* B"
     by (subst (3) row_matrix_matrix_mult[symmetric], simp)
also have "... = row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) ia i
             (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ ia $ j) $ ia"
apply (subst (7) PB_A[symmetric])
apply (subst (1 2) mult_row_mat_1[symmetric])
apply (subst (1 2) row_add_mat_1[symmetric])
unfolding matrix_mul_assoc
unfolding row_matrix_matrix_mult ..
finally show "((\<chi> s. if s = i then mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $ s
        else row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s i
              (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ ia =
  row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) ia i
   (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ ia $ j) $ ia" .
qed

subsubsection\<open>Properties about @{term "Gauss_Jordan_column_k_PA"}\<close>
lemma fst_Gauss_Jordan_column_k:
assumes "i\<le>nrows A"
shows "fst (Gauss_Jordan_column_k (i, A) k) \<le> nrows A"
using assms unfolding Gauss_Jordan_column_k_def Let_def by auto

lemma fst_Gauss_Jordan_column_k_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes PB_A: "P ** B = A"
shows "fst (Gauss_Jordan_column_k_PA (P,i,A) k) ** B = snd (snd (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_PA_def unfolding Let_def
unfolding fst_conv snd_conv by (auto intro: assms fst_Gauss_Jordan_in_ij_PA)

lemma snd_snd_Gauss_Jordan_column_k_PA_eq:
shows "snd (snd (Gauss_Jordan_column_k_PA (P,i,A) k)) = snd (Gauss_Jordan_column_k (i,A) k)"
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_def unfolding Let_def snd_conv fst_conv unfolding snd_Gauss_Jordan_in_ij_PA_eq by auto

lemma fst_snd_Gauss_Jordan_column_k_PA_eq:
shows "fst (snd (Gauss_Jordan_column_k_PA (P,i,A) k)) = fst (Gauss_Jordan_column_k (i,A) k)"
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_def unfolding Let_def snd_conv fst_conv by auto

subsubsection\<open>Properties about @{term "Gauss_Jordan_upt_k_PA"}\<close>

lemma fst_Gauss_Jordan_upt_k_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "fst (Gauss_Jordan_upt_k_PA A k) ** A = snd (Gauss_Jordan_upt_k_PA A k)"
proof (induct k)
show "fst (Gauss_Jordan_upt_k_PA A 0) ** A = snd (Gauss_Jordan_upt_k_PA A 0)" unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv
apply auto unfolding snd_snd_Gauss_Jordan_column_k_PA_eq by (metis fst_Gauss_Jordan_column_k_PA matrix_mul_lid snd_snd_Gauss_Jordan_column_k_PA_eq)
next
case (Suc k)
have suc_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
show ?case
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv
unfolding suc_rw unfolding foldl_append unfolding List.foldl.simps using Suc.hyps[unfolded Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv]
by (metis fst_Gauss_Jordan_column_k_PA prod.collapse)
qed

lemma snd_foldl_Gauss_Jordan_column_k_eq:
"snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<k]) = foldl Gauss_Jordan_column_k (0, A) [0..<k]"
proof (induct k)
case 0
show ?case by simp
case (Suc k)
have suc_rw: "[0..<Suc k] = [0..<k] @ [k]" by simp
show ?case
unfolding suc_rw foldl_append unfolding List.foldl.simps by (metis Suc.hyps fst_snd_Gauss_Jordan_column_k_PA_eq snd_snd_Gauss_Jordan_column_k_PA_eq surjective_pairing)
qed

lemma snd_Gauss_Jordan_upt_k_PA:
shows "snd (Gauss_Jordan_upt_k_PA A k) = (Gauss_Jordan_upt_k A k)"
unfolding Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_def Let_def
using snd_foldl_Gauss_Jordan_column_k_eq[of A "Suc k"] by simp

subsubsection\<open>Properties about @{term "Gauss_Jordan_PA"}\<close>

lemma fst_Gauss_Jordan_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "fst (Gauss_Jordan_PA A) ** A = snd (Gauss_Jordan_PA A)"
unfolding Gauss_Jordan_PA_def using fst_Gauss_Jordan_upt_k_PA by simp

lemma Gauss_Jordan_PA_eq:
shows "snd (Gauss_Jordan_PA A)= (Gauss_Jordan A)"
by (metis Gauss_Jordan_PA_def Gauss_Jordan_def snd_Gauss_Jordan_upt_k_PA)

subsubsection\<open>Proving that the transformation has been carried out by means of elementary operations\<close>
text\<open>This function is very similar to @{term "row_add_iterate"} one. It allows us to prove that @{term "fst (Gauss_Jordan_PA A)"} is an invertible matrix.
Concretly, it has been defined to demonstrate that @{term "fst (Gauss_Jordan_PA A)"} has been obtained by means of elementary operations applied to the identity matrix\<close>

fun row_add_iterate_PA :: "(('a::{semiring_1, uminus}^'m::{mod_type} ^'m::{mod_type}) \<times> ('a^'n^'m::{mod_type}))=> nat => 'm => 'n =>
    (('a^'m::{mod_type} ^'m::{mod_type}) \<times> ('a^'n^'m::{mod_type}))"
    where "row_add_iterate_PA (P,A) 0 i j = (if i=0 then (P,A) else (row_add P 0 i (-A $ 0 $ j), row_add A 0 i (-A $ 0 $ j)))"
         | "row_add_iterate_PA (P,A) (Suc n) i j = (if (Suc n = to_nat i) then row_add_iterate_PA (P,A) n i j
                  else row_add_iterate_PA ((row_add P (from_nat (Suc n)) i (- A $ (from_nat (Suc n)) $ j)), (row_add A (from_nat (Suc n)) i (- A $ (from_nat (Suc n)) $ j))) n i j)"

lemma fst_row_add_iterate_PA_preserves_greater_than_n:
  assumes n: "n<nrows A"
  and a: "to_nat a > n"
  shows "fst (row_add_iterate_PA (P,A) n i j) $ a $ b = P $ a $ b"
  using assms
proof (induct n arbitrary: A P)
  case 0
  show ?case unfolding row_add_iterate.simps
  proof (auto)
    assume "i \<noteq> 0"
    hence "a \<noteq> 0" by (metis "0.prems"(2) less_numeral_extra(3) to_nat_0)
    thus "row_add P 0 i (- A $ 0 $ j) $ a $ b = P $ a $ b" unfolding row_add_def by auto
  qed
next
  case (Suc n)
  have row_add_iterate_A: "fst (row_add_iterate_PA (P,A) n i j) $ a $ b = P $ a $ b" using Suc.hyps Suc.prems by auto
  show ?case
  proof (cases "Suc n = to_nat i")
    case True
    show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = P $ a $ b" unfolding row_add_iterate_PA.simps if_P[OF True] using row_add_iterate_A .
  next
    case False
    define A' where "A' = row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
    define P' where "P' = row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
    have row_add_iterate_A': "fst (row_add_iterate_PA (P',A') n i j) $ a $ b = P' $ a $ b" using Suc.hyps Suc.prems unfolding nrows_def by auto
    have from_nat_not_a: "from_nat (Suc n) \<noteq> a" by (metis less_not_refl Suc.prems to_nat_from_nat_id nrows_def)
    show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = P $ a $ b" unfolding row_add_iterate_PA.simps if_not_P[OF False] row_add_iterate_A'[unfolded A'_def P'_def]
      unfolding row_add_def using from_nat_not_a by simp
  qed
qed

lemma snd_row_add_iterate_PA_eq_row_add_iterate:
shows "snd (row_add_iterate_PA (P,A) n i j)  = row_add_iterate A n i j"
proof (induct n arbitrary: P A)
case 0
show ?case unfolding row_add_iterate_PA.simps row_add_iterate.simps by simp
next
case (Suc n)
show ?case unfolding row_add_iterate_PA.simps row_add_iterate.simps by (simp add: Suc.hyps)
qed

lemma row_add_iterate_PA_preserves_pivot_row:
  assumes n: "n<nrows A"
  and a: "to_nat i \<le> n"
  shows "fst (row_add_iterate_PA (P,A) n i j) $ i $ b = P $ i $ b"
using assms
proof (induct n arbitrary: P A)
case 0
show ?case by (metis "0.prems"(2) fst_conv le_0_eq row_add_iterate_PA.simps(1) to_nat_eq_0)
next
case (Suc n)
show ?case
proof (cases "Suc n = to_nat i")
case True show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True]
  proof (rule fst_row_add_iterate_PA_preserves_greater_than_n)
     show "n < nrows A" by (metis Suc.prems(1) Suc_lessD)
     show "n < to_nat i" by (metis True lessI)
  qed
next
case False
define P' where "P' = row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
define A' where "A' = row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
have from_nat_noteq_i: "from_nat (Suc n) \<noteq> i"  using False Suc.prems(1) from_nat_not_eq unfolding nrows_def by blast
have hyp: "fst (row_add_iterate_PA (P', A') n i j) $ i $ b = P' $ i $ b"
proof (rule Suc.hyps)
show "n < nrows A'" using Suc.prems(1) unfolding nrows_def by simp
show "to_nat i \<le> n" using Suc.prems(2) False by simp
qed
show ?thesis unfolding row_add_iterate_PA.simps unfolding if_not_P[OF False] unfolding hyp[unfolded A'_def P'_def]
unfolding row_add_def using from_nat_noteq_i by auto
qed
qed

lemma fst_row_add_iterate_PA_eq_row_add:
  fixes A::"'a::{ring_1}^'n^'m::{mod_type}"
  assumes a_not_i: "a \<noteq> i"
  and n: "n<nrows A"
  and "to_nat a \<le> n"
  shows "fst (row_add_iterate_PA (P,A) n i j) $ a $ b = (row_add P a i (- A $ a $ j)) $ a $ b"
  using assms
proof (induct n arbitrary: A P)
case 0 show ?case by (metis "0.prems"(3) a_not_i fst_conv le_0_eq row_add_iterate_PA.simps(1) to_nat_eq_0)
next
case (Suc n)
show ?case
proof (cases " Suc n = to_nat i")
case True
show ?thesis
unfolding row_add_iterate_PA.simps if_P[OF True]
proof (rule Suc.hyps[OF a_not_i])
show "n < nrows A" by (metis Suc.prems(2) Suc_lessD)
show "to_nat a \<le> n" by (metis Suc.prems(3) True a_not_i le_SucE to_nat_eq)
qed
next
case False note Suc_n_not_i=False
    show ?thesis
    proof (cases "to_nat a = Suc n")
case True
show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = row_add P a i (- A $ a $ j) $ a $ b"
unfolding row_add_iterate_PA.simps if_not_P[OF False]
by (metis Suc_le_lessD True order_refl less_imp_le fst_row_add_iterate_PA_preserves_greater_than_n Suc.prems(2) to_nat_from_nat nrows_def)
next
case False
define A' where "A' = row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
define P' where "P' = row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
      have rw: "fst (row_add_iterate_PA (P',A') n i j) $ a $ b = row_add P' a i (- A' $ a $ j) $ a $ b"
      proof (rule Suc.hyps)
        show "a \<noteq> i" using Suc.prems(1) by simp
        show "n < nrows A'" using Suc.prems(2) unfolding nrows_def by auto
        show "to_nat a \<le> n" using False Suc.prems(3) by simp
      qed

      have rw1: "P' $ a $ b = P $ a $ b"
        unfolding P'_def row_add_def using False Suc.prems unfolding nrows_def by (auto simp add: to_nat_from_nat_id)
      have rw2: "A' $ a $ j = A $ a $ j"
          unfolding A'_def row_add_def using False Suc.prems unfolding nrows_def by (auto simp add: to_nat_from_nat_id)
      have rw3: "P' $ i $ b = P $ i $ b"
          unfolding P'_def row_add_def using False Suc.prems Suc_n_not_i unfolding nrows_def  by (auto simp add: to_nat_from_nat_id)
show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = row_add P a i (- A $ a $ j) $ a $ b"
unfolding row_add_iterate_PA.simps if_not_P[OF Suc_n_not_i] unfolding rw[unfolded P'_def A'_def]
  unfolding A'_def[symmetric] P'_def[symmetric] unfolding row_add_def apply auto
unfolding rw1 rw2 rw3 ..
    qed
  qed
qed

lemma fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
and i::"'rows" and j::"'cols"
and P::"'a::{field}^'rows::{mod_type}^'rows::{mod_type}"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
defines P': "P'== mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
shows "fst (row_add_iterate_PA (P',A') (nrows A - 1) i j)  = fst (Gauss_Jordan_in_ij_PA (P,A) i j)"
proof (unfold Gauss_Jordan_in_ij_PA_def Let_def, vector, auto)
fix ia
have interchange_rw: "interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j = A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j"
using interchange_rows_j[symmetric, of A "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"] by auto
show "fst (row_add_iterate_PA (P', A') (nrows A - Suc 0) i j) $ i $ ia =
         mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) $ i $ ia"
unfolding A' P' interchange_rw
proof (rule row_add_iterate_PA_preserves_pivot_row, unfold nrows_def)
show "CARD('rows) - Suc 0 < CARD('rows)" by auto
show "to_nat i \<le> CARD('rows) - Suc 0" by (metis Suc_pred leD not_less_eq_eq to_nat_less_card zero_less_card_finite)
qed
next
  fix ia iaa
 have interchange_rw: "A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j = interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j"
   using interchange_rows_j[symmetric, of A "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"] by auto
  assume ia_not_i: "ia \<noteq> i"
  have rw: "(- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ j)
    = - mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j) $ ia $ j"
    unfolding interchange_rows_def mult_row_def using ia_not_i by auto
show "fst (row_add_iterate_PA (P', A') (nrows A - Suc 0) i j) $ ia $ iaa
    = row_add (mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j)) ia i
    (- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ j) $ ia $ iaa"  unfolding interchange_rw unfolding A' P' unfolding rw
proof (rule fst_row_add_iterate_PA_eq_row_add, unfold nrows_def)
 show "ia \<noteq> i" using ia_not_i .
 show "CARD('rows) - Suc 0 < CARD('rows)" using zero_less_card_finite by auto
 show "to_nat ia \<le> CARD('rows) - Suc 0" by (metis Suc_pred leD not_less_eq_eq to_nat_less_card zero_less_card_finite)
qed
qed

lemma invertible_fst_row_add_iterate_PA:
  fixes A::"'a::{ring_1}^'n^'m::{mod_type}"
  assumes n: "n<nrows A"
  and inv_P: "invertible P"
  shows "invertible (fst (row_add_iterate_PA (P,A) n i j))"
  using n inv_P
  proof (induct n arbitrary: A P)
  case 0
  show ?case
    proof (unfold row_add_iterate_PA.simps, auto simp add: "0.prems")
      assume i_not_0: "i \<noteq> 0"
      have "row_add P 0 i (- A $ 0 $ j) = row_add (mat 1) 0 i (- A $ 0 $ j) ** P" unfolding row_add_mat_1 ..
      show "invertible (row_add P 0 i (- A $ 0 $ j))"
        by (subst row_add_mat_1[symmetric], rule invertible_mult, auto simp add: invertible_row_add[of 0 i "(- A $ 0 $ j)"] i_not_0 "0.prems")
    qed
    next
    case (Suc n)
    show ?case
      proof (cases "Suc n = to_nat i")
        case True
        show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True] using Suc.hyps Suc.prems by simp
        next
        case False
        show ?thesis
          proof (unfold row_add_iterate_PA.simps if_not_P[OF False], rule Suc.hyps, unfold nrows_def)
             show "n < CARD('m)" using Suc.prems(1) unfolding nrows_def by simp
             show "invertible (row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
                proof (subst row_add_mat_1[symmetric], rule invertible_mult, rule invertible_row_add)
                   show "from_nat (Suc n) \<noteq> i" using False Suc.prems(1) from_nat_not_eq unfolding nrows_def by blast
                   show "invertible P" using Suc.prems(2) .
                qed
          qed
      qed
qed

lemma invertible_fst_Gauss_Jordan_in_ij_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
assumes inv_P: "invertible P"
and not_all_zero: "\<not> (\<forall>m\<ge>i. A $ m $ j = 0)"
shows "invertible (fst (Gauss_Jordan_in_ij_PA (P,A) i j))"
proof (unfold fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA[symmetric], rule invertible_fst_row_add_iterate_PA, simp add: nrows_def,
subst interchange_rows_mat_1[symmetric], subst mult_row_mat_1[symmetric], rule invertible_mult)
show "invertible (mult_row (mat 1) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j))"
    proof (rule invertible_mult_row')
      have "interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j = A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j" by simp
      also have "... \<noteq> 0" by (metis (lifting, mono_tags) LeastI_ex not_all_zero)
      finally show "1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j \<noteq> 0"
      unfolding inverse_eq_divide[symmetric] using nonzero_imp_inverse_nonzero by blast
    qed
show "invertible (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P)"
  by (rule invertible_mult, rule invertible_interchange_rows, rule inv_P)
qed

lemma invertible_fst_Gauss_Jordan_column_k_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
assumes inv_P: "invertible P"
shows "invertible (fst (Gauss_Jordan_column_k_PA (P,i,A) k))"
proof (unfold Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv, auto simp add: inv_P)
fix m
assume i_less_m: "from_nat i \<le> m" and Amk_not_0: "A $ m $ from_nat k \<noteq> 0"
show "invertible (fst (Gauss_Jordan_in_ij_PA (P, A) (from_nat i) (from_nat k)))"
by (rule invertible_fst_Gauss_Jordan_in_ij_PA[OF inv_P], auto intro!: i_less_m Amk_not_0)
qed

lemma invertible_fst_Gauss_Jordan_upt_k_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
shows "invertible (fst (Gauss_Jordan_upt_k_PA A k))"
proof (induct k)
case 0
show ?case unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv by (simp add: invertible_fst_Gauss_Jordan_column_k_PA invertible_mat_1)
next
case (Suc k)
have list_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
define f where "f = foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]"
have f_rw: "f = (fst f, fst (snd f), snd (snd f))" by simp
show ?case unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw unfolding foldl_append unfolding List.foldl.simps using invertible_fst_Gauss_Jordan_column_k_PA
by (metis (mono_tags) Gauss_Jordan_upt_k_PA_def Suc.hyps fst_conv prod.collapse)
qed

lemma invertible_fst_Gauss_Jordan_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
shows "invertible (fst (Gauss_Jordan_PA A))"
by (unfold Gauss_Jordan_PA_def, rule invertible_fst_Gauss_Jordan_upt_k_PA)

definition "P_Gauss_Jordan A = fst (Gauss_Jordan_PA A)"

end


theory Listas
imports Main
begin

section {* El tipo de las listas *}

text {* ('a list) es el tipo de las listas con elementos de tipo 'a *}
datatype 'a lista = Nil | Cons "'a" "'a lista"

text {* Ejemplos de inferencia de tipo. *}
term "Nil"        (* da "lista.Nil" :: "'a lista" *)
term "Cons 1 Nil" (* da "lista.Cons 1 lista.Nil" :: "'a lista" *)

text {* Declaración para acortar los nombres. *}
declare [[names_short]]

text {* Ejemplos de inferencia de tipo con nombres acortados. *}
term "Nil"        (* da "Nil" :: "'a lista" *)
term "Cons 1 Nil" (* da "Cons 1 lista.Nil" :: "'a lista" *)

section {* Funciones sobre listas: conc e inversa *}

text {* (conc xs ys) es la concatenación de las listas xs e ys. Por
  ejemplo,
     conc (Cons a (Cons b Nil)) (Cons c (Cons d Nil))
     = Cons a (Cons b (Cons c (Cons d Nil)))
*}
fun conc :: "'a lista \<Rightarrow> 'a lista \<Rightarrow> 'a lista"
where
  "conc Nil ys         = ys"
| "conc (Cons x xs) ys = Cons x (conc xs ys)"

value "conc (Cons a (Cons b Nil)) (Cons c (Cons d Nil))"
lemma "conc (Cons a (Cons b Nil)) (Cons c (Cons d Nil))
       = Cons a (Cons b (Cons c (Cons d Nil)))" by simp

text {* (inversa xs) es la inversa de la lista xs. Por ejemplo,
*}
fun inversa :: "'a lista \<Rightarrow> 'a lista"
where
  "inversa Nil         = Nil"
| "inversa (Cons x xs) = conc (inversa xs) (Cons x Nil)"

value "inversa (Cons a (Cons b (Cons c Nil)))"
lemma "inversa (Cons a (Cons b (Cons c Nil)))
       = Cons c (Cons b (Cons a Nil))" by simp

section {* Ejemplo de búsqueda descendente de la demostración *}

text {* El objetivo de esta sección es mostrar cómo se conjeturan lemas
  auxiliares para la demostración de la idempotencia de la función
  inversa.

  Se mostrarán cómo los errores de las pruebas ayudan a conjeturar los
  lemas.
*}

text {* Primer intento de prueba de inversa_inversa. *}
theorem inversa_inversa_1:
  "inversa (inversa xs) = xs"
apply (induction xs)
apply auto
oops

text {* Queda sin demostrar el siguiente objetivo:
     inversa (inversa xs) = xs \<Longrightarrow>
     inversa (conc (inversa xs) (Cons x1 Nil)) = Cons x1 xs

  Se observa que contiene la expresión
     inversa (conc (inversa xs) (Cons x1 Nil))
  que se puede simplificar a
     conc (Cons x1 Nil) (inversa (inversa xs))
  con el siguiente lema:
     inversa (conc xs ys) = conc (inversa ys) (inversa xs)
*}

text {* Primer intento de prueba de inversa_conc. *}
lemma inversa_conc_1:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
apply (induction xs)
apply auto
oops

text {* Queda sin demostrar el objetivo
     inversa ys = conc (inversa ys) Nil
  Se puede demostrar con el siguiente lema
     conc xs Nil = xs
*}

text {* Prueba de conc_Nil2. *}
lemma conc_Nil2:
  "conc xs Nil = xs"
apply (induction xs)
apply auto
done

text {* Segundo intento de prueba de inversa_conc usando conc_Nil2. *}
lemma inversa_conc_2:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
apply (induction xs)
apply (auto simp add: conc_Nil2)
oops

text {* Queda sin probar el objetivo
     inversa (conc xs ys) = conc (inversa ys) (inversa xs) \<Longrightarrow>
       conc (conc (inversa ys) (inversa xs)) (Cons x1 Nil) =
       conc (inversa ys) (conc (inversa xs) (Cons x1 Nil))
  que se puede simplificar usando la propiedad asociativa de conc.
*}

text {* Prueba de asociatividad de conc. *}
lemma conc_asoc:
  "conc (conc xs ys) zs = conc xs (conc ys zs)"
apply (induction xs)
apply auto
done

text {* Prueba de inversa_conc usando conc_Nil2 y conc_asoc. *}
lemma inversa_conc:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
apply (induction xs)
apply (auto simp add: conc_Nil2 conc_asoc)
done

text {* Prueba de inversa_inversa usando inversa_conc. *}
theorem inversa_inversa:
  "inversa (inversa xs) = xs"
apply (induction xs)
apply (auto simp add: inversa_conc)
done

text {* Una vez encontrada la demostración, se puede modificar la
  presentación declarando los lemas como reglas de simplificación, como
  se muestra a continuación. *}

lemma conc_Nil2' [simp]:
  "conc xs Nil = xs"
by (induction xs) auto

lemma conc_asoc' [simp]:
  "conc (conc xs ys) zs = conc xs (conc ys zs)"
by (induction xs) auto

lemma inversa_conc' [simp]:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
by (induction xs) auto

theorem inversa_inversa':
  "inversa (inversa xs) = xs"
by (induction xs) auto

end