section \<open>Simplicial complexes\<close>

text \<open>
  In this section we develop the basic theory of abstract simplicial complexes as a collection of
  finite sets, where the power set of each member set is contained in the collection. Note that in
  this development we allow the empty simplex, since allowing it or not seemed of no logical
  consequence, but of some small practical consequence.
\<close>

theory Simplicial
imports Prelim

begin

subsection \<open>Geometric notions\<close>

text \<open>
  The geometric notions attached to a simplicial complex of main interest to us are those of facets
  (subsets of codimension one), adjacency (sharing a facet in common), and chains of adjacent
  simplices.
\<close>

subsubsection \<open>Facets\<close>

definition facetrel :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<lhd>" 60)
  where "y \<lhd> x \<equiv> \<exists>v. v \<notin> y \<and> x = insert v y"

lemma facetrelI: "v \<notin> y \<Longrightarrow> x = insert v y \<Longrightarrow> y \<lhd> x"
  using facetrel_def by fast

lemma facetrelI_card: "y \<subseteq> x \<Longrightarrow> card (x-y) = 1 \<Longrightarrow> y \<lhd> x"
  using card1[of "x-y"] by (blast intro: facetrelI)

lemma facetrel_complement_vertex: "y\<lhd>x \<Longrightarrow> x = insert v y \<Longrightarrow> v\<notin>y"
  using facetrel_def[of y x] by fastforce

lemma facetrel_diff_vertex: "v\<in>x \<Longrightarrow> x-{v} \<lhd> x"
  by (auto intro: facetrelI)

lemma facetrel_conv_insert: "y \<lhd> x \<Longrightarrow> v \<in> x - y \<Longrightarrow> x = insert v y"
  unfolding facetrel_def by fast

lemma facetrel_psubset: "y \<lhd> x \<Longrightarrow> y \<subset> x"
  unfolding facetrel_def by fast

lemma facetrel_subset: "y \<lhd> x \<Longrightarrow> y \<subseteq> x"
  using facetrel_psubset by fast

lemma facetrel_card: "y \<lhd> x \<Longrightarrow> card (x-y) = 1"
  using insert_Diff_if[of _ y y] unfolding facetrel_def by fastforce

lemma finite_facetrel_card: "finite x \<Longrightarrow> y\<lhd>x \<Longrightarrow> card x = Suc (card y)"
  using facetrel_def[of y x] card_insert_disjoint[of x] by auto

lemma facetrelI_cardSuc: "z\<subseteq>x \<Longrightarrow> card x = Suc (card z) \<Longrightarrow> z\<lhd>x"
  using card_ge_0_finite finite_subset[of z] card_Diff_subset[of z x]
  by    (force intro: facetrelI_card)

lemma facet2_subset: "\<lbrakk> z\<lhd>x; z\<lhd>y; x\<inter>y - z \<noteq> {} \<rbrakk> \<Longrightarrow> x \<subseteq> y"
  unfolding facetrel_def by force

lemma inj_on_pullback_facet:
  assumes "inj_on f x" "z \<lhd> f`x"
  obtains y where "y \<lhd> x" "f`y = z"
proof
  from assms(2) obtain v where v: "v\<notin>z" "f`x = insert v z"
    using facetrel_def[of z] by auto
  define u and y where "u \<equiv> the_inv_into x f v" and y: "y \<equiv> {v\<in>x. f v \<in> z}"
  moreover with assms(2) v have "x = insert u y"
    using the_inv_into_f_eq[OF assms(1)] the_inv_into_into[OF assms(1)]
    by    auto
  ultimately show "y \<lhd> x"
    using v f_the_inv_into_f[OF assms(1)] by (force intro: facetrelI)
  from y assms(2) show "f`y = z" using facetrel_subset by fast
qed

subsubsection \<open>Adjacency\<close>

definition adjacent :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sim>" 70)
  where "x \<sim> y \<equiv> \<exists>z. z\<lhd>x \<and> z\<lhd>y"

lemma adjacentI: "z\<lhd>x \<Longrightarrow> z\<lhd>y \<Longrightarrow> x \<sim> y"
  using adjacent_def by fast

lemma empty_not_adjacent: "\<not> {} \<sim> x"
  unfolding facetrel_def adjacent_def by fast

lemma adjacent_sym: "x \<sim> y \<Longrightarrow> y \<sim> x"
  unfolding adjacent_def by fast

lemma adjacent_refl:
  assumes "x \<noteq> {}"
  shows   "x \<sim> x"
proof-
  from assms obtain v where v: "v\<in>x" by fast
  thus "x \<sim> x" using facetrelI[of v "x-{v}"] unfolding adjacent_def by fast
qed

lemma common_facet: "\<lbrakk> z\<lhd>x; z\<lhd>y; x \<noteq> y \<rbrakk> \<Longrightarrow> z = x \<inter> y"
  using facetrel_subset facet2_subset by fast

lemma adjacent_int_facet1: "x \<sim> y \<Longrightarrow> x \<noteq> y \<Longrightarrow> (x \<inter> y) \<lhd> x"
  using common_facet unfolding adjacent_def by fast

lemma adjacent_int_facet2: "x \<sim> y \<Longrightarrow> x \<noteq> y \<Longrightarrow> (x \<inter> y) \<lhd> y"
  using adjacent_sym adjacent_int_facet1 by (fastforce simp add: Int_commute)

lemma adjacent_conv_insert: "x \<sim> y \<Longrightarrow> v \<in> x - y \<Longrightarrow> x = insert v (x\<inter>y)"
  using adjacent_int_facet1 facetrel_conv_insert by fast

lemma adjacent_int_decomp:
  "x \<sim> y \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>v. v \<notin> y \<and> x = insert v (x\<inter>y)"
  using adjacent_int_facet1 unfolding facetrel_def by fast

lemma adj_antivertex:
  assumes "x\<sim>y" "x\<noteq>y"
  shows   "\<exists>!v. v\<in>x-y"
proof (rule ex_ex1I)
  from assms obtain w where w: "w\<notin>y" "x = insert w (x\<inter>y)"
    using adjacent_int_decomp by fast
  thus "\<exists>v. v\<in>x-y" by auto
  from w have "\<And>v. v\<in>x-y \<Longrightarrow> v=w" by fast
  thus "\<And>v v'. v\<in>x-y \<Longrightarrow> v'\<in>x-y \<Longrightarrow> v=v'" by auto
qed

lemma adjacent_card: "x \<sim> y \<Longrightarrow> card x = card y"
  unfolding adjacent_def facetrel_def by (cases "finite x" "x=y" rule: two_cases) auto

lemma adjacent_to_adjacent_int_subset:
  assumes "C \<sim> D" "f`C \<sim> f`D" "f`C \<noteq> f`D"
  shows   "f`C \<inter> f`D \<subseteq> f`(C\<inter>D)"
proof
  from assms(1,3) obtain v where v: "v \<notin> D" "C = insert v (C\<inter>D)"
    using adjacent_int_decomp by fast
  from assms(2,3) obtain w where w: "w \<notin> f`D" "f`C = insert w (f`C\<inter>f`D)"
    using adjacent_int_decomp[of "f`C" "f`D"] by fast
  from w have w': "w \<in> f`C - f`D" by fast
  with v assms(1,2) have fv_w: "f v = w" using adjacent_conv_insert by fast
  fix b assume "b \<in> f`C \<inter> f`D"
  from this obtain a1 a2
    where a1: "a1 \<in> C" "b = f a1"
    and   a2: "a2 \<in> D" "b = f a2"
    by    fast
  from v a1 a2(2) have "a1 \<notin> D \<Longrightarrow> f a2 = w" using fv_w by auto
  with a2(1) w' have "a1 \<in> D" by fast
  with a1 show "b \<in> f`(C\<inter>D)" by fast
qed

lemma adjacent_to_adjacent_int:
  "\<lbrakk> C \<sim> D; f`C \<sim> f`D; f`C \<noteq> f`D \<rbrakk> \<Longrightarrow> f`(C\<inter>D) = f`C \<inter> f`D"
  using adjacent_to_adjacent_int_subset by fast

subsubsection \<open>Chains of adjacent sets\<close>

abbreviation "adjacentchain  \<equiv> binrelchain adjacent"
abbreviation "padjacentchain \<equiv> proper_binrelchain adjacent"

lemmas adjacentchain_Cons_reduce   = binrelchain_Cons_reduce   [of adjacent]
lemmas adjacentchain_obtain_proper = binrelchain_obtain_proper [of _ _ adjacent]

lemma adjacentchain_card: "adjacentchain (x#xs@[y]) \<Longrightarrow> card x = card y"
  using adjacent_card by (induct xs arbitrary: x) auto

