chapter "Rotational Symmetries of the Tetrahedron"

theory Tetrahedron
imports Orbit_Stabiliser
begin

section "Definition of the Tetrahedron and its Rotations"

text \<open>
  In this section we will use the orbit-stabiliser theorem to count the number of rotational symmetries
  of a tetrahedron.

  The tetrahedron will be defined as a set of four vertices, labelled A, B, C, and D. A rotation
  is defined as a function between the vertices.
\<close>

datatype Vertex = A | B | C | D
definition vertices :: "Vertex set" where
  "vertices = {A, B, C, D}"

type_synonym Rotation = "(Vertex \<Rightarrow> Vertex)"

text \<open>
We define four primitive rotations explicitly. The axis of each rotation is the line through a vertex
that is perpendicular to the face opposite to the vertex. Every rotation is by 120 degrees counter clockwise.

We also define the identity as a possible rotation.
\<close>

definition rotate_A :: Rotation where
  "rotate_A = (\<lambda>v. (case v of A \<Rightarrow> A | B \<Rightarrow> C | C \<Rightarrow> D | D \<Rightarrow> B))"
definition rotate_B :: Rotation where
  "rotate_B = (\<lambda>v. (case v of A \<Rightarrow> D | B \<Rightarrow> B | C \<Rightarrow> A | D \<Rightarrow> C))"
definition rotate_C :: Rotation where
  "rotate_C = (\<lambda>v. (case v of A \<Rightarrow> B | B \<Rightarrow> D | C \<Rightarrow> C | D \<Rightarrow> A))"
definition rotate_D :: Rotation where
  "rotate_D = (\<lambda>v. (case v of A \<Rightarrow> C | B \<Rightarrow> A | C \<Rightarrow> B | D \<Rightarrow> D))"

named_theorems simple_rotations
declare rotate_A_def [simple_rotations] rotate_B_def [simple_rotations] rotate_C_def [simple_rotations] rotate_D_def [simple_rotations]

definition simple_rotations :: "Rotation set" where
  "simple_rotations = {id, rotate_A, rotate_B, rotate_C, rotate_D}"

text \<open>
All other rotations are combinations of the previously defined simple rotations. We define these
inductively.
\<close>
inductive_set complex_rotations :: "Rotation set" where
  simp: "r \<in> simple_rotations \<Longrightarrow> r \<in> complex_rotations" |
  comp: "r \<in> simple_rotations \<Longrightarrow> s \<in> complex_rotations \<Longrightarrow> (r \<circ> s) \<in> complex_rotations"

section "Properties of Rotations"

text \<open>
In this section we prove some basic properties of rotations that will be useful later.
We begin by showing that rotations are bijections.
\<close>

lemma simple_rotations_inj:
  assumes r:"r \<in> simple_rotations"
  shows "inj r"
  using r unfolding simple_rotations_def
  by safe
     (rule injI; rename_tac a b; case_tac a; case_tac b;
      simp add: simple_rotations
     )+

lemma simple_rotations_surj:
  assumes r:"r \<in> simple_rotations"
  shows "surj r"
  using r unfolding simple_rotations_def
  by safe
     (rename_tac a; case_tac a;
      auto simp add: simple_rotations Vertex.split
     )+

lemma simple_rotations_bij:
  assumes r:"r \<in> simple_rotations"
  shows "bij r"
  by (simp add: r bij_def simple_rotations_surj simple_rotations_inj)

lemma complex_rotations_bij: "r \<in> complex_rotations \<Longrightarrow> bij r"
proof(induction r rule: complex_rotations.induct)
  case (simp r) then show ?case using simple_rotations_bij by simp
next
  case (comp r s) then show ?case using bij_comp simple_rotations_bij by blast
qed

lemma simple_rotation_bij_corollary: "r \<in> simple_rotations \<Longrightarrow> r x \<noteq> r y \<longleftrightarrow> x \<noteq> y"
  using bij_def simple_rotations_bij inj_eq by metis

lemma rotation_bij_corollary: "r \<in> complex_rotations \<Longrightarrow> r x \<noteq> r y \<longleftrightarrow> x \<noteq> y"
  using bij_def complex_rotations_bij inj_eq by metis

lemma complex_rotations_comp:
  "r \<in> complex_rotations \<Longrightarrow> s \<in> complex_rotations \<Longrightarrow> (r \<circ> s) \<in> complex_rotations"
apply(induction arbitrary: s rule: complex_rotations.induct)
apply(auto simp add: comp_assoc complex_rotations.comp)
done

text \<open>
Next, we show that simple rotations (except the identity) keep exactly one vertex fixed.
\<close>

lemma simple_rotations_fix:
  assumes r:"r \<in> simple_rotations"
  shows "\<exists>v. r v = v"
  using r unfolding simple_rotations_def
  by (auto simp add: simple_rotations split: Vertex.split)

lemma simple_rotations_fix_unique:
  assumes r:"r \<in> simple_rotations"
  shows "r \<noteq> id \<Longrightarrow> r v = v \<Longrightarrow> r w = w \<Longrightarrow> v = w"
  using r unfolding simple_rotations_def
  by safe
     (case_tac v; case_tac w;
      auto simp add: simple_rotations
     )+

text \<open>
We also show that simple rotations do not contain cycles of length 2.
\<close>

lemma simple_rotations_cycle:
  assumes r:"r \<in> simple_rotations"
  shows "r \<noteq> id \<Longrightarrow> r v = w \<Longrightarrow> v \<noteq> w \<Longrightarrow> r w \<noteq> v"
  using r unfolding simple_rotations_def
  by safe
     (case_tac v;
      auto simp add: simple_rotations
     )+

text \<open>
The following lemmas are all variations on the fact that any property that holds for 4 distinct
vertices holds for all vertices. This is necessary to avoid having to use Vertex.exhaust as much
as possible.
\<close>

lemma distinct_vertices: "distinct[(a::Vertex),b,c,d] \<Longrightarrow> (\<forall> e. e \<in> {a,b,c,d})"
apply(safe)
apply(case_tac a)
apply(auto simp add: distinct_def)
apply(metis Vertex.exhaust)+
done

lemma distinct_map: "r \<in> complex_rotations \<Longrightarrow> distinct[a,b,c,d] \<Longrightarrow> (\<forall> e \<in> {a,b,c}. r e \<noteq> f) \<Longrightarrow> r d = f"
proof -
  assume r:"r \<in> complex_rotations" and dist:"distinct [a,b,c,d]" and notf:"\<forall> e \<in> {a,b,c}. r e \<noteq> f"
  then have 1:"(\<forall> v. v \<in> {a,b,c,d})" using distinct_vertices by simp
  from complex_rotations_bij have "\<exists> v. r v = f" using r bij_pointE by metis
  then have "\<exists> v \<in> {a,b,c,d}. r v = f" using 1 by blast
  then show "r d = f" using notf by simp
qed

lemma distinct_map': "r \<in> complex_rotations \<Longrightarrow> distinct[a,b,c,d] \<Longrightarrow> (\<forall> e \<in> {a,b,c}. r f \<noteq> e) \<Longrightarrow> r f = d"
proof -
  assume r:"r \<in> complex_rotations" and dist:"distinct [a,b,c,d]" and notf:"\<forall> e \<in> {a,b,c}. r f \<noteq> e"
  then have 1:"(\<forall> v. v \<in> {a,b,c,d})" using distinct_vertices by simp
  have "\<exists> v. r f = v" by simp
  then have "\<exists> v \<in> {a,b,c,d}. r f = v" using 1 by blast
  then show "r f = d" using notf by simp
qed

lemma cycle_map: "r \<in> complex_rotations \<Longrightarrow> distinct[a,b,c,d] \<Longrightarrow>
  r a = b \<Longrightarrow> r b = a \<Longrightarrow> r c = d \<Longrightarrow> r d = c \<Longrightarrow> \<forall> v w. r v = w \<longrightarrow> r w = v"
  using distinct_map' rotation_bij_corollary by fastforce

lemma simple_distinct_map: "r \<in> simple_rotations \<Longrightarrow> distinct[a,b,c,d] \<Longrightarrow> (\<forall> e \<in> {a,b,c}. r e \<noteq> f) \<Longrightarrow> r d = f"
  using complex_rotations.simp distinct_map by simp

lemma simple_distinct_map': "r \<in> simple_rotations \<Longrightarrow> distinct[a,b,c,d] \<Longrightarrow> (\<forall> e \<in> {a,b,c}. r f \<noteq> e) \<Longrightarrow> r f = d"
  using complex_rotations.simp distinct_map' by simp

lemma simple_distinct_ident: "r \<in> simple_rotations \<Longrightarrow> distinct[a,b,c,d] \<Longrightarrow> (\<forall> e \<in> {a,b,c}. r e \<noteq> e) \<Longrightarrow> r d = d"
  using simple_rotations_fix simple_distinct_map' by metis

lemma id_decomp:
  assumes distinct:"distinct [(a::Vertex),b,c,d]" and ident:"(\<forall> x \<in> {a,b,c,d}. r x = x)"
  shows "r = id"
proof -
  from distinct_vertices have "\<forall> e. e \<in> set [a,b,c,d]" using distinct by simp
  then have "\<forall> e. r e = e" using ident by auto
  then show "r = id" by auto
qed

text \<open>
Here we show that two invariants hold for rotations. Firstly, any rotation that does not fix a vertex consists
of 2-cycles. Secondly, the only rotation that fixes more than one vertex is the identity.

This proof is very long in part because both invariants have to be proved simultaneously because
they depend on each other.
\<close>

lemma complex_rotations_invariants:
  "r \<in> complex_rotations \<Longrightarrow> (((\<forall> v. r v \<noteq> v) \<longrightarrow> r v = w \<longrightarrow> r w = v) \<and> (r v = v \<longrightarrow> r w = w \<longrightarrow> v \<noteq> w \<longrightarrow> r = id)) "
proof(induction r arbitrary: v w rule: complex_rotations.induct)
  case (simp r)
  assume r:"r \<in> simple_rotations"
  show ?case
  proof
    have "\<exists> v. r v = v" using simple_rotations_fix r by simp
    then have "\<not> (\<forall> v. r v \<noteq> v)" by simp
    then show "(\<forall> v. r v \<noteq> v) \<longrightarrow> r v = w \<longrightarrow> r w = v" by blast

    show "r v = v \<longrightarrow> r w = w \<longrightarrow> v \<noteq> w \<longrightarrow> r = id" using simple_rotations_fix_unique simp by blast
  qed
