(* Title: Designs_And_Graphs.thy
   Author: Chelsea Edmonds
*)

section \<open>Graphs and Designs\<close>
text \<open>There are many links between graphs and design - most fundamentally that graphs are designs\<close>

theory Designs_And_Graphs imports Block_Designs Graph_Theory.Digraph Graph_Theory.Digraph_Component
begin

subsection \<open>Non-empty digraphs\<close>
text \<open>First, we define the concept of a non-empty digraph. This mirrors the idea of a "proper design"
in the design theory library\<close>
locale non_empty_digraph = wf_digraph +
  assumes arcs_not_empty: "arcs G \<noteq> {}"

begin

lemma verts_not_empty: "verts G \<noteq> {}"
  using wf arcs_not_empty head_in_verts by fastforce

end

subsection \<open>Arcs to Blocks\<close>
text \<open>A digraph uses a pair of points to define an ordered edge. In the case of simple graphs,
both possible orderings will be in the arcs set. Blocks are inherently unordered, and as such
a method is required to convert between the two representations\<close>
context graph
begin

definition arc_to_block :: "'b \<Rightarrow> 'a set" where
  "arc_to_block e \<equiv> {tail G e, head G e}"

lemma arc_to_block_to_ends: "{fst (arc_to_ends G e), snd (arc_to_ends G e)} = arc_to_block e"
  by (simp add: arc_to_ends_def arc_to_block_def)

lemma arc_to_block_to_ends_swap: "{snd (arc_to_ends G e), fst (arc_to_ends G e)} = arc_to_block e"
  using arc_to_block_to_ends
  by (simp add: arc_to_block_to_ends insert_commute)

lemma arc_to_ends_to_block: "arc_to_block e = {x, y} \<Longrightarrow>
  arc_to_ends G e = (x, y) \<or> arc_to_ends G e = (y, x)"
  by (metis arc_to_block_def arc_to_ends_def doubleton_eq_iff)

lemma arc_to_block_sym: "arc_to_ends G e1 = (u, v) \<Longrightarrow> arc_to_ends G e2 = (v, u) \<Longrightarrow>
  arc_to_block e1 = arc_to_block e2"
  by (simp add: arc_to_block_def arc_to_ends_def insert_commute)

definition arcs_blocks :: "'a set multiset" where
"arcs_blocks \<equiv> mset_set (arc_to_block ` (arcs G))"

lemma  arcs_blocks_ends: "(x, y) \<in> arcs_ends G \<Longrightarrow> {x, y} \<in># arcs_blocks"
proof (auto simp add: arcs_ends_def arcs_blocks_def )
  fix xa
  assume assm1: "(x, y) = arc_to_ends G xa" and assm2: "xa \<in> arcs G"
  obtain z where zin: "z \<in> (arc_to_block ` (arcs G))" and "z = arc_to_block xa"
    using assm2 by blast
  thus "{x, y} \<in> arc_to_block ` (arcs G)" using assm1 arc_to_block_to_ends
    by (metis fst_conv snd_conv)
qed

lemma arc_ends_blocks_subset: "E \<subseteq> arcs G \<Longrightarrow> (x, y) \<in> ((arc_to_ends G) ` E) \<Longrightarrow>
  {x, y} \<in> (arc_to_block ` E)"
  by (auto simp add: arc_to_ends_def arc_to_block_def )

lemma arc_blocks_end_subset: assumes "E \<subseteq> arcs G"  and "{x, y} \<in> (arc_to_block ` E)"
  shows "(x, y) \<in> ((arc_to_ends G) ` E) \<or> (y, x) \<in> ((arc_to_ends G) ` E)"
proof -
  obtain e where "e \<in> E" and "arc_to_block e = {x,y}" using assms
    by fastforce
  then have "arc_to_ends G e = (x, y) \<or> arc_to_ends G e = (y, x)"
    using arc_to_ends_to_block by simp
  thus ?thesis
    by (metis \<open>e \<in> E\<close> image_iff)
qed

lemma arcs_ends_blocks: "{x, y} \<in># arcs_blocks \<Longrightarrow> (x, y) \<in> arcs_ends G \<and> (y, x) \<in> arcs_ends G"
proof (auto simp add: arcs_ends_def arcs_blocks_def )
  fix xa
  assume assm1: "{x, y} = arc_to_block  xa" and assm2: "xa \<in> (arcs G)"
  obtain z where zin: "z \<in> (arc_to_ends G ` (arcs G))" and "z = arc_to_ends G xa"
    using assm2 by blast
  then have "z = (x, y) \<or> z = (y, x)" using arc_to_block_to_ends assm1
    by (metis arc_to_ends_def doubleton_eq_iff fst_conv snd_conv) (* Slow *)
  thus "(x, y) \<in> arc_to_ends G ` (arcs G)" using assm2
    by (metis arcs_ends_def arcs_ends_symmetric sym_arcs zin)
next
  fix xa
  assume assm1: "{x, y} = arc_to_block  xa" and assm2: "xa \<in> (arcs G)"
  thus "(y, x) \<in> arc_to_ends G ` arcs G" using arcs_ends_def
    by (metis dual_order.refl graph.arc_blocks_end_subset graph_axioms graph_symmetric imageI)
qed

lemma arcs_blocks_iff: "{x, y} \<in># arcs_blocks \<longleftrightarrow> (x, y) \<in> arcs_ends G \<and> (y, x) \<in> arcs_ends G"
  using arcs_ends_blocks arcs_blocks_ends by blast

lemma arcs_ends_wf: "(x, y) \<in> arcs_ends G \<Longrightarrow> x \<in> verts G \<and> y \<in> verts G"
  by auto

lemma arcs_blocks_elem: "bl \<in># arcs_blocks \<Longrightarrow> \<exists> x y . bl = {x, y}"
  apply (auto simp add: arcs_blocks_def)
  by (meson arc_to_block_def)

lemma arcs_ends_blocks_wf:
  assumes "bl \<in># arcs_blocks"
  shows "bl \<subseteq> verts G"
proof -
  obtain x y where blpair: "bl = {x, y}" using arcs_blocks_elem assms
    by fastforce
  then have "(x, y) \<in> arcs_ends G" using arcs_ends_blocks assms by simp
  thus ?thesis using arcs_ends_wf blpair by auto
qed

lemma arcs_blocks_simple: "bl \<in># arcs_blocks \<Longrightarrow> count (arcs_blocks) bl = 1"
  by (simp add: arcs_blocks_def)

lemma arcs_blocks_ne: "arcs G \<noteq> {} \<Longrightarrow> arcs_blocks \<noteq> {#}"
  by (simp add: arcs_blocks_iff arcs_blocks_def mset_set_empty_iff)

end

subsection \<open>Graphs are designs\<close>

text \<open>Prove that a graph is a number of different types of designs\<close>
sublocale graph \<subseteq> design "verts G" "arcs_blocks"
  using arcs_ends_blocks_wf arcs_blocks_elem by (unfold_locales) (auto)

sublocale graph \<subseteq> simple_design "verts G" "arcs_blocks"
  using arcs_ends_blocks_wf arcs_blocks_elem arcs_blocks_simple by (unfold_locales) (auto)

locale non_empty_graph = graph + non_empty_digraph

sublocale non_empty_graph \<subseteq> proper_design "verts G" "arcs_blocks"
  using arcs_blocks_ne arcs_not_empty by (unfold_locales) simp

lemma (in graph) graph_block_size: assumes "bl \<in># arcs_blocks" shows "card bl = 2"
proof -
  obtain x y where blrep: "bl = {x, y}" using assms arcs_blocks_elem
    by fastforce
  then have "(x, y) \<in> arcs_ends G" using arcs_ends_blocks assms by simp
  then have "x \<noteq> y" using no_loops using adj_not_same by blast
  thus ?thesis using blrep by simp
qed

sublocale non_empty_graph \<subseteq> block_design "verts G" "arcs_blocks" 2
  using arcs_not_empty graph_block_size arcs_blocks_ne by (unfold_locales) simp_all

subsection \<open>R-regular graphs\<close>
text \<open>To reason on r-regular graphs and their link to designs, we require a number of extensions to
lemmas reasoning around the degrees of vertices\<close>
context sym_digraph
begin

lemma in_out_arcs_reflexive: "v \<in> verts G \<Longrightarrow> (e \<in> (in_arcs G v) \<Longrightarrow>
    \<exists> e' . (e' \<in> (out_arcs G v) \<and> head G e' = tail G e))"
  using symmetric_conv sym_arcs by fastforce

lemma out_in_arcs_reflexive: "v \<in> verts G \<Longrightarrow> (e \<in> (out_arcs G v) \<Longrightarrow>
    \<exists> e' . (e' \<in> (in_arcs G v) \<and> tail G e' = head G e))"
  using symmetric_conv sym_arcs by fastforce

end

context nomulti_digraph
begin

lemma in_arcs_single_per_vert:
  assumes "v \<in> verts G" and "u \<in> verts G"
  assumes "e1 \<in> in_arcs G v" and " e2 \<in> in_arcs G v"
  assumes "tail G e1 = u" and "tail G e2 = u"
  shows "e1 = e2"
proof -
  have in_arcs1: "e1 \<in> arcs G" and in_arcs2: "e2 \<in> arcs G" using assms by auto
  have "arc_to_ends G e1 = arc_to_ends G e2" using assms arc_to_ends_def
    by (metis in_in_arcs_conv)
  thus ?thesis using in_arcs1 in_arcs2 no_multi_arcs by simp
qed

lemma out_arcs_single_per_vert:
  assumes "v \<in> verts G" and "u \<in> verts G"
  assumes "e1 \<in> out_arcs G v" and " e2 \<in> out_arcs G v"
  assumes "head G e1 = u" and "head G e2 = u"
  shows "e1 = e2"
proof -
  have in_arcs1: "e1 \<in> arcs G" and in_arcs2: "e2 \<in> arcs G" using assms by auto
  have "arc_to_ends G e1 = arc_to_ends G e2" using assms arc_to_ends_def
    by (metis in_out_arcs_conv)
  thus ?thesis using in_arcs1 in_arcs2 no_multi_arcs by simp
qed

end

text \<open>Some helpers on the transformation arc definition\<close>
context graph
begin

lemma arc_to_block_is_inj_in_arcs: "inj_on arc_to_block (in_arcs G v)"
  apply (auto simp add: arc_to_block_def inj_on_def)
  by (metis arc_to_ends_def doubleton_eq_iff no_multi_arcs)

lemma arc_to_block_is_inj_out_arcs: "inj_on arc_to_block (out_arcs G v)"
  apply (auto simp add: arc_to_block_def inj_on_def)
  by (metis arc_to_ends_def doubleton_eq_iff no_multi_arcs)

lemma in_out_arcs_reflexive_uniq: "v \<in> verts G \<Longrightarrow> (e \<in> (in_arcs G v) \<Longrightarrow>
    \<exists>! e' . (e' \<in> (out_arcs G v) \<and> head G e' = tail G e))"
  apply auto
    using symmetric_conv apply fastforce
  using out_arcs_single_per_vert by (metis head_in_verts in_out_arcs_conv)