subsection \<open>Locale and basic facts\<close>

locale SimplicialComplex =
  fixes   X :: "'a set set"
  assumes finite_simplices: "\<forall>x\<in>X. finite x"
  and     faces           : "x\<in>X \<Longrightarrow> y\<subseteq>x \<Longrightarrow> y\<in>X"

context SimplicialComplex
begin

abbreviation "Subcomplex Y \<equiv> Y \<subseteq> X \<and> SimplicialComplex Y"

definition "maxsimp x \<equiv> x\<in>X \<and> (\<forall>z\<in>X. x\<subseteq>z \<longrightarrow> z=x)"

definition adjacentset :: "'a set \<Rightarrow> 'a set set"
  where "adjacentset x = {y\<in>X. x\<sim>y}"

lemma singleton_simplex: "v\<in>\<Union>X \<Longrightarrow> {v} \<in> X"
  using faces by auto

lemma maxsimpI: "x \<in> X \<Longrightarrow> (\<And>z. z\<in>X \<Longrightarrow> x\<subseteq>z \<Longrightarrow> z=x) \<Longrightarrow> maxsimp x"
  using maxsimp_def by auto

lemma maxsimpD_simplex: "maxsimp x \<Longrightarrow> x\<in>X"
  using maxsimp_def by fast

lemma maxsimpD_maximal: "maxsimp x \<Longrightarrow> z\<in>X \<Longrightarrow> x\<subseteq>z \<Longrightarrow> z=x"
  using maxsimp_def by auto

lemmas finite_maxsimp = finite_simplex[OF maxsimpD_simplex]

lemma maxsimp_nempty: "X \<noteq> {{}} \<Longrightarrow> maxsimp x \<Longrightarrow> x \<noteq> {}"
  unfolding maxsimp_def by fast

lemma maxsimp_vertices: "maxsimp x \<Longrightarrow> x\<subseteq>\<Union>X"
  using maxsimpD_simplex by fast

lemma adjacentsetD_adj: "y \<in> adjacentset x \<Longrightarrow> x\<sim>y"
  using adjacentset_def by fast

lemma max_in_subcomplex:
  "\<lbrakk> Subcomplex Y; y \<in> Y; maxsimp y \<rbrakk> \<Longrightarrow> SimplicialComplex.maxsimp Y y"
  using maxsimpD_maximal by (fast intro: SimplicialComplex.maxsimpI)

lemma face_im:
  assumes "w \<in> X" "y \<subseteq> f`w"
  defines "u \<equiv> {a\<in>w. f a \<in> y}"
  shows "y \<in> f\<turnstile>X"
  using assms faces[of w u] image_eqI[of y "(`) f" u X]
  by    fast

lemma im_faces: "x \<in> f \<turnstile> X \<Longrightarrow> y \<subseteq> x \<Longrightarrow> y \<in> f \<turnstile> X"
  using faces face_im[of _ y] by (cases "y={}") auto

lemma map_is_simplicial_morph: "SimplicialComplex (f\<turnstile>X)"
proof
  show "\<forall>x\<in>f\<turnstile>X. finite x" using finite_simplices by fast
  show "\<And>x y. x \<in>f\<turnstile>X \<Longrightarrow> y\<subseteq>x \<Longrightarrow> y\<in>f\<turnstile>X" using im_faces by fast
qed

lemma vertex_set_int:
  assumes "SimplicialComplex Y"
  shows   "\<Union>(X\<inter>Y) = \<Union>X \<inter> \<Union>Y"
proof
  have "\<And>v. v \<in> \<Union>X \<inter> \<Union>Y \<Longrightarrow> v\<in> \<Union>(X\<inter>Y)"
    using faces SimplicialComplex.faces[OF assms] by auto
  thus "\<Union>(X\<inter>Y) \<supseteq> \<Union>X \<inter> \<Union>Y" by fast
qed auto

end (* context SimplicialComplex *)

subsection \<open>Chains of maximal simplices\<close>

text \<open>
  Chains of maximal simplices (with respect to adjacency) will allow us to walk through chamber
  complexes. But there is much we can say about them in simplicial complexes. We will call a chain
  of maximal simplices proper (using the prefix \<open>p\<close> as a naming convention to denote proper)
  if no maximal simplex appears more than once in the chain. (Some sources elect to call improper
  chains prechains, and reserve the name chain to describe a proper chain. And usually a slightly
  weaker notion of proper is used, requiring only that no maximal simplex appear twice in succession. But
  it essentially makes no difference, and we found it easier to use @{const distinct} rather than
  @{term "binrelchain not_equal"}.)
\<close>

context SimplicialComplex
begin

definition "maxsimpchain xs  \<equiv> (\<forall>x\<in>set xs. maxsimp x) \<and> adjacentchain xs"
definition "pmaxsimpchain xs \<equiv> (\<forall>x\<in>set xs. maxsimp x) \<and> padjacentchain xs"

