theory Roy_Floyd_Warshall
imports Main
begin

section \<open>Transitive closure algorithm\<close>

text \<open>
  The Roy-Floyd-Warshall algorithm takes a finite relation as input and
  produces its transitive closure as output. It iterates over all elements of
  the field of the relation and maintains a cumulative approximation of the
  result: step \<open>0\<close> starts with the original relation, and step \<open>Suc n\<close>
  connects all paths over the intermediate element \<open>n\<close>. The final
  approximation coincides with the full transitive closure.

  This algorithm is often named after ``Floyd'', ``Warshall'', or
  ``Floyd-Warshall'', but the earliest known description is due to B. Roy
  @{cite "Roy:1959"}.

  \<^medskip>
  Subsequently we use a direct mathematical model of the relation, bypassing
  matrices and arrays that are usually seen in the literature. This is more
  efficient for sparse relations: only the adjacency for immediate
  predecessors and successors needs to be maintained, not the square of all
  possible combinations. Moreover we do not have to worry about mutable data
  structures in a multi-threaded environment. See also the graph
  implementation in the Isabelle sources @{file
  \<open>$ISABELLE_HOME/src/Pure/General/graph.ML\<close>} and @{file
  \<open>$ISABELLE_HOME/src/Pure/General/graph.scala\<close>}.
\<close>

type_synonym relation = "(nat \<times> nat) set"

fun steps :: "relation \<Rightarrow> nat \<Rightarrow> relation"
where
  "steps rel 0 = rel"
| "steps rel (Suc n) =
    steps rel n \<union> {(x, y). (x, n) \<in> steps rel n \<and> (n, y) \<in> steps rel n}"

text \<open>Implementation view on the relation:\<close>

definition preds :: "relation \<Rightarrow> nat \<Rightarrow> nat set"
  where "preds rel y = {x. (x, y) \<in> rel}"

definition succs :: "relation \<Rightarrow> nat \<Rightarrow> nat set"
  where "succs rel x = {y. (x, y) \<in> rel}"

lemma
  "steps rel (Suc n) =
    steps rel n \<union> {(x, y). x \<in> preds (steps rel n) n \<and> y \<in> succs (steps rel n) n}"
  by (simp add: preds_def succs_def)