next
  case (comp r s)
  assume r:"r \<in> simple_rotations"
  assume s:"s \<in> complex_rotations"
  have fix_unique:"\<forall> v w. s v = v \<longrightarrow> s w = w \<longrightarrow> v \<noteq> w \<longrightarrow> s = id" using comp by blast
  show ?case
  proof
    show "(\<forall>x. (r \<circ> s) x \<noteq> x) \<longrightarrow> (r \<circ> s) v = w \<longrightarrow> (r \<circ> s) w = v"
    proof (rule impI)+
      assume nofixrs:"\<forall> x.(r \<circ> s) x \<noteq> x"
      assume "(r \<circ> s) v = w"
      show "(r \<circ> s) w = v"
      proof (cases "\<forall> x. s x \<noteq> x")
        assume nofixs:"\<forall> x. s x \<noteq> x"
        then have cycle:"\<forall> x y. (s x = y \<longrightarrow> s y = x)" using comp.IH by blast
        then show ?thesis
        proof (cases "r = id")
          assume id:"r = id"
          then have "s v = w" using  \<open>(r \<circ> s) v = w\<close> by simp
          then have "s w = v" using cycle by blast
          then show "(r \<circ> s) w = v" using id by simp
        next
          assume notid:"r \<noteq> id"
          obtain a where "s v = a" and "s a = v" and "a \<noteq> v" using comp.IH nofixs by blast
          obtain b where "s w = b" and "s b = w" and "b \<noteq> w" using comp.IH nofixs by blast
          have "v \<noteq> w" using \<open>(r \<circ> s) v = w\<close> nofixrs by blast
          then have "a \<noteq> b" using comp.hyps rotation_bij_corollary \<open>s a = v\<close> \<open>s b = w\<close> by auto
          have "r a = w" using \<open>s v = a\<close> \<open>(r \<circ> s) v = w\<close> by auto
          then show ?thesis
          proof (cases "a = w")
            assume "a = w"
            then have "r a = a" using \<open>r a = w\<close> by simp
            then have "s v = w" using \<open>a = w\<close> \<open>s v = a\<close> by simp
            then have "b = v" using \<open>s b = w\<close> rotation_bij_corollary comp.hyps by blast
            then have "s w = v" using \<open>s w = b\<close> by simp
            then have "r v \<noteq> v" using simple_rotations_fix_unique notid \<open>r a = a\<close> \<open>a \<noteq> v\<close>
                comp.hyps(1) by auto
            obtain c d where "s c = d" and "c \<noteq> v" and "c \<noteq> w"
              using \<open>a \<noteq> v\<close> \<open>r a = w\<close> \<open>r v \<noteq> v\<close> comp.hyps(1) simple_rotation_bij_corollary by blast
            then have "d \<noteq> v" and "d \<noteq> w"
              using \<open>s w = v\<close> \<open>c \<noteq> v\<close> \<open>s c = d\<close> \<open>s v = w\<close> comp.hyps(2) rotation_bij_corollary by auto
            then have "s d = c" using \<open>s c = d\<close> comp.IH nofixs by blast
            then have "c \<noteq> d" using nofixs by auto
            then show ?thesis
            proof(cases "r v = c")
              assume "r v = c"
              then have "r c \<noteq> v" using \<open>c \<noteq> v\<close> simple_rotations_cycle comp.hyps(1) notid by simp
              have "r c \<noteq> w"
                using \<open>r a = a\<close> \<open>c \<noteq> w\<close> \<open>r a = w\<close> simple_rotation_bij_corollary comp.hyps(1) by auto
              have "r c \<noteq> c" using \<open>a = w\<close> \<open>c \<noteq> w\<close> \<open>r a = a\<close>
                comp.hyps(1) simple_rotations_fix_unique notid by blast
              have dist:"distinct [v,w,c,d]" using \<open>c \<noteq> v\<close> \<open>c \<noteq> w\<close> \<open>c \<noteq> d\<close> \<open>d \<noteq> v\<close> \<open>d \<noteq> w\<close> \<open>v \<noteq> w\<close> by simp
              then have "\<forall> v \<in> {v,w,c}. r c \<noteq> v" using \<open>r c \<noteq> c\<close> \<open>r c \<noteq> v\<close> \<open>r c \<noteq> w\<close> by auto
              then have "r c = d" using simple_distinct_map' comp.hyps(1) dist by auto
              then have "(r \<circ> s) d = d" using \<open>s d = c\<close> by simp
              then have False using nofixrs by blast
              then show ?thesis by simp
            next
              assume "r v \<noteq> c"
              then have "r v \<noteq> w"
                using \<open>r a = a\<close> \<open>v \<noteq> w\<close> \<open>r a = w\<close> simple_rotation_bij_corollary comp.hyps(1) by auto
              then have "r v \<noteq> v" using \<open>a = w\<close> \<open>r a = a\<close>
                comp.hyps(1) simple_rotations_fix_unique notid by blast
              have dist:"distinct [w,c,v,d]" using \<open>c \<noteq> v\<close> \<open>c \<noteq> w\<close> \<open>c \<noteq> d\<close> \<open>d \<noteq> v\<close> \<open>d \<noteq> w\<close> \<open>v \<noteq> w\<close> by simp
              then have "\<forall> x \<in> {w,c,v}. r v \<noteq> x" using \<open>r v \<noteq> c\<close> \<open>r v \<noteq> v\<close> \<open>r v \<noteq> w\<close> by auto
              then have "r v = d" using simple_distinct_map' comp.hyps(1) dist by auto
              then have "r d \<noteq> v" using \<open>d \<noteq> v\<close> simple_rotations_cycle comp.hyps(1) notid by simp
              have "r d \<noteq> w"
                using \<open>r a = a\<close> \<open>d \<noteq> w\<close> \<open>r a = w\<close> simple_rotation_bij_corollary comp.hyps(1) by auto
              have "r d \<noteq> d" using \<open>a = w\<close> \<open>d \<noteq> w\<close> \<open>r a = a\<close>
                comp.hyps(1) simple_rotations_fix_unique notid by blast
              have dist':"distinct [w,v,d,c]" using \<open>c \<noteq> v\<close> \<open>c \<noteq> w\<close> \<open>c \<noteq> d\<close> \<open>d \<noteq> v\<close> \<open>d \<noteq> w\<close> \<open>v \<noteq> w\<close> by simp
              then have "\<forall> v \<in> {w,v,d}. r d \<noteq> v" using \<open>r d \<noteq> d\<close> \<open>r d \<noteq> w\<close> \<open>r d \<noteq> v\<close> by auto
              then have "r d = c" using simple_distinct_map' comp.hyps(1) dist' by auto
              then have "(r \<circ> s) c = c" using \<open>s c = d\<close> by simp
              then have False using nofixrs by blast
              then show ?thesis by simp
            qed
          next
            assume "a \<noteq> w"
            then have "r a \<noteq> a" using \<open>r a = w\<close> by simp
            have "b \<noteq> v" using \<open>a \<noteq> w\<close> \<open>s b = w\<close> \<open>s v = a\<close> by auto
            have "r w \<noteq> w" using \<open>a \<noteq> w\<close> \<open>r a = w\<close> comp.hyps(1) simple_rotation_bij_corollary by auto
            from nofixs have "s w \<noteq> w" by simp
            then have "r v \<noteq> w" using \<open>a \<noteq> v\<close> \<open>r a = w\<close> comp.hyps simple_rotation_bij_corollary by blast
            have "s v \<noteq> w" using \<open>r a = w\<close> \<open>r a \<noteq> a\<close> \<open>s v = a\<close> by blast
            then show ?thesis
            proof (cases "r b = b")
              assume "r b = b"
              then have "r b \<noteq> a" using \<open>a \<noteq> b\<close> by simp
              have "r w \<noteq> a" using \<open>r a = w\<close> \<open>r w \<noteq> w\<close> comp.hyps(1) notid simple_rotations_cycle by blast
              have dist:"distinct [a,b,w,v]" using \<open>a \<noteq> w\<close> \<open>a \<noteq> b\<close> \<open>a \<noteq> v\<close> \<open>b \<noteq> w\<close> \<open>b \<noteq> v\<close> \<open>v \<noteq> w\<close> by simp
              then have "\<forall> x \<in> {a,b,w}. r x \<noteq> a" using \<open>r a \<noteq> a\<close> \<open>r b \<noteq> a\<close> \<open>r w \<noteq> a\<close> by auto
              then have "r v = a" using simple_distinct_map comp.hyps(1) dist by auto
              then show ?thesis using \<open>s a = v\<close> nofixrs comp_apply by metis
            next
              assume "r b \<noteq> b"
              have dist:"distinct [w,a,b,v]" using \<open>a \<noteq> w\<close> \<open>a \<noteq> b\<close> \<open>a \<noteq> v\<close> \<open>b \<noteq> w\<close> \<open>b \<noteq> v\<close> \<open>v \<noteq> w\<close> by simp
              then have "\<forall> x \<in> {w,a,b}. r x \<noteq> x" using \<open>r w \<noteq> w\<close> \<open>r a \<noteq> a\<close> \<open>r b \<noteq> b\<close> by auto
              then have "r v = v" using simple_distinct_ident comp.hyps(1) dist by auto
              have "r w \<noteq> a" using \<open>a \<noteq> w\<close> simple_rotations_cycle comp.hyps(1) notid \<open>r a = w\<close> by simp
              have "r w \<noteq> v" using \<open>r v = v\<close> \<open>v \<noteq> w\<close> comp.hyps(1) simple_rotation_bij_corollary by blast
              have dist':"distinct [a,v,w,b]" using \<open>a \<noteq> w\<close> \<open>a \<noteq> b\<close> \<open>a \<noteq> v\<close> \<open>b \<noteq> w\<close> \<open>b \<noteq> v\<close> \<open>v \<noteq> w\<close> by simp
              then have "\<forall> x \<in> {a,v,w}. r w \<noteq> x" using \<open>r w \<noteq> a\<close> \<open>r w \<noteq> v\<close> \<open>r w \<noteq> w\<close> by auto
              then have "r w = b" using simple_distinct_map' comp.hyps(1) dist' by auto
              then show ?thesis using \<open>s b = w\<close> nofixrs comp_apply by metis
            qed
          qed
        qed
    next
      assume "\<not> (\<forall> v. s v \<noteq> v)"
      then have fix1:"\<exists> v. s v = v" by blast
      then obtain a where a:"s a = a" by blast
      then show ?thesis
      proof (cases "r = id")
        assume id:"r = id"
        then have "(r \<circ> s) a = a" using a by simp
        then have False using nofixrs by auto
        then show ?thesis by simp
      next
        assume notid: "r \<noteq> id"
        then have fix1:"\<exists> v. r v = v" using simple_rotations_fix comp.hyps by simp
        then obtain b where b:"r b = b" by blast
        then show ?thesis
        proof (cases "a = b")
          assume "a = b"
          then have "(r \<circ> s) a = a" using a b by simp
          then have False using nofixrs by blast
          then show ?thesis by simp
        next
          assume "a \<noteq> b"
          have "r a \<noteq> a" using \<open>a \<noteq> b\<close> b comp.hyps(1) notid simple_rotations_fix_unique by blast
          have "r a \<noteq> b" using \<open>a \<noteq> b\<close> b comp.hyps(1) simple_rotation_bij_corollary by auto
          then obtain c where "r a = c" and "a \<noteq> c" and "b \<noteq> c" using \<open>r a \<noteq> a\<close> by auto
          have "s b \<noteq> a" using \<open>a \<noteq> b\<close> a comp.hyps(2) rotation_bij_corollary by blast
          have "s b \<noteq> b" using b nofixrs comp_apply by metis
          then obtain d where "s b = d" and "a \<noteq> d" and "b \<noteq> d" using \<open>s b \<noteq> a\<close> by auto
          have "r c \<noteq> a" using simple_rotations_cycle \<open>a \<noteq> c\<close> \<open>r a = c\<close> comp.hyps(1) notid by blast
          have "r c \<noteq> b" using \<open>b \<noteq> c\<close> b comp.hyps(1) simple_rotation_bij_corollary by blast
          have "r c \<noteq> c" using \<open>b \<noteq> c\<close> b comp.hyps(1) notid simple_rotations_fix_unique by blast
          then show ?thesis
          proof (cases "c = d")
            assume "c = d"
            then have "s c \<noteq> c" using \<open>b \<noteq> c\<close> \<open>s b = d\<close> rotation_bij_corollary s by auto
            obtain e where "r c = e" and "a \<noteq> e" and "b \<noteq> e" and "c \<noteq> e" and "d \<noteq> e"
              using \<open>r c \<noteq> a\<close> \<open>r c \<noteq> b\<close> \<open>r c \<noteq> c\<close> \<open>c = d\<close> by auto
            have "r e \<noteq> b" using \<open>b \<noteq> e\<close> b r simple_rotation_bij_corollary by blast
            have "r e \<noteq> c" using \<open>a \<noteq> e\<close> \<open>r a = c\<close> r simple_rotation_bij_corollary by blast
            have "r e \<noteq> e" using \<open>b \<noteq> e\<close> b notid r simple_rotations_fix_unique by blast
            then have dist:"distinct [b,c,e,a]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> e\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> e\<close> \<open>c \<noteq> e\<close> by simp
            then have "\<forall> x \<in> {b,c,e}. r e \<noteq> x" using \<open>r e \<noteq> b\<close> \<open>r e \<noteq> c\<close> \<open>r e \<noteq> e\<close> by auto
            then have "r e = a" using simple_distinct_map' comp.hyps(1) dist by auto
            have dist:"distinct [a,b,c,e]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> e\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> e\<close> \<open>c \<noteq> e\<close> by simp
            then have "\<forall> x \<in> {a,b,c}. r c \<noteq> x" using \<open>r c \<noteq> a\<close> \<open>r c \<noteq> b\<close> \<open>r c \<noteq> c\<close> by auto
            then have "r c = e" using simple_distinct_map' comp.hyps(1) dist by auto
            have "s e \<noteq> a" using \<open>a \<noteq> e\<close> a rotation_bij_corollary s by blast
            have "s e \<noteq> c" using \<open>b \<noteq> e\<close> \<open>c = d\<close> \<open>s b = d\<close> rotation_bij_corollary s by blast
            have "s e \<noteq> e" using \<open>a \<noteq> e\<close> \<open>s b \<noteq> b\<close> a fix_unique by fastforce
            then have dist:"distinct [a,c,e,b]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> e\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> e\<close> \<open>c \<noteq> e\<close> by simp
            then have "\<forall> x \<in> {a,c,e}. s e \<noteq> x" using \<open>s e \<noteq> a\<close> \<open>s e \<noteq> c\<close> \<open>s e \<noteq> e\<close> by auto
            then have "s e = b" using distinct_map' comp.hyps(2) dist by auto
            have "s c \<noteq> a" using \<open>a \<noteq> c\<close> a rotation_bij_corollary s by blast
            have "s c \<noteq> b" using \<open>c \<noteq> e\<close> \<open>s e = b\<close> rotation_bij_corollary s by blast
            then have dist:"distinct [a,b,c,e]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> e\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> e\<close> \<open>c \<noteq> e\<close> by simp
            then have "\<forall> x \<in> {a,b,c}. s c \<noteq> x" using \<open>s c \<noteq> a\<close> \<open>s c \<noteq> b\<close> \<open>s c \<noteq> c\<close> by auto
            then have "s c = e" using distinct_map' comp.hyps(2) dist by auto

            have rsa:"(r \<circ> s) a = c" using  \<open>r a = c\<close> a by simp
            have rsb:"(r \<circ> s) b = e" using \<open>c = d\<close> \<open>r c = e\<close> \<open>s b = d\<close> by auto
            have rsc:"(r \<circ> s) c = a" using \<open>r e = a\<close> \<open>s c = e\<close> by auto
            have rse:"(r \<circ> s) e = b" using \<open>s e = b\<close> b by simp
            then have dist:"distinct [a,c,b,e]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> e\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> e\<close> \<open>c \<noteq> e\<close> by simp
            have comprs:"r \<circ> s \<in> complex_rotations" using complex_rotations.comp r s by simp
            show ?thesis using cycle_map[OF comprs dist rsa rsc rsb rse] \<open>(r \<circ> s) v = w\<close> by blast
          next
            assume "c \<noteq> d"
            then have dist:"distinct [a,b,c,d]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> d\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> d\<close> \<open>c \<noteq> d\<close> by simp
            then have "\<forall> x \<in> {a,b,c}. r c \<noteq> x" using \<open>r c \<noteq> a\<close> \<open>r c \<noteq> b\<close> \<open>r c \<noteq> c\<close> by auto
            then have "r c = d" using simple_distinct_map' comp.hyps(1) dist by auto
            have "r d \<noteq> b" using \<open>b \<noteq> d\<close> b comp.hyps(1) simple_rotation_bij_corollary by blast
            have "r d \<noteq> c" using \<open>c \<noteq> d\<close> \<open>r c = d\<close> comp.hyps(1) notid simple_rotations_cycle by blast
            have "r d \<noteq> d" using \<open>c \<noteq> d\<close> \<open>r c = d\<close> comp.hyps(1) simple_rotation_bij_corollary by auto
            have dist:"distinct [b,c,d,a]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> d\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> d\<close> \<open>c \<noteq> d\<close> by simp
            then have "\<forall> x \<in> {b,c,d}. r d \<noteq> x" using \<open>r d \<noteq> b\<close> \<open>r d \<noteq> c\<close> \<open>r d \<noteq> d\<close> by auto
            then have "r d = a" using simple_distinct_map' comp.hyps(1) dist by auto
            have "s d \<noteq> a" using \<open>a \<noteq> d\<close> a comp.hyps(2) rotation_bij_corollary by blast
            have "s d \<noteq> c" using nofixrs \<open>r c = d\<close> \<open>c \<noteq> d\<close> comp_apply by metis
            have "s d \<noteq> d" using \<open>b \<noteq> d\<close> \<open>s b = d\<close> comp.hyps(2) rotation_bij_corollary by auto
            have dist:"distinct [a,c,d,b]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> d\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> d\<close> \<open>c \<noteq> d\<close> by simp
            then have "\<forall> x \<in> {a,c,d}. s d \<noteq> x" using \<open>s d \<noteq> a\<close> \<open>s d \<noteq> c\<close> \<open>s d \<noteq> d\<close> by auto
            then have "s d = b" using distinct_map' comp.hyps(2) dist by auto
            have "s c \<noteq> a" using \<open>a \<noteq> c\<close> a comp.hyps(2) rotation_bij_corollary by blast
            have "s c \<noteq> b" using \<open>c \<noteq> d\<close> \<open>s d = b\<close> comp.hyps(2) rotation_bij_corollary by blast
            have "s c \<noteq> d" using \<open>b \<noteq> c\<close> \<open>s b = d\<close> comp.hyps(2) rotation_bij_corollary by blast
            have dist:"distinct [a,b,d,c]" using \<open>a \<noteq> b\<close> \<open>a \<noteq> c\<close> \<open>a \<noteq> d\<close> \<open>b \<noteq> c\<close> \<open>b \<noteq> d\<close> \<open>c \<noteq> d\<close> by simp
            then have "\<forall> x \<in> {a,b,d}. s c \<noteq> x" using \<open>s c \<noteq> a\<close> \<open>s c \<noteq> b\<close> \<open>s c \<noteq> d\<close> by auto
            then have "s c = c" using distinct_map' comp.hyps(2) dist by auto
            then have False using fix_unique \<open>s d \<noteq> d\<close> \<open>a \<noteq> c\<close> a by fastforce
            then show ?thesis by simp
          qed
        qed
      qed
    qed
  qed