function min_maxsimpchain :: "'a set list \<Rightarrow> bool"
  where
    "min_maxsimpchain [] = True"
  | "min_maxsimpchain [x] = maxsimp x"
  | "min_maxsimpchain (x#xs@[y]) =
      (x\<noteq>y \<and> is_arg_min length (\<lambda>zs. maxsimpchain (x#zs@[y])) xs)"
  by (auto, rule list_cases_Cons_snoc)
  termination by (relation "measure length") auto

lemma maxsimpchain_snocI:
  "\<lbrakk> maxsimpchain (xs@[x]); maxsimp y; x\<sim>y \<rbrakk> \<Longrightarrow> maxsimpchain (xs@[x,y])"
  using maxsimpchain_def binrelchain_snoc maxsimpchain_def by auto

lemma maxsimpchainD_maxsimp:
  "maxsimpchain xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> maxsimp x"
  using maxsimpchain_def by fast

lemma maxsimpchainD_adj: "maxsimpchain xs \<Longrightarrow> adjacentchain xs"
  using maxsimpchain_def by fast

lemma maxsimpchain_CConsI:
  "\<lbrakk> maxsimp w; maxsimpchain (x#xs); w\<sim>x \<rbrakk> \<Longrightarrow> maxsimpchain (w#x#xs)"
  using maxsimpchain_def by auto

lemma maxsimpchain_Cons_reduce:
  "maxsimpchain (x#xs) \<Longrightarrow> maxsimpchain xs"
  using     adjacentchain_Cons_reduce maxsimpchain_def by fastforce

lemma maxsimpchain_append_reduce1:
  "maxsimpchain (xs@ys) \<Longrightarrow> maxsimpchain xs"
  using binrelchain_append_reduce1 maxsimpchain_def by auto

lemma maxsimpchain_append_reduce2:
  "maxsimpchain (xs@ys) \<Longrightarrow> maxsimpchain ys"
  using binrelchain_append_reduce2 maxsimpchain_def by auto

lemma maxsimpchain_remdup_adj:
  "maxsimpchain (xs@[x,x]@ys) \<Longrightarrow> maxsimpchain (xs@[x]@ys)"
  using maxsimpchain_def binrelchain_remdup_adj by auto

lemma maxsimpchain_rev: "maxsimpchain xs \<Longrightarrow> maxsimpchain (rev xs)"
  using     maxsimpchainD_maxsimp adjacent_sym
            binrelchain_sym_rev[of adjacent]
  unfolding maxsimpchain_def
  by        fastforce

lemma maxsimpchain_overlap_join:
  "maxsimpchain (xs@[w]) \<Longrightarrow> maxsimpchain (w#ys) \<Longrightarrow>
    maxsimpchain (xs@w#ys)"
  using binrelchain_overlap_join maxsimpchain_def by auto

lemma pmaxsimpchain: "pmaxsimpchain xs \<Longrightarrow> maxsimpchain xs"
  using maxsimpchain_def pmaxsimpchain_def by fast

lemma pmaxsimpchainI_maxsimpchain:
  "maxsimpchain xs \<Longrightarrow> distinct xs \<Longrightarrow> pmaxsimpchain xs"
  using maxsimpchain_def pmaxsimpchain_def by fast

lemma pmaxsimpchain_CConsI:
  "\<lbrakk> maxsimp w; pmaxsimpchain (x#xs); w\<sim>x; w \<notin> set (x#xs) \<rbrakk> \<Longrightarrow>
    pmaxsimpchain (w#x#xs)"
  using pmaxsimpchain_def by auto

lemmas pmaxsimpchainD_maxsimp =
  maxsimpchainD_maxsimp[OF pmaxsimpchain]
lemmas pmaxsimpchainD_adj =
  maxsimpchainD_adj [OF pmaxsimpchain]

lemma pmaxsimpchainD_distinct: "pmaxsimpchain xs \<Longrightarrow> distinct xs"
  using pmaxsimpchain_def by fast

lemma pmaxsimpchain_Cons_reduce:
  "pmaxsimpchain (x#xs) \<Longrightarrow> pmaxsimpchain xs"
  using maxsimpchain_Cons_reduce pmaxsimpchain pmaxsimpchainD_distinct
  by    (fastforce intro: pmaxsimpchainI_maxsimpchain)

lemma pmaxsimpchain_append_reduce1:
  "pmaxsimpchain (xs@ys) \<Longrightarrow> pmaxsimpchain xs"
  using maxsimpchain_append_reduce1 pmaxsimpchain pmaxsimpchainD_distinct
  by    (fastforce intro: pmaxsimpchainI_maxsimpchain)

lemma maxsimpchain_obtain_pmaxsimpchain:
  assumes "x\<noteq>y" "maxsimpchain (x#xs@[y])"
  shows   "\<exists>ys. set ys \<subseteq> set xs \<and> length ys \<le> length xs \<and>
            pmaxsimpchain (x#ys@[y])"
proof-
  obtain ys
    where ys: "set ys \<subseteq> set xs" "length ys \<le> length xs" "padjacentchain (x#ys@[y])"
    using maxsimpchainD_adj[OF assms(2)]
          adjacentchain_obtain_proper[OF assms(1)]
    by    auto
  from ys(1) assms(2) have "\<forall>a\<in>set (x#ys@[y]). maxsimp a"
    using maxsimpchainD_maxsimp by auto
  with ys show ?thesis unfolding pmaxsimpchain_def by auto
qed

lemma min_maxsimpchainD_maxsimpchain:
  assumes "min_maxsimpchain xs"
  shows   "maxsimpchain xs"
proof (cases xs rule: list_cases_Cons_snoc)
  case Nil thus ?thesis using maxsimpchain_def by simp
next
  case Single with assms show ?thesis using maxsimpchain_def by simp
next
  case Cons_snoc with assms show ?thesis using is_arg_minD1 by fastforce
qed

lemma min_maxsimpchainD_min_betw:
  "min_maxsimpchain (x#xs@[y]) \<Longrightarrow> maxsimpchain (x#ys@[y]) \<Longrightarrow>
    length ys \<ge> length xs"
  using is_arg_minD2 by fastforce

lemma min_maxsimpchainI_betw:
  assumes "x\<noteq>y" "maxsimpchain (x#xs@[y])"
          "\<And>ys. maxsimpchain (x#ys@[y]) \<Longrightarrow> length xs \<le> length ys"
  shows   "min_maxsimpchain (x#xs@[y])"
  using   assms by (simp add: is_arg_min_linorderI)

lemma min_maxsimpchainI_betw_compare:
  assumes "x\<noteq>y" "maxsimpchain (x#xs@[y])"
          "min_maxsimpchain (x#ys@[y])" "length xs = length ys"
  shows   "min_maxsimpchain (x#xs@[y])"
  using   assms min_maxsimpchainD_min_betw min_maxsimpchainI_betw
  by      auto

lemma min_maxsimpchain_pmaxsimpchain:
  assumes "min_maxsimpchain xs"
  shows   "pmaxsimpchain xs"
proof (
  rule pmaxsimpchainI_maxsimpchain, rule min_maxsimpchainD_maxsimpchain,
  rule assms, cases xs rule: list_cases_Cons_snoc
)
  case (Cons_snoc x ys y)
  have "\<not> distinct (x#ys@[y]) \<Longrightarrow> False"
  proof (cases "x\<in>set ys" "y\<in>set ys" rule: two_cases)
    case both
    from both(1) obtain as bs where "ys = as@x#bs"
      using in_set_conv_decomp[of x ys] by fast
    with assms Cons_snoc show False
      using min_maxsimpchainD_maxsimpchain[OF assms]
            maxsimpchain_append_reduce2[of "x#as"]
            min_maxsimpchainD_min_betw[of x ys y]
      by    fastforce
  next
    case one
    from one(1) obtain as bs where "ys = as@x#bs"
      using in_set_conv_decomp[of x ys] by fast
    with assms Cons_snoc show False
      using min_maxsimpchainD_maxsimpchain[OF assms]
            maxsimpchain_append_reduce2[of "x#as"]
            min_maxsimpchainD_min_betw[of x ys y]
      by    fastforce
  next
    case other
    from other(2) obtain as bs where "ys = as@y#bs"
      using in_set_conv_decomp[of y ys] by fast
    with assms Cons_snoc show False
      using min_maxsimpchainD_maxsimpchain[OF assms]
            maxsimpchain_append_reduce1[of "x#as@[y]"]
            min_maxsimpchainD_min_betw[of x ys y]
      by    fastforce
  next
    case neither
    moreover assume "\<not> distinct (x # ys @ [y])"
    ultimately obtain as a bs cs where "ys = as@[a]@bs@[a]@cs"
      using assms Cons_snoc not_distinct_decomp[of ys] by auto
    with assms Cons_snoc show False
      using min_maxsimpchainD_maxsimpchain[OF assms]
            maxsimpchain_append_reduce1[of "x#as@[a]"]
            maxsimpchain_append_reduce2[of "x#as@[a]@bs" "a#cs@[y]"]
            maxsimpchain_overlap_join[of "x#as" a "cs@[y]"]
            min_maxsimpchainD_min_betw[of x ys y "as@a#cs"]
      by    auto
  qed
  with Cons_snoc show "distinct xs" by fast
qed auto

lemma min_maxsimpchain_rev:
  assumes "min_maxsimpchain xs"
  shows   "min_maxsimpchain (rev xs)"
proof (cases xs rule: list_cases_Cons_snoc)
  case Single with assms show ?thesis
    using min_maxsimpchainD_maxsimpchain maxsimpchainD_maxsimp by simp
next
  case (Cons_snoc x ys y)
  moreover have "min_maxsimpchain (y # rev ys @ [x])"
  proof (rule min_maxsimpchainI_betw)
    from Cons_snoc assms show "y\<noteq>x"
      using min_maxsimpchain_pmaxsimpchain pmaxsimpchainD_distinct by auto
    from Cons_snoc show "maxsimpchain (y # rev ys @ [x])"
      using min_maxsimpchainD_maxsimpchain[OF assms] maxsimpchain_rev
      by    fastforce
    from Cons_snoc assms
      show  "\<And>zs. maxsimpchain (y#zs@[x]) \<Longrightarrow> length (rev ys) \<le> length zs"
      using maxsimpchain_rev min_maxsimpchainD_min_betw[of x ys y]
      by    fastforce
  qed
  ultimately show ?thesis by simp
qed simp

lemma min_maxsimpchain_adj:
  "\<lbrakk> maxsimp x; maxsimp y; x\<sim>y; x\<noteq>y \<rbrakk> \<Longrightarrow> min_maxsimpchain [x,y]"
  using maxsimpchain_def min_maxsimpchainI_betw[of x y "[]"] by simp

lemma min_maxsimpchain_betw_CCons_reduce:
  assumes "min_maxsimpchain (w#x#ys@[z])"
  shows   "min_maxsimpchain (x#ys@[z])"
proof (rule min_maxsimpchainI_betw)
  from assms show "x\<noteq>z"
    using min_maxsimpchain_pmaxsimpchain pmaxsimpchainD_distinct
    by    fastforce
  show "maxsimpchain (x#ys@[z])"
    using min_maxsimpchainD_maxsimpchain[OF assms]
          maxsimpchain_Cons_reduce
    by    fast
next
 fix zs assume "maxsimpchain (x#zs@[z])"
  hence "maxsimpchain (w#x#zs@[z])"
    using min_maxsimpchainD_maxsimpchain[OF assms] maxsimpchain_def
    by    fastforce
  with assms show "length ys \<le> length zs"
    using min_maxsimpchainD_min_betw[of w "x#ys" z "x#zs"] by simp
qed

lemma min_maxsimpchain_betw_uniform_length:
  assumes "min_maxsimpchain (x#xs@[y])" "min_maxsimpchain (x#ys@[y])"
  shows   "length xs = length ys"
  using   min_maxsimpchainD_min_betw[OF assms(1)]
          min_maxsimpchainD_min_betw[OF assms(2)]
          min_maxsimpchainD_maxsimpchain[OF assms(1)]
          min_maxsimpchainD_maxsimpchain[OF assms(2)]
  by      fastforce

lemma not_min_maxsimpchainI_betw:
  "\<lbrakk> maxsimpchain (x#ys@[y]); length ys < length xs \<rbrakk> \<Longrightarrow>
    \<not> min_maxsimpchain (x#xs@[y])"
  using min_maxsimpchainD_min_betw not_less by blast

lemma maxsimpchain_in_subcomplex:
  "\<lbrakk> Subcomplex Y; set ys \<subseteq> Y; maxsimpchain ys \<rbrakk> \<Longrightarrow>
    SimplicialComplex.maxsimpchain Y ys"
  using maxsimpchain_def max_in_subcomplex
        SimplicialComplex.maxsimpchain_def
  by    force

end (* context SimplicialComplex *)

subsection \<open>Isomorphisms of simplicial complexes\<close>

text \<open>
  Here we develop the concept of isomorphism of simplicial complexes. Note that we have not
  bothered to first develop the concept of morphism of simplicial complexes, since every function
  on the vertex set of a simplicial complex can be considered a morphism of complexes (see lemma
  \<open>map_is_simplicial_morph\<close> above).
\<close>

locale SimplicialComplexIsomorphism = SimplicialComplex X
  for X :: "'a set set"
+ fixes f :: "'a \<Rightarrow> 'b"
  assumes inj: "inj_on f (\<Union>X)"
begin

lemmas morph = map_is_simplicial_morph[of f]

lemma maxsimp_im_max: "maxsimp x \<Longrightarrow> w \<in> X \<Longrightarrow> f`x \<subseteq> f`w \<Longrightarrow> f`w = f`x"
  using maxsimpD_simplex inj_onD[OF inj] maxsimpD_maximal[of x w] by blast

lemma maxsimp_map:
  "maxsimp x \<Longrightarrow> SimplicialComplex.maxsimp (f\<turnstile>X) (f`x)"
  using maxsimpD_simplex maxsimp_im_max morph
        SimplicialComplex.maxsimpI[of "f\<turnstile>X" "f`x"]
  by    fastforce

lemma iso_adj_int_im:
  assumes "maxsimp x" "maxsimp y" "x\<sim>y" "x\<noteq>y"
  shows "(f`x \<inter> f`y) \<lhd> f`x"
proof (rule facetrelI_card)
  from assms(1,2) have  1: "f ` x \<subseteq> f ` y \<Longrightarrow> f ` y = f ` x"
    using maxsimp_map SimplicialComplex.maxsimpD_simplex[OF morph]
          SimplicialComplex.maxsimpD_maximal[OF morph]
    by    simp
  thus "f`x \<inter> f`y \<subseteq> f`x" by fast

  from assms(1) have "card (f`x - f`x \<inter> f`y) \<le> card (f`x - f`(x\<inter>y))"
    using finite_maxsimp card_mono[of "f`x - f`(x\<inter>y)" "f`x - f`x \<inter> f`y"] by fast
  moreover from assms(1,3,4) have "card (f`x - f`(x\<inter>y)) = 1"
    using maxsimpD_simplex faces[of x] maxsimpD_simplex
          iso_codim_map adjacent_int_facet1[of x y] facetrel_card
    by    fastforce
  ultimately have "card (f`x - f`x \<inter> f`y) \<le> 1" by simp
  moreover from assms(1,2,4) have "card (f`x - f`x \<inter> f`y) \<noteq> 0"
    using 1 maxsimpD_simplex finite_maxsimp
          inj_onD[OF induced_pow_fun_inj_on, OF inj, of x y]
    by    auto
  ultimately show "card (f`x - f`x \<inter> f`y) = 1" by simp
qed

lemma iso_adj_map:
  assumes "maxsimp x" "maxsimp y" "x\<sim>y" "x\<noteq>y"
  shows   "f`x \<sim> f`y"
  using assms(3,4) iso_adj_int_im[OF assms] adjacent_sym
        iso_adj_int_im[OF assms(2) assms(1)]
  by    (auto simp add: Int_commute intro: adjacentI)

lemma pmaxsimpchain_map:
  "pmaxsimpchain xs \<Longrightarrow> SimplicialComplex.pmaxsimpchain (f\<turnstile>X) (f\<Turnstile>xs)"
proof (induct xs rule: list_induct_CCons)
  case Nil show ?case
    using map_is_simplicial_morph SimplicialComplex.pmaxsimpchain_def
    by    fastforce
next
  case (Single x) thus ?case
    using map_is_simplicial_morph pmaxsimpchainD_maxsimp maxsimp_map
          SimplicialComplex.pmaxsimpchain_def
    by    fastforce
next
  case (CCons x y xs)
  have "SimplicialComplex.pmaxsimpchain (f \<turnstile> X) ( f`x # f`y # f\<Turnstile>xs)"
  proof (
    rule SimplicialComplex.pmaxsimpchain_CConsI,
    rule map_is_simplicial_morph
  )
    from CCons(2) show "SimplicialComplex.maxsimp (f\<turnstile>X) (f`x)"
      using pmaxsimpchainD_maxsimp maxsimp_map by simp
    from CCons show "SimplicialComplex.pmaxsimpchain (f\<turnstile>X) (f`y # f\<Turnstile>xs)"
      using pmaxsimpchain_Cons_reduce by simp
    from CCons(2) show "f`x \<sim> f`y"
      using pmaxsimpchain_def iso_adj_map by simp
    from inj CCons(2) have "distinct (f\<Turnstile>(x#y#xs))"
      using     maxsimpD_simplex inj_on_distinct_setlistmapim
      unfolding pmaxsimpchain_def
      by        blast
    thus "f`x \<notin> set (f`y # f\<Turnstile>xs)" by simp
  qed
  thus ?case by simp
qed

end (* context SimplicialComplexIsomorphism *)

subsection \<open>The complex associated to a poset\<close>

text \<open>
  A simplicial complex is naturally a poset under the subset relation. The following develops the
  reverse direction: constructing a simplicial complex from a suitable poset.
\<close>

context ordering
begin

definition PosetComplex :: "'a set \<Rightarrow> 'a set set"
  where "PosetComplex P \<equiv> (\<Union>x\<in>P. { {y. pseudominimal_in (P.\<^bold>\<le>x) y} })"

lemma poset_is_SimplicialComplex:
  assumes "\<forall>x\<in>P. simplex_like (P.\<^bold>\<le>x)"
  shows   "SimplicialComplex (PosetComplex P)"
proof (rule SimplicialComplex.intro, rule ballI)
  fix a assume "a \<in> PosetComplex P"
  from this obtain x where "x\<in>P" "a = {y. pseudominimal_in (P.\<^bold>\<le>x) y}"
    unfolding PosetComplex_def by fast
  with assms show "finite a"
    using pseudominimal_inD1 simplex_likeD_finite finite_subset[of a "P.\<^bold>\<le>x"] by fast
next
  fix a b assume ab: "a \<in> PosetComplex P" "b\<subseteq>a"
  from ab(1) obtain x where x: "x\<in>P" "a = {y. pseudominimal_in (P.\<^bold>\<le>x) y}"
    unfolding PosetComplex_def by fast
  from assms x(1) obtain f and A::"nat set"
    where fA: "OrderingSetIso less_eq less (\<subseteq>) (\<subset>) (P.\<^bold>\<le>x) f"
              "f`(P.\<^bold>\<le>x) = Pow A"
    using simplex_likeD_iso[of "P.\<^bold>\<le>x"]
    by    auto
  define x' where x': "x' \<equiv> the_inv_into (P.\<^bold>\<le>x) f (\<Union>(f`b))"
  from fA x(2) ab(2) x' have x'_P: "x'\<in>P"
    using collect_pseudominimals_below_in_poset[of P x f] by simp
  moreover from x fA ab(2) x' have "b = {y. pseudominimal_in (P.\<^bold>\<le>x') y}"
    using collect_pseudominimals_below_in_eq[of x P f] by simp
  ultimately show "b \<in> PosetComplex P" unfolding PosetComplex_def by fast
qed

definition poset_simplex_map :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "poset_simplex_map P x = {y. pseudominimal_in (P.\<^bold>\<le>x) y}"

lemma poset_to_PosetComplex_OrderingSetMap:
  assumes "\<And>x. x\<in>P \<Longrightarrow> simplex_like (P.\<^bold>\<le>x)"
  shows   "OrderingSetMap (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) P (poset_simplex_map P)"
proof
  from assms
    show  "\<And>a b. \<lbrakk> a\<in>P; b\<in>P; a\<^bold>\<le>b \<rbrakk> \<Longrightarrow>
            poset_simplex_map P a \<subseteq> poset_simplex_map P b"
    using     simplex_like_has_bottom pseudominimal_in_below_in
    unfolding poset_simplex_map_def
    by        fast
qed

end (* context ordering *)

text \<open>
  When a poset affords a simplicial complex, there is a natural morphism of posets from the
  source poset into the poset of sets in the complex, as above. However, some further assumptions
  are necessary to ensure that this morphism is an isomorphism. These conditions are collected in
  the following locale.
\<close>

locale ComplexLikePoset = ordering less_eq less
  for less_eq  :: "'a\<Rightarrow>'a\<Rightarrow>bool" (infix "\<^bold>\<le>"  50)
  and less     :: "'a\<Rightarrow>'a\<Rightarrow>bool" (infix "\<^bold><"  50)
+ fixes   P :: "'a set"
  assumes below_in_P_simplex_like: "x\<in>P \<Longrightarrow> simplex_like (P.\<^bold>\<le>x)"
  and     P_has_bottom           : "has_bottom P"
  and     P_has_glbs             : "x\<in>P \<Longrightarrow> y\<in>P \<Longrightarrow> \<exists>b. glbound_in_of P x y b"
begin

abbreviation "smap \<equiv> poset_simplex_map P"

lemma smap_onto_PosetComplex: "smap ` P = PosetComplex P"
  using poset_simplex_map_def PosetComplex_def by auto

lemma ordsetmap_smap: "\<lbrakk> a\<in>P; b\<in>P; a\<^bold>\<le>b \<rbrakk> \<Longrightarrow> smap a \<subseteq> smap b"
  using OrderingSetMap.ordsetmap[
          OF poset_to_PosetComplex_OrderingSetMap, OF below_in_P_simplex_like
        ]
        poset_simplex_map_def
  by    simp

lemma inj_on_smap: "inj_on smap P"
proof (rule inj_onI)
  fix x y assume xy: "x\<in>P" "y\<in>P" "smap x = smap y"
  show "x = y"
  proof (cases "smap x = {}")
    case True with xy show ?thesis
      using poset_simplex_map_def below_in_P_simplex_like P_has_bottom
            simplex_like_no_pseudominimal_in_below_in_imp_singleton[of x P]
            simplex_like_no_pseudominimal_in_below_in_imp_singleton[of y P]
            below_in_singleton_is_bottom[of P x] below_in_singleton_is_bottom[of P y]
      by    auto
  next
    case False
    from this obtain z where "z \<in> smap x" by fast
    with xy(3) have z1: "z \<in> P.\<^bold>\<le>x" "z \<in> P.\<^bold>\<le>y"
      using pseudominimal_inD1 poset_simplex_map_def by auto
    hence "lbound_of x y z" by (auto intro: lbound_ofI)
    with z1(1) obtain b where b: "glbound_in_of P x y b"
      using xy(1,2) P_has_glbs by fast
    moreover have "b \<in> P.\<^bold>\<le>x" "b \<in> P.\<^bold>\<le>y"
      using glbound_in_ofD_in[OF b] glbound_in_of_less_eq1[OF b]
            glbound_in_of_less_eq2[OF b]
      by    auto
    ultimately show ?thesis
      using     xy below_in_P_simplex_like
                pseudominimal_in_below_in_less_eq_glbound[of P x _ y b]
                simplex_like_below_in_above_pseudominimal_is_top[of x P]
                simplex_like_below_in_above_pseudominimal_is_top[of y P]
      unfolding poset_simplex_map_def
      by        force
  qed
qed

lemma OrderingSetIso_smap:
  "OrderingSetIso (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) P smap"
proof (rule OrderingSetMap.isoI)
  show "OrderingSetMap (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) P smap"
    using poset_simplex_map_def below_in_P_simplex_like
          poset_to_PosetComplex_OrderingSetMap
    by    simp
next
  fix x y assume xy: "x\<in>P" "y\<in>P" "smap x \<subseteq> smap y"
  from xy(2) have "simplex_like (P.\<^bold>\<le>y)" using below_in_P_simplex_like by fast
  from this obtain g and A::"nat set"
    where "OrderingSetIso (\<^bold>\<le>) (\<^bold><) (\<subseteq>) (\<subset>) (P.\<^bold>\<le>y) g"
          "g`(P.\<^bold>\<le>y) = Pow A"
    using simplex_likeD_iso[of "P.\<^bold>\<le>y"]
    by    auto
  with xy show "x\<^bold>\<le>y"
    using poset_simplex_map_def collect_pseudominimals_below_in_eq[of y P g]
          collect_pseudominimals_below_in_poset[of P y g]
          inj_onD[OF inj_on_smap, of "the_inv_into (P.\<^bold>\<le>y) g (\<Union>(g ` smap x))" x]
          collect_pseudominimals_below_in_less_eq_top[of P y g A "smap x"]
    by    simp
qed (rule inj_on_smap)

lemmas rev_ordsetmap_smap =
  OrderingSetIso.rev_ordsetmap[OF OrderingSetIso_smap]

end (* context ComplexLikePoset *)

end (* theory *)


theory Chapter3
  imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = (aval a1 s) + (aval a2 s)"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x. 0)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N (n1 + n2) |
    (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply (induction a)
    apply (auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N n1) (N n2) = N (n1 + n2)" |
"plus (N n) v = (if n=0 then v else Plus (N n) v)" |
"plus v (N n) = (if n=0 then v else Plus v (N n))" |
"plus v1 v2 = Plus v1 v2"

lemma aval_plus [simp]: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 rule: plus.induct)
              apply auto
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus a1 a2"

lemma "aval (asimp a) s = aval a s"
  apply (induction a)
    apply auto
  done

fun has_ints :: "aexp \<Rightarrow> bool" where
"has_ints (N n) = True" |
"has_ints (V x) = False" |
"has_ints (Plus a b) = disj (has_ints a) (has_ints b)"

fun minimally_int_free :: "aexp \<Rightarrow> bool" where
"minimally_int_free (N n) = (if n=0 then True else False)" |
"minimally_int_free (V x) = True" |
"minimally_int_free (Plus a b) = conj (~ (has_ints a)) (~ (has_ints b))"

fun has_vars :: "aexp \<Rightarrow> bool" where
"has_vars (N n) = False" |
"has_vars (V x) = True" |
"has_vars (Plus a b) = disj (has_vars a) (has_vars b)"

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (Plus (N n1) (N n2)) = False" |
"optimal (N n) = True" |
"optimal (V x) = True" |
"optimal (Plus a1 a2) = conj (optimal a1) (optimal a2)"

theorem asimp_const_optimal: "optimal (asimp_const a)"
  apply (induction a)
    apply (auto split: aexp.split)
  done

fun var_count :: "aexp \<Rightarrow> nat" where
"var_count (N n) = 0" |
"var_count (V v) = 1" |
"var_count (Plus a b) = (var_count a) + (var_count b)"

fun int_count :: "aexp \<Rightarrow> nat" where
"int_count (N n) = 1" |
"int_count (V v) = 0" |
"int_count (Plus a b) = (int_count a) + (int_count b)"

fun val_count :: "aexp \<Rightarrow> nat" where
"val_count (N n) = 1" |
"val_count (V v) = 1" |
"val_count (Plus a b) = (val_count a) + (val_count b)"

lemma val_count_is_int_plus_var_count: "val_count a = (int_count a) + (var_count a)"
  apply (induction a)
    apply auto
  done

lemma val_count_gt_zero [simp]: "val_count a > 0"
  apply (induction a)
    apply auto
  done

lemma val_count_addend_lt_sum [simp]: "val_count (Plus a b) > val_count a"
  apply (induction a)
    apply auto
  done

function (sequential) full_asimp_step :: "aexp \<Rightarrow> aexp \<Rightarrow> int \<Rightarrow> aexp" where
"full_asimp_step (N n1) (N n2) n3 = N (n1 + n2 + n3)" |
"full_asimp_step (N n1) (V v) n2 = Plus (V v) (N (n1 + n2))" |
"full_asimp_step (N n1) (Plus a b) n2 = full_asimp_step a b (n1 + n2)" |
"full_asimp_step (V v) (N n1) n2 = Plus (V v) (N (n1 + n2))" |
"full_asimp_step (V v1) (V v2) n = Plus (V v1) (Plus (V v2) (N n))" |
"full_asimp_step (V v) (Plus a b) n = Plus (V v) (full_asimp_step a b n)" |
"full_asimp_step (Plus a b) (N n1) n2 = full_asimp_step a b (n1 + n2)" |
"full_asimp_step (Plus a b) (V v) n = Plus (V v) (full_asimp_step a b n)" |
"full_asimp_step (Plus a b) (Plus c d) n = full_asimp_step a (Plus b (Plus c d)) n"
by pat_completeness auto
termination full_asimp_step
  apply (relation "measures [\<lambda>(a,b,n). (val_count (Plus a b)), \<lambda>(a,b,n). (var_count (Plus a b)), \<lambda>(a,b,n). (val_count a)]")
  apply auto
  done

lemma aval_full_asimp_step [simp]: "aval (full_asimp_step a b n) s = (aval a s) + (aval b s) + n"
  apply (induction a b n arbitrary: s rule: full_asimp_step.induct)
          apply auto
  done

lemma int_count_full_asimp_step [simp]: "int_count (full_asimp_step a b n) < 2"
  apply (induction a b n rule: full_asimp_step.induct)
          apply auto
  done

lemma optimal_full_asimp_step [simp]: "optimal (full_asimp_step a b n)"
  apply (induction a b n rule: full_asimp_step.induct)
  apply auto
  done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a = full_asimp_step a (N 0) 0"

theorem full_asimp_example: "full_asimp (Plus (N 1) (Plus (V x) (N 2))) = Plus (V x) (N 3)"
  apply auto
  done

theorem aval_full_asimp: "aval (full_asimp a) s = aval a s"
  apply (induction a arbitrary: s)
    apply auto
  done

lemma int_count_full_asimp: "int_count (full_asimp a) < 2"
  apply (induction a)
    apply auto
  done

lemma optimal_full_asimp: "optimal (full_asimp a)"
  apply (induction a rule: full_asimp.induct)
  apply auto
  done

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst v a (N n) = N n" |
"subst v1 a (V v2) = (if v1=v2 then a else (V v2))" |
"subst v a (Plus b c) = Plus (subst v a b) (subst v a c)"

theorem substitution_

theorem substitution_distributivity: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply auto
  done

datatype mexp = N int | V vname | Plus mexp mexp | Times mexp mexp

fun mval :: "mexp \<Rightarrow> state \<Rightarrow> val" where
"mval (N n) s = n" |
"mval (V v) s = s v" |
"mval (Plus a b) s = (mval a s) + (mval b s)" |
"mval (Times a b) s = (mval a s) * (mval b s)"

fun mplus :: "mexp \<Rightarrow> mexp \<Rightarrow> mexp" where
"mplus (N n1) (N n2) = N (n1 + n2)" |
"mplus (N n) a = (if n=0 then a else (Plus (N n) a))" |
"mplus a (N n) = (if n=0 then a else (Plus a (N n)))" |
"mplus a b = Plus a b"

fun mtimes :: "mexp \<Rightarrow> mexp \<Rightarrow> mexp" where
"mtimes (N n1) (N n2) = N (n1 * n2)" |
"mtimes (N n) a = (if n=1 then a else if n=0 then (N 0) else (Times (N n) a))" |
"mtimes a (N n) = (if n=1 then a else if n=0 then (N 0) else (Times a (N n)))" |
"mtimes a b = Times a b"

fun msimp :: "mexp \<Rightarrow> mexp" where
"msimp (N n) = N n" |
"msimp (V v) = V v" |
"msimp (Plus a b) = mplus (msimp a) (msimp b)" |
"msimp (Times a b) = mtimes (msimp a) (msimp b)"

lemma mval_mplus [simp]: "mval (mplus a b) s = (mval a s) + (mval b s)"
  apply (induction a rule: mplus.induct)
     apply auto
  done

lemma mval_mtimes [simp]: "mval (mtimes a b) s = (mval a s) * (mval b s)"
  apply (induction a rule: mtimes.induct)
  apply auto
  done

theorem mval_msimp: "mval (msimp a) s = mval a s"
  apply (induction a)
     apply auto
  done

fun moptimal :: "mexp \<Rightarrow> bool" where
"moptimal (Plus (N n1) (N n2)) = False" |
"moptimal (Times (N n1) (N n2)) = False" |
"moptimal (Plus a b) = conj (moptimal a) (moptimal b)" |
"moptimal (Times a b) = conj (moptimal a) (moptimal b)" |
"moptimal a = True"

lemma moptimal_mplus [simp]: "(conj (moptimal a) (moptimal b)) \<Longrightarrow> moptimal (mplus a b)"
  apply (induction a b rule: mplus.induct)
  apply auto
  done

lemma moptimal_mtimes [simp]: "(conj (moptimal a) (moptimal b)) \<Longrightarrow> moptimal (mtimes a b)"
  apply (induction a b rule: mtimes.induct)
  apply auto
  done

theorem moptimal_msimp: "moptimal (msimp a)"
  apply (induction a)
  apply auto
  done

datatype cexp = N int |
  V vname |
  Plus cexp cexp |
  Times cexp cexp |
  Minus cexp cexp |
  Divide cexp cexp |
  Incr vname |
  Decr vname

fun cval :: "cexp \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"cval (N n) s = Some (n, s)" |
"cval (V v) s = Some (s v, s)" |
"cval (Incr v) s = Some (s v, s (v:=(s v)+1))" |
"cval (Decr v) s = Some (s v, s (v:=(s v)-1))" |
"cval (Plus a b) s = Some (
  (fst (the (cval a s))) + (fst (the (cval b (snd (the (cval a s)))))),
  snd (the (cval b (snd (the (cval a s)))))
)" |
"cval (Minus a b) s = Some (
  (fst (the (cval a s))) - (fst (the (cval b (snd (the (cval a s)))))),
  snd (the (cval b (snd (the (cval a s)))))
)" |
"cval (Times a b) s = Some (
  (fst (the (cval a s))) * (fst (the (cval b (snd (the (cval a s)))))),
  snd (the (cval b (snd (the (cval a s)))))
)" |
"cval (Divide a b) s = (
  if b=(N 0)
  then None
  else Some (
    (fst (the (cval a s))) div (fst (the (cval b (snd (the (cval a s)))))),
    snd (the (cval b (snd (the (cval a s)))))
  )
)"

fun cval_last :: "cexp list \<Rightarrow> state \<Rightarrow> (val \<times> state)" where
"cval_last Nil s = (0,s)" |
"cval_last (Cons a Nil) s = the (cval a s)" |
"cval_last (Cons a l) s = cval_last l (snd (the (cval a s)))"

lemma incr_is_add_one [simp]: "
fst (cval_last [(Incr v), (V v)] s)
= fst (the (cval (Plus (V v) (N 1)) s))
"
  apply auto
  done

lemma decr_is_minus_one [simp]: "
fst (cval_last [(Decr v), (V v)] s)
= fst (the (cval (Minus (V v) (N 1)) s))
"
  apply auto
  done

lemma incr_decr_is_noop [simp]: "snd (cval_last [(Incr v), (Decr v)] s) = s"
  apply auto
  done

lemma decr_incr_is_noop [simp]: "snd (cval_last [(Decr v), (Incr v)] s) = s"
  apply auto
  done

lemma subeval_order_behavior_l [simp]: "the (cval (Plus (Incr v) (V v)) s) = (fst (the (cval (Plus (Plus (V v) (V v)) (N 1)) s)), snd (the (cval (Incr v) s)))"
  apply auto
  done

lemma subeval_order_behavior_r [simp]: "the (cval (Plus (V v) (Incr v)) s) = (fst (the (cval (Plus (V v) (V v)) s)), snd (the (cval (Incr v) s)))"
  apply auto
  done

lemma plus_minus_is_zero [simp]: "cval (Minus (Plus (V a) (V b)) (V b)) s = cval (V a) s"
  apply auto
  done

lemma times_divide_is_one [simp]: "(fst (the (cval (V b) s)) \<noteq> 0) \<Longrightarrow> (cval (Divide (Times (V a) (V b)) (V b)) s = cval (V a) s)"
  apply auto
  done

lemma times_and_plus_related [simp]: "cval (Times (V a) (N 2)) s = cval (Plus (V a) (V a)) s"
  apply auto
  done

datatype lexp = N int |
  V vname |
  Plus lexp lexp |
  Let vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> val" where
"lval (N n) s = n" |
"lval (V v) s = s v" |
"lval (Plus a b) s = (lval a s) + (lval b s)" |
"lval (Let v t e) s = lval e (s (v:=(lval t s)))"

lemma let_identity: "lval (Let x a (V x)) s = lval a s"
  apply auto
  done

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (lexp.N n) = aexp.N n" |
"inline (lexp.V v) = aexp.V v" |
"inline (lexp.Plus a b) = aexp.Plus (inline a) (inline b)" |
"inline (lexp.Let v t e) = subst v (inline t) (inline e)"

theorem lval_inline [simp]: "aval (inline a) s = lval a s"
  apply (induction a arbitrary: s rule: inline.induct)
  apply auto
  done

datatype bexp =
  Bc bool |
  Not bexp |
  And bexp bexp |
  Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc b) s = b" |