lemma out_in_arcs_reflexive_uniq: "v \<in> verts G \<Longrightarrow> e \<in> (out_arcs G v) \<Longrightarrow>
    \<exists>! e' . (e' \<in> (in_arcs G v) \<and> tail G e' = head G e)"
  apply auto
    using symmetric_conv apply fastforce
  using in_arcs_single_per_vert by (metis tail_in_verts in_in_arcs_conv)

lemma in_eq_out_arc_ends: "(u, v) \<in> ((arc_to_ends G) ` (in_arcs G v)) \<longleftrightarrow>
    (v, u) \<in> ((arc_to_ends G) ` (out_arcs G v))"
  using arc_to_ends_def in_in_arcs_conv in_out_arcs_conv
  by (smt (z3) Pair_inject adj_in_verts(1) dominatesI image_iff out_in_arcs_reflexive_uniq)

lemma in_degree_eq_card_arc_ends: "in_degree G v = card ((arc_to_ends G) ` (in_arcs G v))"
  apply (simp add: in_degree_def)
  using  no_multi_arcs by (metis card_image in_arcs_in_arcs inj_onI)

lemma in_degree_eq_card_arc_blocks: "in_degree G v = card (arc_to_block ` (in_arcs G v))"
  apply (simp add: in_degree_def)
  using no_multi_arcs arc_to_block_is_inj_in_arcs by (simp add: card_image)

lemma out_degree_eq_card_arc_blocks: "out_degree G v = card (arc_to_block ` (out_arcs G v))"
  apply (simp add: out_degree_def)
  using no_multi_arcs arc_to_block_is_inj_out_arcs by (simp add: card_image)

lemma out_degree_eq_card_arc_ends: "out_degree G v = card ((arc_to_ends G) ` (out_arcs G v))"
  apply (simp add: out_degree_def)
  using no_multi_arcs by (metis card_image out_arcs_in_arcs inj_onI)