next
  show "(r \<circ> s) v = v \<longrightarrow> (r \<circ> s) w = w \<longrightarrow> v \<noteq> w \<longrightarrow> r \<circ> s = id"
  proof(rule impI)+
    assume rsv:"(r \<circ> s) v = v" and rsw:"(r \<circ> s) w = w" and "v \<noteq> w"
    show "r \<circ> s = id"
    proof(cases "s = id")
      assume sid:"s = id"
      then have "s v = v" and "s w = w" by auto
      then have "r = id" using simple_rotations_fix_unique rsv rsw \<open>v \<noteq> w\<close> r  by auto
      with sid show ?thesis by simp
    next
      assume snotid:"s \<noteq> id"
      then show ?thesis
      proof(cases "r = id")
        assume rid:"r = id"
        then have "s v = v" and "s w = w" using rsv rsw by auto
        then have "s = id" using \<open>v \<noteq> w\<close> fix_unique by blast
        with rid show ?thesis by simp
      next
        assume rnotid:"r \<noteq> id"
        from simple_rotations_fix_unique[OF comp.hyps(1) rnotid] have
          r_fix_forall:"\<forall>v w. r v = v \<and> r w = w \<longrightarrow> v = w" by blast
        from comp.IH snotid have
          s_fix_forall:"\<forall>v w. s v = v \<and> s w = w \<longrightarrow> v = w" by blast
        have fixes_two: "\<exists>a b. (r \<circ> s) a = a \<and> (r \<circ> s) b = b \<and> a \<noteq> b" using \<open>v \<noteq> w\<close> rsv rsw by blast
        then show ?thesis
        proof (cases "\<forall> x. s x \<noteq> x")
          assume sfix':"\<forall> x. s x \<noteq> x"
          from simple_rotations_fix obtain a where a:"r a = a" using r by blast
          from sfix' have "s a \<noteq> a" by blast
          then have "(r \<circ> s) a \<noteq> a" using a simple_rotation_bij_corollary r by fastforce
          with fixes_two obtain b where "(r \<circ> s) b = b" and "b \<noteq> a" by blast
          with fixes_two obtain c where "(r \<circ> s) c = c" and "c \<noteq> a" and "c \<noteq> b"
            using \<open>(r \<circ> s) a \<noteq> a\<close> by blast

          have "s b \<noteq> a" using a \<open>(r \<circ> s) b = b\<close> sfix' by force
          have "s c \<noteq> a" using a \<open>(r \<circ> s) c = c\<close> sfix' by force

          then obtain d where "s d = a" and "d \<noteq> a" and "d \<noteq> b" and "d \<noteq> c"
            using \<open>s a \<noteq> a\<close> \<open>s b \<noteq> a\<close> \<open>s c \<noteq> a\<close> complex_rotations_bij s bij_pointE by metis
          have "(r \<circ> s) d = a" using a \<open>s d = a\<close> by simp

          have "r b \<noteq> a" using a r simple_rotation_bij_corollary \<open>b \<noteq> a\<close> by auto
          have "r c \<noteq> a" using a r simple_rotation_bij_corollary \<open>c \<noteq> a\<close> by auto
          have "r d \<noteq> a" using a r simple_rotation_bij_corollary \<open>d \<noteq> a\<close> by auto
          have "r b \<noteq> b" using a r simple_rotations_fix_unique rnotid \<open>b \<noteq> a\<close> by blast
          have "r c \<noteq> c" using a r simple_rotations_fix_unique rnotid \<open>c \<noteq> a\<close> by blast
          have "r d \<noteq> d" using a r simple_rotations_fix_unique rnotid \<open>d \<noteq> a\<close> by blast

          then have False using sfix'
          proof (cases "r b = c")
            assume "r b = c"
            then have "r c \<noteq> c" using r simple_rotation_bij_corollary \<open>c \<noteq> b\<close> by auto
            then have "r c \<noteq> b" using r rnotid simple_rotations_cycle \<open>r b = c\<close> by auto
            have dist:"distinct [a,b,c,d]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>d \<noteq> c\<close> \<open>d \<noteq> b\<close> \<open>c \<noteq> b\<close> \<open>b \<noteq> a\<close> by simp
            then have "\<forall> v \<in> {a,b,c}. r c \<noteq> v" using \<open>r c \<noteq> c\<close> \<open>r c \<noteq> a\<close> \<open>r c \<noteq> b\<close> by auto
            then have "r c = d" using simple_distinct_map' r dist by auto

            have "r d \<noteq> c" using r simple_rotation_bij_corollary \<open>d \<noteq> b\<close> \<open>r b = c\<close> by auto
            have "r d \<noteq> d" using r a \<open>d \<noteq> a\<close> \<open>r d \<noteq> d\<close> by simp
            have dist':"distinct [a,c,d,b]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>d \<noteq> c\<close> \<open>d \<noteq> b\<close> \<open>c \<noteq> b\<close> \<open>b \<noteq> a\<close> by simp
            then have "\<forall> v \<in> {a,c,d}. r d \<noteq> v" using \<open>r d \<noteq> c\<close> \<open>r d \<noteq> a\<close> \<open>r d \<noteq> d\<close> by auto
            then have "r d = b" using simple_distinct_map' r dist' by auto

            then have "s b = d" using \<open>(r \<circ> s) b = b\<close> r simple_rotation_bij_corollary by auto
            have "s c = b" using \<open>(r \<circ> s) c = c\<close> \<open>r b = c\<close> r simple_rotation_bij_corollary by auto

            then have "s b \<noteq> c" using \<open>s b = d\<close> \<open>d \<noteq> c\<close> by simp
            then show False using s sfix' \<open>s c = b\<close> comp(3) by blast
          next
            assume "r b \<noteq> c"
            have dist':"distinct [a,b,c,d]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>d \<noteq> c\<close> \<open>d \<noteq> b\<close> \<open>c \<noteq> b\<close> \<open>b \<noteq> a\<close> by simp
            then have "\<forall> v \<in> {a,b,c}. r b \<noteq> v" using \<open>r b \<noteq> a\<close> \<open>r b \<noteq> b\<close> \<open>r b \<noteq> c\<close> by auto
            then have "r b = d" using simple_distinct_map' r dist' by auto

            then have "r c \<noteq> d" using r simple_rotation_bij_corollary \<open>c \<noteq> b\<close> by auto
            have dist'':"distinct [a,c,d,b]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>d \<noteq> c\<close> \<open>d \<noteq> b\<close> \<open>c \<noteq> b\<close> \<open>b \<noteq> a\<close> by simp
            then have "\<forall> v \<in> {a,c,d}. r c \<noteq> v" using \<open>r c \<noteq> a\<close> \<open>r c \<noteq> c\<close> \<open>r c \<noteq> d\<close> by auto
            then have "r c = b" using simple_distinct_map' r dist'' by auto

            then have "r d \<noteq> b" using r simple_rotation_bij_corollary \<open>d \<noteq> c\<close> by auto
            have dist''':"distinct [a,b,d,c]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>d \<noteq> c\<close> \<open>d \<noteq> b\<close> \<open>c \<noteq> b\<close> \<open>b \<noteq> a\<close> by simp
            then have "\<forall> v \<in> {a,b,d}. r d \<noteq> v" using \<open>r d \<noteq> a\<close> \<open>r d \<noteq> b\<close> \<open>r d \<noteq> d\<close> by auto
            then have "r d = c" using simple_distinct_map' r dist''' by auto

            then have "s b = c" using \<open>r c = b\<close> \<open>(r \<circ> s) b = b\<close> r simple_rotation_bij_corollary by auto
            have "s c = d" using \<open>(r \<circ> s) c = c\<close> \<open>r d = c\<close> r simple_rotation_bij_corollary by auto

            then have "s c \<noteq> b" using \<open>d \<noteq> b\<close> by simp
            then have False using comp(3) s sfix' \<open>s b = c\<close> by blast
            then show ?thesis by simp
          qed
          then show ?thesis by simp
        next
          assume "\<not> (\<forall> x. s x \<noteq> x)"
          then have "\<exists> x. s x = x" by simp
          then obtain a where a:"s a = a" by blast
          from simple_rotations_fix obtain b where b:"r b = b" using r by blast
          then show ?thesis
          proof (cases "a = b")
            assume "a \<noteq> b"
            with a b have "r a \<noteq> a" using r rnotid simple_rotations_fix_unique by blast
            then have "(r \<circ> s) a \<noteq> a" using a by simp
            have "s b \<noteq> b" using a \<open>a \<noteq> b\<close> s_fix_forall by blast
            then have "(r \<circ> s) b \<noteq> b" using b simple_rotations_inj r
                complex_rotations.simp rotation_bij_corollary by fastforce
            with fixes_two obtain c where "(r \<circ> s) c = c" and "c \<noteq> a" and "c \<noteq> b" using \<open>(r \<circ> s) a \<noteq> a\<close> by blast
            from fixes_two obtain d where "(r \<circ> s) d = d" and "d \<noteq> a" and "d \<noteq> b" and "d \<noteq> c"
              using \<open>(r \<circ> s) a \<noteq> a\<close> \<open>(r \<circ> s) b \<noteq> b\<close> by blast

            have "s c \<noteq> a" using a \<open>c \<noteq> a\<close> rotation_bij_corollary s by force
            have "s d \<noteq> a" using a \<open>d \<noteq> a\<close> rotation_bij_corollary s by force

            have "r a \<noteq> c" using \<open>s c \<noteq> a\<close> \<open>(r \<circ> s) c = c\<close> \<open>c \<noteq> a\<close> r simple_rotation_bij_corollary by auto
            have "r a \<noteq> d" using \<open>s d \<noteq> a\<close> \<open>(r \<circ> s) d = d\<close> \<open>d \<noteq> a\<close> r simple_rotation_bij_corollary by auto
            have "r a \<noteq> b" using b simple_rotation_bij_corollary \<open>a \<noteq> b\<close> r by auto

            have dist:"distinct [b,c,d,a]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>c \<noteq> b\<close> \<open>a \<noteq> b\<close> \<open>d \<noteq> c\<close> \<open>d \<noteq> b\<close> by simp
            then have "\<forall> v \<in> {b,c,d}. r a \<noteq> v" using \<open>r a \<noteq> b\<close> \<open>r a \<noteq> c\<close> \<open>r a \<noteq> d\<close> by auto
            then have "r a = a" using simple_distinct_map' r dist by simp
            then have False using \<open>r a \<noteq> a\<close> by simp
            then show ?thesis by simp
          next
            assume "a = b"
            with a b have "(r \<circ> s) a = a" by simp
            from fixes_two obtain c where rsc:"(r \<circ> s) c = c" and "c \<noteq> a" by blast
            then have "r c \<noteq> c" using b \<open>a = b\<close>r rnotid simple_rotations_fix_unique by blast
            then have "s c \<noteq> c" using rsc by auto
            then obtain d where "s c = d" and "d \<noteq> c" by blast
            then have "d \<noteq> a" using a s rotation_bij_corollary by blast
            have "s d \<noteq> d" using a using \<open>d \<noteq> a\<close> s_fix_forall by blast
            have "r d = c" using rsc \<open>s c = d\<close> by simp
            then have "r c \<noteq> d" using \<open>d \<noteq> c\<close> simple_rotations_cycle r rnotid by auto
            then obtain e where "r c = e" and "e \<noteq> d" by blast
            then have "e \<noteq> a" using b \<open>a = b\<close> simple_rotation_bij_corollary \<open>c \<noteq> a\<close> r by auto
            then have "e \<noteq> c" using b \<open>a = b\<close> \<open>r c = e\<close> \<open>r c \<noteq> c\<close> by blast
            then have "r e \<noteq> c" using \<open>r c = e\<close> simple_rotations_cycle r rnotid by auto
            have "r e \<noteq> a" using b \<open>a = b\<close> \<open>e \<noteq> a\<close> simple_rotation_bij_corollary r by auto
            then have "r e \<noteq> e" using \<open>e \<noteq> c\<close> \<open>r c = e\<close> r simple_rotation_bij_corollary by blast
            have dist:"distinct [a,c,d,e]" using \<open>c \<noteq> a\<close> \<open>d \<noteq> a\<close> \<open>d \<noteq> c\<close> \<open>e \<noteq> a\<close> \<open>e \<noteq> c\<close> \<open>e \<noteq> d\<close> by simp
            then have "\<forall> v \<in> {a,c,d}. r v \<noteq> d" using \<open>r b = b\<close> \<open>a = b\<close> \<open>r d = c\<close> \<open>r c = e\<close> by auto
            then have "r e = d" using simple_distinct_map r dist by auto

            have dist':"distinct [a,c,e,d]" using dist by auto
            have "s e \<noteq> e" using  \<open>e \<noteq> a\<close> a s_fix_forall by blast
            then have "\<forall> v \<in> {a,c,e}. s v \<noteq> e" using \<open>s a = a\<close> \<open>s c = d\<close> dist by auto
            then have "s d = e" using distinct_map s dist' by auto
            then have "\<forall> v \<in> {a,c,d}. s v \<noteq> c" using \<open>s a = a \<close> \<open>s c = d\<close> dist by auto
            then have "s e = c" using distinct_map s dist by auto
            then have "(r \<circ> s) d = d" using \<open>s d = e\<close> \<open>r e = d\<close> by auto
            then have "(r \<circ> s) e = e" using \<open>s e = c\<close> \<open>r c = e\<close> by auto
            then show "(r \<circ> s) = id" using \<open>(r \<circ> s) d = d\<close>  \<open>(r \<circ> s) a = a\<close> \<open>(r \<circ> s) c = c\<close> dist id_decomp by auto
            qed
          qed
        qed
      qed
    qed
  qed