"bval (Not b) s = (~ (bval b s))" |
"bval (And a b) s = conj (bval a s) (bval b s)" |
"bval (Less a b) s = ((aval a s) < (aval b s))"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

(* book says and, but that's a keyword *)
fun andd :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"andd (Bc True) b = b" |
"andd b (Bc True) = b" |
"andd (Bc False) b = Bc False" |
"andd b (Bc False) = Bc False" |
"andd a b = And a b"

(* it is necessary to specify aexp.N since I created lexp.N as well *)
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (aexp.N a) (aexp.N b) = Bc (a < b)" |
"less a b = Less a b"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc b) = Bc b" |
"bsimp (Not b) = not (bsimp b)" |
"bsimp (And a b) = andd (bsimp a) (bsimp b)" |
"bsimp (Less a b) = less (asimp a) (asimp b)"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a b = And (Not (Less a b)) (Not (Less b a))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a b = Not (Less b a)"

theorem bval_eq [simp]: "bval (Eq a b) s = ((aval a s) = (aval b s))"
  apply auto
  done

theorem bval_le [simp]: "bval (Le a b) s = ((aval a s) \<le> (aval b s))"
  apply auto
  done

datatype ifexp =
  Bc2 bool |
  If ifexp ifexp ifexp |
  Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 b) s = b" |