lemma bij_betw_in_out_arcs: "bij_betw (\<lambda> (u, v) . (v, u)) ((arc_to_ends G) ` (in_arcs G v))
    ((arc_to_ends G) ` (out_arcs G v))"
  apply (auto simp add: bij_betw_def)
    apply (simp add: swap_inj_on)
   apply (metis Pair_inject arc_to_ends_def image_eqI in_eq_out_arc_ends in_in_arcs_conv)
  by (metis arc_to_ends_def imageI in_eq_out_arc_ends in_out_arcs_conv pair_imageI)

lemma in_eq_out_degree: "in_degree G v = out_degree G v"
  using bij_betw_in_out_arcs bij_betw_same_card in_degree_eq_card_arc_ends
    out_degree_eq_card_arc_ends by auto

lemma in_out_arcs_blocks: "arc_to_block ` (in_arcs G v) = arc_to_block ` (out_arcs G v)"
proof (auto)
  fix xa
  assume a1: "xa \<in> arcs G" and a2: "v = head G xa"
  then have "xa \<in> in_arcs G v" by simp
  then obtain e where out: "e \<in> out_arcs G v" and "head G e = tail G xa"
    using out_in_arcs_reflexive_uniq by force
  then have "arc_to_ends G e = (v, tail G xa)"
    by (simp add: arc_to_ends_def)
  then have "arc_to_block xa = arc_to_block e"
    using arc_to_block_sym by (metis a2 arc_to_ends_def)
  then show "arc_to_block xa \<in> arc_to_block ` out_arcs G (head G xa)"
    using out a2 by blast
next
  fix xa
  assume a1: "xa \<in> arcs G" and a2: "v = tail G xa"
  then have "xa \<in> out_arcs G v" by simp
  then obtain e where ina: "e \<in> in_arcs G v" and "tail G e = head G xa"
    using out_in_arcs_reflexive_uniq by force
  then have "arc_to_ends G e = (head G xa, v)"
    by (simp add: arc_to_ends_def)
  then have "arc_to_block xa = arc_to_block e"
    using arc_to_block_sym by (metis a2 arc_to_ends_def)
  then show "arc_to_block xa \<in> arc_to_block ` in_arcs G (tail G xa)"
    using ina a2 by blast
qed

end

text \<open>A regular digraph is defined as one where the in degree equals the out degree which in turn
equals some fixed integer $\mathrm{r}$\<close>
locale regular_digraph = wf_digraph +
  fixes \<r> :: nat
  assumes in_deg_r: "v \<in> verts G \<Longrightarrow> in_degree G v = \<r>"
  assumes out_deg_r: "v \<in> verts G \<Longrightarrow> out_degree G v = \<r>"

locale regular_graph = graph + regular_digraph
begin

lemma rep_vertices_in_blocks [simp]:
  assumes "x \<in> verts G"
  shows "size {# e \<in># arcs_blocks . x \<in> e #} = \<r>"
proof -
  have "\<And> e . e \<in> (arc_to_block ` (arcs G)) \<Longrightarrow> x \<in> e \<Longrightarrow> e \<in> (arc_to_block ` in_arcs G x)"
    using arc_to_block_def in_in_arcs_conv insert_commute insert_iff singleton_iff sym_arcs
      symmetric_conv by fastforce
  then have "{ e \<in> (arc_to_block ` (arcs G)) . x \<in> e} =  (arc_to_block ` (in_arcs G x))"
    using arc_to_block_def by auto
  then have "card { e \<in> (arc_to_block ` (arcs G)) . x \<in> e} = \<r>"
    using in_deg_r in_degree_eq_card_arc_blocks assms by auto
  thus ?thesis
    using arcs_blocks_def finite_arcs by force
qed

end

text \<open>Intro rules for regular graphs\<close>
lemma graph_in_degree_r_imp_reg[intro]: assumes "graph G"
  assumes "(\<And> v . v \<in> (verts G) \<Longrightarrow> in_degree G v = \<r>)"
  shows "regular_graph G \<r>"
proof -
  interpret g: graph G using assms by simp
  interpret wf: wf_digraph G by (simp add: g.wf_digraph_axioms)
  show ?thesis
    using assms(2) g.in_eq_out_degree by (unfold_locales) simp_all
qed

lemma graph_out_degree_r_imp_reg[intro]: assumes "graph G"
  assumes "(\<And> v . v \<in> (verts G) \<Longrightarrow> out_degree G v = \<r>)"
  shows "regular_graph G \<r>"
proof -
  interpret g: graph G using assms by simp
  interpret wf: wf_digraph G by (simp add: g.wf_digraph_axioms)
  show ?thesis
    using assms(2) g.in_eq_out_degree by (unfold_locales) simp_all
qed

text \<open>Regular graphs (non-empty) can be shown to be a constant rep design\<close>
locale non_empty_regular_graph = regular_graph + non_empty_digraph

sublocale non_empty_regular_graph \<subseteq> non_empty_graph
  by unfold_locales

sublocale non_empty_regular_graph \<subseteq> constant_rep_design "verts G" "arcs_blocks" \<r>
  using arcs_blocks_ne arcs_not_empty
  by (unfold_locales)(simp_all add: point_replication_number_def)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Lattice\<close>
theory Predicates_Lattice
  imports
    HOL_Syntax_Bundles_Lattices
    HOL.Boolean_Algebras
begin

lemma inf_predI [intro]:
  assumes "P x"
  and "Q x"
  shows "(P \<sqinter> Q) x"
  using assms by (intro inf1I)

lemma inf_predE [elim]:
  assumes "(P \<sqinter> Q) x"
  obtains "P x" "Q x"
  using assms by (rule inf1E)

lemma inf_predD:
  assumes "(P \<sqinter> Q) x"
  shows "P x" and "Q x"
  using assms by auto

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Cardinality of Bijections\<close>

theory Card_Bijections
imports
  Twelvefold_Way_Entry2
  Twelvefold_Way_Entry3
  Twelvefold_Way_Entry5
  Twelvefold_Way_Entry6
  Twelvefold_Way_Entry8
  Twelvefold_Way_Entry9
  Twelvefold_Way_Entry11
  Twelvefold_Way_Entry12
begin

subsection \<open>Bijections from A to B\<close>

lemma bij_betw_set_is_empty:
  assumes "finite A" "finite B"
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = {}"
using assms bij_betw_same_card by blast

lemma card_bijections_eq_zero:
  assumes "finite A" "finite B"
  assumes "card A \<noteq> card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = 0"
using bij_betw_set_is_empty[OF assms] by (simp only: card_empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on A.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = fact (card B)"
proof -
  have "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = card {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
    using \<open>finite B\<close> \<open>card A = card B\<close> by (metis bij_betw_implies_inj_on_and_card_eq)
  also have "\<dots> = fact (card B)"
    using \<open>finite A\<close> \<open>finite B\<close> \<open>card A = card B\<close> by (simp add: card_extensional_funcset_inj_on)
  finally show ?thesis .
qed

lemma card_bijections:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = fact (card B)"
proof -
  have "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = card {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B}"
    using \<open>finite A\<close> \<open>card A = card B\<close>
    by (metis bij_betw_implies_surj_on_and_card_eq)
  also have "\<dots> = fact (card B)"
    using \<open>finite A\<close> \<open>finite B\<close> \<open>card A = card B\<close>
    by (simp add: card_extensional_funcset_surj_on)
  finally show ?thesis .
qed

subsection \<open>Bijections from A to B up to a Permutation on A\<close>

lemma bij_betw_quotient_domain_permutation_eq_empty:
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B = {}"
using \<open>card A \<noteq> card B\<close> bij_betw_same_card by auto

lemma card_bijections_domain_permutation_eq_0:
  assumes "card A \<noteq> card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 0"
using bij_betw_quotient_domain_permutation_eq_empty[OF assms] by (simp only: card_empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on A.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B
    = {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_inj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_injective_functions_domain_permutation)
qed

lemma card_bijections_domain_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B
    = {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_surj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_surjective_functions_domain_permutation)
qed

lemma card_bijections_domain_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = iverson (card A = card B)"
using assms card_bijections_domain_permutation_eq_0 card_bijections_domain_permutation_eq_1
unfolding iverson_def by auto

subsection \<open>Bijections from A to B up to a Permutation on B\<close>

lemma bij_betw_quotient_range_permutation_eq_empty:
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B = {}"
using \<open>card A \<noteq> card B\<close> bij_betw_same_card by auto

lemma card_bijections_range_permutation_eq_0:
  assumes "card A \<noteq> card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 0"
using bij_betw_quotient_range_permutation_eq_empty[OF assms] by (simp only: card_empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on B.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_inj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: iverson_def card_injective_functions_range_permutation)
qed

lemma card_bijections_range_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_surj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_surjective_functions_range_permutation)
qed

lemma card_bijections_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = iverson (card A = card B)"
using assms card_bijections_range_permutation_eq_0 card_bijections_range_permutation_eq_1
unfolding iverson_def by auto

subsection \<open>Bijections from A to B up to a Permutation on A and B\<close>

lemma bij_betw_quotient_domain_and_range_permutation_eq_empty:
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B = {}"
using \<open>card A \<noteq> card B\<close> bij_betw_same_card by auto

lemma card_bijections_domain_and_range_permutation_eq_0:
  assumes "card A \<noteq> card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 0"
using bij_betw_quotient_domain_and_range_permutation_eq_empty[OF assms] by (simp only: card_empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on A and B.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_inj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: iverson_def card_injective_functions_domain_and_range_permutation)
qed

lemma card_bijections_domain_and_range_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_surj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_surjective_functions_domain_and_range_permutation Partition_diag)
qed

lemma card_bijections_domain_and_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = iverson (card A = card B)"
using assms card_bijections_domain_and_range_permutation_eq_0 card_bijections_domain_and_range_permutation_eq_1
unfolding iverson_def by auto

end


theory GabrielaLimonta
imports "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Vars"
begin

fun gen :: "com \<Rightarrow> (vname * aexp) set"
and "kill" :: "com \<Rightarrow> (vname * aexp) set" where
"gen SKIP = {}" |
"gen (x ::= a) = (if x \<notin> vars a then {(x, a)} else {})" |
"gen (c1 ;; c2) = (gen c1 - kill c2) \<union> gen c2" |
"gen (IF b THEN c1 ELSE c2) = (gen c1 - kill c2) \<inter> gen c2" |
"gen (WHILE b DO c) = gen c" |
"kill SKIP = {}" |
"kill (x ::= a) = {(y,e). y = x \<and> e \<noteq> a} \<union> {(y,e). x \<in> vars e}" |
"kill (c1 ;; c2) = kill c1 \<union> kill c2" |
"kill (IF b THEN c1 ELSE c2) = kill c1 \<union> kill c2" |
"kill (WHILE b DO c) = kill c"

definition AD :: "(vname * aexp) set \<Rightarrow> com \<Rightarrow> (vname * aexp) set" where
"AD A c = gen c \<union> (A - kill c)"

lemma "{(''x'', (N 5)), (''y'', (N 8))} = AD {(''x'', (N 4)), (''y'', (N 8))} (''x'' ::= (N 5))"
by (auto simp: AD_def)

theorem "\<lbrakk> (c,s) \<Rightarrow> s'; \<forall> (x, a) \<in> A. s x = aval a s \<rbrakk>
  \<Longrightarrow> \<forall> (x, a) \<in> AD A c. s' x = aval a s'"
proof (induction arbitrary: A rule: big_step_induct)
print_cases
case (Skip s)
  thus ?case using AD_def by auto
next
case (Assign x' a' s)
  thus ?case using AD_def by (auto split: if_splits)
next
case (Seq c1 s1 s2 c2 s3)
  thus ?case using AD_def sorry
next
case (IfTrue b s c1 t)
  thus ?case using AD_def by auto
next
case (IfFalse b s c2 t)
  thus ?case using AD_def by auto
next
case (WhileFalse b s)
  thus ?case using AD_def and big_step.intros sorry
next
case (WhileTrue b s1 c s2 s3)
  thus ?case using AD_def and big_step.intros sorry
qed

end


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


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

section \<open>Misc word operations\<close>

theory More_Word_Operations
  imports
    "HOL-Library.Word"
    Aligned
    Reversed_Bit_Lists
    More_Misc
    Signed_Words
    Word_Lemmas
begin

definition
  ptr_add :: "'a :: len word \<Rightarrow> nat \<Rightarrow> 'a word" where
  "ptr_add ptr n \<equiv> ptr + of_nat n"

definition
  alignUp :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word" where
 "alignUp x n \<equiv> x + 2 ^ n - 1 AND NOT (2 ^ n - 1)"

lemma alignUp_unfold:
  \<open>alignUp w n = (w + mask n) AND NOT (mask n)\<close>
  by (simp add: alignUp_def mask_eq_exp_minus_1 add_mask_fold)

(* standard notation for blocks of 2^n-1 words, usually aligned;
   abbreviation so it simplifies directly *)
abbreviation mask_range :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" where
  "mask_range p n \<equiv> {p .. p + mask n}"

definition
  w2byte :: "'a :: len word \<Rightarrow> 8 word" where
  "w2byte \<equiv> ucast"

(* Count leading zeros  *)
definition
  word_clz :: "'a::len word \<Rightarrow> nat"
where
  "word_clz w \<equiv> length (takeWhile Not (to_bl w))"

(* Count trailing zeros  *)
definition
  word_ctz :: "'a::len word \<Rightarrow> nat"
where
  "word_ctz w \<equiv> length (takeWhile Not (rev (to_bl w)))"

lemma word_ctz_le:
  "word_ctz (w :: ('a::len word)) \<le> LENGTH('a)"
  apply (clarsimp simp: word_ctz_def)
  using length_takeWhile_le apply (rule order_trans)
  apply simp
  done

lemma word_ctz_less:
  "w \<noteq> 0 \<Longrightarrow> word_ctz (w :: ('a::len word)) < LENGTH('a)"
  apply (clarsimp simp: word_ctz_def eq_zero_set_bl)
  using length_takeWhile_less apply (rule less_le_trans)
  apply auto
  done

lemma take_bit_word_ctz_eq [simp]:
  \<open>take_bit LENGTH('a) (word_ctz w) = word_ctz w\<close>
  for w :: \<open>'a::len word\<close>
  apply (simp add: take_bit_nat_eq_self_iff word_ctz_def to_bl_unfold)
  using length_takeWhile_le apply (rule le_less_trans)
  apply simp
  done

lemma word_ctz_not_minus_1:
  \<open>word_of_nat (word_ctz (w :: 'a :: len word)) \<noteq> (- 1 :: 'a::len word)\<close> if \<open>1 < LENGTH('a)\<close>
proof -
  note word_ctz_le
  also from that have \<open>LENGTH('a) < mask LENGTH('a)\<close>
    by (simp add: less_mask)
  finally have \<open>word_ctz w < mask LENGTH('a)\<close> .
  then have \<open>word_of_nat (word_ctz w) < (word_of_nat (mask LENGTH('a)) :: 'a word)\<close>
    by (simp add: of_nat_word_less_iff)
  also have \<open>\<dots> = - 1\<close>
    by (rule bit_word_eqI) (simp add: bit_simps)
  finally show ?thesis
    by simp
qed

lemma unat_of_nat_ctz_mw:
  "unat (of_nat (word_ctz (w :: 'a :: len word)) :: 'a :: len word) = word_ctz w"
  by simp

lemma unat_of_nat_ctz_smw:
  "unat (of_nat (word_ctz (w :: 'a :: len word)) :: 'a :: len signed word) = word_ctz w"
  by simp

definition
  word_log2 :: "'a::len word \<Rightarrow> nat"
where
  "word_log2 (w::'a::len word) \<equiv> size w - 1 - word_clz w"

(* Bit population count. Equivalent of __builtin_popcount. *)
definition
  pop_count :: "('a::len) word \<Rightarrow> nat"
where
  "pop_count w \<equiv> length (filter id (to_bl w))"

(* Sign extension from bit n *)
definition
  sign_extend :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word"
where
  "sign_extend n w \<equiv> if bit w n then w OR NOT (mask n) else w AND mask n"

lemma sign_extend_eq_signed_take_bit:
  \<open>sign_extend = signed_take_bit\<close>
proof (rule ext)+
  fix n and w :: \<open>'a::len word\<close>
  show \<open>sign_extend n w = signed_take_bit n w\<close>
  proof (rule bit_word_eqI)
    fix q
    assume \<open>q < LENGTH('a)\<close>
    then show \<open>bit (sign_extend n w) q \<longleftrightarrow> bit (signed_take_bit n w) q\<close>
      by (auto simp add: bit_signed_take_bit_iff
        sign_extend_def bit_and_iff bit_or_iff bit_not_iff bit_mask_iff not_less
        exp_eq_0_imp_not_bit not_le min_def)
  qed
qed

definition
  sign_extended :: "nat \<Rightarrow> 'a::len word \<Rightarrow> bool"
where
  "sign_extended n w \<equiv> \<forall>i. n < i \<longrightarrow> i < size w \<longrightarrow> bit w i = bit w n"

lemma ptr_add_0 [simp]:
  "ptr_add ref 0 = ref "
  unfolding ptr_add_def by simp

lemma pop_count_0[simp]:
  "pop_count 0 = 0"
  by (clarsimp simp:pop_count_def)

lemma pop_count_1[simp]:
  "pop_count 1 = 1"
  by (clarsimp simp:pop_count_def to_bl_1)

lemma pop_count_0_imp_0:
  "(pop_count w = 0) = (w = 0)"
  apply (rule iffI)
   apply (clarsimp simp:pop_count_def)
   apply (subst (asm) filter_empty_conv)
   apply (clarsimp simp:eq_zero_set_bl)
   apply fast
  apply simp
  done

lemma word_log2_zero_eq [simp]:
  \<open>word_log2 0 = 0\<close>
  by (simp add: word_log2_def word_clz_def word_size)

lemma word_log2_unfold:
  \<open>word_log2 w = (if w = 0 then 0 else Max {n. bit w n})\<close>
  for w :: \<open>'a::len word\<close>
proof (cases \<open>w = 0\<close>)
  case True
  then show ?thesis
    by simp
next
  case False
  then obtain r where \<open>bit w r\<close>
    by (auto simp add: bit_eq_iff)
  then have \<open>Max {m. bit w m} = LENGTH('a) - Suc (length
    (takeWhile (Not \<circ> bit w) (rev [0..<LENGTH('a)])))\<close>
    by (subst Max_eq_length_takeWhile [of _ \<open>LENGTH('a)\<close>])
      (auto simp add: bit_imp_le_length)
  then have \<open>word_log2 w = Max {x. bit w x}\<close>
    by (simp add: word_log2_def word_clz_def word_size to_bl_unfold rev_map takeWhile_map)
  with \<open>w \<noteq> 0\<close> show ?thesis
    by simp
qed

lemma word_log2_eqI:
  \<open>word_log2 w = n\<close>
  if \<open>w \<noteq> 0\<close> \<open>bit w n\<close> \<open>\<And>m. bit w m \<Longrightarrow> m \<le> n\<close>
  for w :: \<open>'a::len word\<close>
proof -
  from \<open>w \<noteq> 0\<close> have \<open>word_log2 w = Max {n. bit w n}\<close>
    by (simp add: word_log2_unfold)
  also have \<open>Max {n. bit w n} = n\<close>
    using that by (auto intro: Max_eqI)
  finally show ?thesis .
qed

lemma bit_word_log2:
  \<open>bit w (word_log2 w)\<close> if \<open>w \<noteq> 0\<close>
proof -
  from \<open>w \<noteq> 0\<close> have \<open>\<exists>r. bit w r\<close>
    by (simp add: bit_eq_iff)
  then obtain r where \<open>bit w r\<close> ..
  from \<open>w \<noteq> 0\<close> have \<open>word_log2 w = Max {n. bit w n}\<close>
    by (simp add: word_log2_unfold)
  also have \<open>Max {n. bit w n} \<in> {n. bit w n}\<close>
    using \<open>bit w r\<close> by (subst Max_in) auto
  finally show ?thesis
    by simp
qed

lemma word_log2_maximum:
  \<open>n \<le> word_log2 w\<close> if \<open>bit w n\<close>
proof -
  have \<open>n \<le> Max {n. bit w n}\<close>
    using that by (auto intro: Max_ge)
  also from that have \<open>w \<noteq> 0\<close>
    by force
  then have \<open>Max {n. bit w n} = word_log2 w\<close>
    by (simp add: word_log2_unfold)
  finally show ?thesis .
qed

lemma word_log2_nth_same:
  "w \<noteq> 0 \<Longrightarrow> bit w (word_log2 w)"
  by (drule bit_word_log2) simp

lemma word_log2_nth_not_set:
  "\<lbrakk> word_log2 w < i ; i < size w \<rbrakk> \<Longrightarrow> \<not> bit w i"
  using word_log2_maximum [of w i] by auto

lemma word_log2_highest:
  assumes a: "bit w i"
  shows "i \<le> word_log2 w"
  using a by (simp add: word_log2_maximum)

lemma word_log2_max:
  "word_log2 w < size w"
  apply (cases \<open>w = 0\<close>)
   apply (simp_all add: word_size)
  apply (drule bit_word_log2)
  apply (fact bit_imp_le_length)
  done

lemma word_clz_0[simp]:
  "word_clz (0::'a::len word) = LENGTH('a)"
  unfolding word_clz_def by simp

lemma word_clz_minus_one[simp]:
  "word_clz (-1::'a::len word) = 0"
  unfolding word_clz_def by simp

lemma is_aligned_alignUp[simp]:
  "is_aligned (alignUp p n) n"
  by (simp add: alignUp_def is_aligned_mask mask_eq_decr_exp word_bw_assocs)

lemma alignUp_le[simp]:
  "alignUp p n \<le> p + 2 ^ n - 1"
  unfolding alignUp_def by (rule word_and_le2)

lemma alignUp_idem:
  fixes a :: "'a::len word"
  assumes "is_aligned a n" "n < LENGTH('a)"
  shows "alignUp a n = a"
  using assms unfolding alignUp_def
  by (metis add_cancel_right_right add_diff_eq and_mask_eq_iff_le_mask mask_eq_decr_exp mask_out_add_aligned order_refl word_plus_and_or_coroll2)

lemma alignUp_not_aligned_eq:
  fixes a :: "'a :: len word"
  assumes al: "\<not> is_aligned a n"
  and     sz: "n < LENGTH('a)"
  shows   "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
proof -
  have anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz) fact+

  then have um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0" using sz
    by (meson Euclidean_Division.div_eq_0_iff le_m1_iff_lt measure_unat order_less_trans
              unat_less_power word_less_sub_le word_mod_less_divisor)

  have "a + 2 ^ n - 1 = (a div 2 ^ n) * 2 ^ n + (a mod 2 ^ n) + 2 ^ n - 1"
    by (simp add: word_mod_div_equality)
  also have "\<dots> = (a mod 2 ^ n - 1) + (a div 2 ^ n + 1) * 2 ^ n"
    by (simp add: field_simps)
  finally show "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n" using sz
    unfolding alignUp_def
    apply (subst mask_eq_decr_exp [symmetric])
    apply (erule ssubst)
    apply (subst neg_mask_is_div)
    apply (simp add: word_arith_nat_div)
    apply (subst unat_word_ariths(1) unat_word_ariths(2))+
    apply (subst uno_simps)
    apply (subst unat_1)
    apply (subst mod_add_right_eq)
    apply simp
    apply (subst power_mod_div)
    apply (subst div_mult_self1)
     apply simp
    apply (subst um)
    apply simp
    apply (subst mod_mod_power)
    apply simp
    apply (subst word_unat_power, subst Abs_fnat_hom_mult)
    apply (subst mult_mod_left)
    apply (subst power_add [symmetric])
    apply simp
    apply (subst Abs_fnat_hom_1)
    apply (subst Abs_fnat_hom_add)
    apply (subst word_unat_power, subst Abs_fnat_hom_mult)
    apply (subst word_unat.Rep_inverse[symmetric], subst Abs_fnat_hom_mult)
    apply simp
    done
qed

lemma alignUp_ge:
  fixes a :: "'a :: len word"
  assumes sz: "n < LENGTH('a)"
  and nowrap: "alignUp a n \<noteq> 0"
  shows "a \<le> alignUp a n"
proof (cases "is_aligned a n")
  case True
  then show ?thesis using sz
    by (subst alignUp_idem, simp_all)
next
  case False

  have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
    by (metis le_add_diff_inverse2 less_mult_imp_div_less order_less_imp_le power_add unsigned_less)

  have"2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
    by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right lt0 nat_le_power_trans nat_less_le)
  moreover have "2 ^ n * (unat a div 2 ^ n + 1) \<noteq> 2 ^ LENGTH('a)" using nowrap sz
    apply -
    apply (erule contrapos_nn)
    apply (subst alignUp_not_aligned_eq [OF False sz])
    apply (subst unat_arith_simps)
    apply (subst unat_word_ariths)
    apply (subst unat_word_ariths)
    apply simp
    apply (subst mult_mod_left)
    apply (simp add: unat_div field_simps power_add[symmetric] mod_mod_power)
    done
  ultimately have lt: "2 ^ n * (unat a div 2 ^ n + 1) < 2 ^ LENGTH('a)" by simp

  have "a = a div 2 ^ n * 2 ^ n + a mod 2 ^ n" by (rule word_mod_div_equality [symmetric])
  also have "\<dots> < (a div 2 ^ n + 1) * 2 ^ n" using sz lt
    apply (simp add: field_simps)
    apply (rule word_add_less_mono1)
    apply (rule word_mod_less_divisor)
    apply (simp add: word_less_nat_alt)
    apply (subst unat_word_ariths)
    apply (simp add: unat_div)
    done
  also have "\<dots> =  alignUp a n"
    by (rule alignUp_not_aligned_eq [symmetric]) fact+
  finally show ?thesis by (rule order_less_imp_le)
qed

lemma alignUp_le_greater_al:
  fixes x :: "'a :: len word"
  assumes le: "a \<le> x"
  and     sz: "n < LENGTH('a)"
  and     al: "is_aligned x n"
  shows   "alignUp a n \<le> x"
proof (cases "is_aligned a n")
  case True
  then show ?thesis using sz le by (simp add: alignUp_idem)
next
  case False

  then have anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz)

  from al obtain k where xk: "x = 2 ^ n * of_nat k" and kv: "k < 2 ^ (LENGTH('a) - n)"
    by (auto elim!: is_alignedE)

  then have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
    using sz
    apply (subst unat_of_nat_eq)
     apply (erule order_less_le_trans)
     apply simp
    apply (subst mult.commute)
    apply simp
    apply (rule nat_less_power_trans)
     apply simp
    apply simp
    done

  have au: "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
    by (rule alignUp_not_aligned_eq) fact+
  also have "\<dots> \<le> of_nat k * 2 ^ n"
  proof (rule word_mult_le_mono1 [OF inc_le _ kn])
    show "a div 2 ^ n < of_nat k" using kv xk le sz anz
      by (simp add: alignUp_div_helper)

    show "(0:: 'a word) < 2 ^ n" using sz by (simp add: p2_gt_0 sz)
  qed

  finally show ?thesis using xk by (simp add: field_simps)
qed

lemma alignUp_is_aligned_nz:
  fixes a :: "'a :: len word"
  assumes al: "is_aligned x n"
  and     sz: "n < LENGTH('a)"
  and     ax: "a \<le> x"
  and     az: "a \<noteq> 0"
  shows   "alignUp (a::'a :: len word) n \<noteq> 0"
proof (cases "is_aligned a n")
  case True
  then have "alignUp a n = a" using sz by (simp add: alignUp_idem)
  then show ?thesis using az by simp
next
  case False
  then have anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz)

  {
    assume asm: "alignUp a n = 0"

    have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
      by (metis le_add_diff_inverse2 less_mult_imp_div_less order_less_imp_le power_add unsigned_less)

    have leq: "2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
      by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right lt0 nat_le_power_trans
                order_less_imp_le)

    from al obtain k where  kv: "k < 2 ^ (LENGTH('a) - n)" and xk: "x = 2 ^ n * of_nat k"
      by (auto elim!: is_alignedE)

    then have "a div 2 ^ n < of_nat k" using ax sz anz
      by (rule alignUp_div_helper)

    then have r: "unat a div 2 ^ n < k" using sz
      by (simp flip: drop_bit_eq_div unat_drop_bit_eq) (metis leI le_unat_uoi unat_mono)

    have "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
      by (rule alignUp_not_aligned_eq) fact+

    then have "\<dots> = 0" using asm by simp
    then have "2 ^ LENGTH('a) dvd 2 ^ n * (unat a div 2 ^ n + 1)"
      using sz by (simp add: unat_arith_simps ac_simps)
                  (simp add: unat_word_ariths mod_simps mod_eq_0_iff_dvd)
    with leq have "2 ^ n * (unat a div 2 ^ n + 1) = 2 ^ LENGTH('a)"
      by (force elim!: le_SucE)
    then have "unat a div 2 ^ n = 2 ^ LENGTH('a) div 2 ^ n - 1"
      by (metis (no_types, hide_lams) Groups.add_ac(2) add.right_neutral
                add_diff_cancel_left' div_le_dividend div_mult_self4 gr_implies_not0
                le_neq_implies_less power_eq_0_iff zero_neq_numeral)
    then have "unat a div 2 ^ n = 2 ^ (LENGTH('a) - n) - 1"
      using sz by (simp add: power_sub)
    then have "2 ^ (LENGTH('a) - n) - 1 < k" using r
      by simp
    then have False using kv by simp
  } then show ?thesis by clarsimp
qed

lemma alignUp_ar_helper:
  fixes a :: "'a :: len word"
  assumes al: "is_aligned x n"
  and     sz: "n < LENGTH('a)"
  and    sub: "{x..x + 2 ^ n - 1} \<subseteq> {a..b}"
  and    anz: "a \<noteq> 0"
  shows "a \<le> alignUp a n \<and> alignUp a n + 2 ^ n - 1 \<le> b"
proof
  from al have xl: "x \<le> x + 2 ^ n - 1" by (simp add: is_aligned_no_overflow)

  from xl sub have ax: "a \<le> x"
    by auto

  show "a \<le> alignUp a n"
  proof (rule alignUp_ge)
    show "alignUp a n \<noteq> 0" using al sz ax anz
      by (rule alignUp_is_aligned_nz)
  qed fact+

  show "alignUp a n + 2 ^ n - 1 \<le> b"
  proof (rule order_trans)
    from xl show tp: "x + 2 ^ n - 1 \<le> b" using sub
      by auto

    from ax have "alignUp a n \<le> x"
      by (rule alignUp_le_greater_al) fact+
    then have "alignUp a n + (2 ^ n - 1) \<le> x + (2 ^ n - 1)"
      using xl al is_aligned_no_overflow' olen_add_eqv word_plus_mcs_3 by blast
    then show "alignUp a n + 2 ^ n - 1 \<le> x + 2 ^ n - 1"
      by (simp add: field_simps)
  qed
qed

lemma alignUp_def2:
  "alignUp a sz = a + 2 ^ sz - 1 AND NOT (mask sz)"
  by (simp add: alignUp_def flip: mask_eq_decr_exp)

lemma alignUp_def3:
  "alignUp a sz = 2^ sz + (a - 1 AND NOT (mask sz))"
  by (simp add: alignUp_def2 is_aligned_triv field_simps mask_out_add_aligned)

lemma  alignUp_plus:
  "is_aligned w us \<Longrightarrow> alignUp (w + a) us  = w + alignUp a us"
  by (clarsimp simp: alignUp_def2 mask_out_add_aligned field_simps)

lemma alignUp_distance:
  "alignUp (q :: 'a :: len word) sz - q \<le> mask sz"
  by (metis (no_types) add.commute add_diff_cancel_left alignUp_def2 diff_add_cancel
                       mask_2pm1 subtract_mask(2) word_and_le1 word_sub_le_iff)

lemma is_aligned_diff_neg_mask:
  "is_aligned p sz \<Longrightarrow> (p - q AND NOT (mask sz)) = (p - ((alignUp q sz) AND NOT (mask sz)))"
  apply (clarsimp simp only:word_and_le2 diff_conv_add_uminus)
  apply (subst mask_out_add_aligned[symmetric]; simp)
  apply (simp add: eq_neg_iff_add_eq_0)
  apply (subst add.commute)
  apply (simp add: alignUp_distance is_aligned_neg_mask_eq mask_out_add_aligned and_mask_eq_iff_le_mask flip: mask_eq_x_eq_0)
  done

lemma word_clz_max:
  "word_clz w \<le> size (w::'a::len word)"
  unfolding word_clz_def
  by (metis length_takeWhile_le word_size_bl)

lemma word_clz_nonzero_max:
  fixes w :: "'a::len word"
  assumes nz: "w \<noteq> 0"
  shows "word_clz w < size (w::'a::len word)"
proof -
  {
    assume a: "word_clz w = size (w::'a::len word)"
    hence "length (takeWhile Not (to_bl w)) = length (to_bl w)"
      by (simp add: word_clz_def word_size)
    hence allj: "\<forall>j\<in>set(to_bl w). \<not> j"
      by (metis a length_takeWhile_less less_irrefl_nat word_clz_def)
    hence "to_bl w = replicate (length (to_bl w)) False"
      using eq_zero_set_bl nz by fastforce
    hence "w = 0"
      by (metis to_bl_0 word_bl.Rep_eqD word_bl_Rep')
    with nz have False by simp
  }
  thus ?thesis using word_clz_max
    by (fastforce intro: le_neq_trans)
qed

(* Sign extension from bit n. *)

lemma bin_sign_extend_iff [bit_simps]:
  \<open>bit (sign_extend e w) i \<longleftrightarrow> bit w (min e i)\<close>
  if \<open>i < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
  using that by (simp add: sign_extend_def bit_simps min_def)

lemma sign_extend_bitwise_if:
  "i < size w \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> (if i < e then bit w i else bit w e)"
  by (simp add: word_size bit_simps)

lemma sign_extend_bitwise_if'  [word_eqI_simps]:
  \<open>i < LENGTH('a) \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> (if i < e then bit w i else bit w e)\<close>
  for w :: \<open>'a::len word\<close>
  using sign_extend_bitwise_if [of i w e] by (simp add: word_size)

lemma sign_extend_bitwise_disj:
  "i < size w \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> i \<le> e \<and> bit w i \<or> e \<le> i \<and> bit w e"
  by (auto simp: sign_extend_bitwise_if)

lemma sign_extend_bitwise_cases:
  "i < size w \<Longrightarrow> bit (sign_extend e w) i \<longleftrightarrow> (i \<le> e \<longrightarrow> bit w i) \<and> (e \<le> i \<longrightarrow> bit w e)"
  by (auto simp: sign_extend_bitwise_if)

lemmas sign_extend_bitwise_disj' = sign_extend_bitwise_disj[simplified word_size]
lemmas sign_extend_bitwise_cases' = sign_extend_bitwise_cases[simplified word_size]

(* Often, it is easier to reason about an operation which does not overwrite
   the bit which determines which mask operation to apply. *)
lemma sign_extend_def':
  "sign_extend n w = (if bit w n then w OR NOT (mask (Suc n)) else w AND mask (Suc n))"
  by (rule bit_word_eqI) (auto simp add: bit_simps sign_extend_eq_signed_take_bit min_def less_Suc_eq_le)

lemma sign_extended_sign_extend:
  "sign_extended n (sign_extend n w)"
  by (clarsimp simp: sign_extended_def word_size sign_extend_bitwise_if)

lemma sign_extended_iff_sign_extend:
  "sign_extended n w \<longleftrightarrow> sign_extend n w = w"
  apply auto
   apply (auto simp add: bit_eq_iff)
    apply (simp_all add: bit_simps sign_extend_eq_signed_take_bit not_le min_def sign_extended_def word_size split: if_splits)
  using le_imp_less_or_eq apply auto[1]
   apply (metis bit_imp_le_length nat_less_le)
  apply (metis Suc_leI Suc_n_not_le_n le_trans nat_less_le)
  done

lemma sign_extended_weaken:
  "sign_extended n w \<Longrightarrow> n \<le> m \<Longrightarrow> sign_extended m w"
  unfolding sign_extended_def by (cases "n < m") auto

lemma sign_extend_sign_extend_eq:
  "sign_extend m (sign_extend n w) = sign_extend (min m n) w"
  by (rule bit_word_eqI) (simp add: sign_extend_eq_signed_take_bit bit_simps)

lemma sign_extended_high_bits:
  "\<lbrakk> sign_extended e p; j < size p; e \<le> i; i < j \<rbrakk> \<Longrightarrow> bit p i = bit p j"
  by (drule (1) sign_extended_weaken; simp add: sign_extended_def)

lemma sign_extend_eq:
  "w AND mask (Suc n) = v AND mask (Suc n) \<Longrightarrow> sign_extend n w = sign_extend n v"
  by (simp flip: take_bit_eq_mask add: sign_extend_eq_signed_take_bit signed_take_bit_eq_iff_take_bit_eq)

lemma sign_extended_add:
  assumes p: "is_aligned p n"
  assumes f: "f < 2 ^ n"
  assumes e: "n \<le> e"
  assumes "sign_extended e p"
  shows "sign_extended e (p + f)"
proof (cases "e < size p")
  case True
  note and_or = is_aligned_add_or[OF p f]
  have "\<not> bit f e"
    using True e less_2p_is_upper_bits_unset[THEN iffD1, OF f]
    by (fastforce simp: word_size)
  hence i: "bit (p + f) e = bit p e"
    by (simp add: and_or bit_simps)
  have fm: "f AND mask e = f"
    by (fastforce intro: subst[where P="\<lambda>f. f AND mask e = f", OF less_mask_eq[OF f]]
                  simp: mask_twice e)
  show ?thesis
    using assms
     apply (simp add: sign_extended_iff_sign_extend sign_extend_def i)
     apply (simp add: and_or word_bw_comms[of p f])
     apply (clarsimp simp: word_ao_dist fm word_bw_assocs split: if_splits)
    done
next
  case False thus ?thesis
    by (simp add: sign_extended_def word_size)
qed

lemma sign_extended_neq_mask:
  "\<lbrakk>sign_extended n ptr; m \<le> n\<rbrakk> \<Longrightarrow> sign_extended n (ptr AND NOT (mask m))"
  by (fastforce simp: sign_extended_def word_size neg_mask_test_bit bit_simps)

definition
  "limited_and (x :: 'a :: len word) y \<longleftrightarrow> (x AND y = x)"

lemma limited_and_eq_0:
  "\<lbrakk> limited_and x z; y AND NOT z = y \<rbrakk> \<Longrightarrow> x AND y = 0"
  unfolding limited_and_def
  apply (subst arg_cong2[where f="(AND)"])
    apply (erule sym)+
  apply (simp(no_asm) add: word_bw_assocs word_bw_comms word_bw_lcs)
  done

lemma limited_and_eq_id:
  "\<lbrakk> limited_and x z; y AND z = z \<rbrakk> \<Longrightarrow> x AND y = x"
  unfolding limited_and_def
  by (erule subst, fastforce simp: word_bw_lcs word_bw_assocs word_bw_comms)

lemma lshift_limited_and:
  "limited_and x z \<Longrightarrow> limited_and (x << n) (z << n)"
  unfolding limited_and_def
  by (metis push_bit_and)

lemma rshift_limited_and:
  "limited_and x z \<Longrightarrow> limited_and (x >> n) (z >> n)"
  unfolding limited_and_def
  by (metis drop_bit_and)

lemmas limited_and_simps1 = limited_and_eq_0 limited_and_eq_id

lemmas is_aligned_limited_and
    = is_aligned_neg_mask_eq[unfolded mask_eq_decr_exp, folded limited_and_def]

lemmas limited_and_simps = limited_and_simps1
       limited_and_simps1[OF is_aligned_limited_and]
       limited_and_simps1[OF lshift_limited_and]
       limited_and_simps1[OF rshift_limited_and]
       limited_and_simps1[OF rshift_limited_and, OF is_aligned_limited_and]
       not_one

definition
  from_bool :: "bool \<Rightarrow> 'a::len word" where
  "from_bool b \<equiv> case b of True \<Rightarrow> of_nat 1
                         | False \<Rightarrow> of_nat 0"

lemma from_bool_eq:
  \<open>from_bool = of_bool\<close>
  by (simp add: fun_eq_iff from_bool_def)

lemma from_bool_0:
  "(from_bool x = 0) = (\<not> x)"
  by (simp add: from_bool_def split: bool.split)

lemma from_bool_eq_if':
  "((if P then 1 else 0) = from_bool Q) = (P = Q)"
  by (cases Q) (simp_all add: from_bool_def)

definition
  to_bool :: "'a::len word \<Rightarrow> bool" where
  "to_bool \<equiv> (\<noteq>) 0"

lemma to_bool_and_1:
  "to_bool (x AND 1) \<longleftrightarrow> bit x 0"
  by (simp add: to_bool_def and_one_eq mod_2_eq_odd)

lemma to_bool_from_bool [simp]:
  "to_bool (from_bool r) = r"
  unfolding from_bool_def to_bool_def
  by (simp split: bool.splits)

lemma from_bool_neq_0 [simp]:
  "(from_bool b \<noteq> 0) = b"
  by (simp add: from_bool_def split: bool.splits)

lemma from_bool_mask_simp [simp]:
  "(from_bool r :: 'a::len word) AND 1 = from_bool r"
  unfolding from_bool_def
  by (clarsimp split: bool.splits)

lemma from_bool_1 [simp]:
  "(from_bool P = 1) = P"
  by (simp add: from_bool_def split: bool.splits)

lemma ge_0_from_bool [simp]:
  "(0 < from_bool P) = P"
  by (simp add: from_bool_def split: bool.splits)

lemma limited_and_from_bool:
  "limited_and (from_bool b) 1"
  by (simp add: from_bool_def limited_and_def split: bool.split)

lemma to_bool_1 [simp]: "to_bool 1" by (simp add: to_bool_def)
lemma to_bool_0 [simp]: "\<not>to_bool 0" by (simp add: to_bool_def)

lemma from_bool_eq_if:
  "(from_bool Q = (if P then 1 else 0)) = (P = Q)"
  by (cases Q) (simp_all add: from_bool_def)

lemma to_bool_eq_0:
  "(\<not> to_bool x) = (x = 0)"
  by (simp add: to_bool_def)

lemma to_bool_neq_0:
  "(to_bool x) = (x \<noteq> 0)"
  by (simp add: to_bool_def)

lemma from_bool_all_helper:
  "(\<forall>bool. from_bool bool = val \<longrightarrow> P bool)
      = ((\<exists>bool. from_bool bool = val) \<longrightarrow> P (val \<noteq> 0))"
  by (auto simp: from_bool_0)

lemma fold_eq_0_to_bool:
  "(v = 0) = (\<not> to_bool v)"
  by (simp add: to_bool_def)

lemma from_bool_to_bool_iff:
  "w = from_bool b \<longleftrightarrow> to_bool w = b \<and> (w = 0 \<or> w = 1)"
  by (cases b) (auto simp: from_bool_def to_bool_def)

lemma from_bool_eqI:
  "from_bool x = from_bool y \<Longrightarrow> x = y"
  unfolding from_bool_def
  by (auto split: bool.splits)

lemma neg_mask_in_mask_range:
  "is_aligned ptr bits \<Longrightarrow> (ptr' AND NOT(mask bits) = ptr) = (ptr' \<in> mask_range ptr bits)"
  apply (erule is_aligned_get_word_bits)
   apply (rule iffI)
    apply (drule sym)
    apply (simp add: word_and_le2)
    apply (subst word_plus_and_or_coroll, word_eqI_solve)
    apply (metis bit.disj_ac(2) bit.disj_conj_distrib2 le_word_or2 word_and_max word_or_not)
   apply clarsimp
   apply (smt add.right_neutral eq_iff is_aligned_neg_mask_eq mask_out_add_aligned neg_mask_mono_le
              word_and_not)
  apply (simp add: power_overflow mask_eq_decr_exp)
  done

lemma aligned_offset_in_range:
  "\<lbrakk> is_aligned (x :: 'a :: len word) m; y < 2 ^ m; is_aligned p n; n \<ge> m; n < LENGTH('a) \<rbrakk>
   \<Longrightarrow> (x + y \<in> {p .. p + mask n}) = (x \<in> mask_range p n)"
  apply (subst disjunctive_add)
   apply (simp add: bit_simps)
  apply (erule is_alignedE')
   apply (auto simp add: bit_simps not_le)[1]
   apply (metis less_2p_is_upper_bits_unset)
  apply (simp only: is_aligned_add_or word_ao_dist flip: neg_mask_in_mask_range)
  apply (subgoal_tac \<open>y AND NOT (mask n) = 0\<close>)
   apply simp
  apply (metis (full_types) is_aligned_mask is_aligned_neg_mask less_mask_eq word_bw_comms(1) word_bw_lcs(1))
  done

lemma mask_range_to_bl':
  "\<lbrakk> is_aligned (ptr :: 'a :: len word) bits; bits < LENGTH('a) \<rbrakk>
   \<Longrightarrow> mask_range ptr bits
       = {x. take (LENGTH('a) - bits) (to_bl x) = take (LENGTH('a) - bits) (to_bl ptr)}"
  apply (rule set_eqI, rule iffI)
   apply clarsimp
   apply (subgoal_tac "\<exists>y. x = ptr + y \<and> y < 2 ^ bits")
    apply clarsimp
    apply (subst is_aligned_add_conv)
       apply assumption
      apply simp
    apply simp
   apply (rule_tac x="x - ptr" in exI)
   apply (simp add: add_diff_eq[symmetric])
   apply (simp only: word_less_sub_le[symmetric])
   apply (rule word_diff_ls')
    apply (simp add: field_simps mask_eq_decr_exp)
   apply assumption
  apply simp
  apply (subgoal_tac "\<exists>y. y < 2 ^ bits \<and> to_bl (ptr + y) = to_bl x")
   apply clarsimp
   apply (rule conjI)
    apply (erule(1) is_aligned_no_wrap')
   apply (simp only: add_diff_eq[symmetric] mask_eq_decr_exp)
   apply (rule word_plus_mono_right)
    apply simp
   apply (erule is_aligned_no_wrap')
   apply simp
  apply (rule_tac x="of_bl (drop (LENGTH('a) - bits) (to_bl x))" in exI)
  apply (rule context_conjI)
   apply (rule order_less_le_trans [OF of_bl_length])
    apply simp
   apply simp
  apply (subst is_aligned_add_conv)
     apply assumption
    apply simp
  apply (drule sym)
  apply (simp add: word_rep_drop)
  done

lemma mask_range_to_bl:
  "is_aligned (ptr :: 'a :: len word) bits
   \<Longrightarrow> mask_range ptr bits
        = {x. take (LENGTH('a) - bits) (to_bl x) = take (LENGTH('a) - bits) (to_bl ptr)}"
  apply (erule is_aligned_get_word_bits)
   apply (erule(1) mask_range_to_bl')
  apply (rule set_eqI)
  apply (simp add: power_overflow mask_eq_decr_exp)
  done

lemma aligned_mask_range_cases:
  "\<lbrakk> is_aligned (p :: 'a :: len word) n; is_aligned (p' :: 'a :: len word) n' \<rbrakk>
   \<Longrightarrow> mask_range p n \<inter> mask_range p' n' = {} \<or>
       mask_range p n \<subseteq> mask_range p' n' \<or>
       mask_range p n \<supseteq> mask_range p' n'"
  apply (simp add: mask_range_to_bl)
  apply (rule Meson.disj_comm, rule disjCI)
  apply auto
  apply (subgoal_tac "(\<exists>n''. LENGTH('a) - n = (LENGTH('a) - n') + n'')
                    \<or> (\<exists>n''. LENGTH('a) - n' = (LENGTH('a) - n) + n'')")
   apply (fastforce simp: take_add)
  apply arith
  done

lemma aligned_mask_range_offset_subset:
  assumes al: "is_aligned (ptr :: 'a :: len word) sz" and al': "is_aligned x sz'"
  and szv: "sz' \<le> sz"
  and xsz: "x < 2 ^ sz"
  shows "mask_range (ptr+x) sz' \<subseteq> mask_range ptr sz"
  using al
proof (rule is_aligned_get_word_bits)
  assume p0: "ptr = 0" and szv': "LENGTH ('a) \<le> sz"
  then have "(2 ::'a word) ^ sz = 0" by simp
  show ?thesis using p0
    by (simp add: \<open>2 ^ sz = 0\<close> mask_eq_decr_exp)
next
  assume szv': "sz < LENGTH('a)"

  hence blah: "2 ^ (sz - sz') < (2 :: nat) ^ LENGTH('a)"
    using szv by auto
  show ?thesis using szv szv'
    apply auto
    using al assms(4) is_aligned_no_wrap' apply blast
    apply (simp only: flip: add_diff_eq add_mask_fold)
    apply (subst add.assoc, rule word_plus_mono_right)
     using al' is_aligned_add_less_t2n xsz
     apply fastforce
    apply (simp add: field_simps szv al is_aligned_no_overflow)
    done
qed

lemma aligned_mask_ranges_disjoint:
  "\<lbrakk> is_aligned (p :: 'a :: len word) n; is_aligned (p' :: 'a :: len word) n';
     p AND NOT(mask n') \<noteq> p'; p' AND NOT(mask n) \<noteq> p \<rbrakk>
   \<Longrightarrow> mask_range p n \<inter> mask_range p' n' = {}"
  using aligned_mask_range_cases
  by (auto simp: neg_mask_in_mask_range)

lemma aligned_mask_ranges_disjoint2:
  "\<lbrakk> is_aligned p n; is_aligned ptr bits; n \<ge> m; n < size p; m \<le> bits;
     (\<forall>y < 2 ^ (n - m). p + (y << m) \<notin> mask_range ptr bits) \<rbrakk>
   \<Longrightarrow> mask_range p n \<inter> mask_range ptr bits = {}"
  apply safe
  apply (simp only: flip: neg_mask_in_mask_range)
  apply simp
  apply (drule_tac x="x AND mask n >> m" in spec)
  apply (auto simp add: and_mask_less_size wsst_TYs multiple_mask_trivia neg_mask_twice
                        word_bw_assocs max_absorb2)
   apply (erule notE)

  apply (simp add: shiftr_mask2)
   apply (rule and_mask_less')
  apply simp
  apply (subst (asm) disjunctive_add)
   apply (simp add: bit_simps)
  apply auto
  apply (erule notE)
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps)
  done

lemma word_clz_sint_upper[simp]:
  "LENGTH('a) \<ge> 3 \<Longrightarrow> sint (of_nat (word_clz (w :: 'a :: len word)) :: 'a sword) \<le> int (LENGTH('a))"
  using word_clz_max [of w]
  apply (simp add: word_size)
  apply (subst signed_take_bit_int_eq_self)
    apply simp_all
   apply (metis negative_zle of_nat_numeral semiring_1_class.of_nat_power)
  apply (drule small_powers_of_2)
  apply (erule le_less_trans)
  apply simp
  done

lemma word_clz_sint_lower[simp]:
  "LENGTH('a) \<ge> 3
   \<Longrightarrow> - sint (of_nat (word_clz (w :: 'a :: len word)) :: 'a signed word) \<le> int (LENGTH('a))"
  apply (subst sint_eq_uint)
  using word_clz_max [of w]
   apply (simp_all add: word_size)
  apply (rule not_msb_from_less)
  apply (simp add: word_less_nat_alt)
  apply (subst take_bit_nat_eq_self)
   apply (simp add: le_less_trans)
  apply (drule small_powers_of_2)
  apply (erule le_less_trans)
  apply simp
  done

lemma mask_range_subsetD:
  "\<lbrakk> p' \<in> mask_range p n; x' \<in> mask_range p' n'; n' \<le> n; is_aligned p n; is_aligned p' n' \<rbrakk> \<Longrightarrow>
   x' \<in> mask_range p n"
  using aligned_mask_step by fastforce

lemma nasty_split_lt:
  "\<lbrakk> (x :: 'a:: len word) < 2 ^ (m - n); n \<le> m; m < LENGTH('a::len) \<rbrakk>
     \<Longrightarrow> x * 2 ^ n + (2 ^ n - 1) \<le> 2 ^ m - 1"
  apply (simp only: add_diff_eq)
  apply (subst mult_1[symmetric], subst distrib_right[symmetric])
  apply (rule word_sub_mono)
     apply (rule order_trans)
      apply (rule word_mult_le_mono1)
        apply (rule inc_le)
        apply assumption
       apply (subst word_neq_0_conv[symmetric])
       apply (rule power_not_zero)
       apply simp
      apply (subst unat_power_lower, simp)+
      apply (subst power_add[symmetric])
      apply (rule power_strict_increasing)
       apply simp
      apply simp
     apply (subst power_add[symmetric])
     apply simp
    apply simp
   apply (rule word_sub_1_le)
   apply (subst mult.commute)
   apply (subst shiftl_t2n[symmetric])
   apply (rule word_shift_nonzero)
     apply (erule inc_le)
    apply simp
   apply (unat_arith)
  apply (drule word_power_less_1)
  apply simp
  done

lemma nasty_split_less:
  "\<lbrakk>m \<le> n; n \<le> nm; nm < LENGTH('a::len); x < 2 ^ (nm - n)\<rbrakk>
   \<Longrightarrow> (x :: 'a word) * 2 ^ n + (2 ^ m - 1) < 2 ^ nm"
  apply (simp only: word_less_sub_le[symmetric])
  apply (rule order_trans [OF _ nasty_split_lt])
     apply (rule word_plus_mono_right)
      apply (rule word_sub_mono)
         apply (simp add: word_le_nat_alt)
        apply simp
       apply (simp add: word_sub_1_le[OF power_not_zero])
      apply (simp add: word_sub_1_le[OF power_not_zero])
     apply (rule is_aligned_no_wrap')
      apply (rule is_aligned_mult_triv2)
     apply simp
    apply (erule order_le_less_trans, simp)
   apply simp+
  done

lemma add_mult_in_mask_range:
  "\<lbrakk> is_aligned (base :: 'a :: len word) n; n < LENGTH('a); bits \<le> n; x < 2 ^ (n - bits) \<rbrakk>
   \<Longrightarrow> base + x * 2^bits \<in> mask_range base n"
  by (simp add: is_aligned_no_wrap' mask_2pm1 nasty_split_lt word_less_power_trans2
                word_plus_mono_right)

lemma from_to_bool_last_bit:
  "from_bool (to_bool (x AND 1)) = x AND 1"
  by (metis from_bool_to_bool_iff word_and_1)

lemma sint_ctz:
  "LENGTH('a) > 2
   \<Longrightarrow> 0 \<le> sint (of_nat (word_ctz (x :: 'a :: len word)) :: 'a signed word)
        \<and> sint (of_nat (word_ctz x) :: 'a signed word) \<le> int (LENGTH('a))"
  apply (subgoal_tac "LENGTH('a) < 2 ^ (LENGTH('a) - 1)")
   apply (rule conjI)
    apply (metis len_signed order_le_less_trans sint_of_nat_ge_zero word_ctz_le)
   apply (metis int_eq_sint len_signed sint_of_nat_le word_ctz_le)
  using small_powers_of_2 [of \<open>LENGTH('a)\<close>] by simp

lemma unat_of_nat_word_log2:
  "LENGTH('a) < 2 ^ LENGTH('b)
   \<Longrightarrow> unat (of_nat (word_log2 (n :: 'a :: len word)) :: 'b :: len word) = word_log2 n"
  by (metis less_trans unat_of_nat_eq word_log2_max word_size)

lemma aligned_mask_diff:
  "\<lbrakk> is_aligned (dest :: 'a :: len word) bits; is_aligned (ptr :: 'a :: len word) sz;
     bits \<le> sz; sz < LENGTH('a); dest < ptr \<rbrakk>
   \<Longrightarrow> mask bits + dest < ptr"
  apply (frule_tac p' = ptr in aligned_mask_range_cases, assumption)
  apply (elim disjE)
    apply (drule_tac is_aligned_no_overflow_mask, simp)+
    apply (simp add: algebra_split_simps word_le_not_less)
   apply (drule is_aligned_no_overflow_mask; fastforce)
  apply (simp add: is_aligned_weaken algebra_split_simps)
  apply (auto simp add: not_le)
  using is_aligned_no_overflow_mask leD apply blast
  apply (meson aligned_add_mask_less_eq is_aligned_weaken le_less_trans)
  done

end


theory CKA
  imports "$AFP/Kleene_Algebra/Kleene_Algebra"
begin

no_notation
  Transitive_Closure.trancl ("(_\<^sup>+)" [1000] 999)

context kleene_algebra begin

definition trancl :: "'a \<Rightarrow> 'a" ("_\<^sup>+" [101] 100) where
  "x\<^sup>+ \<equiv> x\<^sup>\<star>\<cdot>x"

lemma trancl_ext: "x \<le> x\<^sup>+"
  by (metis mult_oner star_slide_var star_unfoldl_eq subdistl trancl_def)

lemma trancl_unfoldr: "x + x\<^sup>+\<cdot>x = x\<^sup>+"
  by (metis add_0_left add_commute mult_onel star_slide_var star_zero trancl_def troeger)

lemma trancl_inductr: "z + y\<cdot>x \<le> y \<Longrightarrow> z\<cdot>x\<^sup>+ \<le> y"
  by (metis add_ub2 distrib_left order_trans star_inductr star_slide_var star_unfoldl_eq trancl_def)

lemma trancl_unfoldl: "x + x\<cdot>x\<^sup>+ = x\<^sup>+"
  by (metis mult_assoc star_slide_var trancl_def trancl_unfoldr)

lemma trancl_inductl: "z + x\<cdot>y \<le> y \<Longrightarrow> x\<^sup>+\<cdot>z \<le> y"
  by (metis add_lub mult_assoc order_prop star_inductl subdistl trancl_def)

lemma star_trancl: "x\<^sup>+ = x \<cdot> x\<^sup>\<star>"
  by (metis star_slide_var trancl_def)

lemma star_trancl2: "x\<^sup>\<star> = 1 + x\<^sup>+"
  by (metis star_trancl star_unfoldl_eq)

end

class par_dioid = join_semilattice_zero + one +
  fixes par :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<parallel>" 70)
  assumes par_assoc: "(x\<parallel>y)\<parallel>z = x\<parallel>(y\<parallel>z)"
  and par_comm: "x\<parallel>y = y\<parallel>x"
  and par_distl: "x\<parallel>(y+z) = x\<parallel>y+x\<parallel>z"
  and par_unitl: "1\<parallel>x = x"
  and par_annil: "0\<parallel>x = 0"
begin

(* Parallel operator *)
lemma par_comml: "y\<parallel>(x\<parallel>z) = x\<parallel>(y\<parallel>z)"
  by (metis par_assoc par_comm)

lemma par_distr: "(x+y)\<parallel>z = x\<parallel>z+y\<parallel>z"
  by (metis par_comm par_distl)

lemma par_isor: "x \<le> y \<Longrightarrow> x\<parallel>z \<le> y\<parallel>z"
  by (metis less_eq_def par_distr)

lemma par_isol: "x \<le> y \<Longrightarrow> z\<parallel>x \<le> z\<parallel>y"
  by (metis less_eq_def par_distl)

lemma par_unitr: "x\<parallel>1 = x"
  by (metis par_comm par_unitl)

lemma par_annir: "x\<parallel>0 = 0"
  by (metis par_annil par_comm)

lemma par_subdistl: "x\<parallel>z \<le> (x + y)\<parallel>z"
  by (metis order_prop par_distr)

lemma par_subdistr: "z\<parallel>x \<le> z\<parallel>(x + y)"
  by (metis par_comm par_subdistl)

lemma par_double_iso: "w \<le> x \<and> y \<le> z \<longrightarrow> w\<parallel>y \<le> x\<parallel>z"
  by (metis order_trans par_isol par_isor)

end

class trioid = dioid + par_dioid

class cka = trioid + kleene_algebra +
  assumes exchange: "(w\<parallel>x)\<cdot>(y\<parallel>z) \<le> (w\<cdot>y)\<parallel>(x\<cdot>z)"
begin

lemma mult_incl: "x\<cdot>y \<le> x\<parallel>y"
  by (metis par_unitl par_unitr exchange mult_onel mult_oner)

lemma small_exchange1: "(x\<parallel>y)\<cdot>z \<le> x\<parallel>(y\<cdot>z)"
  by (metis par_unitl exchange mult_oner)

lemma small_exchange2: "x\<cdot>(y\<parallel>z) \<le> (x\<cdot>y)\<parallel>z"
  by (metis par_unitr exchange mult_onel)

end

class ckat = cka +
  fixes B :: "'a set"
  assumes test_idem:     "p \<in> B \<Longrightarrow> p\<cdot>p = p"
  and test_top:      "p \<in> B \<Longrightarrow> p \<le> 1"

  and test_exchangel: "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> (p\<parallel>q)\<cdot>(x\<parallel>y) = (p\<cdot>x)\<parallel>(q\<cdot>y)"
  and test_exchanger: "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> (x\<parallel>y)\<cdot>(p\<parallel>q) = (x\<cdot>p)\<parallel>(y\<cdot>q)"

  and test_eq:        "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> p\<parallel>q = p\<cdot>q"

  and test_add_closed:  "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> (p + q) \<in> B"
  and test_mult_closed: "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> (p \<cdot> q) \<in> B"
  and test_par_closed:  "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> (p \<parallel> q) \<in> B"
begin

  lemma everything_preserves_tests:
    assumes test_one_closed: "1 \<in> B"
    and p_test: "p \<in> B"
    shows "p\<cdot>x = x\<cdot>p"
  proof -
    have "p\<cdot>x = (1\<parallel>p)\<cdot>(x\<parallel>1)"
      by (metis par_unitl par_unitr)
    also have "... = (1\<cdot>x)\<parallel>(p\<cdot>1)"
      by (metis p_test test_exchangel test_one_closed)
    also have "... = (1\<cdot>p)\<parallel>(x\<cdot>1)"
      by (metis mult_onel mult_oner par_comm)
    also have "... = x\<cdot>p"
      by (metis p_test par_unitl par_unitr test_exchanger test_one_closed)
    finally show ?thesis .
  qed

  lemma "p\<cdot>x \<le> x\<cdot>q"

lemma "p \<in> B \<Longrightarrow> p\<parallel>p = p"
  by (metis test_eq test_idem)

lemma test_comm: "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> p\<cdot>q = q\<cdot>p"
  by (metis par_comm test_eq)

lemma "\<lbrakk>p \<in> B; q \<in> B; p\<cdot>x = p\<cdot>x\<cdot>q\<rbrakk> \<Longrightarrow> p\<cdot>x \<le> q"
  nitpick oops

lemma test_assocl: "p \<in> B \<Longrightarrow> p\<cdot>(x\<parallel>y) \<le> (p\<cdot>x)\<parallel>(p\<cdot>y)"
  by (metis test_eq test_exchangel test_idem)

lemma test_assocr: "p \<in> B \<Longrightarrow> (x\<parallel>y)\<cdot>p \<le> (x\<cdot>p)\<parallel>(y\<cdot>p)"
  by (metis test_eq test_exchanger test_idem)

lemma encoding_eq: "\<lbrakk>p \<in> B; q \<in> B\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>x\<cdot>q \<longleftrightarrow> p\<cdot>x \<le> x\<cdot>q"
proof (default, metis mult_assoc mult_isor mult_onel test_top)
  assume assm: "p \<in> B" "q \<in> B" "p\<cdot>x \<le> x\<cdot>q"
  have "p\<cdot>x \<le> p\<cdot>x\<cdot>q"
    by (metis assm(1) assm(3) mult_assoc mult_isol test_idem)
  moreover have "p\<cdot>x\<cdot>q \<le> p\<cdot>x"
    by (metis (full_types) assm(2) mult_isol mult_oner test_top)
  finally show "p \<in> B \<Longrightarrow> q \<in> B \<Longrightarrow> p \<cdot> x \<le> x \<cdot> q \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
    by metis
qed

end
end


theory NameEquiv
imports RhoCalc
begin

section\<open>Name equivalence\<close>
text\<open>Similarly to structural congruence, we build up an equivalence of names:
To quote an unquoted name n gives n back:
\begin{equation}
n \equiv_N \left\ulcorner \left\urcorner n \right\ulcorner \right\urcorner.
\end{equation}
Furtermore, the quotations of two structurally equivalent processes are name equivalent \<close>

fun name_equivalence :: "n \<Rightarrow> n \<Rightarrow> bool" (infix "=N" 52)
  where
    "zero =N `Input x y P\<acute> = False"
  | "zero =N `Lift _ _\<acute> = False"
  | "zero =N `Par P Q\<acute> = (Null =C (P\<parallel>Q))"
  | "zero =N `\<acute>a`\<acute> = (zero =N a)"
  | "zero =N zero = True"

  | "((`(Input x y P)\<acute>) =N `Input p q Q\<acute>) = ((Input x y P)  =C (Input p q Q))"
  | "((`(Input x y P)\<acute>) =N `Lift _ _\<acute>) = False"
  | "((`(Input x y P)\<acute>) =N `Par _ _\<acute>) = False"
  | "((`(Input x y P)\<acute>) =N zero) = False"
  | "((`(Input x y P)\<acute>) =N `\<acute>a`\<acute>) = (`(Input x y P)\<acute> =N a)"

  | "((`Lift x P\<acute>) =N `Lift y Q\<acute>) = (Lift x P =C Lift y Q)"
  | "((`Lift x P\<acute>) =N `Input _ _ _\<acute>) = False"
  | "((`Lift x P\<acute>) =N `Par _ _\<acute>) = False"
  | "((`Lift x P\<acute>) =N zero) = False"
  | "((`Lift x P\<acute>) =N `\<acute>a`\<acute>) = (`(Lift x P)\<acute> =N a)"

  | "((`P\<parallel>Q\<acute>) =N (`A\<parallel>B\<acute>)) = ((P\<parallel>Q) =C (A\<parallel>B))"
  | "((`P\<parallel>Q\<acute>) =N (`Lift _ _\<acute>)) = False"
  | "((`P\<parallel>Q\<acute>) =N (`Input _ _ _\<acute>)) = False"
  | "((`P\<parallel>Q\<acute>) =N zero) = ((P\<parallel>Q) =C Null)"
  | "((`P\<parallel>Q\<acute>) =N (`\<acute>a`\<acute>)) = (`(P\<parallel>Q)\<acute> =N a)"

  | "`\<acute>a`\<acute> =N `Input x y P\<acute> = (a =N `Input x y P\<acute>)"
  | "`\<acute>a`\<acute> =N `Lift x P\<acute> = (a =N `Lift x P\<acute>)"
  | "`\<acute>a`\<acute> =N `Par P Q\<acute> = (a =N `Par P Q\<acute>)"
  | "`\<acute>a`\<acute> =N `\<acute>b`\<acute> = (a =N b)"
  | "`\<acute>a`\<acute> =N zero = (a =N zero)"

text\<open>Some examples\<close>
value "`\<acute>zero`\<acute> =N zero"
value "`\<acute>`\<acute>zero`\<acute>`\<acute> =N zero"
value "newName 3 =N three"
value "newName 3 =N zero"
value "three =N newName 3"
value "`((One\<parallel>Two)\<parallel>(Three\<parallel>Four))\<parallel>Null\<acute> =N `((One\<parallel>Three)\<parallel>(Two\<parallel>Four))\<acute>"
value "`p \<parallel> (\<^bold>0 \<parallel> q)\<acute> =N `q \<parallel> p\<acute>"
theorem testNameEQ1:
  shows "`p \<parallel> (\<^bold>0 \<parallel> q)\<acute> =N `q \<parallel> p\<acute>"
using parCommutative by auto

subsection\<open>Proof of equivalence relation\<close>
text\<open>Reflexivity and symmetry is proven: only transitivity is unfinished.
(It also relies on unfinished proofs of structural congruence)
\<close>

theorem name_equivalence_reflexive:
  shows "reflexive name_equivalence"
apply auto
proof -
  fix r
  show "r =N r"
  using congruReflexive by (induction r rule: name_equivalence.induct, auto)
qed

theorem name_equivalence_symmetric:
  assumes "x =N y"
  shows "y =N x"
using assms congruSymmetric eqSymmetric by (induct x rule: name_equivalence.induct, auto)

theorem name_equivalence_transitive:
  assumes "a =N b" and "b =N c"
  shows "a =N c"
(* I dont know how to make an induction argument here which runs over all three variables
using assms apply (induct a c rule: name_equivalence.induct)
apply auto
apply (simp add: assms congruTransitive eqTransitive)
*)
sorry

end


theory prop_85
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"

  fun zip2 :: "'a list => 'b list => ('a * 'b) list" where
  "zip2 (Nil2) y = Nil2"
  | "zip2 (Cons2 z x2) (Nil2) = Nil2"
  | "zip2 (Cons2 z x2) (Cons2 x3 x4) = Cons2 (z, x3) (zip2 x2 x4)"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster zip2 len append rev *)
  (*hipster rev*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes rev.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes rev.simps)

lemma lemma_ab [thy_expl]: "append (rev x5) (rev y5) = rev (append y5 x5)"
by (hipster_induct_schemes rev.simps)

(*hipster len zip2*)
lemma lemma_ac [thy_expl]: "zip2 Nil2 x1 = zip2 x1 Nil2"
by (hipster_induct_schemes len.simps zip2.simps)

lemma lemma_ad [thy_expl]: "zip2 Nil2 x1 = zip2 y1 Nil2"
by (hipster_induct_schemes len.simps zip2.simps)

(*hipster rev zip2*)
lemma lemma_ae [thy_expl]: "zip2 x2 (append x2 y2) = zip2 x2 x2"
by (hipster_induct_schemes rev.simps zip2.simps)

lemma lemma_af [thy_expl]: "zip2 (append x1 y1) x1 = zip2 x1 x1"
by (hipster_induct_schemes rev.simps zip2.simps)

(*hipster zip2 append*)
lemma lemma_ah [thy_expl]: "zip2 (append x4 x4) (Cons2 y4 Nil2) = zip2 x4 (Cons2 y4 Nil2)"
by (hipster_induct_schemes zip2.simps append.simps)

lemma lemma_ai [thy_expl]: "zip2 (Cons2 x1 Nil2) (append y1 y1) = zip2 (Cons2 x1 Nil2) y1"
by (hipster_induct_schemes zip2.simps append.simps)

(*hipster len rev append*)
lemma lemma_aj [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes len.simps rev.simps append.simps)

lemma unknown []: "zip2 (append x y) (rev x) = zip2 x (rev x)"
oops

lemma unknown []: "zip2 (rev x) (append x y) = zip2 (rev x) x"
oops

(*hipster len rev append zip2*)
(*lemma lemma_ag [thy_expl]: "len (prop_85.append x4 y4) = len (prop_85.append y4 x4)"
by (hipster_induct_schemes prop_85.len.simps prop_85.rev.simps prop_85.append.simps prop_85.zip2.simps Nat.exhaust)*)

lemma unknown []: "zip2 (prop_85.append x y) (prop_85.rev x) = zip2 x (prop_85.rev x)"
oops

lemma unknown []: "zip2 (prop_85.rev x) (prop_85.append x y) = zip2 (prop_85.rev x) x"
oops

lemma unknown []: "zip2 (prop_85.append x x) (prop_85.rev x) = zip2 x (prop_85.rev x)"
oops

lemma unknown []: "zip2 (prop_85.rev x) (prop_85.append x x) = zip2 (prop_85.rev x) x"
oops

(*hipster len *)

fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
| "equal2 (Z) (S z) = False"
| "equal2 (S x2) (Z) = False"
| "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun lenb :: "Nat list => Nat" where
  "lenb (Nil2) = Z"
  | "lenb (Cons2 y xs) = S (lenb xs)"
fun leneq :: "Nat list \<Rightarrow> Nat list \<Rightarrow> bool" where
  "leneq x y = equal2 (lenb x) (lenb y)"
  fun appendb :: "Nat list => Nat list => Nat list" where
  "appendb (Nil2) y = y"
  | "appendb (Cons2 z xs) y = Cons2 z (appendb xs y)"
  fun revb :: "Nat list => Nat list" where
  "revb (Nil2) = Nil2"
  | "revb (Cons2 y xs) = appendb (revb xs) (Cons2 y (Nil2))"

(*hipster equal2*)
lemma lemma_ag [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes prop_85.equal2.simps)

lemma lemma_ak [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes prop_85.equal2.simps)

lemma lemma_al [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes prop_85.equal2.simps)

(*hipster_cond equal2 len*)
lemma lemma_am [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes prop_85.equal2.simps prop_85.len.simps)

(*hipster_cond equal2 leneq len*)

(*hipster equal2 leneq appendb*)
lemma lemma_an [thy_expl]: "appendb (appendb x1 y1) z1 = appendb x1 (appendb y1 z1)"
by (hipster_induct_schemes prop_85.equal2.simps prop_85.leneq.simps prop_85.appendb.simps)

lemma lemma_ao [thy_expl]: "leneq (appendb x1 y1) (appendb x1 z1) = leneq y1 z1"
by (hipster_induct_schemes prop_85.equal2.simps prop_85.leneq.simps prop_85.appendb.simps)

lemma lemma_ap [thy_expl]: "equal2 Z (lenb x2) = leneq y2 (appendb y2 x2)"
by (hipster_induct_schemes prop_85.equal2.simps prop_85.leneq.simps prop_85.appendb.simps)

(*
hipster_cond equal2 leneq appendb

hipster_cond leneq equal2

hipster leneq equal2 lenb

hipster_cond leneq equal2 lenb

hipster_cond leneq appendb len

hipster equal2 leneq len appendb

hipster_cond equal2 leneq len appendb

hipster_cond leneq appendb revb equal2*)

(*hipster append len*)

lemma xx[thy_expl]: "len (append xs (Cons2 y ys)) = S (len (prop_85.append xs ys))"
by (hipster_induct_schemes append.simps len.simps list.exhaust)

lemma lemma_applen [thy_expl]: "len (append x y) = len (append y x)"
by (hipster_induct_schemes append.simps len.simps list.exhaust)
(*
apply(induction x y rule: zip2.induct)
apply(simp_all)
apply(metis thy_expl append.simps len.simps list.exhaust)
apply(metis thy_expl zip2.simps append.simps len.simps list.exhaust)
apply(metis (full_types) thy_expl zip2.simps append.simps len.simps list.exhaust)
by (hipster_induct_schemes append.simps len.simps list.exhaust)*)

lemma lemma_at [thy_expl]: "len (rev x3) = len x3"
by (hipster_induct_schemes len.simps rev.simps append.simps)

(*
len (x++y) == len (y++x) proved by induction on  y, x

zip (x++y) (rev x) == zip x (rev x) failed to be proved
zip (rev x) (x++y) == zip (rev x) x failed to be proved

zip x x++++zip y z == zip (x++y) (x++z) proved by induction on  x

zip (rev x) (rev x) == prev (zip x x) proved by induction on  x

zip (x++y) (rev x) == zip x (rev x) failed to be proved
zip (rev x) (x++y) == zip (rev x) x failed to be proved
zip (rev x) (x++x) == zip (rev x) x failed to be proved
zip (x++x) (rev x) == zip x (rev x) failed to be proved

prop_85 failed to be proved

*)

  theorem x0 :
    "((len xs) = (len ys)) ==>
       ((zip2 (rev xs) (rev ys)) = (rev (zip2 xs ys)))"
       by (hipster_induct_schemes len.simps zip2.simps rev.simps)

(*
    apply(induction xs ys rule: zip2.induct)
apply simp_all
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end