text \<open>
  The main function requires an upper bound for the iteration, which is left
  unspecified here (via Hilbert's choice).
\<close>

definition is_bound :: "relation \<Rightarrow> nat \<Rightarrow> bool"
  where "is_bound rel n \<longleftrightarrow> (\<forall>m \<in> Field rel. m < n)"

definition "transitive_closure rel = steps rel (SOME n. is_bound rel n)"

section \<open>Correctness proof\<close>

subsection \<open>Miscellaneous lemmas\<close>

lemma finite_bound:
  assumes "finite rel"
  shows "\<exists>n. is_bound rel n"
  using assms
proof induct
  case empty
  then show ?case by (simp add: is_bound_def)
next
  case (insert p rel)
  then obtain n where n: "\<forall>m \<in> Field rel. m < n"
    unfolding is_bound_def by blast
  obtain x y where "p = (x, y)" by (cases p)
  then have "\<forall>m \<in> Field (insert p rel). m < max (Suc x) (max (Suc y) n)"
    using n by auto
  then show ?case
    unfolding is_bound_def by blast
qed

lemma steps_Suc: "(x, y) \<in> steps rel (Suc n) \<longleftrightarrow>
  (x, y) \<in> steps rel n \<or> (x, n) \<in> steps rel n \<and> (n, y) \<in> steps rel n"
  by auto

lemma steps_cases:
  assumes "(x, y) \<in> steps rel (Suc n)"
  obtains (copy) "(x, y) \<in> steps rel n"
    | (step) "(x, n) \<in> steps rel n" and "(n, y) \<in> steps rel n"
  using assms by auto

lemma steps_rel: "(x, y) \<in> rel \<Longrightarrow> (x, y) \<in> steps rel n"
  by (induct n) auto

subsection \<open>Bounded closure\<close>

text \<open>
  The bounded closure connects all transitive paths over elements below a
  given bound. For an upper bound of the relation, this coincides with the
  full transitive closure.
\<close>

inductive_set Clos :: "relation \<Rightarrow> nat \<Rightarrow> relation"
  for rel :: relation and n :: nat
where
  base: "(x, y) \<in> Clos rel n" if "(x, y) \<in> rel"
| step: "(x, y) \<in> Clos rel n" if "(x, z) \<in> Clos rel n" and "(z, y) \<in> Clos rel n" and "z < n"

theorem Clos_closure:
  assumes "is_bound rel n"
  shows "(x, y) \<in> Clos rel n \<longleftrightarrow> (x, y) \<in> rel\<^sup>+"
proof
  show "(x, y) \<in> rel\<^sup>+" if "(x, y) \<in> Clos rel n"
    using that by induct simp_all
  show "(x, y) \<in> Clos rel n" if "(x, y) \<in> rel\<^sup>+"
    using that
  proof (induct rule: trancl_induct)
    case (base y)
    then show ?case by (rule Clos.base)
  next
    case (step y z)
    from \<open>(y, z) \<in> rel\<close> have 1: "(y, z) \<in> Clos rel n" by (rule base)
    from \<open>(y, z) \<in> rel\<close> and \<open>is_bound rel n\<close> have 2: "y < n"
      unfolding is_bound_def Field_def by blast
    from step(3) 1 2 show ?case by (rule Clos.step)
  qed
qed

lemma Clos_Suc:
  assumes "(x, y) \<in> Clos rel n"
  shows "(x, y) \<in> Clos rel (Suc n)"
  using assms by induct (auto intro: Clos.intros)

text \<open>
  In each step of the algorithm the approximated relation is exactly the
  bounded closure.
\<close>

theorem steps_Clos_equiv: "(x, y) \<in> steps rel n \<longleftrightarrow> (x, y) \<in> Clos rel n"
proof (induct n arbitrary: x y)
  case 0
  show ?case
  proof
    show "(x, y) \<in> Clos rel 0" if "(x, y) \<in> steps rel 0"
    proof -
      from that have "(x, y) \<in> rel" by simp
      then show ?thesis by (rule Clos.base)
    qed
    show "(x, y) \<in> steps rel 0" if "(x, y) \<in> Clos rel 0"
      using that by cases simp_all
  qed
next
  case (Suc n)
  show ?case
  proof
    show "(x, y) \<in> Clos rel (Suc n)" if "(x, y) \<in> steps rel (Suc n)"
      using that
    proof (cases rule: steps_cases)
      case copy
      with Suc(1) have "(x, y) \<in> Clos rel n" ..
      then show ?thesis by (rule Clos_Suc)
    next
      case step
      with Suc have "(x, n) \<in> Clos rel n" and "(n, y) \<in> Clos rel n"
        by simp_all
      then have "(x, n) \<in> Clos rel (Suc n)" and "(n, y) \<in> Clos rel (Suc n)"
        by (simp_all add: Clos_Suc)
      then show ?thesis by (rule Clos.step) simp
    qed
    show "(x, y) \<in> steps rel (Suc n)" if "(x, y) \<in> Clos rel (Suc n)"
      using that
    proof induct
      case (base x y)
      then show ?case by (simp add: steps_rel)
    next
      case (step x z y)
      with Suc show ?case
        by (auto simp add: steps_Suc less_Suc_eq intro: Clos.step)
    qed
  qed
qed

subsection \<open>Main theorem\<close>

text \<open>
  The main theorem follows immediately from the key observations above. Note
  that the assumption of finiteness gives a bound for the iteration, although
  the details are left unspecified. A concrete implementation could choose the
  the maximum element + 1, or iterate directly over the data structures for
  the @{term preds} and @{term succs} implementation.
\<close>

theorem transitive_closure_correctness:
  assumes "finite rel"
  shows "transitive_closure rel = rel\<^sup>+"
proof -
  let ?N = "SOME n. is_bound rel n"
  have is_bound: "is_bound rel ?N"
    by (rule someI_ex) (rule finite_bound [OF \<open>finite rel\<close>])
  have "(x, y) \<in> steps rel ?N \<longleftrightarrow> (x, y) \<in> rel\<^sup>+" for x y
  proof -
    have "(x, y) \<in> steps rel ?N \<longleftrightarrow> (x, y) \<in> Clos rel ?N"
      by (rule steps_Clos_equiv)
    also have "\<dots> \<longleftrightarrow> (x, y) \<in> rel\<^sup>+"
      using is_bound by (rule Clos_closure)
    finally show ?thesis .
  qed
  then show ?thesis unfolding transitive_closure_def by auto
qed

section \<open>Alternative formulation\<close>

text \<open>
  The core of the algorithm may be expressed more declaratively as follows,
  using an inductive definition to imitate a logic-program. This is equivalent
  to the function specification @{term steps} from above.
\<close>

inductive Steps :: "relation \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> bool"
  for rel :: relation
where
  base: "Steps rel 0 (x, y)" if "(x, y) \<in> rel"
| copy: "Steps rel (Suc n) (x, y)" if "Steps rel n (x, y)"
| step: "Steps rel (Suc n) (x, y)" if "Steps rel n (x, n)" and "Steps rel n (n, y)"

lemma steps_equiv: "(x, y) \<in> steps rel n \<longleftrightarrow> Steps rel n (x, y)"
proof
  show "Steps rel n (x, y)" if "(x, y) \<in> steps rel n"
    using that
  proof (induct n arbitrary: x y)
    case 0
    then have "(x, y) \<in> rel" by simp
    then show ?case by (rule base)
  next
    case (Suc n)
    from Suc(2) show ?case
    proof (cases rule: steps_cases)
      case copy
      with Suc(1) have "Steps rel n (x, y)" .
      then show ?thesis by (rule Steps.copy)
    next
      case step
      with Suc(1) have "Steps rel n (x, n)" and "Steps rel n (n, y)"
        by simp_all
      then show ?thesis by (rule Steps.step)
    qed
  qed
  show "(x, y) \<in> steps rel n" if "Steps rel n (x, y)"
    using that by induct simp_all
qed

end


header {* Directed Graphs *}
(* Author: Peter Lammich *)
theory Digraph
  imports
  "CAVA_Base/CAVA_Base"
  "Words"
begin

subsection "Directed Graphs"
text {* Directed graphs are modeled as a relation on nodes *}
type_synonym 'v digraph = "('v\<times>'v) set"

locale digraph = fixes E :: "'v digraph"

subsubsection {* Paths *}
text {* Path are modeled as list of nodes, the last node of a path is not included
  into the list. This formalization allows for nice concatenation and splitting
  of paths. *}
inductive path :: "'v digraph \<Rightarrow> 'v \<Rightarrow> 'v list \<Rightarrow> 'v \<Rightarrow> bool" for E where
  path0: "path E u [] u"
| path_prepend: "\<lbrakk> (u,v)\<in>E; path E v l w \<rbrakk> \<Longrightarrow> path E u (u#l) w"

lemma path1: "(u,v)\<in>E \<Longrightarrow> path E u [u] v"
  by (auto intro: path.intros)

lemma path_empty_conv[simp]:
  "path E u [] v \<longleftrightarrow> u=v"
  by (auto intro: path0 elim: path.cases)

inductive_cases path_uncons: "path E u (u'#l) w"
inductive_simps path_cons_conv: "path E u (u'#l) w"

lemma path_no_edges[simp]: "path {} u p v \<longleftrightarrow> (u=v \<and> p=[])"
  by (cases p) (auto simp: path_cons_conv)

lemma path_conc:
  assumes P1: "path E u la v"
  assumes P2: "path E v lb w"
  shows "path E u (la@lb) w"
  using P1 P2 apply induct
  by (auto intro: path.intros)

lemma path_append:
  "\<lbrakk> path E u l v; (v,w)\<in>E \<rbrakk> \<Longrightarrow> path E u (l@[v]) w"
  using path_conc[OF _ path1] .

lemma path_unconc:
  assumes "path E u (la@lb) w"
  obtains v where "path E u la v" and "path E v lb w"
  using assms
  thm path.induct
  apply (induct u "la@lb" w arbitrary: la lb rule: path.induct)
  apply (auto intro: path.intros elim!: list_Cons_eq_append_cases)
  done

lemma path_conc_conv:
  "path E u (la@lb) w \<longleftrightarrow> (\<exists>v. path E u la v \<and> path E v lb w)"
  by (auto intro: path_conc elim: path_unconc)

lemma (in -) path_append_conv: "path E u (p@[v]) w \<longleftrightarrow> (path E u p v \<and> (v,w)\<in>E)"
  by (simp add: path_cons_conv path_conc_conv)

lemmas path_simps = path_empty_conv path_cons_conv path_conc_conv

lemmas path_trans[trans] = path_prepend path_conc path_append
lemma path_from_edges: "\<lbrakk>(u,v)\<in>E; (v,w)\<in>E\<rbrakk> \<Longrightarrow> path E u [u] v"
  by (auto simp: path_simps)

lemma path_edge_cases[case_names no_use split]:
  assumes "path (insert (u,v) E) w p x"
  obtains
    "path E w p x"
  | p1 p2 where "path E w p1 u" "path (insert (u,v) E) v p2 x"
  using assms
  apply induction
  apply simp
  apply (clarsimp)
  apply (metis path_simps path_cons_conv)
  done

lemma path_edge_rev_cases[case_names no_use split]:
  assumes "path (insert (u,v) E) w p x"
  obtains
    "path E w p x"
  | p1 p2 where "path (insert (u,v) E) w p1 u" "path E v p2 x"
  using assms
  apply (induction p arbitrary: x rule: rev_induct)
  apply simp
  apply (clarsimp simp: path_cons_conv path_conc_conv)
  apply (metis path_simps path_append_conv)
  done

lemma path_mono:
  assumes S: "E\<subseteq>E'"
  assumes P: "path E u p v"
  shows "path E' u p v"
  using P
  apply induction
  apply simp
  using S
  apply (auto simp: path_cons_conv)
  done

lemma path_is_rtrancl:
  assumes "path E u l v"
  shows "(u,v)\<in>E\<^sup>*"
  using assms
  by induct auto

lemma rtrancl_is_path:
  assumes "(u,v)\<in>E\<^sup>*"
  obtains l where "path E u l v"
  using assms
  by induct (auto intro: path0 path_append)

lemma path_is_trancl:
  assumes "path E u l v"
  and "l\<noteq>[]"
  shows "(u,v)\<in>E\<^sup>+"
  using assms
  apply induct
  apply auto []
  apply (case_tac l)
  apply auto
  done

lemma trancl_is_path:
  assumes "(u,v)\<in>E\<^sup>+"
  obtains l where "l\<noteq>[]" and "path E u l v"
  using assms
  by induct (auto intro: path0 path_append)

lemma path_nth_conv: "path E u p v \<longleftrightarrow> (let p'=p@[v] in
  u=p'!0 \<and>
  (\<forall>i<length p' - 1. (p'!i,p'!Suc i)\<in>E))"
  apply (induct p arbitrary: v rule: rev_induct)
  apply (auto simp: path_conc_conv path_cons_conv nth_append)
  done

lemma path_mapI:
  assumes "path E u p v"
  shows "path (pairself f ` E) (f u) (map f p) (f v)"
  using assms
  apply induction
  apply (simp)
  apply (force simp: path_cons_conv)
  done

lemma path_restrict:
  assumes "path E u p v"
  shows "path (E \<inter> set p \<times> insert v (set (tl p))) u p v"
  using assms
proof induction
  print_cases
  case (path_prepend u v p w)
  from path_prepend.IH have "path (E \<inter> set (u#p) \<times> insert w (set p)) v p w"
    apply (rule path_mono[rotated])
    by (cases p) auto
  thus ?case using `(u,v)\<in>E`
    by (cases p) (auto simp add: path_cons_conv)
qed auto

lemma path_restrict_closed:
  assumes CLOSED: "E``D \<subseteq> D"
  assumes I: "v\<in>D" and P: "path E v p v'"
  shows "path (E\<inter>D\<times>D) v p v'"
  using P CLOSED I
  by induction (auto simp: path_cons_conv)

lemma path_set_induct:
  assumes "path E u p v" and "u\<in>I" and "E``I \<subseteq> I"
  shows "set p \<subseteq> I"
  using assms
  by (induction rule: path.induct) auto

lemma path_nodes_reachable: "path E u p v \<Longrightarrow> insert v (set p) \<subseteq> E\<^sup>*``{u}"
  apply (auto simp: in_set_conv_decomp path_cons_conv path_conc_conv)
  apply (auto dest!: path_is_rtrancl)
  done

lemma path_nodes_edges: "path E u p v \<Longrightarrow> set p \<subseteq> fst`E"
  by (induction rule: path.induct) auto

lemma path_tl_nodes_edges:
  assumes "path E u p v"
  shows "set (tl p) \<subseteq> fst`E \<inter> snd`E"
proof -
  from path_nodes_edges[OF assms] have "set (tl p) \<subseteq> fst`E"
    by (cases p) auto

  moreover have "set (tl p) \<subseteq> snd`E"
    using assms
    apply (cases)
    apply simp
    apply simp
    apply (erule path_set_induct[where I = "snd`E"])
    apply auto
    done
  ultimately show ?thesis
    by auto
qed

lemma path_loop_shift:
  assumes P: "path E u p u"
  assumes S: "v\<in>set p"
  obtains p' where "set p' = set p" "path E v p' v"
proof -
  from S obtain p1 p2 where [simp]: "p = p1@v#p2" by (auto simp: in_set_conv_decomp)
  from P obtain v' where A: "path E u p1 v" "(v, v') \<in> E" "path E v' p2 u"
    by (auto simp: path_simps)
  hence "path E v (v#p2@p1) v" by (auto simp: path_simps)
  thus ?thesis using that[of "v#p2@p1"] by auto
qed

subsubsection {* Infinite Paths *}
definition ipath :: "'q digraph \<Rightarrow> 'q word \<Rightarrow> bool"
  -- "Predicate for an infinite path in a digraph"
  where "ipath E r \<equiv> \<forall>i. (r i, r (Suc i))\<in>E"

lemma ipath_conc_conv:
  "ipath E (u \<frown> v) \<longleftrightarrow> (\<exists>a. path E a u (v 0) \<and> ipath E v)"
  apply (auto simp: conc_def ipath_def path_nth_conv nth_append)
  apply (metis add_Suc_right diff_add_inverse not_add_less1)
  by (metis Suc_diff_Suc diff_Suc_Suc not_less_eq)

lemma ipath_iter_conv:
  assumes "p\<noteq>[]"
  shows "ipath E (p\<^sup>\<omega>) \<longleftrightarrow> (path E (hd p) p (hd p))"
proof (cases p)
  case Nil thus ?thesis using assms by simp
next
  case (Cons u p') hence PLEN: "length p > 0" by simp
  show ?thesis proof
    assume "ipath E (iter (p))"
    hence "\<forall>i. (iter (p) i, iter (p) (Suc i)) \<in> E"
      unfolding ipath_def by simp
    hence "(\<forall>i<length p. (p!i,(p@[hd p])!Suc i)\<in>E)"
      apply (simp add: assms)
      apply safe
      apply (drule_tac x=i in spec)
      apply simp
      apply (case_tac "Suc i = length p")
      apply (simp add: Cons)
      apply (simp add: nth_append)
      done
    thus "path E (hd p) p (hd p)"
      by (auto simp: path_nth_conv Cons nth_append nth_Cons')
  next
    assume "path E (hd p) p (hd p)"
    thus "ipath E (iter p)"
      apply (auto simp: path_nth_conv ipath_def assms Let_def)
      apply (drule_tac x="i mod length p" in spec)
      apply (auto simp: nth_append assms split: split_if_asm)
      apply (metis less_not_refl mod_Suc)
      by (metis PLEN diff_self_eq_0 mod_Suc nth_Cons_0
        semiring_numeral_div_class.pos_mod_bound)
  qed
qed

lemma ipath_to_rtrancl:
  assumes R: "ipath E r"
  assumes I: "i1\<le>i2"
  shows "(r i1,r i2)\<in>E\<^sup>*"
  using I
proof (induction i2)
  case (Suc i2)
  show ?case proof (cases "i1=Suc i2")
    assume "i1\<noteq>Suc i2"
    with Suc have "(r i1,r i2)\<in>E\<^sup>*" by auto
    also from R have "(r i2,r (Suc i2))\<in>E" unfolding ipath_def by auto
    finally show ?thesis .
  qed simp
qed simp

lemma ipath_to_trancl:
  assumes R: "ipath E r"
  assumes I: "i1<i2"
  shows "(r i1,r i2)\<in>E\<^sup>+"
proof -
  from R have "(r i1,r (Suc i1))\<in>E"
    by (auto simp: ipath_def)
  also have "(r (Suc i1),r i2)\<in>E\<^sup>*"
    using ipath_to_rtrancl[OF R,of "Suc i1" i2] I by auto
  finally (rtrancl_into_trancl2) show ?thesis .
qed

lemma run_limit_two_connectedI:
  assumes A: "ipath E r"
  assumes B: "a \<in> limit r" "b\<in>limit r"
  shows "(a,b)\<in>E\<^sup>+"
proof -
  from B have "{a,b} \<subseteq> limit r" by simp
  with A show ?thesis
    by (metis ipath_to_trancl two_in_limit_iff)
qed

lemma ipath_subpath:
  assumes P: "ipath E r"
  assumes LE: "l\<le>u"
  shows "path E (r l) (map r [l..<u]) (r u)"
  using LE
proof (induction "u-l" arbitrary: u l)
  case (Suc n)
  note IH=Suc.hyps(1)
  from `Suc n = u-l` `l\<le>u` obtain u' where [simp]: "u=Suc u'"
    and A: "n=u'-l" "l \<le> u'"
    by (cases u) auto

  note IH[OF A]
  also from P have "(r u',r u)\<in>E"
    by (auto simp: ipath_def)
  finally show ?case using `l \<le> u'` by (simp add: upt_Suc_append)
qed auto

lemma ipath_restrict_eq: "ipath (E \<inter> (E\<^sup>*``{r 0} \<times> E\<^sup>*``{r 0})) r \<longleftrightarrow> ipath E r"
  unfolding ipath_def
  by (auto simp: relpow_fun_conv rtrancl_power)
lemma ipath_restrict: "ipath E r \<Longrightarrow> ipath (E \<inter> (E\<^sup>*``{r 0} \<times> E\<^sup>*``{r 0})) r"
  by (simp add: ipath_restrict_eq)

lemma ipathI[intro?]: "\<lbrakk>\<And>i. (r i, r (Suc i)) \<in> E\<rbrakk> \<Longrightarrow> ipath E r"
  unfolding ipath_def by auto

lemma ipathD: "ipath E r \<Longrightarrow> (r i, r (Suc i)) \<in> E"
  unfolding ipath_def by auto

lemma ipath_in_Domain: "ipath E r \<Longrightarrow> r i \<in> Domain E"
  unfolding ipath_def by auto

lemma ipath_in_Range: "\<lbrakk>ipath E r; i\<noteq>0\<rbrakk> \<Longrightarrow> r i \<in> Range E"
  unfolding ipath_def by (cases i) auto

lemma ipath_suffix: "ipath E r \<Longrightarrow> ipath E (suffix i r)"
  unfolding suffix_def ipath_def by auto

subsubsection {* Strongly Connected Components *}

text {* A strongly connected component is a maximal mutually connected set
  of nodes *}
definition is_scc :: "'q digraph \<Rightarrow> 'q set \<Rightarrow> bool"
  where "is_scc E U \<longleftrightarrow> U\<times>U\<subseteq>E\<^sup>* \<and> (\<forall>V. V\<supset>U \<longrightarrow> \<not> (V\<times>V\<subseteq>E\<^sup>*))"

lemma scc_non_empty[simp]: "\<not>is_scc E {}" unfolding is_scc_def by auto

lemma scc_non_empty'[simp]: "is_scc E U \<Longrightarrow> U\<noteq>{}" unfolding is_scc_def by auto

lemma is_scc_closed:
  assumes SCC: "is_scc E U"
  assumes MEM: "x\<in>U"
  assumes P: "(x,y)\<in>E\<^sup>*" "(y,x)\<in>E\<^sup>*"
  shows "y\<in>U"
proof -
  from SCC MEM P have "insert y U \<times> insert y U \<subseteq> E\<^sup>*"
    unfolding is_scc_def
    apply clarsimp
    apply rule
    apply clarsimp_all
    apply (erule disjE1)
    apply clarsimp
    apply (metis in_mono mem_Sigma_iff rtrancl_trans)
    apply auto []
    apply (erule disjE1)
    apply clarsimp
    apply (metis in_mono mem_Sigma_iff rtrancl_trans)
    apply auto []
    done
  with SCC show ?thesis unfolding is_scc_def by blast
qed

lemma is_scc_connected:
  assumes SCC: "is_scc E U"
  assumes MEM: "x\<in>U" "y\<in>U"
  shows "(x,y)\<in>E\<^sup>*"
  using assms unfolding is_scc_def by auto

text {* In the following, we play around with alternative characterizations, and
  prove them all equivalent .*}

text {* A common characterization is to define an equivalence relation
  ,,mutually connected'' on nodes, and characterize the SCCs as its
  equivalence classes: *}

definition mconn :: "('a\<times>'a) set \<Rightarrow> ('a \<times> 'a) set"
  -- "Mutually connected relation on nodes"
  where "mconn E = E\<^sup>* \<inter> (E\<inverse>)\<^sup>*"

lemma mconn_pointwise:
   "mconn E = {(u,v). (u,v)\<in>E\<^sup>* \<and> (v,u)\<in>E\<^sup>*}"
  by (auto simp add: mconn_def rtrancl_converse)

text {* @{text "mconn"} is an equivalence relation: *}
lemma mconn_refl[simp]: "Id\<subseteq>mconn E"
  by (auto simp add: mconn_def)

lemma mconn_sym: "mconn E = (mconn E)\<inverse>"
  by (auto simp add: mconn_pointwise)

lemma mconn_trans: "mconn E O mconn E = mconn E"
  by (auto simp add: mconn_def)

lemma is_scc_mconn_eqclasses: "is_scc E U \<longleftrightarrow> U \<in> UNIV // mconn E"
  -- "The strongly connected components are the equivalence classes of the
    mutually-connected relation on nodes"
proof
  assume A: "is_scc E U"
  then obtain x where "x\<in>U" unfolding is_scc_def by auto
  hence "U = mconn E `` {x}" using A
    unfolding mconn_pointwise is_scc_def
    apply clarsimp
    apply rule
    apply auto []
    apply clarsimp
    by (metis A is_scc_closed)
  thus "U \<in> UNIV // mconn E"
    by (auto simp: quotient_def)
next
  assume "U \<in> UNIV // mconn E"
  thus "is_scc E U"
    by (auto simp: is_scc_def mconn_pointwise quotient_def)
qed

(* For presentation in the paper *)
lemma "is_scc E U \<longleftrightarrow> U \<in> UNIV // (E\<^sup>* \<inter> (E\<inverse>)\<^sup>*)"
  unfolding is_scc_mconn_eqclasses mconn_def by simp

text {* We can also restrict the notion of "reachability" to nodes
  inside the SCC
  *}

lemma find_outside_node:
  assumes "(u,v)\<in>E\<^sup>*"
  assumes "(u,v)\<notin>(E\<inter>U\<times>U)\<^sup>*"
  assumes "u\<in>U" "v\<in>U"
  shows "\<exists>u'. u'\<notin>U \<and> (u,u')\<in>E\<^sup>* \<and> (u',v)\<in>E\<^sup>*"
  using assms
  apply (induction)
  apply auto []
  apply clarsimp
  by (metis IntI mem_Sigma_iff rtrancl.simps)

lemma is_scc_restrict1:
  assumes SCC: "is_scc E U"
  shows "U\<times>U\<subseteq>(E\<inter>U\<times>U)\<^sup>*"
  using assms
  unfolding is_scc_def
  apply clarsimp
  apply (rule ccontr)
  apply (drule (2) find_outside_node[rotated])
  apply auto []
  by (metis is_scc_closed[OF SCC] mem_Sigma_iff rtrancl_trans subsetD)

lemma is_scc_restrict2:
  assumes SCC: "is_scc E U"
  assumes "V\<supset>U"
  shows "\<not> (V\<times>V\<subseteq>(E\<inter>V\<times>V)\<^sup>*)"
  using assms
  unfolding is_scc_def
  apply clarsimp
  using rtrancl_mono[of "E \<inter> V \<times> V" "E"]
  apply clarsimp
  apply blast
  done

lemma is_scc_restrict3:
  assumes SCC: "is_scc E U"
  shows "((E\<^sup>*``((E\<^sup>*``U) - U)) \<inter> U = {})"
  apply auto
  by (metis assms is_scc_closed is_scc_connected rtrancl_trans)

lemma is_scc_alt_restrict_path:
  "is_scc E U \<longleftrightarrow> U\<noteq>{} \<and>
    (U\<times>U \<subseteq> (E\<inter>U\<times>U)\<^sup>*) \<and> ((E\<^sup>*``((E\<^sup>*``U) - U)) \<inter> U = {})"
  apply rule
  apply (intro conjI)
  apply simp
  apply (blast dest: is_scc_restrict1)
  apply (blast dest: is_scc_restrict3)

  unfolding is_scc_def
  apply rule
  apply clarsimp
  apply (metis (full_types) Int_lower1 in_mono mem_Sigma_iff rtrancl_mono_mp)
  apply blast
  done

lemma is_scc_pointwise:
  "is_scc E U \<longleftrightarrow>
    U\<noteq>{}
  \<and> (\<forall>u\<in>U. \<forall>v\<in>U. (u,v)\<in>(E\<inter>U\<times>U)\<^sup>*)
  \<and> (\<forall>u\<in>U. \<forall>v. (v\<notin>U \<and> (u,v)\<in>E\<^sup>*) \<longrightarrow> (\<forall>u'\<in>U. (v,u')\<notin>E\<^sup>*))"
  -- "Alternative, pointwise characterization"
  unfolding is_scc_alt_restrict_path
  by blast

subsection "Finitely Reachable Graphs"
text {* Finitely reachable graphs are directed graphs with an explicit set
  of root nodes, such that only finitely many nodes are reachable from
  the set of root nodes *}

record 'v fr_graph_rec =
  frg_V :: "'v set"
  frg_E :: "'v digraph"
  frg_V0 :: "'v set"

locale fr_graph =
  -- "Directed graph with explicit set of root nodes, and
      finitely many reachable nodes"
  fixes G :: "('v,'more) fr_graph_rec_scheme"
  assumes finite_reachableE_V0[simp, intro!]: "finite ((frg_E G)\<^sup>*``frg_V0 G)"
  assumes V0_ss: "frg_V0 G \<subseteq> (frg_V G)"
  assumes E_ss: "frg_E G \<subseteq> (frg_V G)\<times>(frg_V G)"
begin
  abbreviation "V \<equiv> frg_V G"
  abbreviation "E \<equiv> frg_E G"
  abbreviation "V0 \<equiv> frg_V0 G"

  lemma is_fr_graph: "fr_graph G" by unfold_locales

  lemma finite_V0[simp, intro!]: "finite V0"
    using finite_reachableE_V0
    apply (rule finite_subset[rotated])
    by auto

  definition is_run
    -- "Infinite run, i.e., a rooted infinite path"
    where "is_run r \<equiv> r 0 \<in> V0 \<and> ipath E r"

  lemma run_reachable: "is_run r \<Longrightarrow> r i \<in> E\<^sup>*``V0"
    unfolding is_run_def
    using ipath_to_rtrancl[of "frg_E G" r 0 i]
    by auto

  lemma
    assumes "is_run r"
    shows run_ipath: "ipath E r"
    and run_V0: "r 0 \<in> V0"
    using assms unfolding is_run_def by auto

  lemma is_run_finite: "is_run r \<Longrightarrow> finite (range r)"
    apply (rule finite_subset[OF _ finite_reachableE_V0])
    using run_reachable
    by auto

  lemma run_V: "is_run r \<Longrightarrow> range r \<subseteq> V"
    using run_ipath[THEN ipath_in_Domain] E_ss by auto

end

locale fin_fr_graph = fr_graph G
  for G :: "('v,'more) fr_graph_rec_scheme"
+ assumes finite_V[simp, intro!]: "finite V"
begin
  lemma is_fin_fr_graph: "fin_fr_graph G" by unfold_locales

  lemma finite_E[simp, intro!]: "finite E"
    using finite_subset[OF E_ss] by auto

end

abbreviation "rename_E f E \<equiv> (\<lambda>(u,v). (f u, f v))`E"

definition "fr_rename_ext ecnv f G \<equiv> \<lparr>
    frg_V = f`(frg_V G),
    frg_E = rename_E f (frg_E G),
    frg_V0 = (f`frg_V0 G),
    \<dots> = ecnv G
  \<rparr>"

locale fr_rename_precond
  = fr_graph G for G :: "('u,'more) fr_graph_rec_scheme" +
  fixes f :: "'u \<Rightarrow> 'v"
  fixes ecnv :: "('u, 'more) fr_graph_rec_scheme \<Rightarrow> 'more'"
  assumes INJ: "inj_on f V"
begin
  abbreviation "G' \<equiv> fr_rename_ext ecnv f G"

  lemma G'_fields:
    "frg_V G' = f`V"
    "frg_V0 G' = f`V0"
    "frg_E G' = rename_E f E"
    unfolding fr_rename_ext_def by simp_all

  definition "fi \<equiv> the_inv_into V f"

  lemma
    fi_f: "x\<in>V \<Longrightarrow> fi (f x) = x" and
    f_fi: "y\<in>f`V \<Longrightarrow> f (fi y) = y" and
    fi_f_eq: "\<lbrakk>f x = y; x\<in>V\<rbrakk> \<Longrightarrow> fi y = x"
    unfolding fi_def
    by (auto
      simp: the_inv_into_f_f f_the_inv_into_f the_inv_into_f_eq INJ)

  lemma E'_to_E: "(u,v) \<in> frg_E G' \<Longrightarrow> (fi u, fi v)\<in>E"
    using E_ss
    by (auto simp: fi_f G'_fields)

  lemma V0'_to_V0: "v\<in>frg_V0 G' \<Longrightarrow> fi v \<in> V0"
    using V0_ss
    by (auto simp: fi_f G'_fields)

  lemma rtrancl_E'_sim:
    assumes "(f u,v')\<in>(frg_E G')\<^sup>*"
    assumes "u\<in>V"
    shows "\<exists>v. v' = f v \<and> v\<in>V \<and> (u,v)\<in>E\<^sup>*"
    using assms
  proof (induction "f u" v' arbitrary: u)
    case (rtrancl_into_rtrancl v' w' u)
    then obtain v w where "v' = f v" "w' = f w" "(v,w)\<in>E"
      by (auto simp: G'_fields)
    hence "v\<in>V" "w\<in>V" using E_ss by auto
    from rtrancl_into_rtrancl obtain vv where "v' = f vv" "vv\<in>V" "(u,vv)\<in>E\<^sup>*"
      by blast
    from `v' = f v` `v\<in>V` `v' = f vv` `vv\<in>V` have [simp]: "vv = v"
      using INJ by (metis inj_on_contraD)

    note `(u,vv)\<in>E\<^sup>*`[simplified]
    also note `(v,w)\<in>E`
    finally show ?case using `w' = f w` `w\<in>V` by blast
  qed auto

  lemma rtrancl_E'_to_E: assumes "(u,v)\<in>(frg_E G')\<^sup>*" shows "(fi u, fi v)\<in>E\<^sup>*"
    using assms apply induction
    by (fastforce intro: E'_to_E rtrancl_into_rtrancl)+

  lemma G'_invar: "fr_graph G'"
    apply unfold_locales
  proof -
    have "(frg_E G')\<^sup>* `` frg_V0 G' \<subseteq> f ` (E\<^sup>*``V0)"
      apply (clarsimp_all simp: G'_fields(2))
      apply (drule rtrancl_E'_sim)
      using V0_ss apply auto []
      apply auto
      done
    thus "finite ((frg_E G')\<^sup>* `` frg_V0 G')"
      by (rule finite_subset) simp

    show "frg_V0 G' \<subseteq> frg_V G'"
      using V0_ss by (auto simp: G'_fields) []

    show "frg_E G' \<subseteq> frg_V G' \<times> frg_V G'"
      using E_ss by (auto simp: G'_fields) []
  qed

  sublocale G'!: fr_graph G' using G'_invar .

  lemma V'_to_V: "v \<in> G'.V \<Longrightarrow> fi v \<in> V"
    by (auto simp: fi_f G'_fields)

  lemma ipath_sim1: "ipath E r \<Longrightarrow> ipath G'.E (f o r)"
    unfolding ipath_def by (auto simp: G'_fields)

  lemma ipath_sim2: "ipath G'.E r \<Longrightarrow> ipath E (fi o r)"
    unfolding ipath_def
    apply (clarsimp simp: G'_fields)
    apply (drule_tac x=i in spec)
    using E_ss
    by (auto simp: fi_f)

  lemma run_sim1: "is_run r \<Longrightarrow> G'.is_run (f o r)"
    unfolding is_run_def G'.is_run_def
    apply (intro conjI)
    apply (auto simp: G'_fields) []
    apply (auto simp: ipath_sim1)
    done

  lemma run_sim2: "G'.is_run r \<Longrightarrow> is_run (fi o r)"
    unfolding is_run_def G'.is_run_def
    by (auto simp: ipath_sim2 V0'_to_V0)

end

end


theory Section2_1 imports Main begin

section "Exercise 2.1"

type_alias var = nat

datatype expr =
  NatLit nat |
  Var var |
  Plus expr expr |
  LAbs "var list" expr |
  LApp expr "expr list"

fun varSubst :: "expr \<Rightarrow> (var \<times> expr) list \<Rightarrow> expr" where
  varSubstNatLit_iff: "varSubst (NatLit n) _ = (NatLit n)" |
  varSubstVarNil_iff: "varSubst (Var v') [] = (Var v')" |
  varSubstVarCons_iff: "varSubst (Var v') ((v, e)#vs) = (if v = v' then e else varSubst (Var v') vs)" |
  varSubstPlus_iff: "varSubst (Plus l r) ss = (Plus (varSubst l ss) (varSubst r ss))" |
  varSubstLAbs_iff: "varSubst (LAbs vs b) ss = (LAbs vs (varSubst b ss))" |
  varSubstLApp_iff: "varSubst (LApp f ps) ss = (LApp (varSubst f ss) (map (\<lambda>p. varSubst p ss) ps))"

lemma pairConsI[intro]: "\<lbrakk> \<forall>i < length xs. zs!i = (xs!i, ys!i) \<rbrakk> \<Longrightarrow> (\<forall>i < length (x#xs). ((x, y)#zs)!i = ((x#xs)!i, (y#ys)!i))"
  using less_Suc_eq_0_disj by auto

inductive_set B :: "(expr \<times> expr) set" where
  BNatLitI: "(NatLit n, NatLit n) \<in> B" |
  BVarI: "(Var v, Var v) \<in> B" |
  BPlusI: "\<lbrakk> (l, l') \<in> B; (r, r') \<in> B \<rbrakk> \<Longrightarrow> (Plus l r, Plus l' r') \<in> B" |
  BLAbsI: "\<lbrakk> (b, b') \<in> B \<rbrakk> \<Longrightarrow> (LAbs vs b, LAbs vs b') \<in> B" |
  BLAppI: "\<lbrakk>
    (f, LAbs vs b) \<in> B;
    length vs = length ps;
    \<forall>i. i < length vs \<longrightarrow> ((ss!i) = (vs!i, ps!i));
    length ss = length vs;
    e = varSubst b ss
  \<rbrakk> \<Longrightarrow> (LApp f ps, e) \<in> B"

theorem "((LApp (LAbs [0] (Var 0)) [NatLit 1]), NatLit 1) \<in> B"
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(force)
  apply(intro allI)
  apply(intro impI)
  apply(clarsimp)
  apply(rule nth_Cons_0)
  apply(simp)
  apply(subst varSubstVarCons_iff)
  apply(simp)
  done

theorem "(LApp (LApp (LAbs [0] (Var 0)) [LAbs [0] (Var 0)]) [NatLit 2], NatLit 2) \<in> B"
  apply(rule BLAppI)
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(simp)
  apply(simp)
  apply(rule nth_Cons_0)
  apply(simp)
  apply(subst varSubstVarCons_iff)
  apply(simp)
  apply(simp)
  apply(simp)
  apply(rule nth_Cons_0)
  apply(simp)
  apply(subst varSubstVarCons_iff)
  apply(simp)
  done

definition LId :: "expr" where
  "LId \<equiv> (LAbs [0] (Var 0))"

theorem "(LApp LId [e], e) \<in> B"
  apply(unfold LId_def)
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(simp)
  apply(subgoal_tac "\<forall>i<length [0]. [(0, e)] ! i = ([0] ! i, [e] ! i)")
  apply(assumption)
  apply(auto)
  done

definition f :: "expr" where
  "f \<equiv> LAbs [0, 1, 2] (Plus (Var 0) (Plus (Var 1) (Var 2)))"

definition g :: "expr" where
  "g \<equiv> LAbs [0] (LAbs [1] (LAbs [2] (Plus (Var 0) (Plus (Var 1) (Var 2)))))"

lemma f_fullBetaConv: "(LApp f [NatLit 1, NatLit 2, NatLit 3], (Plus (NatLit 1) (Plus (NatLit 2) (NatLit 3)))) \<in> B"
  apply(unfold f_def)
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(simp)
  apply(rule BPlusI)
  apply(rule BVarI)
  apply(rule BPlusI)
  apply(rule BVarI)
  apply(rule BVarI)
  apply(simp)
  apply(rule pairConsI)
  apply(rule pairConsI)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(simp)
  done

lemma g_fullBetaConv: "(LApp (LApp (LApp g [NatLit 1]) [NatLit 2]) [NatLit 3], (Plus (NatLit 1) (Plus (NatLit 2) (NatLit 3)))) \<in> B"
  apply(unfold g_def)
  apply(rule BLAppI)
  apply(rule BLAppI)
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(simp)
  apply(rule BLAbsI)
  apply(rule BLAbsI)
  apply(rule BPlusI)
  apply(rule BVarI)
  apply(rule BPlusI)
  apply(rule BVarI)
  apply(rule BVarI)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(simp)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(subst varSubstLAbs_iff)
  apply(rule refl)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(simp)
  done

theorem "\<exists>x. (LApp f [NatLit 1, NatLit 2, NatLit 3], x) \<in> B \<and> (LApp (LApp (LApp g [NatLit 1]) [NatLit 2]) [NatLit 3], x) \<in> B"
  apply(rule_tac x="Plus (NatLit 1) (Plus (NatLit 2) (NatLit 3))" in exI)
  apply(intro conjI)
  apply(rule f_fullBetaConv)
  apply(rule g_fullBetaConv)
  done

fun vars :: "expr \<Rightarrow> var set" where
  varsNarLit_iff: "vars (NatLit _) = {}" |
  varsVar_iff: "vars (Var v) = {v}" |
  varsPlus_iff: "vars (Plus l r) = vars l \<union> vars r" |
  varsLAbs_iff: "vars (LAbs as b) = vars b \<union> set as" |
  varsLApp_iff: "vars (LApp fn ps) = vars fn \<union> (\<Union> (vars ` set ps))"

fun fv :: "expr \<Rightarrow> var set" where
  fvNatLit_iff: "fv (NatLit _) = {}" |
  fvVar_iff: "fv (Var v) = {v}" |
  fvPlus_iff: "fv (Plus l r) = (fv l) \<union> (fv r)" |
  fvLAbs_iff: "fv (LAbs vs b) = (fv b) - (set vs)" |
  fvLApp_iff: "fv (LApp fn as) = (fv fn) \<union> (\<Union> (fv ` set as))"

theorem "0 \<notin> fv (LAbs [0] (Var 0))"
  apply(simp)
  done

theorem "1 \<in> fv (LAbs [0] (Var 1))"
  apply(simp)
  done

theorem "0 \<in> fv (Plus (Var 0) (LApp (LAbs [0] (Var 0)) [NatLit 0]))"
  apply(simp)
  done

fun closed :: "expr \<Rightarrow> bool" where
  "closed e = (fv e = {})"

fun binded :: "var \<Rightarrow> expr \<Rightarrow> bool" where
  bindedNatLit_iff: "binded _ (NatLit _) = False" |
  bindedVar_iff: "binded _ (Var _) = False" |
  bindedPlus_iff: "binded v (Plus l r) = (binded v l \<or> binded v r)" |
  bindedLAbs_iff: "binded v (LAbs as b) = (v \<in> set as \<or> binded v b)" |
  bindedLApp_iff: "binded v (LApp fn ps) = (binded v fn \<or> (\<exists>p \<in> set ps. binded v p))"

inductive_set E :: "expr set" where
  ENatLitI: "NatLit _ \<in> E" |
  EVarI: "Var _ \<in> E" |
  EPlusI: "\<lbrakk> l \<in> E; r \<in> E \<rbrakk> \<Longrightarrow> Plus l r \<in> E" |
  ELAbsI: "\<lbrakk> b \<in> E; \<forall>v \<in> set vs. \<not>binded v b \<rbrakk> \<Longrightarrow> LAbs vs b \<in> E" |
  ELAppI: "\<lbrakk> f \<in> E; \<forall>p \<in> set ps. p \<in> E \<rbrakk> \<Longrightarrow> LApp f ps \<in> E"

inductive_cases ELAbsE: "LAbs vs b \<in> E"

theorem "\<lbrakk> e \<in> E \<rbrakk> \<Longrightarrow> fv e \<subseteq> vars e"
  apply(erule E.induct)
  apply(auto)
  done

theorem "LAbs [0] (Var 0) \<in> E"
  apply(rule ELAbsI)
  apply(rule EVarI)
  apply(intro ballI)
  apply(subst bindedVar_iff)
  apply(rule notI)
  apply(assumption)
  done

lemma listSingletonI: "x \<in> set [x]"
  apply(subst set_simps)
  apply(rule Set.insertI1)
  done

theorem "(LAbs [0] (LAbs [0] (Var 0))) \<notin> E"
  apply(rule notI)
  apply(erule ELAbsE)
  apply(drule_tac x=0 in bspec)
  apply(rule listSingletonI)
  apply(subst (asm) bindedLAbs_iff)
  apply(erule notE)
  apply(rule disjI1)
  apply(rule listSingletonI)
  done

fun betaSet :: "expr \<Rightarrow> expr set" where
  "betaSet e = B\<^sup>+ `` {e}"

theorem "NatLit n \<in> betaSet (NatLit n)"
  apply(auto)
  apply(subst trancl_unfold)
  apply(rule UnI1)
  apply(rule BNatLitI)
  done

theorem "NatLit 1 \<in> betaSet (LApp (LAbs [0] (Var 0)) [NatLit 1])"
  apply(auto)
  apply(subst trancl_unfold)
  apply(rule UnI1)
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(simp)
  done

(* \<beta>簡約が2回必要なのに1回の分岐に入ったみた *)
theorem "NatLit 1 \<in> betaSet (LApp LId [LApp LId [NatLit 1]])"
  apply(auto)
  apply(subst trancl_unfold)
  apply(rule UnI1) (* \<beta>簡約1回の分岐に入る *)
  apply(rule BLAppI)
  apply(unfold LId_def)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(simp)
  (* goal: False *)
  oops

theorem "NatLit 1 \<in> betaSet (LApp LId [LApp LId [NatLit 1]])"
  apply(auto)
  apply(subst trancl_unfold)
  apply(rule UnI2) (* \<beta>簡約1回のルートを避ける *)
  apply(rule relcomp.relcompI)
  apply(subst trancl_unfold)
  apply(rule UnI1) (* \<beta>簡約2回のルートへ入る *)
  apply(rule BLAppI)
  apply(unfold LId_def)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(rule refl)
  apply(subst varSubstVarCons_iff)
  apply(simp)
  apply(rule BLAppI)
  apply(rule BLAbsI)
  apply(rule BVarI)
  apply(simp)
  apply(rule pairConsI)
  apply(simp)
  apply(simp)
  apply(simp)
  done

(* TODO: 練習問題の = の意味が怪しいがこれ以上\<beta>変換できない的な意味なら、それぞれがただ1つのこれ以上
   \<beta>変換できない式をもつ的な条件を加えてあげないと存在限量の主張が題意に対して弱すぎる気がする *)
theorem "\<lbrakk> e \<in> E \<rbrakk> \<Longrightarrow> \<exists>e' \<in> betaSet e. {e'} = betaSet e'"
  oops
end


(*  Title:      Free_Boolean_Algebra.thy
    Author:     Brian Huffman, Portland State University
*)

header {* Free Boolean algebras *}

theory Free_Boolean_Algebra
imports Main
begin

(*<*)
notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65)

lemma sup_conv_inf:
  fixes x y :: "'a::boolean_algebra"
  shows "x \<squnion> y = - (- x \<sqinter> - y)"
by simp
(*>*)

subsection {* Free boolean algebra as a set *}

text {*
  We start by defining the free boolean algebra over type @{typ 'a} as
  an inductive set.  Here @{text "i :: 'a"} represents a variable;
  @{text "A :: 'a set"} represents a valuation, assigning a truth
  value to each variable; and @{text "S :: 'a set set"} represents a
  formula, as the set of valuations that make the formula true.  The
  set @{text fba} contains representatives of formulas built from
  finite combinations of variables with negation and conjunction.
*}

inductive_set
  fba :: "'a set set set"
where
  var: "{A. i \<in> A} \<in> fba"
| Compl: "S \<in> fba \<Longrightarrow> - S \<in> fba"
| inter: "S \<in> fba \<Longrightarrow> T \<in> fba \<Longrightarrow> S \<inter> T \<in> fba"

lemma fba_Diff: "S \<in> fba \<Longrightarrow> T \<in> fba \<Longrightarrow> S - T \<in> fba"
unfolding Diff_eq by (intro fba.inter fba.Compl)

lemma fba_union: "S \<in> fba \<Longrightarrow> T \<in> fba \<Longrightarrow> S \<union> T \<in> fba"
proof -
  assume "S \<in> fba" and "T \<in> fba"
  hence "- (- S \<inter> - T) \<in> fba" by (intro fba.intros)
  thus "S \<union> T \<in> fba" by simp
qed

lemma fba_empty: "({} :: 'a set set) \<in> fba"
proof -
  obtain S :: "'a set set" where "S \<in> fba"
    by (fast intro: fba.var)
  hence "S \<inter> - S \<in> fba"
    by (intro fba.intros)
  thus ?thesis by simp
qed

lemma fba_UNIV: "(UNIV :: 'a set set) \<in> fba"
proof -
  have "- {} \<in> fba" using fba_empty by (rule fba.Compl)
  thus "UNIV \<in> fba" by simp
qed

subsection {* Free boolean algebra as a type *}

text {*
  The next step is to use @{text typedef} to define a type isomorphic
  to the set @{const fba}.  We also define a constructor @{text var}
  that corresponds with the similarly-named introduction rule for
  @{const fba}.
*}

typedef 'a formula = "fba :: 'a set set set"
  by (auto intro: fba_empty)

definition var :: "'a \<Rightarrow> 'a formula"
where "var i = Abs_formula {A. i \<in> A}"

lemma Rep_formula_var: "Rep_formula (var i) = {A. i \<in> A}"
unfolding var_def using fba.var by (rule Abs_formula_inverse)

text {*
  \medskip
  Now we make type @{typ "'a formula"} into a Boolean algebra.  This
  involves defining the various operations (ordering relations, binary
  infimum and supremum, complement, difference, top and bottom
  elements) and proving that they satisfy the appropriate laws.
*}

instantiation formula :: (type) boolean_algebra
begin

definition
  "x \<sqinter> y = Abs_formula (Rep_formula x \<inter> Rep_formula y)"

definition
  "x \<squnion> y = Abs_formula (Rep_formula x \<union> Rep_formula y)"

definition
  "\<top> = Abs_formula UNIV"

definition
  "\<bottom> = Abs_formula {}"

definition
  "x \<le> y \<longleftrightarrow> Rep_formula x \<subseteq> Rep_formula y"

definition
  "x < y \<longleftrightarrow> Rep_formula x \<subset> Rep_formula y"

definition
  "- x = Abs_formula (- Rep_formula x)"

definition
  "x - y = Abs_formula (Rep_formula x - Rep_formula y)"

lemma Rep_formula_inf:
  "Rep_formula (x \<sqinter> y) = Rep_formula x \<inter> Rep_formula y"
unfolding inf_formula_def
by (intro Abs_formula_inverse fba.inter Rep_formula)

lemma Rep_formula_sup:
  "Rep_formula (x \<squnion> y) = Rep_formula x \<union> Rep_formula y"
unfolding sup_formula_def
by (intro Abs_formula_inverse fba_union Rep_formula)

lemma Rep_formula_bot: "Rep_formula \<bottom> = {}"
unfolding bot_formula_def by (intro Abs_formula_inverse fba_empty)

lemma Rep_formula_compl: "Rep_formula (- x) = - Rep_formula x"
unfolding uminus_formula_def
by (intro Abs_formula_inverse fba.Compl Rep_formula)

lemma Rep_formula_diff:
  "Rep_formula (x - y) = Rep_formula x - Rep_formula y"
unfolding minus_formula_def
by (intro Abs_formula_inverse fba_Diff Rep_formula)

lemmas eq_formula_iff = Rep_formula_inject [symmetric]

lemmas Rep_formula_simps =
  less_eq_formula_def less_formula_def eq_formula_iff
  Rep_formula_sup Rep_formula_inf Rep_formula_top Rep_formula_bot
  Rep_formula_compl Rep_formula_diff Rep_formula_var

instance proof
qed (unfold Rep_formula_simps, auto)

end

text {*
  \medskip
  The laws of a Boolean algebra do not require the top and bottom
  elements to be distinct, so the following rules must be proved
  separately:
*}

lemma bot_neq_top_formula [simp]: "(\<bottom> :: 'a formula) \<noteq> \<top>"
unfolding Rep_formula_simps by auto

lemma top_neq_bot_formula [simp]: "(\<top> :: 'a formula) \<noteq> \<bottom>"
unfolding Rep_formula_simps by auto

text {*
  \medskip
  Here we prove an essential property of a free Boolean algebra:
  all generators are independent.
*}

lemma var_le_var_simps [simp]:
  "var i \<le> var j \<longleftrightarrow> i = j"
  "\<not> var i \<le> - var j"
  "\<not> - var i \<le> var j"
unfolding Rep_formula_simps by fast+

lemma var_eq_var_simps [simp]:
  "var i = var j \<longleftrightarrow> i = j"
  "var i \<noteq> - var j"
  "- var i \<noteq> var j"
unfolding Rep_formula_simps set_eq_subset by fast+

text {*
  \medskip
  We conclude this section by proving an induction principle for
  formulas.  It mirrors the definition of the inductive set @{text
  fba}, with cases for variables, complements, and conjunction.
*}

lemma formula_induct [case_names var compl inf, induct type: formula]:
  fixes P :: "'a formula \<Rightarrow> bool"
  assumes 1: "\<And>i. P (var i)"
  assumes 2: "\<And>x. P x \<Longrightarrow> P (- x)"
  assumes 3: "\<And>x y. P x \<Longrightarrow> P y \<Longrightarrow> P (x \<sqinter> y)"
  shows "P x"
proof (induct x rule: Abs_formula_induct)
  fix y :: "'a set set"
  assume "y \<in> fba" thus "P (Abs_formula y)"
  proof (induct rule: fba.induct)
    case (var i)
    have "P (var i)" by (rule 1)
    thus ?case unfolding var_def .
  next
    case (Compl S)
    from `P (Abs_formula S)` have "P (- Abs_formula S)" by (rule 2)
    with `S \<in> fba` show ?case
      unfolding uminus_formula_def by (simp add: Abs_formula_inverse)
  next
    case (inter S T)
    from `P (Abs_formula S)` and `P (Abs_formula T)`
    have "P (Abs_formula S \<sqinter> Abs_formula T)" by (rule 3)
    with `S \<in> fba` and `T \<in> fba` show ?case
      unfolding inf_formula_def by (simp add: Abs_formula_inverse)
  qed
qed

subsection {* If-then-else for Boolean algebras *}

text {*
  This is a generic if-then-else operator for arbitrary Boolean
  algebras.
*}

definition
  ifte :: "'a::boolean_algebra \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "ifte a x y = (a \<sqinter> x) \<squnion> (- a \<sqinter> y)"

lemma ifte_top [simp]: "ifte \<top> x y = x"
unfolding ifte_def by simp

lemma ifte_bot [simp]: "ifte \<bottom> x y = y"
unfolding ifte_def by simp

lemma ifte_same: "ifte a x x = x"
unfolding ifte_def
by (simp add: inf_sup_distrib2 [symmetric] sup_compl_top)

lemma compl_ifte: "- ifte a x y = ifte a (- x) (- y)"
unfolding ifte_def
apply (rule order_antisym)
apply (simp add: inf_sup_distrib1 inf_sup_distrib2 compl_inf_bot)
apply (simp add: sup_inf_distrib1 sup_inf_distrib2 sup_compl_top)
apply (simp add: le_infI1 le_infI2 le_supI1 le_supI2)
apply (simp add: le_infI1 le_infI2 le_supI1 le_supI2)
done

lemma inf_ifte_distrib:
  "ifte x a b \<sqinter> ifte x c d = ifte x (a \<sqinter> c) (b \<sqinter> d)"
unfolding ifte_def
apply (simp add: inf_sup_distrib1 inf_sup_distrib2)
apply (simp add: inf_sup_aci inf_compl_bot)
done

lemma ifte_ifte_distrib:
  "ifte x (ifte y a b) (ifte y c d) = ifte y (ifte x a c) (ifte x b d)"
unfolding ifte_def [of x] sup_conv_inf
by (simp only: compl_ifte [symmetric] inf_ifte_distrib [symmetric] ifte_same)

subsection {* Formulas over a set of generators *}

text {*
  The set @{text "formulas S"} consists of those formulas that only
  depend on variables in the set @{text S}.  It is analogous to the
  @{const lists} operator for the list datatype.
*}

definition
  formulas :: "'a set \<Rightarrow> 'a formula set"
where
  "formulas S =
    {x. \<forall>A B. (\<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B) \<longrightarrow>
      A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x}"

lemma formulasI:
  assumes "\<And>A B. \<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B
    \<Longrightarrow> A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x"
  shows "x \<in> formulas S"
using assms unfolding formulas_def by simp

lemma formulasD:
  assumes "x \<in> formulas S"
  assumes "\<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B"
  shows "A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x"
using assms unfolding formulas_def by simp

lemma formulas_mono: "S \<subseteq> T \<Longrightarrow> formulas S \<subseteq> formulas T"
by (fast intro!: formulasI elim!: formulasD)

lemma formulas_insert: "x \<in> formulas S \<Longrightarrow> x \<in> formulas (insert a S)"
unfolding formulas_def by simp

lemma formulas_var: "i \<in> S \<Longrightarrow> var i \<in> formulas S"
unfolding formulas_def by (simp add: Rep_formula_simps)

lemma formulas_var_iff: "var i \<in> formulas S \<longleftrightarrow> i \<in> S"
unfolding formulas_def by (simp add: Rep_formula_simps, fast)

lemma formulas_bot: "\<bottom> \<in> formulas S"
unfolding formulas_def by (simp add: Rep_formula_simps)

lemma formulas_compl: "x \<in> formulas S \<Longrightarrow> - x \<in> formulas S"
unfolding formulas_def by (simp add: Rep_formula_simps)

lemma formulas_inf:
  "x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow> x \<sqinter> y \<in> formulas S"
unfolding formulas_def by (auto simp add: Rep_formula_simps)

lemma formulas_sup:
  "x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow> x \<squnion> y \<in> formulas S"
unfolding formulas_def by (auto simp add: Rep_formula_simps)

lemma formulas_diff:
  "x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow> x - y \<in> formulas S"
unfolding formulas_def by (auto simp add: Rep_formula_simps)

lemma formulas_ifte:
  "a \<in> formulas S \<Longrightarrow> x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow>
    ifte a x y \<in> formulas S"
unfolding ifte_def
by (intro formulas_sup formulas_inf formulas_compl)

lemmas formulas_intros =
  formulas_var formulas_bot formulas_top formulas_compl
  formulas_inf formulas_sup formulas_diff formulas_ifte

subsection {* Injectivity of if-then-else *}

text {*
  The if-then-else operator is injective in some limited
  circumstances: when the scrutinee is a variable that is not
  mentioned in either branch.
*}

lemma ifte_inject:
  assumes "ifte (var i) x y = ifte (var i) x' y'"
  assumes "i \<notin> S"
  assumes "x \<in> formulas S" and "x' \<in> formulas S"
  assumes "y \<in> formulas S" and "y' \<in> formulas S"
  shows "x = x' \<and> y = y'"
proof
  have 1: "\<And>A. i \<in> A \<Longrightarrow> A \<in> Rep_formula x \<longleftrightarrow> A \<in> Rep_formula x'"
    using assms(1)
    by (simp add: Rep_formula_simps ifte_def set_eq_iff, fast)
  have 2: "\<And>A. i \<notin> A \<Longrightarrow> A \<in> Rep_formula y \<longleftrightarrow> A \<in> Rep_formula y'"
    using assms(1)
    by (simp add: Rep_formula_simps ifte_def set_eq_iff, fast)

  show "x = x'"
  unfolding Rep_formula_simps
  proof (rule set_eqI)
    fix A
    have "A \<in> Rep_formula x \<longleftrightarrow> insert i A \<in> Rep_formula x"
      using `x \<in> formulas S` by (rule formulasD, force simp add: `i \<notin> S`)
    also have "\<dots> \<longleftrightarrow> insert i A \<in> Rep_formula x'"
      by (rule 1, simp)
    also have "\<dots> \<longleftrightarrow> A \<in> Rep_formula x'"
      using `x' \<in> formulas S` by (rule formulasD, force simp add: `i \<notin> S`)
    finally show "A \<in> Rep_formula x \<longleftrightarrow> A \<in> Rep_formula x'" .
  qed
  show  "y = y'"
  unfolding Rep_formula_simps
  proof (rule set_eqI)
    fix A
    have "A \<in> Rep_formula y \<longleftrightarrow> A - {i} \<in> Rep_formula y"
      using `y \<in> formulas S` by (rule formulasD, force simp add: `i \<notin> S`)
    also have "\<dots> \<longleftrightarrow> A - {i} \<in> Rep_formula y'"
      by (rule 2, simp)
    also have "\<dots> \<longleftrightarrow> A \<in> Rep_formula y'"
      using `y' \<in> formulas S` by (rule formulasD, force simp add: `i \<notin> S`)
    finally show "A \<in> Rep_formula y \<longleftrightarrow> A \<in> Rep_formula y'" .
  qed
qed

subsection {* Specification of homomorphism operator *}

text {*
  Our goal is to define a homomorphism operator @{text hom} such that
  for any function @{text f}, @{text "hom f"} is the unique Boolean
  algebra homomorphism satisfying @{text "hom f (var i) = f i"}
  for all @{text i}.

  Instead of defining @{text hom} directly, we will follow the
  approach used to define Isabelle's @{text fold} operator for finite
  sets.  First we define the graph of the @{text hom} function as a
  relation; later we will define the @{text hom} function itself using
  definite choice.

  The @{text hom_graph} relation is defined inductively, with
  introduction rules based on the if-then-else normal form of Boolean
  formulas.  The relation is also indexed by an extra set parameter
  @{text S}, to ensure that branches of each if-then-else do not use
  the same variable again.
*}

inductive
  hom_graph ::
    "('a \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> 'a set \<Rightarrow> 'a formula \<Rightarrow> 'b \<Rightarrow> bool"
  for f :: "'a \<Rightarrow> 'b::boolean_algebra"
where
  bot: "hom_graph f {} bot bot"
| top: "hom_graph f {} top top"
| ifte: "i \<notin> S \<Longrightarrow> hom_graph f S x a \<Longrightarrow> hom_graph f S y b \<Longrightarrow>
  hom_graph f (insert i S) (ifte (var i) x y) (ifte (f i) a b)"

text {*
  \medskip
  The next two lemmas establish a stronger elimination rule for
  assumptions of the form @{term "hom_graph f (insert i S) x a"}.
  Essentially, they say that we can arrange the top-level if-then-else
  to use the variable of our choice.  The proof makes use of the
  distributive properties of if-then-else.
*}

lemma hom_graph_dest:
  "hom_graph f S x a \<Longrightarrow> k \<in> S \<Longrightarrow> \<exists>y z b c.
    x = ifte (var k) y z \<and> a = ifte (f k) b c \<and>
    hom_graph f (S - {k}) y b \<and> hom_graph f (S - {k}) z c"
proof (induct set: hom_graph)
  case (ifte i S x a y b) show ?case
  proof (cases "i = k")
    assume "i = k" with ifte(1,2,4) show ?case by auto
  next
    assume "i \<noteq> k"
    with `k \<in> insert i S` have k: "k \<in> S" by simp
    have *: "insert i S - {k} = insert i (S - {k})"
      using `i \<noteq> k` by (simp add: insert_Diff_if)
    have **: "i \<notin> S - {k}" using `i \<notin> S` by simp
    from ifte(1) ifte(3) [OF k] ifte(5) [OF k]
    show ?case
      unfolding *
      apply clarify
      apply (simp only: ifte_ifte_distrib [of "var i"])
      apply (simp only: ifte_ifte_distrib [of "f i"])
      apply (fast intro: hom_graph.ifte [OF **])
      done
  qed
qed simp_all

lemma hom_graph_insert_elim:
  assumes "hom_graph f (insert i S) x a" and "i \<notin> S"
  obtains y z b c
  where "x = ifte (var i) y z"
    and "a = ifte (f i) b c"
    and "hom_graph f S y b"
    and "hom_graph f S z c"
using hom_graph_dest [OF assms(1) insertI1]
by (clarify, simp add: assms(2))

text {*
  \medskip
  Now we prove the first uniqueness property of the @{const hom_graph}
  relation.  This version of uniqueness says that for any particular
  value of @{text S}, the relation @{term "hom_graph f S"} maps each
  @{text x} to at most one @{text a}.  The proof uses the
  injectiveness of if-then-else, which we proved earlier.
*}

lemma hom_graph_imp_formulas:
  "hom_graph f S x a \<Longrightarrow> x \<in> formulas S"
by (induct set: hom_graph, simp_all add: formulas_intros formulas_insert)

lemma hom_graph_unique:
  "hom_graph f S x a \<Longrightarrow> hom_graph f S x a' \<Longrightarrow> a = a'"
proof (induct arbitrary: a' set: hom_graph)
  case (ifte i S y b z c a')
  from ifte(6,1) obtain y' z' b' c'
    where 1: "ifte (var i) y z = ifte (var i) y' z'"
      and 2: "a' = ifte (f i) b' c'"
      and 3: "hom_graph f S y' b'"
      and 4: "hom_graph f S z' c'"
    by (rule hom_graph_insert_elim)
  from 1 3 4 ifte(1,2,4) have "y = y' \<and> z = z'"
    by (intro ifte_inject hom_graph_imp_formulas)
  with 2 3 4 ifte(3,5) show "ifte (f i) b c = a'"
    by simp
qed (erule hom_graph.cases, simp_all)+

text {*
  \medskip
  The next few lemmas will help to establish a stronger version of the
  uniqueness property of @{const hom_graph}.  They show that the @{const
  hom_graph} relation is preserved if we replace @{text S} with a
  larger finite set.
*}

lemma hom_graph_insert:
  assumes "hom_graph f S x a"
  shows "hom_graph f (insert i S) x a"
proof (cases "i \<in> S")
  assume "i \<in> S" with assms show ?thesis by (simp add: insert_absorb)
next
  assume "i \<notin> S"
  hence "hom_graph f (insert i S) (ifte (var i) x x) (ifte (f i) a a)"
    by (intro hom_graph.ifte assms)
  thus "hom_graph f (insert i S) x a"
    by (simp only: ifte_same)
qed

lemma hom_graph_finite_superset:
  assumes "hom_graph f S x a" and "finite T" and "S \<subseteq> T"
  shows "hom_graph f T x a"
proof -
  from `finite T` have "hom_graph f (S \<union> T) x a"
    by (induct set: finite, simp add: assms, simp add: hom_graph_insert)
  with `S \<subseteq> T` show "hom_graph f T x a"
    by (simp only: subset_Un_eq)
qed

lemma hom_graph_imp_finite:
  "hom_graph f S x a \<Longrightarrow> finite S"
by (induct set: hom_graph) simp_all

text {*
  \medskip
  This stronger uniqueness property says that @{term "hom_graph f"}
  maps each @{text x} to at most one @{text a}, even for
  \emph{different} values of the set parameter.
*}

lemma hom_graph_unique':
  assumes "hom_graph f S x a" and "hom_graph f T x a'"
  shows "a = a'"
proof (rule hom_graph_unique)
  have fin: "finite (S \<union> T)"
    using assms by (intro finite_UnI hom_graph_imp_finite)
  show "hom_graph f (S \<union> T) x a"
    using assms(1) fin Un_upper1 by (rule hom_graph_finite_superset)
  show "hom_graph f (S \<union> T) x a'"
    using assms(2) fin Un_upper2 by (rule hom_graph_finite_superset)
qed

text {*
  \medskip
  Finally, these last few lemmas establish that the @{term "hom_graph
  f"} relation is total: every @{text x} is mapped to some @{text a}.
*}

lemma hom_graph_var: "hom_graph f {i} (var i) (f i)"
proof -
  have "hom_graph f {i} (ifte (var i) top bot) (ifte (f i) top bot)"
    by (simp add: hom_graph.intros)
  thus "hom_graph f {i} (var i) (f i)"
    unfolding ifte_def by simp
qed

lemma hom_graph_compl:
  "hom_graph f S x a \<Longrightarrow> hom_graph f S (- x) (- a)"
by (induct set: hom_graph, simp_all add: hom_graph.intros compl_ifte)

lemma hom_graph_inf:
  "hom_graph f S x a \<Longrightarrow> hom_graph f S y b \<Longrightarrow>
   hom_graph f S (x \<sqinter> y) (a \<sqinter> b)"
 apply (induct arbitrary: y b set: hom_graph)
   apply (simp add: hom_graph.bot)
  apply simp
 apply (erule (1) hom_graph_insert_elim)
 apply (auto simp add: inf_ifte_distrib hom_graph.ifte)
done

lemma hom_graph_union_inf:
  assumes "hom_graph f S x a" and "hom_graph f T y b"
  shows "hom_graph f (S \<union> T) (x \<sqinter> y) (a \<sqinter> b)"
proof (rule hom_graph_inf)
  have fin: "finite (S \<union> T)"
    using assms by (intro finite_UnI hom_graph_imp_finite)
  show "hom_graph f (S \<union> T) x a"
    using assms(1) fin Un_upper1 by (rule hom_graph_finite_superset)
  show "hom_graph f (S \<union> T) y b"
    using assms(2) fin Un_upper2 by (rule hom_graph_finite_superset)
qed

lemma hom_graph_exists: "\<exists>a S. hom_graph f S x a"
by (induct x)
   (auto intro: hom_graph_var hom_graph_compl hom_graph_union_inf)

subsection {* Homomorphisms into other boolean algebras *}

text {*
  Now that we have proved the necessary existence and uniqueness
  properties of @{const hom_graph}, we can define the function @{text
  hom} using definite choice.
*}

definition
  hom :: "('a \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> 'a formula \<Rightarrow> 'b"
where
  "hom f x = (THE a. \<exists>S. hom_graph f S x a)"

lemma hom_graph_hom: "\<exists>S. hom_graph f S x (hom f x)"
unfolding hom_def
apply (rule theI')
apply (rule ex_ex1I)
apply (rule hom_graph_exists)
apply (fast elim: hom_graph_unique')
done

lemma hom_equality:
  "hom_graph f S x a \<Longrightarrow> hom f x = a"
unfolding hom_def
apply (rule the_equality)
apply (erule exI)
apply (erule exE)
apply (erule (1) hom_graph_unique')
done

text {*
  \medskip
  The @{const hom} function correctly implements its specification:
*}

lemma hom_var [simp]: "hom f (var i) = f i"
by (rule hom_equality, rule hom_graph_var)

lemma hom_bot [simp]: "hom f \<bottom> = \<bottom>"
by (rule hom_equality, rule hom_graph.bot)

lemma hom_top [simp]: "hom f \<top> = \<top>"
by (rule hom_equality, rule hom_graph.top)

lemma hom_compl [simp]: "hom f (- x) = - hom f x"
proof -
  obtain S where "hom_graph f S x (hom f x)"
    using hom_graph_hom ..
  hence "hom_graph f S (- x) (- hom f x)"
    by (rule hom_graph_compl)
  thus "hom f (- x) = - hom f x"
    by (rule hom_equality)
qed

lemma hom_inf [simp]: "hom f (x \<sqinter> y) = hom f x \<sqinter> hom f y"
proof -
  obtain S where S: "hom_graph f S x (hom f x)"
    using hom_graph_hom ..
  obtain T where T: "hom_graph f T y (hom f y)"
    using hom_graph_hom ..
  have "hom_graph f (S \<union> T) (x \<sqinter> y) (hom f x \<sqinter> hom f y)"
    using S T by (rule hom_graph_union_inf)
  thus ?thesis by (rule hom_equality)
qed

lemma hom_sup [simp]: "hom f (x \<squnion> y) = hom f x \<squnion> hom f y"
unfolding sup_conv_inf by (simp only: hom_compl hom_inf)

lemma hom_diff [simp]: "hom f (x - y) = hom f x - hom f y"
unfolding diff_eq by (simp only: hom_compl hom_inf)

lemma hom_ifte [simp]:
  "hom f (ifte x y z) = ifte (hom f x) (hom f y) (hom f z)"
unfolding ifte_def by (simp only: hom_compl hom_inf hom_sup)

lemmas hom_simps =
  hom_var hom_bot hom_top hom_compl
  hom_inf hom_sup hom_diff hom_ifte

text {*
  \medskip
  The type @{typ "'a formula"} can be viewed as a monad, with @{const
  var} as the unit, and @{const hom} as the bind operator.  We can
  prove the standard monad laws with simple proofs by induction.
*}

lemma hom_var_eq_id: "hom var x = x"
by (induct x) simp_all

lemma hom_hom: "hom f (hom g x) = hom (\<lambda>i. hom f (g i)) x"
by (induct x) simp_all

subsection {* Map operation on Boolean formulas *}

text {*
  We can define a map functional in terms of @{const hom} and @{const
  var}.  The properties of @{text fmap} follow directly from the
  lemmas we have already proved about @{const hom}.
*}

definition
  fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a formula \<Rightarrow> 'b formula"
where
  "fmap f = hom (\<lambda>i. var (f i))"

lemma fmap_var [simp]: "fmap f (var i) = var (f i)"
unfolding fmap_def by simp

lemma fmap_bot [simp]: "fmap f \<bottom> = \<bottom>"
unfolding fmap_def by simp

lemma fmap_top [simp]: "fmap f \<top> = \<top>"
unfolding fmap_def by simp

lemma fmap_compl [simp]: "fmap f (- x) = - fmap f x"
unfolding fmap_def by simp

lemma fmap_inf [simp]: "fmap f (x \<sqinter> y) = fmap f x \<sqinter> fmap f y"
unfolding fmap_def by simp

lemma fmap_sup [simp]: "fmap f (x \<squnion> y) = fmap f x \<squnion> fmap f y"
unfolding fmap_def by simp

lemma fmap_diff [simp]: "fmap f (x - y) = fmap f x - fmap f y"
unfolding fmap_def by simp

lemma fmap_ifte [simp]:
  "fmap f (ifte x y z) = ifte (fmap f x) (fmap f y) (fmap f z)"
unfolding fmap_def by simp

lemmas fmap_simps =
  fmap_var fmap_bot fmap_top fmap_compl
  fmap_inf fmap_sup fmap_diff fmap_ifte

text {*
  \medskip
  The map functional satisfies the functor laws: it preserves identity
  and function composition.
*}

lemma fmap_ident: "fmap (\<lambda>i. i) x = x"
by (induct x) simp_all

lemma fmap_fmap: "fmap f (fmap g x) = fmap (f \<circ> g) x"
by (induct x) simp_all

subsection {* Hiding lattice syntax *}

text {*
  The following command hides the lattice syntax, to avoid potential
  conflicts with other theories that import this one.  To re-enable
  the syntax, users should import theory @{text Lattice_Syntax} from
  the Isabelle library.
*}

no_notation
  top ("\<top>") and
  bot ("\<bottom>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_53
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun count :: "Nat => Nat list => Nat" where
"count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if x y z2 then S (count y ys) else count y ys)"

fun t2 :: "Nat => Nat => bool" where
"t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

fun insort :: "Nat => Nat list => Nat list" where
"insort y (nil2) = cons2 y (nil2)"
| "insort y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (insort y xs))"

fun sort :: "Nat list => Nat list" where
"sort (nil2) = nil2"
| "sort (cons2 z xs) = insort z (sort xs)"

theorem property0 :
  "((count n xs) = (count n (sort xs)))"
  oops

end


theory hw07
  imports Main
begin

hide_const (open) inv

type_synonym intervals = "(nat*nat) list"

fun inv' :: "nat \<Rightarrow> intervals \<Rightarrow> bool" where
  "inv' n [] \<longleftrightarrow> True"|
  "inv' n ((a,b)#ivs) \<longleftrightarrow> n\<le>a \<and> a\<le>b \<and> inv' (b+2) ivs"

definition inv where "inv = inv' 0"

fun set_of :: "intervals \<Rightarrow> nat set"
where
  "set_of [] = {}"|
  "set_of ((a,b)#ivs) = {a..b} \<union> set_of ivs"

fun del :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
  where
   "del x [] = []"
|  "del x ((a,b)#lis) = (
    if (x < a) then (a,b)#lis
    else if (x = a \<and> x = b) then lis
    else if (x = a) then ((a+1), b)#lis
    else if (x < b) then (a,x-1)#(x+1,b)#lis
    else if (x = b) then (a,b-1)#lis
    else (a,b)#(del x lis))"

value "del (12::nat) [(2,5),(7,7),(9,11)]"
value "set_of [] - {1::nat}"

lemma del_pres_inv: "n\<le>x \<Longrightarrow> inv' n itl \<Longrightarrow> inv' n (del x itl)"
proof (induction itl arbitrary:n)
  case Nil
  then show ?case by auto
next
  case (Cons a itl)
  then show ?case
    apply (cases a)
    apply (cases itl)
    apply auto
    done
qed

lemma set_of_del:
  assumes "n\<le>x"
  assumes "inv' n itl"
  shows "set_of (del x itl) =  set_of itl - {x}"
  using assms
proof (induction itl arbitrary:n)
case Nil
  then show ?case by auto
next
  case (Cons a itl)
  then show ?case
    apply (cases a)
    apply (cases itl)
     apply (auto split: if_splits)
    apply (auto)
    done
qed

lemma del_correct:
  assumes "inv itl"
  shows "inv (del x itl)" "set_of (del x itl) =  (set_of itl) - {x}"
  using assms del_pres_inv hw07.inv_def apply fastforce
  using assms hw07.inv_def set_of_del by fastforce

fun addi :: "nat \<Rightarrow> nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "addi i j [] = [(i,j)]"|
  "addi i j ((a,b)#lis) = (
    if j + 1 < a then ((i,j)#(a,b)#lis)
    else if j+1 = a then ((i,b)#lis)
    else if j \<le> b then(
      if i < a then ((i,b)#lis)
      else ((a,b)#lis))
    else (
      if i < a then addi i j lis
      else if i \<le> b+1 then addi a j lis
      else ((a,b)#(addi i j lis)))
    )"

value "addi 5 99 [(2,5),(7,7),(9,11)]"

lemma addi_pres_inv: "n\<le>i \<Longrightarrow> i\<le>j \<Longrightarrow> inv' n itl \<Longrightarrow> inv' n (addi i j itl)"
proof (induction i j itl arbitrary:n rule:addi.induct)
  case (1 i j)
  then show ?case by auto
next
  case (2 i j a b itl)
  then show ?case
    apply(cases itl)
     apply(auto)
    done
qed

lemma set_of_addi:
  assumes "n\<le>i" "i\<le>j"
  assumes "inv' n itl"
  shows "set_of (addi i j itl) = {i..j} \<union> set_of itl"
  using assms
proof (induction i j itl arbitrary:n rule:addi.induct)
  case (1 i j)
  then show ?case by auto
next
  case (2 i j a b lis)
  then show ?case
    apply(cases lis)
     apply(cases a)
      apply(cases b)
       apply (auto split:if_splits)
          apply fastforce
         apply fastforce
        apply fastforce
       apply fastforce
      apply fastforce
     apply fastforce
    apply fastforce
    done
qed

lemma addi_correct:
  assumes "inv is" "i\<le>j"
  shows "inv (addi i j is)" "set_of (addi i j is) = {i..j} \<union> (set_of is)"
  using addi_pres_inv assms hw07.inv_def zero_order(3) apply force
  by (metis assms hw07.inv_def le0 set_of_addi)

end


theory prop_68
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun delete :: "Nat => Nat list => Nat list" where
  "delete x (Nil2) = Nil2"
  | "delete x (Cons2 z xs) =
       (if equal2 x z then delete x xs else Cons2 z (delete x xs))"
  (*hipster len le equal2 delete *)

lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes equal2.simps)

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

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

(*hipster le len*)
lemma lemma_ac [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps len.simps)

lemma lemma_ad [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps len.simps)

lemma lemma_ae [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps len.simps)

hipster_cond le

lemma lemma_ah [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps len.simps)

lemma lemma_ai [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps len.simps)

lemma lemma_aj [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps len.simps Nat.exhaust)

lemma lemma_ak [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps  Nat.exhaust)

(*hipster delete len*)
lemma lemma_af [thy_expl]: "delete x10 (delete y10 z10) = delete y10 (delete x10 z10)"
by (hipster_induct_schemes delete.simps len.simps)

lemma lemma_ag [thy_expl]: "delete x6 (delete x6 y6) = delete x6 y6"
by (hipster_induct_schemes delete.simps len.simps)

  theorem x0 :
    "le (len (delete n xs)) (len xs)"
    by (hipster_induct_schemes)

end


header "A Typed Language"
(** Score: 5/5
*)
theory GabrielaLimonta
imports "~~/src/HOL/IMP/Star"
begin

subsection "Expressions"

datatype val = Iv int | Bv bool

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

datatype exp =  N int | V vname | Plus exp exp |
  Bc bool | Not exp | And exp exp | Less exp exp

inductive eval :: "exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"eval (N i) s (Iv i)" |
"eval (V x) s (s x)" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2)
 \<Longrightarrow> eval (Plus a1 a2) s (Iv(i1+i2))" |
"eval (Bc v) s (Bv v)" |
"eval b s (Bv bv) \<Longrightarrow> eval (Not b) s (Bv(\<not> bv))" |
"eval b1 s (Bv bv1) \<Longrightarrow> eval b2 s (Bv bv2) \<Longrightarrow> eval (And b1 b2) s (Bv(bv1 & bv2))" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2) \<Longrightarrow> eval (Less a1 a2) s (Bv(i1 < i2))"

inductive_cases [elim!]:
  "eval (N i) s v"
  "eval (V x) s v"
  "eval (Plus a1 a2) s v"
  "eval (Bc b) s v"
  "eval (Not b) s v"
  "eval (And b1 b2) s v"
  "eval (Less a1 a2) s v"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname exp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     exp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  exp com         ("WHILE _ DO _"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "eval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Bty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive etyping :: "tyenv \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> N i : Ity" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Ity" |
B_ty: "\<Gamma> \<turnstile> Bc v : Bty" |
Not_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> Not b : Bty" |
And_ty: "\<Gamma> \<turnstile> b1 : Bty \<Longrightarrow> \<Gamma> \<turnstile> b2 : Bty \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2 : Bty" |
Less_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2 : Bty"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Bv r) = Bty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Bty[simp]: "type v = Bty \<longleftrightarrow> (\<exists>r. v = Bv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma epreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> eval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
proof (induction rule: etyping.induct)
print_cases
  case (Ic_ty \<Gamma> i)
    thus ?case by auto
  next
  case (V_ty \<Gamma> x)
    thus ?case using styping_def by auto
  next
  case (Plus_ty \<Gamma> a1 a2)
    thus ?case by auto
  next
  case (B_ty \<Gamma> v)
    thus ?case by auto
  next
  case (Not_ty \<Gamma> b)
    thus ?case by auto
  next
  case (And_ty \<Gamma> b1 b2)
    thus ?case by auto
  next
  case (Less_ty \<Gamma> a1 a2)
    thus ?case by auto
qed

lemma eprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. eval a s v"
proof (induction rule: etyping.induct)
print_cases
  case (Ic_ty \<Gamma>)
    thus ?case using eval.intros(1) by auto
  next
  case (V_ty \<Gamma>)
    thus ?case using eval.intros(2) by auto
  next
  case (Plus_ty \<Gamma> a1 a2)
    from this obtain v1 v2 where "eval a1 s v1" and "eval a2 s v2" by blast
    from this and Plus_ty and epreservation have "type v1 = Ity" and "type v2 = Ity" by auto
    from this and `eval a1 s v1` and `eval a2 s v2` and Plus_ty
      obtain i1 i2 where "v1 = (Iv i1)" and "v2 = (Iv i2)" by auto
    from this and Plus_ty and `eval a1 s v1` and `eval a2 s v2` and epreservation and eval.intros(3)
      show ?case by blast
  next
  case (B_ty \<Gamma>)
    thus ?case using eval.intros(4) by auto
  next
  case (Not_ty \<Gamma> b)
    from this obtain v where "eval b s v" by blast
    from this and Not_ty and epreservation have "type v = Bty" by auto
    from this and `eval b s v` and Not_ty obtain bv where "v = (Bv bv)" by auto
    from this and Not_ty and `eval b s v` and epreservation and eval.intros(5) show ?case by blast
  next
  case (And_ty \<Gamma> b1 b2)
    from this obtain v1 v2 where "eval b1 s v1" and "eval b2 s v2" by blast
    from this and And_ty and epreservation have "type v1 = Bty" and "type v2 = Bty" by auto
    from this and `eval b1 s v1` and `eval b2 s v2` and And_ty
      obtain bv1 bv2 where "v1 = (Bv bv1)" and "v2 = (Bv bv2)" by auto
    from this and And_ty and `eval b1 s v1` and `eval b2 s v2` and epreservation and eval.intros(6)
      show ?case by blast
  next
  case (Less_ty \<Gamma> a1 a2)
    from this obtain v1 v2 where "eval a1 s v1" and "eval a2 s v2" by blast
    from this and Less_ty and epreservation have "type v1 = Ity" and "type v2 = Ity" by auto
    from this and `eval a1 s v1` and `eval a2 s v2` and Less_ty
      obtain i1 i2 where "v1 = (Iv i1)" and "v2 = (Iv i2)" by auto
    from this and Less_ty and `eval a1 s v1` and `eval a2 s v2` and epreservation and eval.intros(7)
      show ?case by blast
qed

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof (induction rule: ctyping.induct)
print_cases
  case (Skip_ty \<Gamma>)
    thus ?case by auto
  next
  case (Assign_ty \<Gamma> a x)
    from this and eprogress obtain v where "eval a s v" by blast
    from this and Assign show ?case by blast
  next
  case (Seq_ty \<Gamma> c1 c2)
    thus ?case by (metis PairE Seq1 Seq2)
  next
  case (If_ty \<Gamma> b c1 c2)
    from this and eprogress obtain v where "eval b s v" by blast
    moreover have "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2, s) \<rightarrow> (c2, s)" using IfFalse by auto
    moreover have "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2, s) \<rightarrow> (c1, s)" using IfTrue by auto
    ultimately show ?case using If_ty and epreservation and type_eq_Bty by metis
  next
  case (While_ty \<Gamma> b c)
    from this have "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" using While by blast
    thus ?case by auto
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof (induction rule: small_step_induct)
print_cases
  case (Assign a s v x)
    thus ?case using styping_def and epreservation by auto
  next
  case (Seq1 c s)
    thus ?case by auto
  next
  case (Seq2 c1 s c1' s' c2)
    thus ?case by auto
  next
  case (IfTrue b s c1 c2)
    thus ?case by auto
  next
  case (IfFalse b s c1 c2)
    thus ?case by auto
  next
  case (While b c s)
    thus ?case by auto
qed

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
proof (induction rule: small_step_induct)
print_cases
  case (Assign a s v)
    thus ?case using ctyping.Skip_ty by simp
  next
  case (Seq1 c)
    thus ?case by auto
  next
  case (Seq2 c1 s c1' s' c2)
    thus ?case using ctyping.Seq_ty and small_step.Seq2 by blast
  next
  case (IfTrue b s c1 c2)
    thus ?case by auto
  next
  case (IfFalse b s c1 c2)
    thus ?case by auto
  next
  case (While b c)
    thus ?case using ctyping.intros by auto
qed

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
proof (induction rule: star_induct)
print_cases
  case (refl a b)
    thus ?case using progress by auto
  next
  case (step a1 b1 a' b' a2 b2)
    thus ?case using ctyping_preservation and styping_preservation by auto
qed

end


(*  Title:      FOL/ex/Miniscope.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Classical First-Order Logic.
Conversion to nnf/miniscope format: pushing quantifiers in.
Demonstration of formula rewriting by proof.
*)

theory Miniscope
imports FOL
begin

lemmas ccontr = FalseE [THEN classical]

subsection \<open>Negation Normal Form\<close>

subsubsection \<open>de Morgan laws\<close>

lemma demorgans:
  "\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q"
  "\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q"
  "\<not> \<not> P \<longleftrightarrow> P"
  "\<And>P. \<not> (\<forall>x. P(x)) \<longleftrightarrow> (\<exists>x. \<not> P(x))"
  "\<And>P. \<not> (\<exists>x. P(x)) \<longleftrightarrow> (\<forall>x. \<not> P(x))"
  by blast+

(*** Removal of --> and <-> (positive and negative occurrences) ***)
(*Last one is important for computing a compact CNF*)
lemma nnf_simps:
  "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)"
  "\<not> (P \<longrightarrow> Q) \<longleftrightarrow> (P \<and> \<not> Q)"
  "(P \<longleftrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q) \<and> (\<not> Q \<or> P)"
  "\<not> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<or> Q) \<and> (\<not> P \<or> \<not> Q)"
  by blast+

(* BEWARE: rewrite rules for <-> can confuse the simplifier!! *)

subsubsection \<open>Pushing in the existential quantifiers\<close>

lemma ex_simps:
  "(\<exists>x. P) \<longleftrightarrow> P"
  "\<And>P Q. (\<exists>x. P(x) \<and> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<and> Q"
  "\<And>P Q. (\<exists>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<exists>x. Q(x))"
  "\<And>P Q. (\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> (\<exists>x. P(x)) \<or> (\<exists>x. Q(x))"
  "\<And>P Q. (\<exists>x. P(x) \<or> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<or> Q"
  "\<And>P Q. (\<exists>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<exists>x. Q(x))"
  by blast+

subsubsection \<open>Pushing in the universal quantifiers\<close>

lemma all_simps:
  "(\<forall>x. P) \<longleftrightarrow> P"
  "\<And>P Q. (\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> (\<forall>x. P(x)) \<and> (\<forall>x. Q(x))"
  "\<And>P Q. (\<forall>x. P(x) \<and> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<and> Q"
  "\<And>P Q. (\<forall>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<forall>x. Q(x))"
  "\<And>P Q. (\<forall>x. P(x) \<or> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<or> Q"
  "\<And>P Q. (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<forall>x. Q(x))"
  by blast+

lemmas mini_simps = demorgans nnf_simps ex_simps all_simps

ML \<open>
val mini_ss = simpset_of (@{context} addsimps @{thms mini_simps});
fun mini_tac ctxt =
  resolve_tac ctxt @{thms ccontr} THEN' asm_full_simp_tac (put_simpset mini_ss ctxt);
\<close>

end


(*  Author:     Tobias Nipkow, 2002  *)

section "Arrow's Theorem for Utility Functions"

theory Arrow_Utility imports Complex_Main
begin

text\<open>This theory formalizes the first proof due to
Geanakoplos~\<^cite>\<open>"Geanakoplos05"\<close>.  In contrast to the standard model
of preferences as linear orders, we model preferences as \emph{utility
functions} mapping each alternative to a real number. The type of
alternatives and voters is assumed to be finite.\<close>

typedecl alt
typedecl indi

axiomatization where
  alt3: "\<exists>a b c::alt. distinct[a,b,c]" and
  finite_alt: "finite(UNIV:: alt set)" and

  finite_indi: "finite(UNIV:: indi set)"

lemma third_alt: "a \<noteq> b \<Longrightarrow> \<exists>c::alt. distinct[a,b,c]"
using alt3 by simp metis

lemma alt2: "\<exists>b::alt. b \<noteq> a"
using alt3 by simp metis

type_synonym pref = "alt \<Rightarrow> real"
type_synonym prof = "indi \<Rightarrow> pref"

definition
 top :: "pref \<Rightarrow> alt \<Rightarrow> bool" (infixr "<\<cdot>" 60) where
"p <\<cdot> b  \<equiv>  \<forall>a. a \<noteq> b \<longrightarrow> p a < p b"

definition
 bot :: "alt \<Rightarrow> pref \<Rightarrow> bool" (infixr "\<cdot><" 60) where
"b \<cdot>< p  \<equiv>  \<forall>a. a \<noteq> b \<longrightarrow> p b < p a"

definition
 extreme :: "pref \<Rightarrow> alt \<Rightarrow> bool" where
"extreme p b  \<equiv>  b \<cdot>< p \<or> p <\<cdot> b"

abbreviation
"Extreme P b == \<forall>i. extreme (P i) b"

lemma less_if_bot[simp]: "\<lbrakk> b \<cdot>< p; x \<noteq> b \<rbrakk> \<Longrightarrow> p b < p x"
by(simp add:bot_def)

lemma [simp]: "\<lbrakk> p <\<cdot> b; x \<noteq> b \<rbrakk> \<Longrightarrow> p x < p b"
by(simp add:top_def)

lemma [simp]: assumes top: "p <\<cdot> b" shows "\<not> p b < p c"
proof (cases)
  assume "b = c" thus ?thesis by simp
next
  assume "b \<noteq> c"
  with top have "p c < p b" by (simp add:eq_sym_conv)
  thus ?thesis by simp
qed

lemma not_less_if_bot[simp]:
  assumes bot: "b \<cdot>< p" shows "\<not> p c < p b"
proof (cases)
  assume "b = c" thus ?thesis by simp
next
  assume "b \<noteq> c"
  with bot have "p b < p c" by (simp add:eq_sym_conv)
  thus ?thesis by simp
qed

lemma top_impl_not_bot[simp]: "p <\<cdot> b \<Longrightarrow> \<not> b \<cdot>< p"
by(unfold bot_def, simp add:alt2)

lemma [simp]: "extreme p b \<Longrightarrow> (\<not> p <\<cdot> b) = (b \<cdot>< p)"
apply(unfold extreme_def)
apply(fastforce dest:top_impl_not_bot)
done

lemma [simp]: "extreme p b \<Longrightarrow> (\<not> b \<cdot>< p) = (p <\<cdot> b)"
apply(unfold extreme_def)
apply(fastforce dest:top_impl_not_bot)
done

text\<open>Auxiliary construction to hide details of preference model.\<close>

definition
 mktop :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mktop p b \<equiv> p(b := Max(range p) + 1)"

definition
 mkbot :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mkbot p b \<equiv> p(b := Min(range p) - 1)"

definition
 between :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"between p a b c \<equiv> p(b := (p a + p c)/2)"

text\<open>To make things simpler:\<close>
declare between_def[simp]

lemma [simp]: "a \<noteq> b \<Longrightarrow> mktop p b a = p a"
by(simp add:mktop_def)

lemma [simp]: "a \<noteq> b \<Longrightarrow> mkbot p b a = p a"
by(simp add:mkbot_def)

lemma [simp]: "a \<noteq> b \<Longrightarrow> p a < mktop p b b"
by(simp add:mktop_def finite_alt)

lemma [simp]: "a \<noteq> b \<Longrightarrow> mkbot p b b < p a"
by(simp add:mkbot_def finite_alt)

lemma [simp]: "mktop p b <\<cdot> b"
by(simp add:mktop_def top_def finite_alt)

lemma [simp]: "\<not> b \<cdot>< mktop p b"
by(simp add:mktop_def bot_def alt2 finite_alt)

lemma [simp]: "a \<noteq> b \<Longrightarrow> \<not> P p a < mkbot (P p) b b"
proof (simp add:mkbot_def finite_alt)
  have "\<not> P p a + 1 < P p a" by simp
  thus "\<exists>x. \<not> P p a + 1 < P p x" ..
qed

text\<open>The proof starts here.\<close>

locale arrow =
fixes F :: "prof \<Rightarrow> pref"
assumes unanimity: "(\<And>i. P i a < P i b) \<Longrightarrow> F P a < F P b"
and IIA:
"(\<And>i. (P i a < P i b) = (P' i a < P' i b)) \<Longrightarrow>
 (F P a < F P b) = (F P' a < F P' b)"
begin

lemmas IIA' = IIA[THEN iffD1]

definition
 dictates :: "indi \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates _ < _") where
"(i dictates a < b)  \<equiv>  \<forall>P. P i a < P i b \<longrightarrow> F P a < F P b"
definition
 dictates2 :: "indi \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates _,_") where
"(i dictates a,b)  \<equiv>  (i dictates a < b) \<and> (i dictates b < a)"
definition
 dictatesx:: "indi \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates'_except _") where
"(i dictates_except c)  \<equiv>  \<forall>a b. c \<notin> {a,b} \<longrightarrow> (i dictates a<b)"
definition
 dictator :: "indi \<Rightarrow> bool" where
"dictator i  \<equiv>  \<forall>a b. (i dictates a<b)"

definition
 pivotal :: "indi \<Rightarrow> alt \<Rightarrow> bool" where
"pivotal i b \<equiv>
 \<exists>P. Extreme P b  \<and>  b \<cdot>< P i  \<and>  b \<cdot>< F P  \<and>
     F (P(i := mktop (P i) b)) <\<cdot> b"

lemma all_top[simp]: "\<forall>i. P i <\<cdot> b \<Longrightarrow> F P <\<cdot> b"
by (unfold top_def) (simp add: unanimity)

lemma not_extreme:
  assumes nex: "\<not> extreme p b"
  shows "\<exists>a c. distinct[a,b,c] \<and> \<not> p a < p b \<and> \<not> p b < p c"
proof -
  obtain a c where abc: "a \<noteq> b \<and> \<not> p a < p b" "b \<noteq> c \<and> \<not> p b < p c"
    using nex by (unfold extreme_def top_def bot_def) fastforce
  show ?thesis
  proof (cases "a = c")
    assume "a \<noteq> c" thus ?thesis using abc by simp blast
  next
    assume ac: "a = c"
    obtain d where d: "distinct[a,b,d]" using abc third_alt by blast
    show ?thesis
    proof (cases "p b < p d")
      case False thus ?thesis using abc d by blast
    next
      case True
      hence db: "\<not> p d < p b" by arith
      from d have "distinct[d,b,c]" by(simp add:ac eq_sym_conv)
      thus ?thesis using abc db by blast
    qed
  qed
qed

lemma extremal:
  assumes extremes: "Extreme P b" shows "extreme (F P) b"
proof (rule ccontr)
  assume nec: "\<not> extreme (F P) b"
  hence "\<exists>a c. distinct[a,b,c] \<and> \<not> F P a < F P b \<and> \<not> F P b < F P c"
    by(rule not_extreme)
  then obtain a c where d: "distinct[a,b,c]" and
    ab: "\<not> F P a < F P b" and bc: "\<not> F P b < F P c" by blast
  let ?P = "\<lambda>i. if P i <\<cdot> b then between (P i) a c b
                else (P i)(c := P i a + 1)"
  have "\<not> F ?P a < F ?P b"
    using extremes d by(simp add:IIA[of _ _ _ P] ab)
  moreover have "\<not> F ?P b < F ?P c"
    using extremes d by(simp add:IIA[of _ _ _ P] bc eq_sym_conv)
  moreover have "F ?P a < F ?P c" by(rule unanimity)(insert d, simp)
  ultimately show False by arith
qed

lemma pivotal_ind: assumes fin: "finite D"
  shows "\<And>P. \<lbrakk> D = {i. b \<cdot>< P i}; Extreme P b; b \<cdot>< F P \<rbrakk>
  \<Longrightarrow> \<exists>i. pivotal i b" (is "\<And>P. ?D D P \<Longrightarrow> ?E P \<Longrightarrow> ?B P \<Longrightarrow> _")
using fin
proof (induct)
  case (empty P)
  from empty(1,2) have "\<forall>i. P i <\<cdot> b" by simp
  hence "F P <\<cdot> b" by simp
  hence False using empty by(blast dest:top_impl_not_bot)
  thus ?case ..
next
  fix D i P
  assume IH: "\<And>P. ?D D P \<Longrightarrow> ?E P \<Longrightarrow> ?B P \<Longrightarrow> \<exists>i. pivotal i b"
    and "?E P" and "?B P" and insert: "insert i D = {i. b \<cdot>< P i}" and "i \<notin> D"
  from insert have "b \<cdot>< P i" by blast
  let ?P = "P(i := mktop (P i) b)"
  show "\<exists>i. pivotal i b"
  proof (cases "F ?P <\<cdot> b")
    case True
    have "pivotal i b"
    proof -
      from \<open>?E P\<close> \<open>?B P\<close> \<open>b \<cdot>< P i\<close> True
      show ?thesis by(unfold pivotal_def, blast)
    qed
    thus ?thesis ..
  next
    case False
    have "D = {i. b \<cdot>< ?P i}"
      by (rule set_eqI) (simp add:\<open>i \<notin> D\<close>, insert insert, blast)
    moreover have "Extreme ?P b"
      using \<open>?E P\<close> by (simp add:extreme_def)
    moreover have "b \<cdot>< F ?P"
      using extremal[OF \<open>Extreme ?P b\<close>] False by(simp del:fun_upd_apply)
    ultimately show ?thesis by(rule IH)
  qed
qed

lemma pivotal_exists: "\<exists>i. pivotal i b"
proof -
  let ?P = "(\<lambda>_ a. if a=b then 0 else 1)::prof"
  have "Extreme ?P b" by(simp add:extreme_def bot_def)
  moreover have "b \<cdot>< F ?P"
    by(simp add:bot_def unanimity del: less_if_bot not_less_if_bot)
  ultimately show "\<exists>i. pivotal i b"
    by (rule pivotal_ind[OF finite_subset[OF subset_UNIV finite_indi] refl])
qed

lemma pivotal_xdictates: assumes pivo: "pivotal i b"
  shows "i dictates_except b"
proof -
  have "\<And>a c. \<lbrakk> a \<noteq> b; b \<noteq> c \<rbrakk> \<Longrightarrow> i dictates a < c"
  proof (unfold dictates_def, intro allI impI)
    fix a c and P::prof
    assume abc: "a \<noteq> b" "b \<noteq> c" and
           ac: "P i a < P i c"
    show "F P a < F P c"
    proof -
      obtain P1 P2 where
        "Extreme P1 b" and "b \<cdot>< F P1" and "b \<cdot>< P1 i" and "F P2 <\<cdot> b" and
        [simp]: "P2 = P1(i := mktop (P1 i) b)"
        using pivo by (unfold pivotal_def) fast
      let ?P = "\<lambda>j. if j=i then between (P j) a b c
                    else if P1 j <\<cdot> b then mktop (P j) b else mkbot (P j) b"
      have eq: "(F P a < F P c) = (F ?P a < F ?P c)"
        using abc by - (rule IIA, auto)
      have "F ?P a < F ?P b"
      proof (rule IIA')
        fix j show "(P2 j a < P2 j b) = (?P j a < ?P j b)"
          using \<open>Extreme P1 b\<close> by(simp add: ac)
      next
        show "F P2 a < F P2 b"
          using \<open>F P2 <\<cdot> b\<close> abc by(simp add: eq_sym_conv)
      qed
      also have "\<dots> < F ?P c"
      proof (rule IIA')
        fix j show "(P1 j b < P1 j c) = (?P j b < ?P j c)"
          using \<open>Extreme P1 b\<close> \<open>b \<cdot>< P1 i\<close> by(simp add: ac)
      next
        show "F P1 b < F P1 c"
          using \<open>b \<cdot>< F P1\<close> abc by(simp add: eq_sym_conv)
      qed
      finally show ?thesis by(simp add:eq)
    qed
  qed
  thus ?thesis  by(unfold dictatesx_def) fast
qed

lemma pivotal_is_dictator:
  assumes pivo: "pivotal i b" and ab: "a \<noteq> b" and d: "j dictates a,b"
  shows "i = j"
proof (rule ccontr)
  assume pd: "i \<noteq> j"
  obtain P1 P2 where "Extreme P1 b" and "b \<cdot>< F P1" and "F P2 <\<cdot> b" and
    P2: "P2 = P1(i := mktop (P1 i) b)"
    using pivo by (unfold pivotal_def) fast
  have "~(P1 j a < P1 j b)" (is "~ ?ab")
  proof
    assume "?ab"
    hence "F P1 a < F P1 b" using d by(simp add: dictates_def dictates2_def)
    with \<open>b \<cdot>< F P1\<close> show False by simp
  qed
  hence "P1 j b < P1 j a" using \<open>Extreme P1 b\<close>[THEN spec, of j] ab
    unfolding extreme_def top_def bot_def by metis
  hence "P2 j b < P2 j a" using pd by (simp add:P2)
  hence "F P2 b < F P2 a" using d by(simp add: dictates_def dictates2_def)
  with \<open>F P2 <\<cdot> b\<close> show False by simp
qed

theorem dictator: "\<exists>i. dictator i"
proof-
  from pivotal_exists[of b] obtain i where pivo: "pivotal i b" ..
  { fix a assume neq: "a \<noteq> b" have "i dictates a,b"
    proof -
      obtain c where dist: "distinct[a,b,c]"
        using neq third_alt by blast
      obtain j where "pivotal j c" using pivotal_exists by fast
      hence "j dictates_except c" by(rule pivotal_xdictates)
      hence b: "j dictates a,b"
        using dist by(simp add:dictatesx_def dictates2_def eq_sym_conv)
      with pivo neq have "i = j" by(rule pivotal_is_dictator)
      thus ?thesis using b by simp
    qed
  }
  with pivotal_xdictates[OF pivo] have "dictator i"
    by(simp add: dictates_def dictatesx_def dictates2_def dictator_def)
      (metis less_le)
  thus ?thesis ..
qed

end

end


section \<open> Enumeration Extras \<close>

theory Enum_extra
  imports "HOL-Library.Code_Cardinality"
begin

subsection \<open> First Index Function \<close>

text \<open> The following function extracts the index of the first occurrence of an element in a list,
  assuming it is indeed an element. \<close>

fun first_ind :: "'a list \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
"first_ind [] y i = undefined" |
"first_ind (x # xs) y i = (if (x = y) then i else first_ind xs y (Suc i))"

lemma first_ind_length:
  "x \<in> set(xs) \<Longrightarrow> first_ind xs x i < length(xs) + i"
  by (induct xs arbitrary: i, auto, metis add_Suc_right)

lemma nth_first_ind:
  "\<lbrakk> distinct xs; x \<in> set(xs) \<rbrakk> \<Longrightarrow> xs ! (first_ind xs x i - i) = x"
  apply (induct xs arbitrary: i)
   apply (auto)
  apply (metis One_nat_def add.right_neutral add_Suc_right add_diff_cancel_left' diff_diff_left empty_iff first_ind.simps(2) list.set(1) nat.simps(3) neq_Nil_conv nth_Cons' zero_diff)
  done

lemma first_ind_nth:
  "\<lbrakk> distinct xs; i < length xs \<rbrakk> \<Longrightarrow> first_ind xs (xs ! i) j = i + j"
  apply (induct xs arbitrary: i j)
   apply (auto)
   apply (metis less_Suc_eq_le nth_equal_first_eq)
  using less_Suc_eq_0_disj apply auto
  done

subsection \<open> Enumeration Indices \<close>

syntax
  "_ENUM" :: "type \<Rightarrow> logic" ("ENUM'(_')")

translations
  "ENUM('a)" => "CONST Enum.enum :: ('a::enum) list"

text \<open> Extract a unique natural number associated with an enumerated value by using its index
  in the characteristic list \<^term>\<open>ENUM('a)\<close>. \<close>

definition enum_ind :: "'a::enum \<Rightarrow> nat" where
"enum_ind (x :: 'a::enum) = first_ind ENUM('a) x 0"

lemma length_enum_CARD: "length ENUM('a) = CARD('a)"
  by (simp add: UNIV_enum distinct_card enum_distinct)

lemma CARD_length_enum: "CARD('a) = length ENUM('a)"
  by (simp add: length_enum_CARD)

lemma enum_ind_less_CARD [simp]: "enum_ind (x :: 'a::enum) < CARD('a)"
  using first_ind_length[of x, OF in_enum, of 0] by (simp add: enum_ind_def CARD_length_enum)

lemma enum_nth_ind [simp]: "Enum.enum ! (enum_ind x) = x"
  using nth_first_ind[of Enum.enum x 0, OF enum_distinct in_enum] by (simp add: enum_ind_def)

lemma enum_distinct_conv_nth:
  assumes "i < CARD('a)" "j < CARD('a)" "ENUM('a) ! i = ENUM('a) ! j"
  shows "i = j"
proof -
  have "(\<forall>i<length ENUM('a). \<forall>j<length ENUM('a). i \<noteq> j \<longrightarrow> ENUM('a) ! i \<noteq> ENUM('a) ! j)"
    using distinct_conv_nth[of "ENUM('a)", THEN sym] by (simp add: enum_distinct)
  with assms show ?thesis
    by (auto simp add: CARD_length_enum)
qed

lemma enum_ind_nth [simp]:
  assumes "i < CARD('a::enum)"
  shows "enum_ind (ENUM('a) ! i) = i"
  using assms first_ind_nth[of "ENUM('a)" i 0, OF enum_distinct]
  by (simp add: enum_ind_def CARD_length_enum)

lemma enum_ind_spec:
  "enum_ind (x :: 'a::enum) = (THE i. i < CARD('a) \<and> Enum.enum ! i = x)"
proof (rule sym, rule the_equality, safe)
  show "enum_ind x < CARD('a)"
    by (simp add: enum_ind_less_CARD[of x])
  show "enum_class.enum ! enum_ind x = x"
    by simp
  show "\<And>i. i < CARD('a) \<Longrightarrow> x = ENUM('a) ! i \<Longrightarrow> i = enum_ind (ENUM('a) ! i)"
    by (simp add: enum_ind_nth)
qed

lemma enum_ind_inj: "inj (enum_ind :: 'a::enum \<Rightarrow> nat)"
  by (rule inj_on_inverseI[of _ "\<lambda> i. ENUM('a) ! i"], simp)

lemma enum_ind_neq [simp]: "x \<noteq> y \<Longrightarrow> enum_ind x \<noteq> enum_ind y"
  by (simp add: enum_ind_inj inj_eq)

end