"ifval (If g a b) s = (
  if (ifval g s)
  then (ifval a s)
  else (ifval b s)
)" |
"ifval (Less2 a b) s = ((aval a s) < (aval b s))"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc b) = Bc2 b" |
"b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)" |
"b2ifexp (And a b) = If (b2ifexp a) (b2ifexp b) (Bc2 False)" |
"b2ifexp (Less a b) = Less2 a b"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 b) = (Bc b)" |
"if2bexp (If g a b) =
And
  (Not (And
    (if2bexp g)
    (Not (if2bexp a))
  ))
  (Not (And
    (Not (if2bexp g))
    (Not (if2bexp b))
   ))
" |
"if2bexp (Less2 a b) = Less a b"

theorem b2ifexp_if2exp_noop [simp]: "ifval (b2ifexp (if2bexp a)) s = ifval a s"
  apply (induction a arbitrary: s)
  apply auto
  done

theorem if2bexp_b2ifexp_noop [simp]: "bval (if2bexp (b2ifexp a)) s = bval a s"
  apply (induction a arbitrary: s)
  apply auto
  done

datatype pbexp =
  VAR vname |
  NOT pbexp |
  AND pbexp pbexp |
  OR pbexp pbexp

type_synonym pbstate = "vname \<Rightarrow> bool"