qed

text \<open>
  This lemma is a simple corollary of the previous result. It is the main result necessary to
  count stabilisers.
\<close>

corollary complex_rotations_fix: "r \<in> complex_rotations \<Longrightarrow> r a = a \<Longrightarrow> r b = b \<Longrightarrow> a \<noteq> b \<Longrightarrow> r = id"
  using complex_rotations_invariants by blast

section "Inversions"
text \<open>
  In this section we show that inverses exist for each rotation, which we will need to show that
  the rotations we defined indeed form a group.
\<close>

lemma simple_rotations_rotate_id:
  assumes r:"r \<in> simple_rotations"
  shows "r \<circ> r \<circ> r = id"
  using r unfolding simple_rotations_def
  by safe
     (rule ext; rename_tac a; case_tac a;
      simp add: simple_rotations
     )+

lemma simple_rotations_inverses:
  assumes r:"r \<in> simple_rotations"
  shows "\<exists>y\<in>complex_rotations. y \<circ> r = id"
proof
  let ?y = "r \<circ> r"
  from r show y:"?y \<in> complex_rotations" using complex_rotations.intros by simp
  from simple_rotations_rotate_id show "?y \<circ> r = id" using r by auto
qed

lemma complex_rotations_inverses:
  "r \<in> complex_rotations \<Longrightarrow> \<exists>y\<in>complex_rotations. y \<circ> r = id"
proof (induction r rule: complex_rotations.induct)
  case (simp r) then show ?case using simple_rotations_inverses by blast
next
  case (comp r s)
  obtain r' where r'_comp:"r'\<in>complex_rotations" and r'_inv:"r' \<circ> r = id"
    using simple_rotations_inverses comp.hyps  by auto
  obtain y where y_comp:"y\<in>complex_rotations" and y_inv:"y \<circ> s = id" using comp.IH by blast
  from complex_rotations_comp have yr':"y \<circ> r' \<in> complex_rotations" using r'_comp y_comp by simp
  have "r' \<circ> (r \<circ> s) = r' \<circ> r \<circ> s" using comp_assoc by metis
  then have "r' \<circ> (r \<circ> s) = s" using r'_inv by simp
  then have "y \<circ> r' \<circ> (r \<circ> s) = id" using y_inv comp_assoc by metis
  then show ?case using yr' by metis
qed

section "The Tetrahedral Group"

text \<open>
We can now define the group of rotational symmetries of a tetrahedron. Since we modeled rotations
as functions, the group operation is functional composition and the identity element of the group is
the identity function
\<close>

definition tetrahedral_group :: "Rotation monoid" where
  "tetrahedral_group = \<lparr>carrier = complex_rotations, mult = (\<circ>), one = id\<rparr>"

text \<open>
We now prove that this indeed forms a group. Most of the subgoals are trivial, the last goal uses
our results from the previous section about inverses.
\<close>

lemma is_tetrahedral_group: "group tetrahedral_group"
proof(rule groupI)
  show "\<one>\<^bsub>tetrahedral_group\<^esub> \<in> carrier tetrahedral_group"
    by (simp add: complex_rotations.intros(1) simple_rotations_def tetrahedral_group_def)
next
  fix x
  assume "x \<in> carrier tetrahedral_group"
  show "\<one>\<^bsub>tetrahedral_group\<^esub> \<otimes>\<^bsub>tetrahedral_group\<^esub> x = x"
    unfolding id_comp tetrahedral_group_def monoid.select_convs(1) monoid.select_convs(2) ..
next
  fix x y z
  assume "x \<in> carrier tetrahedral_group" and
    "y \<in> carrier tetrahedral_group" and
    "z \<in> carrier tetrahedral_group"
  then show "x \<otimes>\<^bsub>tetrahedral_group\<^esub> y \<otimes>\<^bsub>tetrahedral_group\<^esub> z =
             x \<otimes>\<^bsub>tetrahedral_group\<^esub> (y \<otimes>\<^bsub>tetrahedral_group\<^esub> z)"
    unfolding tetrahedral_group_def monoid.select_convs(1) by auto
next
  fix x y
  assume "x \<in> carrier tetrahedral_group" and
    "y \<in> carrier tetrahedral_group"
  then show "x \<otimes>\<^bsub>tetrahedral_group\<^esub> y \<in> carrier tetrahedral_group"
    by (simp add: complex_rotations.intros(2) tetrahedral_group_def complex_rotations_comp)
next
  fix x
  assume "x \<in> carrier tetrahedral_group"
  then show "\<exists>y\<in>carrier tetrahedral_group.
            y \<otimes>\<^bsub>tetrahedral_group\<^esub> x = \<one>\<^bsub>tetrahedral_group\<^esub>"
    using complex_rotations_inverses by (simp add: tetrahedral_group_def)
qed

text \<open>
Having proved that our definition forms a group we can now instantiate our orbit-stabiliser locale.
The group action is the application of a rotation.
\<close>

fun apply_rotation :: "Rotation \<Rightarrow> Vertex \<Rightarrow> Vertex" where "apply_rotation r v = r v"

interpretation tetrahedral: orbit_stabiliser "tetrahedral_group" "apply_rotation :: Rotation \<Rightarrow> Vertex \<Rightarrow> Vertex"
proof intro_locales
  show "Group.monoid tetrahedral_group" using is_tetrahedral_group by (simp add: group.is_monoid)
  show "group_axioms tetrahedral_group" using is_tetrahedral_group by (simp add: group_def)
  show "orbit_stabiliser_axioms tetrahedral_group apply_rotation"
  proof
    fix x
    show "apply_rotation \<one>\<^bsub>tetrahedral_group\<^esub> x = x" by (simp add: tetrahedral_group_def)
  next
    fix g h x
    show "g \<in> carrier tetrahedral_group \<and> h \<in> carrier tetrahedral_group
           \<longrightarrow> apply_rotation g (apply_rotation h x) = apply_rotation (g \<otimes>\<^bsub>tetrahedral_group\<^esub> h) x"
      by (simp add: tetrahedral_group_def)
  qed
qed

section "Counting Orbits"
text \<open>
We now prove that there is an orbit for each vertex. That is, the group action is transitive.
\<close>
lemma orbit_is_transitive: "tetrahedral.orbit A = vertices"
proof
  show "tetrahedral.orbit A \<subseteq> vertices" unfolding vertices_def using Vertex.exhaust by blast
  have "id \<in> complex_rotations" using complex_rotations.intros simple_rotations_def by auto
  then have "id \<in> carrier tetrahedral_group"
    unfolding tetrahedral_group_def partial_object.select_convs(1).
  moreover have "apply_rotation id A = A" by simp
  ultimately have A:"A \<in> (tetrahedral.orbit A)"
    using tetrahedral.orbit_def mem_Collect_eq by fastforce

  have "rotate_C \<in> simple_rotations"
    using simple_rotations_def insert_subset subset_insertI by blast
  then have "rotate_C \<in> complex_rotations" using complex_rotations.intros(1) by simp
  then have "rotate_C \<in> carrier tetrahedral_group"
    unfolding tetrahedral_group_def partial_object.select_convs(1).
  moreover have "apply_rotation rotate_C A = B" by (simp add: rotate_C_def)
  ultimately have B:"B \<in> (tetrahedral.orbit A)"
    using tetrahedral.orbit_def mem_Collect_eq by fastforce

  have "rotate_D \<in> simple_rotations"
    using simple_rotations_def insert_subset subset_insertI by blast
  then have "rotate_D \<in> complex_rotations" using complex_rotations.intros(1) by simp
  then have "rotate_D \<in> carrier tetrahedral_group"
    unfolding tetrahedral_group_def partial_object.select_convs(1).
  moreover have "apply_rotation rotate_D A = C" by (simp add: rotate_D_def)
  ultimately have C:"C \<in> (tetrahedral.orbit A)"
    using tetrahedral.orbit_def mem_Collect_eq by fastforce

  have "rotate_B \<in> simple_rotations"
    using simple_rotations_def insert_subset subset_insertI by blast
  then have "rotate_B \<in> complex_rotations" using complex_rotations.intros(1) by simp
  then have "rotate_B \<in> carrier tetrahedral_group"
    unfolding tetrahedral_group_def partial_object.select_convs(1).
  moreover have "apply_rotation rotate_B A = D" by (simp add: rotate_B_def)
  ultimately have D:"D \<in> (tetrahedral.orbit A)"
    using tetrahedral.orbit_def mem_Collect_eq by fastforce

  from A B C D show "vertices \<subseteq> tetrahedral.orbit A" by (simp add: vertices_def subsetI)