fun pbval :: "pbexp \<Rightarrow> pbstate \<Rightarrow> bool" where
"pbval (VAR v) bs = bs v" |
"pbval (NOT b) bs = (~ (pbval b bs))" |
"pbval (AND a b) bs = conj (pbval a bs) (pbval b bs)" |
"pbval (OR a b) bs = disj (pbval a bs) (pbval b bs)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR v) = True" |
"is_nnf (NOT (VAR v)) = True" |
"is_nnf (NOT b) = False" |
"is_nnf (AND a b) = conj (is_nnf a) (is_nnf b)" |
"is_nnf (OR a b) = conj (is_nnf a) (is_nnf b)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR v) = VAR v" |
"nnf (NOT (VAR v)) = NOT (VAR v)" |
"nnf (NOT (NOT b)) = nnf b" |
"nnf (NOT (AND a b)) = OR (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (OR a b)) = AND (nnf (NOT a)) (nnf (NOT b))" |
"nnf (AND a b) = AND (nnf a) (nnf b)" |
"nnf (OR a b) = OR (nnf a) (nnf b)"

theorem nnf_preserves_pbval [simp]: "pbval (nnf b) bs = pbval b bs"
  apply (induction b rule: nnf.induct)
  apply auto
  done

theorem nnf_is_nnf [simp]: "is_nnf (nnf a)"
  apply (induction a rule: nnf.induct)
  apply auto
  done

fun is_dnf_conj :: "pbexp \<Rightarrow> bool" where
"is_dnf_conj (VAR v) = True" |
"is_dnf_conj (NOT (VAR v)) = True" |
"is_dnf_conj (NOT b) = False" |
"is_dnf_conj (AND a b) = conj (is_dnf_conj a) (is_dnf_conj b)" |
"is_dnf_conj (OR a b) = False"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf (VAR v) = True" |
"is_dnf (NOT (VAR v)) = True" |
"is_dnf (NOT b) = False" |
"is_dnf (AND a b) = conj (is_dnf_conj a) (is_dnf_conj b)" |
"is_dnf (OR a b) = conj (is_dnf a) (is_dnf b)"

lemma is_dnf_not_implies_is_dnf_conj_not [simp]: "is_dnf (NOT b) \<Longrightarrow> is_dnf_conj (NOT b)"
  apply (induction b)
  apply auto
  done

lemma is_nnf_not_implies_is_dnf_not [simp]: "is_nnf (NOT b) \<Longrightarrow> is_dnf (NOT b)"
  apply (induction b)
  apply auto
  done

fun dist_conj_over_dnfs :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"dist_conj_over_dnfs (OR a b) c = OR (dist_conj_over_dnfs a c) (dist_conj_over_dnfs b c)" |
"dist_conj_over_dnfs a (OR b c) = OR (dist_conj_over_dnfs a b) (dist_conj_over_dnfs a c)" |
"dist_conj_over_dnfs a b = AND a b"

lemma dist_conj_over_dnfs_preserves_val [simp]: "pbval (dist_conj_over_dnfs a b) bs = pbval (AND a b) bs"
  apply (induction a b rule: dist_conj_over_dnfs.induct)
  apply auto
  done

lemma dist_conj_over_dnfs_preserves_dnf [simp]: "(conj (is_dnf a) (is_dnf b)) \<Longrightarrow> is_dnf (dist_conj_over_dnfs a b)"
  apply (induction a b rule: dist_conj_over_dnfs.induct)
  apply auto
  done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR v) = VAR v" |
"dnf_of_nnf (NOT b) = NOT b" |
"dnf_of_nnf (AND a b) = dist_conj_over_dnfs (dnf_of_nnf a) (dnf_of_nnf b)" |
"dnf_of_nnf (OR a b) = OR (dnf_of_nnf a) (dnf_of_nnf b)"

theorem dnf_of_nnf_preserves_val [simp]: "pbval (dnf_of_nnf b) bs = pbval b bs"
  apply (induction b)
  apply auto
  done

theorem dnf_of_nnf_turns_nnf_into_dnf [simp]: "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply (induction b rule: dnf_of_nnf.induct)
  apply auto
  done

lemma full_dnf_preserves_val [simp]: "pbval (dnf_of_nnf (nnf b)) bs = pbval b bs"
  apply auto
  done

datatype instr =
  LOADI val |
  LOAD vname |
  ADD

type_synonym stack = "val list"

abbreviation hd2 :: "'a list \<Rightarrow> 'a" where
"hd2 xs \<equiv> hd (tl xs)"

abbreviation tl2 :: "'a list \<Rightarrow> 'a list" where
"tl2 xs \<equiv> tl (tl xs)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 (LOAD v) s stk = Some (s (v) # stk)" |
"exec1 ADD _ (Cons a (Cons b stk)) = Some ((a + b) # stk)" |
"exec1 ADD _ stk = None"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack option \<Rightarrow> stack option" where
"exec [] _ (Some stk) = Some stk" |
"exec is s None = None" |
"exec (i#is) s (Some stk) = exec is s (exec1 i s stk)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (aexp.N n) = [(LOADI n)]" |
"comp (aexp.V v) = [(LOAD v)]" |
"comp (aexp.Plus a b) = (comp a) @ (comp b) @ [(ADD)]"

theorem seq_instr_exec_equiv_recurs_stack_eval [simp]: "exec (a @ b) s some_stk = exec b s (exec a s some_stk)"
  apply (induction a s some_stk arbitrary: b rule: exec.induct)
   apply auto
  done

theorem compiled_execution_matches_evaluation [simp]: "exec (comp a) s (Some stk) = Some (aval a s#stk)"
  apply (induction a arbitrary: stk)
  apply auto
  done

type_synonym reg = nat

datatype rinstr =
  RLOADI int reg |
  RLOAD vname reg |
  RADD reg reg

type_synonym rstate = "reg \<Rightarrow> int"