qed

text \<open>
It follows from the previous lemma, that the cardinality of the set of orbits for a particular vertex is 4.
\<close>
lemma card_orbit: "card (tetrahedral.orbit A) = 4"
proof -
  from card_empty card_insert_if have "card vertices = 4" unfolding vertices_def by auto
  with orbit_is_transitive show "card (tetrahedral.orbit A) = 4" by simp
qed

section "Counting Stabilisers"

text \<open>
Each vertex has three elements in its stabiliser - the identity, a rotation around its axis by 120 degrees,
and a rotation around its axis by 240 degrees. We will prove this next.
\<close>
definition stabiliser_A :: "Rotation set" where
  "stabiliser_A = {id, rotate_A, rotate_A \<circ> rotate_A}"

text \<open>
This lemma shows that our conjectured stabiliser is correct.
\<close>
lemma is_stabiliser: "tetrahedral.stabiliser A = stabiliser_A"
proof
  show "stabiliser_A \<subseteq> tetrahedral.stabiliser A"
  proof -
    have "id \<in> complex_rotations" using complex_rotations.intros simple_rotations_def by auto
    then have "id \<in> carrier tetrahedral_group"
      unfolding tetrahedral_group_def partial_object.select_convs(1) by simp
    moreover have "apply_rotation id A = A" by simp
    ultimately have id:"id \<in> (tetrahedral.stabiliser A)"
      using tetrahedral.stabiliser_def mem_Collect_eq by fastforce

    have "rotate_A \<in> simple_rotations"
      using simple_rotations_def insert_subset subset_insertI by blast
    then have "rotate_A \<in> complex_rotations" using complex_rotations.intros(1) by simp
    then have "rotate_A \<in> carrier tetrahedral_group"
      unfolding tetrahedral_group_def partial_object.select_convs(1) by simp
    moreover have "apply_rotation rotate_A A = A" by (simp add: rotate_A_def)
    ultimately have A:"rotate_A \<in> (tetrahedral.stabiliser A)"
      using tetrahedral.stabiliser_def mem_Collect_eq by fastforce

    have "rotate_A \<in> simple_rotations"
      using simple_rotations_def insert_subset subset_insertI by blast
    then have "rotate_A \<circ> rotate_A \<in> complex_rotations" using complex_rotations.intros by simp
    then have "rotate_A \<circ> rotate_A \<in> carrier tetrahedral_group"
      unfolding tetrahedral_group_def partial_object.select_convs(1) by simp
    moreover have "apply_rotation (rotate_A \<circ> rotate_A) A = A" by (simp add: rotate_A_def)
    ultimately have AA:"(rotate_A \<circ> rotate_A) \<in> (tetrahedral.stabiliser A)"
      using tetrahedral.stabiliser_def mem_Collect_eq by fastforce

    from id A AA show "stabiliser_A \<subseteq> tetrahedral.stabiliser A"
      by (simp add: stabiliser_A_def subsetI)
  qed
  show "tetrahedral.stabiliser A \<subseteq> stabiliser_A"
  proof
    fix x
    assume a:"x \<in> tetrahedral.stabiliser A"
    with tetrahedral.stabiliser_def have "apply_rotation x A = A" by simp
    with apply_rotation.simps have xA:"x A = A" by simp
    from a have "x \<in> carrier tetrahedral_group"
      using subgroup.mem_carrier[of "tetrahedral.stabiliser A"] tetrahedral.stabiliser_subgroup by auto
    then have xC:"x \<in> complex_rotations"
      unfolding tetrahedral_group_def partial_object.select_convs(1) by simp
    have "x B \<noteq> A" using xA xC rotation_bij_corollary by fastforce
    then have "x \<in> complex_rotations \<Longrightarrow> x A = A \<Longrightarrow> x \<in> stabiliser_A"
    proof (cases "x B", simp)
      assume "x B = B"
      then have "x = id" using complex_rotations_fix xC xA by simp
      then show ?thesis using stabiliser_A_def by auto
    next
      assume "x B = C"
      then have "x \<noteq> id" by auto
      then have "x D \<noteq> D" using complex_rotations_fix xC xA by blast
      have "x D \<noteq> C" using xC \<open>x B = C\<close> rotation_bij_corollary by fastforce
      have "x D \<noteq> A" using xC xA rotation_bij_corollary by fastforce
      then have "x D = B" using \<open>x D \<noteq> C\<close>  \<open>x D \<noteq> D\<close> Vertex.exhaust by blast

      have "x C \<noteq> A" using xC xA rotation_bij_corollary by fastforce
      have "x C \<noteq> B" using xC \<open>x D = B\<close> rotation_bij_corollary by fastforce
      have "x C \<noteq> C" using complex_rotations_fix xC xA \<open>x \<noteq> id\<close> by blast
      then have "x C = D" using \<open>x C \<noteq> A\<close> \<open>x C \<noteq> B\<close> Vertex.exhaust by blast

      have "\<forall> v. x v = rotate_A v"
        using xA \<open>x B = C\<close> \<open>x D = B\<close> \<open>x C = D\<close> Vertex.exhaust rotate_A_def Vertex.simps by metis
      then have "x = rotate_A" by auto
      then show ?thesis using stabiliser_A_def by auto
    next
      assume "x B = D"
      then have "x \<noteq> id" by auto
      then have "x C \<noteq> C" using complex_rotations_fix xC xA by blast
      have "x C \<noteq> D" using xC \<open>x B = D\<close> rotation_bij_corollary by fastforce
      have "x C \<noteq> A" using xC xA rotation_bij_corollary by fastforce
      then have "x C = B" using \<open>x C \<noteq> D\<close>  \<open>x C \<noteq> C\<close> Vertex.exhaust by blast

      have "x D \<noteq> A" using xC xA rotation_bij_corollary by fastforce
      have "x D \<noteq> B" using xC \<open>x C = B\<close> rotation_bij_corollary by fastforce
      have "x D \<noteq> D" using complex_rotations_fix xC xA \<open>x \<noteq> id\<close> by blast
      then have "x D = C" using \<open>x D \<noteq> A\<close> \<open>x D \<noteq> B\<close> Vertex.exhaust by blast

      have "\<forall> v. x v = (rotate_A \<circ> rotate_A) v"
        using xA \<open>x B = D\<close> \<open>x C = B\<close> \<open>x D = C\<close> Vertex.exhaust rotate_A_def Vertex.simps comp_apply by metis
      then have "x = rotate_A \<circ> rotate_A" by auto
      then show ?thesis using stabiliser_A_def by auto
    qed
    then show "x \<in> stabiliser_A" using xA xC by simp
  qed
qed

text \<open>
Using the previous result, we can now show that the cardinality of the stabiliser is 3.
\<close>
lemma card_stabiliser_help: "card stabiliser_A = 3"
proof -
  have idA:"id \<noteq> rotate_A"
  proof -
    have "id B = B" by simp
    moreover have "rotate_A B = C" by (simp add: rotate_A_def)
    ultimately show "id \<noteq> rotate_A" by force
  qed
  have idAA:"id \<noteq> rotate_A \<circ> rotate_A"
  proof -
    have "id B = B" by simp
    moreover have "(rotate_A \<circ> rotate_A) B = D" by (simp add: rotate_A_def)
    ultimately show "id \<noteq> rotate_A \<circ> rotate_A" by force
  qed
  have AAA:"rotate_A \<noteq> rotate_A \<circ> rotate_A"
  proof -
    have "rotate_A B = C" by (simp add: rotate_A_def)
    moreover have "(rotate_A \<circ> rotate_A) B = D" by (simp add: rotate_A_def)
    ultimately show "rotate_A \<noteq> rotate_A \<circ> rotate_A" by force
  qed
  from idA idAA AAA card_empty card_insert_if show
    "(card stabiliser_A) = 3" unfolding stabiliser_A_def by auto
qed

lemma card_stabiliser: "card (tetrahedral.stabiliser A) = 3"
  using is_stabiliser card_stabiliser_help by simp

section "Proving Finiteness"

text \<open>
In order to apply the orbit-stabiliser theorem, we need to prove that the set of rotations is
finite. We first prove that the set of vertices is finite.
\<close>
lemma vertex_set: "(UNIV::Vertex set) = {A, B, C, D}"
  by(auto, metis Vertex.exhaust)

lemma vertex_finite: "finite (UNIV :: Vertex set)"
  by (simp add: vertex_set)

text \<open>
Next we need instantiate Vertex as an element of the type class of finite sets in
HOL/Finite\_Set.thy. This will allow us to use the lemma that functions between finite sets
are finite themselves.
\<close>

instantiation Vertex :: finite
begin
instance proof
  show "finite (UNIV :: Vertex set)" by (simp add: vertex_set)
qed

text \<open>
Now we can show that the set of rotations is finite.
\<close>
lemma finite_carrier: "finite (carrier tetrahedral_group)"
proof -
  (* This follows from the instantiation above *)
  have "finite (UNIV :: (Vertex \<Rightarrow> Vertex) set)" by simp
  moreover have "complex_rotations \<subseteq> (UNIV :: (Vertex \<Rightarrow> Vertex) set)" by simp
  ultimately show "finite (carrier tetrahedral_group)" using finite_subset top_greatest by blast
qed

section "Order of the Group"

text \<open>
We can now finally apply the orbit-stabiliser theorem.
Since we have orbits of cardinality 4 and stabilisers of cardinality 3, the order of the tetrahedral group,
and with it the number of rotational symmetries of the tetrahedron, is 12.
\<close>
theorem "order tetrahedral_group = 12"
proof -
  have "card (tetrahedral.orbit A) * card (tetrahedral.stabiliser A) = 12"
    using card_stabiliser card_orbit by simp
  with tetrahedral.orbit_stabiliser[OF finite_carrier]
  show "order tetrahedral_group = 12" by simp
qed

end

end


theory mp1_sol
imports Main
begin

(*
In this exercise, you will prove some lemmas of propositional
logic with the aid of a calculus of natural deduction.

For the proofs, you may only use "assumption", and the following rules
with rule, erule, rule_tac or erule_tac.  You may also use lemmas that
you have proved so long as they meet the same restriction.
*)

thm notI
thm notE
thm conjI
thm conjE
thm disjI1
thm disjI2
thm disjE
thm impI
thm impE
thm iffI
thm iffE

(*
notI: (P \<Longrightarrow> False) \<Longrightarrow> \<not> P
notE: \<lbrakk> \<not> P; P \<rbrakk> \<Longrightarrow> Q
conjI: \<lbrakk> P; Q \<rbrakk> \<Longrightarrow> P \<and> Q
conjE: \<lbrakk> P \<and> Q; \<lbrakk> P; Q \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R
disjI1: P \<Longrightarrow> P \<or> Q
disjI2: Q \<Longrightarrow> P \<or> Q
disjE: \<lbrakk> P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R
impI: (P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q
impE: \<lbrakk> P \<longrightarrow> Q; P; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R
iffI: \<lbrakk> P \<Longrightarrow> Q; Q \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P = Q
iffE: \<lbrakk> P = Q; \<lbrakk> P \<longrightarrow> Q; Q \<longrightarrow> P \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R

Prove:
*)

(* +3 *)
lemma problem1: "(A \<and> B) \<longrightarrow> (B \<and> A)"
apply (rule impI)
apply (erule conjE)
apply (rule conjI)
apply assumption
apply assumption
done

(* + 4 *)
lemma problem2: "(A \<or> A) \<longrightarrow> (B \<or> A)"
apply (rule impI)
apply (rule disjI2)
apply (erule disjE)
apply (assumption)
apply (assumption)
done

(* +4  *)
lemma problem3: "(A \<and> B) \<longrightarrow> ((\<not>B) \<longrightarrow> (\<not>A))"
apply (rule impI)
apply (erule conjE)
apply (rule impI)
apply (erule notE)
apply assumption
done

(* + 5 *)
lemma problem4: " (A \<longrightarrow> B) \<longrightarrow> ((\<not> B) \<longrightarrow> (\<not> A))"
apply (rule impI)
apply (rule impI)
apply (rule notI)
apply (rule impE, assumption, assumption)
apply (rule notE, assumption, assumption)
done

(* + 5 *)
lemma problem5: "((A \<and> B) \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> (B \<longrightarrow> C))"
apply (rule impI)
apply (rule impI)
apply (rule impI)
apply (rule impE, assumption)
apply (rule conjI, assumption, assumption)
apply assumption
done

(* + 7 *)
lemma problem6: "((\<not> B) \<or> (\<not> A)) \<longrightarrow> (\<not>(A \<and> B))"
apply (rule impI)
apply (rule notI)
apply (rule conjE, assumption)
apply (rule disjE, assumption)
apply (rule notE, assumption, assumption)
apply (rule notE, assumption, assumption)
done

(* + 7 *)
lemma problem7: "(\<not>A \<or> \<not>B) \<longrightarrow> (\<not>(A \<and> B))"
apply (rule impI)
apply (rule notI)
apply (rule conjE, assumption)
apply (rule disjE, assumption)
apply (rule notE, assumption, assumption)
apply (rule notE, assumption, assumption)
done

(* Extra Credit *)
thm classical

(* + 1 *)
lemma problem8: "\<not> \<not> A \<longrightarrow> A"
apply(rule impI)
apply(rule classical)
apply(erule notE)
apply assumption
done

(* + 2 *)
lemma problem9: "A \<or> \<not> A"
apply(rule classical)
apply(rule disjI2)
apply(rule notI)
apply(erule notE)
apply(rule disjI1)
apply assumption
done

(* + 2 *)
lemma problem10: "(\<not> A \<longrightarrow> B) \<longrightarrow> (\<not> B \<longrightarrow> A)"
apply(rule impI)
apply(rule impI)
apply(rule classical)
apply(erule impE)
apply(assumption)
apply(erule notE)
apply assumption
done

(* +2 *)
lemma problem11: "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
apply(rule impI)
apply(rule classical)
apply(erule impE)
apply(rule impI)
apply(erule notE)
apply assumption
apply assumption
done

(* + 5 *)
lemma problem12: "(\<not> (A \<and> B)) = (\<not> A \<or> \<not> B)"
apply (rule iffI)
apply (rule classical)
apply (rule disjI1)
apply (rule notI)
apply (erule notE)
apply (rule conjI)
apply assumption
apply (rule classical)
apply (erule notE)
apply (rule disjI2)
apply assumption
apply (rule notI)
apply (erule conjE)
apply (erule disjE)
apply (erule notE)
apply assumption
apply (erule notE)
apply assumption
done

(* + 3 *)
lemma problem13: "(\<not> A \<longrightarrow> False) \<longrightarrow> A"
apply (rule impI)
apply (rule classical)
apply (erule impE)
apply assumption
apply (rule_tac P = "\<not> A" in notE)
apply (rule notI)
apply assumption
apply assumption
done

end


theory Dependency
  imports Main "HOL-Library.Finite_Map" FactoredSystem ActionSeqProcess RelUtils
begin

section \<open>Dependency\<close>

text \<open> State variable dependency analysis may be used to find structure in a factored system and
find useful projections, for example on variable sets which are closed under mutual dependency.
[Abdulaziz et al., p.13]

In the following the dependency predicate (`dep`) is formalized and some dependency related
propositions are proven. Dependency between variables `v1`, `v2` w.r.t to an action set @{term "\<delta>"} is given
if one of the following holds:
  (1) `v1` and `v2` are equal
  (2) an action @{term "(p, e) \<in> \<delta>"} exists where @{term "v1 \<in> \<D>(p)"} and @{term "v2 \<in> \<D>(e)"} (meaning that it is a
necessary condition that `p v1` is given if the action has effect `e v2`).
  (3) or, an action @{term "(p, e) \<in> \<delta>"} exists s.t. @{term "v1 v2 \<in> \<D>(e)"}
This notion is extended to sets of variables `vs1`, `vs2` (`dep\_var\_set`): `vs1` and `vs2` are
dependent iff `vs1` and `vs2` are disjoint and if dependent `v1`, `v2` exist where @{term "v1 \<in> vs1"},
@{term "v2 \<in> vs2"}. [Abdulaziz et al., Definition 7, p.13][Abdulaziz et al., HOL4 Definition 5, p.14] \<close>

subsection \<open>Dependent Variables and Variable Sets\<close>

\<comment> \<open>NOTE name shortened to 'dep'.\<close>
definition dep where
  "dep PROB v1 v2 \<equiv> (\<exists>a.
    a \<in> PROB
    \<and> (
      ((v1 \<in> fmdom' (fst a)) \<and> (v2 \<in> fmdom' (snd a)))
      \<or> ((v1 \<in> fmdom' (snd a) \<and> v2 \<in> fmdom' (snd a)))
    )
  )
    \<or> (v1 = v2)"

\<comment> \<open>NOTE name shortened to 'dep\_var\_set'.\<close>
definition dep_var_set where
  "dep_var_set PROB vs1 vs2 \<equiv> (disjnt vs1 vs2) \<and>
                              (\<exists> v1 v2. (v1 \<in> vs1) \<and> (v2 \<in> vs2) \<and> (dep PROB v1 v2)
  )"

lemma  dep_var_set_self_empty:
  fixes PROB vs
  assumes "dep_var_set PROB vs vs"
  shows "(vs = {})"
  using assms
  unfolding dep_var_set_def
proof -
  obtain v1 v2 where
    "v1 \<in> vs" "v2 \<in> vs" "disjnt vs vs" "dep PROB v1 v2"
    using assms
    unfolding dep_var_set_def
    by blast
  then show ?thesis
    by force
qed

lemma DEP_REFL:
  fixes PROB
  shows "reflexive (\<lambda>v v'. dep PROB v v')"
  unfolding dep_def reflexive_def
  by presburger

\<comment> \<open>NOTE added lemma.\<close>
lemma NEQ_DEP_IMP_IN_DOM_i:
  fixes a v
  assumes "a \<in> PROB" "v \<in> fmdom' (fst a)"
  shows "v \<in> prob_dom PROB"
proof -
  have "v \<in> fmdom' (fst a)"
    using assms(2)
    by simp
  moreover have "fmdom' (fst a) \<subseteq> prob_dom PROB"
    using assms(1)
    unfolding prob_dom_def action_dom_def
    using case_prod_beta'
    by auto
  ultimately show ?thesis
    by blast
qed

\<comment> \<open>NOTE added lemma.\<close>
lemma NEQ_DEP_IMP_IN_DOM_ii:
  fixes a v
  assumes "a \<in> PROB" "v \<in> fmdom' (snd a)"
  shows "v \<in> prob_dom PROB"
proof -
  have "v \<in> fmdom' (snd a)"
    using assms(2)
    by simp
  moreover have "fmdom' (snd a) \<subseteq> prob_dom PROB"
    using assms(1)
    unfolding prob_dom_def action_dom_def
    using case_prod_beta'
    by auto
  ultimately show ?thesis
    by blast
qed

lemma dep_sos_imp_mem_dep:
  fixes PROB S vs
  assumes "(dep_var_set PROB (\<Union> S) vs)"
  shows "(\<exists>vs'. vs' \<in> S \<and> dep_var_set PROB vs' vs)"
proof -
  obtain v1 v2 where obtain_v1_v2: "v1 \<in> \<Union>S" "v2 \<in> vs" "disjnt (\<Union>S) vs" "dep PROB v1 v2"
    using assms dep_var_set_def[of PROB "\<Union> S" vs]
    by blast
  moreover
  {
    fix vs'
    assume "vs' \<in> S"
    moreover have "vs' \<subseteq> (\<Union>S)"
      using calculation Union_upper
      by blast
    ultimately have "disjnt vs' vs"
      using obtain_v1_v2(3) disjnt_subset1
      by blast
  }
  ultimately show ?thesis
    unfolding dep_var_set_def
    by blast
qed

lemma dep_union_imp_or_dep:
  fixes PROB vs vs' vs''
  assumes "(dep_var_set PROB vs (vs' \<union> vs''))"
  shows "(dep_var_set PROB vs vs' \<or> dep_var_set PROB vs vs'')"
proof -
  obtain v1 v2 where
    obtain_v1_v2: "v1 \<in> vs" "v2 \<in> vs' \<union> vs''" "disjnt vs (vs' \<union> vs'')" "dep PROB v1 v2"
    using assms dep_var_set_def[of PROB vs "(vs' \<union> vs'')"]
    by blast
      \<comment> \<open>NOTE The proofs for the cases introduced here yield the goal's left and right side
    respectively.\<close>
  consider (i) "v2 \<in> vs'" | (ii) "v2 \<in> vs''"
    using obtain_v1_v2(2)
    by blast
  then show ?thesis
  proof (cases)
    case i
    have "vs' \<subseteq> vs' \<union> vs''"
      by auto
    moreover have "disjnt (vs' \<union> vs'') vs"
      using obtain_v1_v2(3) disjnt_sym
      by blast
    ultimately have "disjnt vs vs'"
      using disjnt_subset1 disjnt_sym
      by blast
    then have "dep_var_set PROB vs vs'"
      unfolding dep_var_set_def
      using obtain_v1_v2(1, 4) i
      by blast
    then show ?thesis
      by simp
  next
    case ii
    then have "vs'' \<subseteq> vs' \<union> vs''"
      by simp
    moreover have "disjnt (vs' \<union> vs'') vs"
      using obtain_v1_v2(3) disjnt_sym
      by fast
    ultimately have "disjnt vs vs''"
      using disjnt_subset1 disjnt_sym
      by metis
    then have "dep_var_set PROB vs vs''"
      unfolding dep_var_set_def
      using obtain_v1_v2(1, 4) ii
      by blast
    then show ?thesis
      by simp
  qed
qed

\<comment> \<open>NOTE This is symmetrical to `dep\_sos\_imp\_mem\_dep` w.r.t to `vs` and @{term "\<Union> S"}.\<close>
lemma dep_biunion_imp_or_dep:
  fixes PROB vs S
  assumes "(dep_var_set PROB vs (\<Union>S))"
  shows "(\<exists>vs'. vs' \<in> S \<and> dep_var_set PROB vs vs')"
proof -
  obtain v1 v2 where obtain_v1_v2: "v1 \<in> vs" "v2 \<in> (\<Union>S)" "disjnt vs (\<Union>S)" "dep PROB v1 v2"
    using assms dep_var_set_def[of PROB vs "\<Union> S"]
    by blast
  moreover
  {
    fix vs'
    assume "vs' \<in> S"
    then have "vs' \<subseteq> (\<Union>S)"
      using calculation Union_upper
      by blast
    moreover have "disjnt (\<Union>S) vs"
      using obtain_v1_v2(3) disjnt_sym
      by blast
    ultimately have "disjnt vs vs'"
      using obtain_v1_v2(3) disjnt_subset1 disjnt_sym
      by metis
  }
  ultimately show ?thesis
    unfolding dep_var_set_def
    by blast
qed

subsection "Transitive Closure of Dependent Variables and Variable Sets"

definition dep_tc where
  "dep_tc PROB = TC (\<lambda>v1' v2'. dep PROB v1' v2')"

\<comment> \<open>NOTE type of `PROB` had to be fixed for MP on `NEQ\_DEP\_IMP\_IN\_DOM`.\<close>
lemma dep_tc_imp_in_dom:
  fixes PROB :: "(('a, 'b) fmap \<times> ('a, 'b) fmap) set" and v1 v2
  assumes "\<not>(v1 = v2)" "(dep_tc PROB v1 v2)"
  shows "(v1 \<in> prob_dom PROB)"
proof -
  have "TC (dep PROB) v1 v2"
    using assms(2)
    unfolding dep_tc_def
    by simp
  then have "dep PROB v1 v2 \<or> (\<exists>y. v1 \<noteq> y \<and> y \<noteq> v2 \<and> dep PROB v1 y \<and> TC (dep PROB) y v2)"
    using TC_CASES1_NEQ[where R = "(\<lambda>v1' v2'. dep PROB v1' v2')" and x = v1 and z = v2]
    by (simp add: TC_equiv_tranclp)
      \<comment> \<open>NOTE Split on the disjunction yielded by the previous step.\<close>
  then consider
    (i) "dep PROB v1 v2"
    | (ii) "(\<exists>y. v1 \<noteq> y \<and> y \<noteq> v2 \<and> dep PROB v1 y \<and> TC (dep PROB) y v2)"
    by fast
  then show ?thesis
  proof (cases)
    case i
    {
      consider
        (II) "(\<exists>a.
            a \<in> PROB \<and>
            (
              v1 \<in> fmdom' (fst a) \<and> v2 \<in> fmdom' (snd a)
              \<or> v1 \<in> fmdom' (snd a) \<and> v2 \<in> fmdom' (snd a)))"
        | (III) "v1 = v2"
        using i
        unfolding dep_def
        by blast
      then have ?thesis
      proof (cases)
        case II
        then obtain a where 1:
          "a \<in> PROB" "(v1 \<in> fmdom' (fst a) \<and> v2 \<in> fmdom' (snd a)
              \<or> v1 \<in> fmdom' (snd a) \<and> v2 \<in> fmdom' (snd a))"
          by blast
        then have "v1 \<in> fmdom' (fst a) \<union> fmdom' (snd a)"
          by blast
        then have 2: "v1 \<in> action_dom (fst a) (snd a)"
          unfolding action_dom_def
          by blast
        then have "action_dom (fst a) (snd a) \<subseteq> prob_dom PROB"
          using 1(1) exec_as_proj_valid_2
          by fast
        then have "v1 \<in> prob_dom PROB"
          using 1 2
          by fast
        then show ?thesis
          by simp
      next
        case III
        then show ?thesis
          using assms(1)
          by simp
      qed
    }
    then show ?thesis
      by simp
  next
    case ii
    then obtain y where "v1 \<noteq> y" "y \<noteq> v2" "dep PROB v1 y" "TC (dep PROB) y v2"
      using ii
      by blast
    then show ?thesis
      using NEQ_DEP_IMP_IN_DOM
      by metis
  qed