(* The book says exec1 :: "instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int",
   but exec isn't going to know which register has been set without a deeper spec,
   which would defeat the purpose of having a separate exec1 in the first place. *)
fun rexec1 :: "rinstr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
"rexec1 (RLOADI i r) _ rs = (rs (r:=i))" |
"rexec1 (RLOAD v r) s rs = (rs (r:=s v))" |
"rexec1 (RADD r r2) _ rs = (rs (r:=(rs r) + (rs r2)))"

lemma rexec1_radd_behavior [simp]: "(conj (a = rs r1) (b = rs r2)) \<Longrightarrow> ((rexec1 (RADD r1 r2) s rs) r1 = a + b)"
  apply auto
  done

fun rexec :: "rinstr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
"rexec [] _ rs = rs" |
"rexec (i#is) s rs = rexec is s (rexec1 i s rs)"

fun rcomp :: "aexp \<Rightarrow> reg \<Rightarrow> rinstr list" where
"rcomp (aexp.N n) r = [(RLOADI n r)]" |
"rcomp (aexp.V v) r = [(RLOAD v r)]" |
"rcomp (aexp.Plus a b) r = (rcomp a r) @ (rcomp b (r+1)) @ [(RADD r (r+1))]"

lemma rexec_seq_instr_equals_seq_rexec [simp]: "(rexec (a @ b) s rs) rr = (rexec b s (rexec a s rs)) rr"
  apply (induction a s rs arbitrary: b rr rule: rexec.induct)
  apply auto
  done

lemma smaller_registers_untouched [simp]: "(rl < r) \<Longrightarrow> ((rexec (rcomp a r) s rs) rl = rs rl)"
  apply (induction a r arbitrary: s rs rl rule: rcomp.induct)
  apply auto
  done

lemma rcomp_preserves_incr_regs [simp]: "(rexec (a @ (rcomp b r)) s rs) r = (rexec (rcomp b r) s rs) r"
  apply (induction b r arbitrary: a s rs rule: rcomp.induct)
  apply auto
  done

theorem rexec_rcomp_equals_aval [simp]: "rexec (rcomp a r) s rs r = aval a s"
  apply (induction a r arbitrary: s rs rule: rcomp.induct)
  apply auto
  done

datatype instr0 =
  LDI0 val |
  LD0 vname |
  MV0 reg |
  ADD0 reg

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
"exec01 (LDI0 i) _ rs = rs (0:=i)" |
"exec01 (LD0 v) s rs = rs (0:=s v)" |
"exec01 (MV0 r) _ rs = rs (r:=rs 0)" |
"exec01 (ADD0 r) _ rs = rs (0:=(rs 0) + (rs r))"

lemma exec01_mov0_behavior [simp]: "(exec01 (MV0 r) s rs) r = rs 0"
  apply auto
  done

(* "is" is a keyword in some circumstances.
   While using it as a variable name as described in the book
   is sometimes not a problem, at other times it can be a problem.
   As such, it seems prudent to always avoid using "is" as a variable name. *)
fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
"exec0 [] _ rs = rs" |
"exec0 (i#ins) s rs = exec0 ins s (exec01 i s rs)"

fun comp0_below :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0_below (aexp.N n) r = [(LDI0 n)]" |
"comp0_below (aexp.V v) r = [(LD0 v)]" |
"comp0_below (aexp.Plus a b) r = (comp0_below a (r+2)) @ [(MV0 (r+1))] @ (comp0_below b (r+2)) @ [(ADD0 (r+1))]"

lemma exec0_seq_instr_equals_seq_exec0 [simp]: "exec0 (a @ b) s rs = exec0 b s (exec0 a s rs)"
  apply (induction a s rs arbitrary: b rule: exec0.induct)
  apply auto
  done

lemma comp0_below_skips_regs [simp]: "(conj (rl \<noteq> 0) (rl < r)) \<Longrightarrow> ((exec0 (comp0_below a r) s rs) rl = rs rl)"
  apply (induction a r arbitrary: rl rs s rule: comp0_below.induct)
  apply auto
  done

lemma append_mv0_behavior [simp]: "(exec0 (ins @ [(MV0 r)]) s rs) r = (exec0 ins s rs) 0"
  apply auto
  done

lemma exec0_comp0_below_equals_aval [simp]: "(exec0 (comp0_below a r) s rs) 0 = aval a s"
  apply (induction a r arbitrary: s rs rule: comp0_below.induct)
  apply auto
  done

fun comp0 :: "aexp \<Rightarrow> instr0 list" where
"comp0 a = comp0_below a 0"

theorem exec0_comp0_equals_aval [simp]: "(exec0 (comp0 a) s rs) 0 = aval a s"
  apply auto
  done

end


theory Submission
  imports Defs
begin

fun double :: "'a list \<Rightarrow> 'a list"  where
  "double [] = []" |
  "double (x#xs) = x#x#(double xs)"

value "double [1,2,(3::nat)] = [1,1,2,2,3,3]"

theorem double_len: "length (double xs) = 2 * length xs"
  by (induction xs) simp+

lemma double_snoc:"double (snoc xs x) = snoc ( snoc (double xs) x) x"
  by (induction xs) auto

theorem reverse_double: "reverse (double xs) = double (reverse xs)"
  by (induction xs) (simp add: double_snoc)+

lemma double_add_tl:"(double xs) @ [a, a] = double (xs @ [a])"
  by (induction xs) simp+

theorem rev_double: "rev (double xs) = double (rev xs)"
  by (induction xs) (simp add: double_add_tl)+

end


(*  File:       Evaluation_Function.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Evaluation Function\<close>

theory Evaluation_Function
  imports "Social_Choice_Types/Profile"
begin

text \<open>
  This is the evaluation function. From a set of currently eligible
  alternatives, the evaluation function computes a numerical value that is then
  to be used for further (s)election, e.g., by the elimination module.
\<close>

subsection \<open>Definition\<close>

type_synonym 'a Evaluation_Function = "'a  \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> nat"

subsection \<open>Property\<close>

text \<open>
  An Evaluation function is Condorcet-rating iff the following holds:
  If a Condorcet Winner w exists, w and only w has the highest value.
\<close>

definition condorcet_rating :: "'a Evaluation_Function \<Rightarrow> bool" where
  "condorcet_rating f \<equiv>
    \<forall> A p w . condorcet_winner A p w \<longrightarrow>
      (\<forall> l \<in> A . l \<noteq> w \<longrightarrow> f l A p < f w A p)"

subsection \<open>Theorems\<close>

text \<open>
  If e is Condorcet-rating, the following holds:
  If a Condorcet Winner w exists, w has the maximum evaluation value.
\<close>

theorem cond_winner_imp_max_eval_val:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w"
  shows "e w A p = Max {e a A p | a. a \<in> A}"
proof -
  let ?set = "{e a A p | a. a \<in> A}" and
      ?eMax = "Max {e a A p | a. a \<in> A}" and
      ?eW = "e w A p"
  from f_prof
  have 0: "finite ?set"
    by simp
  have 1: "?set \<noteq> {}"
    using condorcet_winner.simps winner
    by fastforce
  have 2: "?eW \<in> ?set"
    using CollectI condorcet_winner.simps winner
    by (metis (mono_tags, lifting))
  have 3: "\<forall> e \<in> ?set . e \<le> ?eW"
  proof (safe)
    fix a :: "'a"
    assume aInA: "a \<in> A"
    have "\<forall>n na. (n::nat) \<noteq> na \<or> n \<le> na"
      by simp
    with aInA show "e a A p \<le> e w A p"
      using less_imp_le rating winner
      unfolding condorcet_rating_def
      by (metis (no_types))
  qed
  from 2 3 have 4:
    "?eW \<in> ?set \<and> (\<forall>a \<in> ?set. a \<le> ?eW)"
    by blast
  from 0 1 4 Max_eq_iff
  show ?thesis
    by (metis (no_types, lifting))
qed

text \<open>
  If e is Condorcet-rating, the following holds:
  If a Condorcet Winner w exists, a non-Condorcet
  winner has a value lower than the maximum
  evaluation value.
\<close>

theorem non_cond_winner_not_max_eval:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w" and
    linA: "l \<in> A" and
    loser: "w \<noteq> l"
  shows "e l A p < Max {e a A p | a. a \<in> A}"
proof -
  have "e l A p < e w A p"
    using linA loser rating winner
    unfolding condorcet_rating_def
    by metis
  also have "e w A p = Max {e a A p |a. a \<in> A}"
    using cond_winner_imp_max_eval_val f_prof rating winner
    by fastforce
  finally show ?thesis
    by simp
qed

end