qed

lemma not_dep_disj_imp_not_dep:
  fixes PROB vs_1 vs_2 vs_3
  assumes "((vs_1 \<inter> vs_2) = {})" "(vs_3 \<subseteq> vs_2)" "\<not>(dep_var_set PROB vs_1 vs_2)"
  shows "\<not>(dep_var_set PROB vs_1 vs_3)"
  using assms subset_eq
  unfolding dep_var_set_def disjnt_def
  by blast

lemma dep_slist_imp_mem_dep:
  fixes PROB vs lvs
  assumes "(dep_var_set PROB (\<Union> (set lvs)) vs)"
  shows "(\<exists>vs'. ListMem vs' lvs \<and> dep_var_set PROB vs' vs)"
proof -
  obtain v1 v2 where
    obtain_v1_v2: "v1 \<in> \<Union>(set lvs)" "v2 \<in> vs" "disjnt (\<Union>(set lvs)) vs" "dep PROB v1 v2"
    using assms dep_var_set_def[of PROB "\<Union> (set lvs)" vs]
    by blast
  then obtain vs' where obtain_vs': "vs' \<in> set lvs" "v1 \<in> vs'"
    by blast
  then have "ListMem vs' lvs"
    using ListMem_iff
    by fast
  moreover {
    have "disjnt vs' vs"
      using obtain_v1_v2(3) obtain_vs'(1) by auto
    then have "dep_var_set PROB vs' vs"
      unfolding dep_var_set_def
      using obtain_v1_v2(1, 2, 4) obtain_vs'(2)
      by blast
  }
  ultimately show ?thesis
    by blast
qed

lemma n_bigunion_le_sum_3:
  fixes PROB vs svs
  assumes "(\<forall> vs'. vs' \<in> svs \<longrightarrow> \<not>(dep_var_set PROB vs' vs))"
  shows "\<not>(dep_var_set PROB (\<Union>svs) vs)"
proof -
  {
    assume "(dep_var_set PROB (\<Union>svs) vs)"
    then obtain v1 v2 where obtain_vs: "v1 \<in> \<Union>svs" "v2 \<in> vs" "disjnt (\<Union>svs) vs" "dep PROB v1 v2"
      unfolding dep_var_set_def
      by blast
    then obtain vs' where obtain_vs': "v1 \<in> vs'" "vs' \<in> svs"
      by blast
    then have a: "disjnt vs' vs"
      using obtain_vs(3) obtain_vs'(2) disjnt_subset1
      by blast
    then have "\<forall>v1 v2. \<not>(v1 \<in> vs') \<or> \<not>(v2 \<in> vs) \<or> \<not>disjnt vs' vs \<or> \<not>dep PROB v1 v2"
      using assms obtain_vs'(2) dep_var_set_def
      by fast
    then have False
      using a obtain_vs'(1) obtain_vs(2, 4)
      by blast
  }
  then show ?thesis
    by blast
qed

lemma disj_not_dep_vset_union_imp_or:
  fixes PROB a vs vs'
  assumes "(a \<in> PROB)" "(disjnt vs vs')"
    "(\<not>(dep_var_set PROB vs' vs) \<or> \<not>(dep_var_set PROB vs vs'))"
    "(varset_action a (vs \<union> vs'))"
  shows "(varset_action a vs \<or> varset_action a vs')"
  using assms
  unfolding varset_action_def dep_var_set_def dep_def
proof -
  assume a1: "fmdom' (snd a) \<subseteq> vs \<union> vs'"
  assume "disjnt vs vs'"
  assume " \<not> (disjnt vs' vs \<and>
        (\<exists>v1 v2. v1 \<in> vs' \<and> v2 \<in> vs \<and> ((\<exists>a. a \<in> PROB \<and> (v1 \<in> fmdom' (fst a) \<and> v2 \<in> fmdom' (snd a) \<or> v1 \<in> fmdom' (snd a) \<and> v2 \<in> fmdom' (snd a))) \<or> v1 = v2))) \<or>
       \<not> (disjnt vs vs' \<and>
        (\<exists>v1 v2. v1 \<in> vs \<and> v2 \<in> vs' \<and> ((\<exists>a. a \<in> PROB \<and> (v1 \<in> fmdom' (fst a) \<and> v2 \<in> fmdom' (snd a) \<or> v1 \<in> fmdom' (snd a) \<and> v2 \<in> fmdom' (snd a))) \<or> v1 = v2))) "
  then have f2: "\<And>aa ab. aa \<notin> vs \<or> ab \<notin> vs' \<or> aa \<notin> fmdom' (snd a) \<or> ab \<notin> fmdom' (snd a)"
    using \<open>a \<in> PROB\<close> \<open>disjnt vs vs'\<close> disjnt_sym by blast
  obtain aa :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a" where
    f3: "\<And>A Aa a Ab Ac. (A \<subseteq> Aa \<or> aa A Aa \<in> A) \<and> (aa A Aa \<notin> Aa \<or> A \<subseteq> Aa)
      \<and> ((a::'a) \<notin> Ab \<or> \<not> Ab \<subseteq> Ac \<or> a \<in> Ac)"
    by moura
  then have "\<And>A. fmdom' (snd a) \<subseteq> A \<or> aa (fmdom' (snd a)) A \<in> vs \<or> aa (fmdom' (snd a)) A \<in> vs'"
    using a1 by (meson Un_iff)
  then show "fmdom' (snd a) \<subseteq> vs \<or> fmdom' (snd a) \<subseteq> vs'"
    using f3 f2 by meson
qed

end


(* Various presentations of finite sets *)
theory FSets_Alternatives
imports FSets_Bags
begin

(* Alternative descriptions of finite sets and the transport of the recursors to the type of sets.
The development culminates with a series of fold operators for finite sets. *)

section{* Finite sets initial semi-lattice with unit (ACIU): *}

nonfree_datatype 'a fsetS = SEmp | SSingl 'a | SUni "'a fsetS" "'a fsetS"
where
  Assoc: "SUni (SUni A1 A2) A3 = SUni A1 (SUni A2 A3)"
| Comm: "SUni A1 A2 = SUni A2 A1"
| Idem: "SUni A A = A"
| Id: "SUni SEmp A = A"

declare Idem[simp]  declare Id[simp]

lemma SUni_SEmp[simp]: "SUni A SEmp = A"
by (metis Comm Id)

nonfree_primrec from_fsetS :: "'a fsetS \<Rightarrow> 'a fset"
where
  "from_fsetS SEmp = Emp"
| "from_fsetS (SSingl a) = Singl a"
| "from_fsetS (SUni A1 A2) = Uni (from_fsetS A1) (from_fsetS A2)"
apply auto using Uni_assoc Uni_com by metis+

nonfree_primrec to_fsetS :: "'a fset \<Rightarrow> 'a fsetS"
where
  "to_fsetS Emp = SEmp"
| "to_fsetS (Ins a A) = SUni (SSingl a) (to_fsetS A)"
by (metis Assoc Idem Comm)+

lemma from_fsetS_to_fsetS[simp]: "from_fsetS (to_fsetS A) = A"
by (induct A) (auto simp: Singl_def)

lemma asFSetsS_Uni[simp]: "to_fsetS (Uni A B) = SUni (to_fsetS A) (to_fsetS B)"
apply(induction A) apply auto using Assoc
apply metis done

lemma to_fsetS_from_fsetS[simp]: "to_fsetS (from_fsetS A) = A"
apply(induction A) by (auto simp: Singl_def)

section{* Nonempty finite sets, as initial semilattice (ACI): *}

nonfree_datatype 'a fsetN = NSingl 'a | NUni "'a fsetN" "'a fsetN"
where
  AssocN: "NUni (NUni A1 A2) A3 = NUni A1 (NUni A2 A3)"
| CommN: "NUni A1 A2 = NUni A2 A1"
| IdemN: "NUni A A = A"

nonfree_primrec memN :: "'a \<Rightarrow> 'a fsetN \<Rightarrow> bool"
where
  "memN b (NSingl a) = (a = b)"
| "memN b (NUni A B) = (memN b A \<or> memN b B)"
using Ins2 by auto

nonfree_primrec from_fsetN :: "'a fsetN \<Rightarrow> 'a fset"
where
  "from_fsetN (NSingl a) = Singl a"
| "from_fsetN (NUni A1 A2) = Uni (from_fsetN A1) (from_fsetN A2)"
apply auto using Uni_assoc Uni_com by metis+

nonfree_primrec to_fsetN' :: "'a fset \<Rightarrow> 'a fsetN option"
where
  "to_fsetN' Emp = None"
| "to_fsetN' (Ins a A) =
   (case to_fsetN' A of None \<Rightarrow> Some (NSingl a)
                      |Some N \<Rightarrow> Some (NUni (NSingl a) N))"
by (auto split: option.splits) (metis AssocN IdemN CommN)+

lemma not_Emp_to_fsetN':
"A \<noteq> Emp \<Longrightarrow> to_fsetN' A \<noteq> None"
by (induction A) (auto split: option.splits)

definition to_fsetN :: "'a fset \<Rightarrow> 'a fsetN"
where "to_fsetN = the o to_fsetN'"

lemma to_fsetN_simps[simp]:
"to_fsetN (Ins a Emp) = NSingl a"
"A \<noteq> Emp \<Longrightarrow> to_fsetN (Ins a A) = NUni (NSingl a) (to_fsetN A)"
unfolding to_fsetN_def
by (auto split: option.splits simp: not_Emp_to_fsetN')

lemma mem_from_fsetN[simp]:
"mem a (from_fsetN A) \<longleftrightarrow> memN a A"
by (induction A) (auto simp: Singl_def)

lemma from_fsetN_to_fsetN: "A \<noteq> Emp \<Longrightarrow> from_fsetN (to_fsetN A) = A"
apply(induction A) by (case_tac "A = Emp") (auto simp: Singl_def)

lemma from_fsetN_not_Emp[simp]: "from_fsetN A \<noteq> Emp"
by(induction A) auto

lemma Singl_inj[simp]: "Singl x = Singl y \<longleftrightarrow> x = y"
unfolding Singl_def by (metis mem.simps)

lemma from_fsetN_surj:
assumes "B \<noteq> Emp"
shows "\<exists> A. B = from_fsetN A"
using assms by(induction B) (auto, metis Ins_not_Emp from_fsetN_to_fsetN)

lemma to_fsetN_Uni[simp]:
assumes "A \<noteq> Emp" and "B \<noteq> Emp"
shows "to_fsetN (Uni A B) = NUni (to_fsetN A) (to_fsetN B)"
using assms apply(induction A)
by (case_tac "A = Emp") (auto simp: Singl_def AssocN)

lemma to_fsetN_from_fsetN[simp]: "to_fsetN (from_fsetN A) = A"
by (induction A) (auto simp: Singl_def)

lemma from_fsetN_inj[simp]: "from_fsetN A = from_fsetN B \<longleftrightarrow> A = B"
by (metis to_fsetN_from_fsetN)

lemma to_fsetN_Ins[simp]:
"A \<noteq> Emp \<Longrightarrow> to_fsetN (Ins a A) = NUni (NSingl a) (to_fsetN A)"
by (metis Singl_def Uni.simps from_fsetN.simps from_fsetN_to_fsetN to_fsetN_from_fsetN)

lemma to_fsetN_Ins_Emp[simp]: "to_fsetN (Ins a Emp) = NSingl a"
by (metis Singl_def from_fsetN.simps(2) to_fsetN_from_fsetN)

lemma to_fsetN_inj[simp]:
assumes "A \<noteq> Emp" and "B \<noteq> Emp"
shows "to_fsetN A = to_fsetN B \<longleftrightarrow> A = B"
by (metis assms from_fsetN_to_fsetN)

lemma memN_to_fsetN[simp]:
"A \<noteq> Emp \<Longrightarrow> memN a (to_fsetN A) \<longleftrightarrow> mem a A"
by (metis from_fsetN_to_fsetN mem_from_fsetN)

section{* Nonempty finite sets, as singleton-insert view: *}

nonfree_datatype 'a fsetNN = NNSingl 'a | NNIns 'a "'a fsetNN"
where
  NNIns1: "NNIns a (NNIns a A) = NNIns a A"
| NNIns2: "NNIns a1 (NNIns a2 A) = NNIns a2 (NNIns a1 A)"
(* error in the paper's appendix---the following were not included: *)
| NNIns_NNSingl1: "NNIns a (NNSingl a) = NNSingl a"
| NNIns_NNSingl2: "NNIns a1 (NNSingl a2) = NNIns a2 (NNSingl a1)"

nonfree_primrec memNN :: "'a \<Rightarrow> 'a fsetNN \<Rightarrow> bool"
where
  "memNN b (NNSingl a) = (a = b)"
| "memNN b (NNIns a A) = (a = b \<or> memNN b A)"
using Ins2 by auto

nonfree_primrec from_fsetNN :: "'a fsetNN \<Rightarrow> 'a fset"
where
  "from_fsetNN (NNSingl a) = Singl a"
| "from_fsetNN (NNIns a A) = Ins a (from_fsetNN A)"
using Ins1 Ins2 unfolding Singl_def by metis+

nonfree_primrec to_fsetNN' :: "'a fset \<Rightarrow> 'a fsetNN option"
where
  "to_fsetNN' Emp = None"
| "to_fsetNN' (Ins a A) =
   (case to_fsetNN' A of None \<Rightarrow> Some (NNSingl a)
                      |Some N \<Rightarrow> Some (NNIns a N))"
apply (auto split: option.splits)
by (metis NNIns1 NNIns2 NNIns_NNSingl1 NNIns_NNSingl2)+

lemma not_Emp_to_fsetNN':
"A \<noteq> Emp \<Longrightarrow> to_fsetNN' A \<noteq> None"
by (induction A) (auto split: option.splits)

definition to_fsetNN :: "'a fset \<Rightarrow> 'a fsetNN"
where "to_fsetNN = the o to_fsetNN'"

lemma to_fsetNN_simps[simp]:
"to_fsetNN (Ins a Emp) = NNSingl a"
"A \<noteq> Emp \<Longrightarrow> to_fsetNN (Ins a A) = NNIns a (to_fsetNN A)"
unfolding to_fsetNN_def
by (auto split: option.splits simp: not_Emp_to_fsetNN')

lemma mem_from_fsetNN[simp]:
"mem a (from_fsetNN A) \<longleftrightarrow> memNN a A"
by (induction A) (auto simp: Singl_def)

lemma from_fsetNN_to_fsetNN: "A \<noteq> Emp \<Longrightarrow> from_fsetNN (to_fsetNN A) = A"
apply(induction A) by (case_tac "A = Emp") (auto simp: Singl_def)

lemma from_fsetNN_not_Emp[simp]: "from_fsetNN A \<noteq> Emp"
by(induction A) auto

lemma from_fsetNN_surj:
assumes "B \<noteq> Emp"
shows "\<exists> A. B = from_fsetNN A"
using assms by(induction B) (auto, metis Ins_not_Emp from_fsetNN_to_fsetNN)

lemma to_fsetNN_from_fsetNN[simp]: "to_fsetNN (from_fsetNN A) = A"
by (induction A) (auto simp: Singl_def)

lemma from_fsetNN_inj[simp]: "from_fsetNN A = from_fsetNN B \<longleftrightarrow> A = B"
by (metis to_fsetNN_from_fsetNN)

lemma to_fsetNN_Ins[simp]:
"A \<noteq> Emp \<Longrightarrow> to_fsetNN (Ins a A) = NNIns a (to_fsetNN A)"
by auto

lemma to_fsetNN_Ins_Emp[simp]: "to_fsetNN (Ins a Emp) = NNSingl a"
by (metis Singl_def from_fsetNN.simps(2) to_fsetNN_from_fsetNN)

lemma to_fsetNN_inj[simp]:
assumes "A \<noteq> Emp" and "B \<noteq> Emp"
shows "to_fsetNN A = to_fsetNN B \<longleftrightarrow> A = B"
by (metis assms from_fsetNN_to_fsetNN)

lemma memNN_to_fsetNN[simp]:
"A \<noteq> Emp \<Longrightarrow> memNN a (to_fsetNN A) \<longleftrightarrow> mem a A"
by (metis from_fsetNN_to_fsetNN mem_from_fsetNN)

section{* Cover existing fold functions: *}

(* Isabelle's fold for finite sets: *)
locale Isabelle =
fixes f :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
assumes f_assoc: "f (f a b) c = f a (f b c)"
    and f_comm: "f a b = f b a"
begin

nonfree_primrec fold1 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a fset \<Rightarrow> 'a fset \<times> 'b"
where
  "fold1 g z Emp = (Emp, z)"
| "fold1 g z (Ins a A) =
   (case fold1 g z A of (A,b) \<Rightarrow> (Ins a A, if mem a A then b else f (g a) b))"
using f_comm f_assoc Ins2 by auto

lemma fold1: "fold1 g z A = (A',b) \<Longrightarrow> A = A'"
by (induct arbitrary: A' b rule: fset_induct) (auto split: prod.splits)

definition fold :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a fset \<Rightarrow> 'b"
where "fold g z = snd o (fold1 g z)"

lemma fold_simps[simp]:
  "fold g z Emp = z"
  "fold g z (Ins a A) = (if mem a A then fold g z A else f (g a) (fold g z A))"
  "\<not> mem a A \<Longrightarrow> fold g z (Ins a A) = f (g a) (fold g z A)"
unfolding fold_def using fold1 by (fastforce split: prod.splits)+

end

(* HOL4 and PVS fold for finite sets: *)
locale HOL4_PVS =
fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
assumes f_left_comm: "f a1 (f a2 b) = f a2 (f a1 b)"
begin

nonfree_primrec fold1 :: "'b \<Rightarrow> 'a fset \<Rightarrow> 'a fset \<times> 'b"
where
  "fold1 z Emp = (Emp, z)"
| "fold1 z (Ins a A) =
   (case fold1 z A of (A,b) \<Rightarrow> (Ins a A, if mem a A then b else f a b))"
using f_left_comm Ins2 by force+

lemma fold1: "fold1 z A = (A',b) \<Longrightarrow> A = A'"
by (induct arbitrary: A' b rule: fset_induct) (auto split: prod.splits)

definition fold :: "'b \<Rightarrow> 'a fset \<Rightarrow> 'b"
where "fold z = snd o (fold1 z)"

lemma fold_simps[simp]:
  "fold z Emp = z"
  "fold z (Ins a A) = (if mem a A then fold z A else f a (fold z A))"
  "\<not> mem a A \<Longrightarrow> fold z (Ins a A) = f a (fold z A)"
unfolding fold_def using fold1 by (fastforce split: prod.splits)+

end

(* Isabelle's fold for nonempty finite sets: *)
locale Isabelle_NE =
fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
assumes f_assoc: "f (f a b) c = f a (f b c)"
    and f_comm: "f a b = f b a"
begin

nonfree_primrec fold1 :: "'a fsetNN \<Rightarrow> 'a fsetNN \<times> 'a"
where
  "fold1 (NNSingl a) = (NNSingl a, a)"
| "fold1 (NNIns a A) =
   (case fold1 A of (A,b) \<Rightarrow> (NNIns a A, if memNN a A then b else f a b))"
using f_comm f_assoc NNIns1 NNIns2 NNIns_NNSingl1 NNIns_NNSingl2 by fastforce+

lemma fold1: "fold1 A = (A',b) \<Longrightarrow> A = A'"
by (induction A arbitrary: A' b) (auto split: prod.splits)

definition fold :: "'a fsetNN \<Rightarrow> 'a"
where "fold = snd o fold1"

lemma fold_simps[simp]:
  "fold (NNSingl a) = a"
  "fold (NNIns a A) = (if memNN a A then fold A else f a (fold A))"
  "\<not> memNN a A \<Longrightarrow> fold (NNIns a A) = f a (fold A)"
unfolding fold_def using fold1 by (fastforce split: prod.splits)+

end

section{* Transfer to the type 'a set *}

definition fold_fset :: "'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b" where
"fold_fset E I = iter_fset E I o asFset"

(* Fold equations coming from 'a fset : *)
lemma fold_fset_emp:
assumes "\<And>a b. I a (I a b) = I a b"
and "\<And> a1 a2 b. I a1 (I a2 b) = I a2 (I a1 b)"
shows "fold_fset E I {} = E"
unfolding fold_fset_def comp_def using assms apply simp
apply(rule fset_iter_rews) by auto

lemma fold_fset_insert:
assumes A: "finite A"
and "\<And>a b. I a (I a b) = I a b"
and "\<And> a1 a2 b. I a1 (I a2 b) = I a2 (I a1 b)"
shows "fold_fset E I (insert a A) = I a (fold_fset E I A)"
unfolding fold_fset_def comp_def using assms apply simp
apply(rule fset_iter_rews) by auto

definition fold_fsetS :: "'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b" where
"fold_fsetS E S U = iter_fsetS E S U o (to_fsetS o asFset)"

(* Fold equations coming from 'a fsetS : *)
lemma fold_fsetS_emp:
assumes "\<And>a b c. U (U a b) c = U a (U b c)"
and "\<And> a b. U a b = U b a"
and "\<And> a. U a a = a"
and "\<And> a. U a E = a"
shows "fold_fsetS E S U {} = E"
unfolding fold_fsetS_def comp_def using assms apply simp
apply(rule fsetS_iter_rews) by auto

lemma fold_fsetS_singl:
assumes "\<And>a b c. U (U a b) c = U a (U b c)"
and "\<And> a b. U a b = U b a"
and "\<And> a. U a a = a"
and "\<And> a. U a E = a"
shows "fold_fsetS E S U {a} = S a"
unfolding fold_fsetS_def comp_def using assms apply simp
apply(rule fsetS_iter_rews) by auto

lemma fold_fsetS_Un:
assumes A: "finite A" and B: "finite B"
and "\<And>a b c. U (U a b) c = U a (U b c)"
and "\<And> a b. U a b = U b a"
and "\<And> a. U a a = a"
and "\<And> a. U a E = a"
shows "fold_fsetS E S U (A \<union> B) = U (fold_fsetS E S U A) (fold_fsetS E S U B)"
unfolding fold_fsetS_def comp_def using assms apply simp
apply(rule fsetS_iter_rews) by auto

(* Fold equations coming from 'a fsetN : *)
definition fold_fsetN :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b" where
"fold_fsetN S U \<equiv> iter_fsetN S U o (to_fsetN o asFset)"

lemma fold_fsetN_singl:
assumes "\<And>a b c. U (U a b) c = U a (U b c)"
and "\<And> a b. U a b = U b a"
and "\<And> a. U a a = a"
shows "fold_fsetN S U {a} = S a"
unfolding fold_fsetN_def comp_def using assms apply simp
apply(rule fsetN_iter_rews) by auto

lemma fold_fsetN_Un:
assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
and "\<And>a b c. U (U a b) c = U a (U b c)"
and "\<And> a b. U a b = U b a"
and "\<And> a. U a a = a"
shows "fold_fsetN S U (A \<union> B) = U (fold_fsetN S U A) (fold_fsetN S U B)"
unfolding fold_fsetN_def comp_def using assms apply simp
apply(rule fsetN_iter_rews) by auto

(* Fold equations coming from 'a fsetNN : *)
definition fold_fsetNN :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b" where
"fold_fsetNN S I \<equiv> iter_fsetNN S I o (to_fsetNN o asFset)"

lemma fold_fsetNN_singl:
assumes "\<And>a1 a2 b. I a1 (I a2 b) =  I a2 (I a1 b)"
and "\<And>a b. I a (I a b) = I a b"
and "\<And>a1 a2. I a1 (S a2) =  I a2 (S a1)"
and "\<And>a. I a (S a) = S a"
shows "fold_fsetNN S I {a} = S a"
unfolding fold_fsetNN_def comp_def using assms apply simp
apply(rule fsetNN_iter_rews) by auto

lemma fold_fsetNN_Un:
assumes A: "finite A" "A \<noteq> {}"
and "\<And>a1 a2 b. I a1 (I a2 b) =  I a2 (I a1 b)"
and "\<And>a b. I a (I a b) =  I a b"
and "\<And>a1 a2. I a1 (S a2) =  I a2 (S a1)"
and "\<And>a. I a (S a) = S a"
shows "fold_fsetNN S I (insert a A) = I a (fold_fsetNN S I A)"
unfolding fold_fsetNN_def comp_def using assms apply simp
apply(rule fsetNN_iter_rews) by auto

end